Discussion :

[Jipété]

Bonsoir,

une fois n'est pas coutume, je ne viens pas pleurer demander de l'aide crier au secours, non, je viens vous passer un lien sur un petit projet qui m'a semblé sympathique et qui a compilé instantanément sans aucune retouche, et rien que pour ça, je suis aux anges.
La chose est décrite comme capable d'accélérer le rendu des graphismes, serait compatible Linux, Windows, Mac, et avec un soupçon d'OpenGL.

Ce projet est discuté là (ah ben vi, tout en english mais c'est pas trop compliqué et c'est vite lu), quand vous avez fini de lire vous remontez tout en haut il y a un lien "next" à droite qui vous emmènera vers la 2^e partie, puis deux fois "next" pour atteindre la 3^e et dernière partie où se trouve un lien github pour récupérer un zip.

Il y a un benchmark et j'arrive à 40 fps (env. 24 msec) sur ma vieille machine qui n'a pas une carte graphique de gamer ; est-ce que c'est bien ? Est-ce que c'est mal ? Testez puis revenez et comparez.

Enjoy,

[BeanzMaster]

Salut, le graphisme j'aime bien donc allons voir ce que Jipete nous a trouvé !!! je clone les sources, parfait, je lance Lazarus (pas trop fort au cas ou) j'ouvre les differents projets ok pas soucis et je fini par le projet GridInQuestII et la PAF

Error: resource compiler "windres.exe" not found, switching to external mode

Bon c'est quoi ce machin "WindRes" ? ok petite recherche sur le forum de FPC

windres is part of fpc (and should be located inside its platform dependent directory), in my particular Free pascal specific case: G:\WinDev\FPC\3.0.0\bin\i386-win32\windres.exe
...
I've just searched the entire C: drive and have found two of these windres files. One is called i386-win32-windres and it is located in C:\lazarus\fpc\3.0.0\bin\x86_64-win64 and the other is called windres and it is located in C:\Program Files (x86)\CodeBlocks\MinGW\bin.

Bon ok je recherche ce bidule dans C:\lazarus\fpc\3.0.0\bin\x86_64-win64 (ben vi je suis sous W10 64bit) et la quenini, walou, que dalle.
Je persiste, me met a la base ("c:\lazarus") lance une recherche *wind*.* seul truc que je trouve c'est : windres-2.2.2.patch ok c'est un patch pour FPC 2.2 bref le truc qui sert à rien vu que c'est FPC 3.0.0

Bon alors il est ou ce fichier windres dans Lazarus 1.6 avec FPC 3.0.0 de la date du 06/11/2016 SVN Revision 51630 ???????


Bon je vais pas me laisser 3mx4$f0 par ce fichier, je continue ma lecture du forum de FPC et je lis :

In case you install the 64-bit version of lazarus and want to cross-compile 32 bit windows you'd also need to install this file here
https://sourceforge.net/projects/laz...in32-win64.exe

Ok j'installe le bignou, et avant de compiler je refais une petite recherche je le trouve bien C:\lazarus\fpc\3.0.0\bin\x86_64-win64 et sous le nom "i386-win32-windres.exe" (y'en une dizaine de fichiers comme ça) pffff pourquoi faire simple quand on peux faire compliquer hein les petits gars de FPC ? ils aiment ça on dirait !

bref un renommage en bonne et due forme, je recompile et

Warning: windres: preprocessing failed.
Splash.pas(140,1) Error: Error while compiling resources -> Compile with -vd for more details. Check for duplicates.

ok je rajoute le -vd dans les options je recompile pas plus de details, elle sert à rien cette options Vérifier quelles duplications ???

Bon je vais dans les options du projet et je passe en "Release 32Bit" vous devinerez jamais et bien rebaffe

Désolé Jipete mais je pourrais pas comparer. Si quelqu'un à l'astuce au cas ou je suis preneur. peut-être Gille ?

Mise à part

You know what? I'm just getting back to the previous version.

I don't have the time or the patience to fix these problems. I just want to install and use it, as I always did since the first version. Maybe in future releases, these bugs might be fixed.

Thank you all for your kindness and help.

Bonne soirée

PS : J'ai téléchargé l'exe du projet (win64) et celui-ci ne se lance pas (aussi) chez moi

[Jipété]

Bonsoir,

et je finis par le projet GridInQuestII et là PAF

Je ne vois pas le rapport entre ce GridInQuestII et le projet "Free Pascal Fast Bitmaps" dont j'ai parlé

Je ne pourrai donc pas t'aider sur ce coup-là, d'autant plus qu'il me semble que tu tournes sous Window (sans "s", il parait, à partir de 10...)

(En ce qui me concerne,je voulais jeter un coup d'œil à son projet Mandelbrot mais lui aussi ne compile pas, peut-être à cause d'un mic-mac de versions de fichiers -- j'envisage de le contacter demain)

[BeanzMaster]

Salut

Je ne vois pas le rapport entre ce GridInQuestII et le projet "Free Pascal Fast Bitmaps" dont j'ai parlé
....
quand vous avez fini de lire vous remontez tout en haut il y a un lien "next" à droite qui vous emmènera vers la 2e partie, puis deux fois "next" pour atteindre la 3e et dernière partie où se trouve un lien github pour récupérer un zip.

je tombe la dessus http://michellcomputing.co.uk/blog/2...aunched-today/ en bas le lien https://bitbucket.org/PaulFMichell/gridinquestii apres 2 "next" pfff faut encore faire 2 fois next apres je tombe sur la partie 3 de l'article sur "fast-bitmap" apres le mandelbrot que tu parle chelou je deteste "wordpress"

pour ceux qui on la flemme de lire : https://bitbucket.org/PaulFMichell/c...ages/downloads et https://bitbucket.org/PaulFMichell/mandelbrot/downloads

[Jipété]

chelou je deteste "wordpress"

Sinon, pour cette histoire de "duplicate resource", ça me disait quelque chose et ça m'est revenu : c'est une histoire tordue entre les .lrs et les .rc, je ne me souviens pas comment je m'en suis sorti, peut-être en commentant toutes les lignes où ces extensions sont présentes puis en réactivant soit les .lrs soit les .rc, je ne sais plus trop mais c'est par là.

Bonne découverte, mais en ce qui me concerne, j'ai du mal à mettre ça en œuvre, tous comptes faits...

EDIT : Mandelbrot ne compile pas chez moi, sous Linux comme sous XP le tout en 32 bits (mais je ne pense pas que ça ait une incidence)
Hier j'ai dit que je lui écrirais (concernant ce problème) mais ça n'est pas la peine, le problème est dans mon camp...
Dans son code il utilise les propriétés .Width, .Height et .CenterPoint du TRect, indisponibles actuellement. /EDIT

[Jipété]

Hier j'ai dit que je lui écrirais (concernant ce problème) mais ça n'est pas la peine, le problème est dans mon camp...
Dans son code il utilise les propriétés .Width, .Height et .CenterPoint du TRect, indisponibles actuellement

Je m'en suis sorti, en me souvenant que sur son blog il parle d'un Lazarus 1.7 !
Doit y avoir des choses pour lesquelles on n'est pas au courant.

Bref, voilà les corrections pour le projet MandelBrot, et attention aux options du projet, où il a forcé Win64.
Dans le fichier Generators.pas :
ligne 148

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Procedure TGeneratorController.BoxZoom(ZoomRect: TRect);
Var
  ZoomCenter: TRealPoint;
  ViewCenter: TRealPoint;
  ScaleX: Double;
  ScaleY: Double;
Begin
//  ZoomCenter := PointToRealPoint(ZoomRect.CenterPoint);
  ZoomCenter := PointToRealPoint(CenterPoint(ZoomRect));
  { Zoom centre must be calculated prior to scale. }
//  ScaleX := ZoomRect.Width/OutputRectangle.Width;
  ScaleX := (ZoomRect.Right-ZoomRect.Left)/(OutputRectangle.Right-OutputRectangle.Left);
//  ScaleY := ZoomRect.Height/OutputRectangle.Height;
  ScaleY := (ZoomRect.Bottom-ZoomRect.Top)/(OutputRectangle.Bottom-OutputRectangle.Top);
  If ScaleX>ScaleY Then
    VS := VS*ScaleX
  Else
    VS := VS*ScaleY;
//  ViewCenter := PointToRealPoint(OutputRectangle.CenterPoint);
  ViewCenter := PointToRealPoint(CenterPoint(OutputRectangle));
  VR := VR-ViewCenter.R+ZoomCenter.R;
  VI := VI-ViewCenter.I+ZoomCenter.I;
  UpdateImage;
End;

Faudra peut-être rajouter un "-1" aux soustractions, flemme de tester plus précisément.

Et tout en bas

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Procedure TGeneratorController.SetOutputRectangle(Value: TRect);
Begin
  FOutputRectangle := Value;
//  FPanStep := FOutputRectangle.Width Div 5;
  FPanStep := (FOutputRectangle.Right-FOutputRectangle.Left) Div 5;

Des surprises à venir avec la prochaine version, donc, car dans son programme le menu Edit propose une option Copy (sous-entendu l'image dans le presse-papiers) et à l'heure actuelle, que ça soit sous Linux ou sous XP, je gagne Cannot assign a TCompactImage to a TClipboard.
Vivement la 1.8

[tourlourou]

A voir s'il n'existe pas un truc style RegisterClipBoardFormat

[Jipété]

A voir s'il n'existe pas un truc style RegisterClipBoardFormat

Rien trouvé

Mais il y a des trucs qui compensent : je vous invite à sélectionner des zones à la souris sur l'image en tenant Shift appuyé !



C'est bientôt l'hiver, cette année les flocons sont bizarres

[Jipété]

Salut et bravo !

Cependant, après tous les déboires que j'ai vécus récemment avec l'installation des composants, je me suis dit qu'ici j'allais y aller doucement, et j'ai commencé par vouloir faire tourner le test de démo sans ton composant : facile, il suffit de commenter 3 lignes dans main.pas et de supprimer les données relatives à FastImage1 dans main.lfm, normalement ça aurait dû compiler, après avoir adapté le chemin de recherche des fichiers (Projet / Options / Chemins) mais que nenni !

Je me prends une méchante erreur lclfastbitmaphandler.pas(37,41) Error: Identifier not found "TRect" là :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
//===[ TLCLFASTBITMAPHANDLER ]==================================================
Type
  TLCLFastBitmapHandler = Class(TCustomFastBitmapHandler)
  Public
    Procedure DrawTo(Canvas: TCanvas; R:TRect);
  End;

avec le curseur qui clignote devant TRect, et si je rajoute Classes dans les uses, c'est plus loin que ça coince : lclfastbitmaphandler.pas(77,25) Error: Identifier not found "FCompactImage" là :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
{$ELSE}{$IFDEF LCLGTK2}
Begin
  gdk_draw_rgb_32_image(TGTKDeviceContext(Canvas.Handle).Drawable,
                        TGTKDeviceContext(Canvas.Handle).GC, 0, 0,
                        FCompactImage.Width, FCompactImage.Height,

J'avoue que ça me dépasse un peu...


Second point -- pourquoi utiliser cette construction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Constructor TCustomFastBitmapHandler.Create(CompactImage: TFastBitmap);
Begin
  FFastBitmap := CompactImage;

Pourquoi pas directement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Constructor TCustomFastBitmapHandler.Create;
Begin
  FFastBitmap := TFastBitmap;

?
Merci pour les précisions...

[BeanzMaster]

Bref, voilà les corrections pour le projet MandelBrot, et attention aux options du projet, où il a forcé Win64.
Dans le fichier Generators.pas :

Trop drôle ai fait les même modifs avant de venir ici

Sinon pour le benchmark

Ma config :
Processeur : AMD A10-7870K, RADEON 7,12 Compute Core 4C+8G 3.90Ghz
RAM : 16Go
Carte Graphique : NVidia GT 740 1Go (vivement noêl que je me paye une GTX 1080 )
Resolution : 1080p, 1920x1080
OS : Windows 10

En mode normal
Average Draw Time 7.75ms (129.03 fps)
Avec OpenGL :
Average Draw Time 16,54ms (60 fps)

ici avec l'opengl on depassera pas les 60fps et c'est normal.

Faudrais tester avec un "TBitmap.RawImage.Data" histoire de voir si il y une difference.

Pour Mandelbrot
Mode de generation et affichage normal
- Single ~355ms et display 3ms
- Double ~335ms et display 3ms
- SSE ~545ms et display 3ms

Mode de generation et affichage OpenGL
- Single ~354ms et display 6ms
- Double ~343ms et display 4ms
- SSE ~554ms et display 4ms

Sinon, pour cette histoire de "duplicate resource", ça me disait quelque chose et ça m'est revenu : c'est une histoire tordue entre les .lrs et les .rc, je ne me souviens pas comment je m'en suis sorti, peut-être en commentant toutes les lignes où ces extensions sont présentes puis en réactivant soit les .lrs soit les .rc, je ne sais plus trop mais c'est par là.

Ok merci je rechercherai par la dès que j'aurai un peu plus de temps libre.

[Jipété]

En mode normal
Average Draw Time 7.75ms (129.03 fps)

Pour Mandelbrot
Mode de generation et affichage normal
- Single ~355ms et display 3ms

Oh lala j'ai honte ! J'ai une vieille Radeon 710, et ça donne
en haut : 22 ms et 45 fps
en bas : 683 ms et 43 ms, une horreur...

Faudrait tester avec un "TBitmap.RawImage.Data" histoire de voir si il y a une différence.

Tu n'aurais pas un exemple, stp ?, vu que je n'ai jamais travaillé de cette manière.

[BeanzMaster]

Je viens de retenter de compiler et j'ai eu ce message :
Fatal: Impossible de trouver system utilisé par Test. Vérifiez que tous les fichiers "ppu" du paquet soient présents dans le répertoire de sortie. "ppu" dans un répertoire incorrect = /usr/lib/fpc/3.0.0/units/x86_64-linux/rtl/system.ppu..


j'ai vérifié il est bien présent pourtant ???

Messages - Avertissements : 1
Warning: other sources path of "Test" contains "/usr/share/lazarus/1.6.2/lcl", which belongs to package "LCLBase"
Compiler le paquet FCL 1.0.1: Succès
Compiler le paquet LazUtils 1.0: Succès - Avertissements : 2
unixfileutil.inc(6,51) Warning: Symbol "UTF8ToSys" is deprecated: "Use the function in LazUTF8 unit"
unixfileutil.inc(6,11) Warning: Symbol "SysToUTF8" is deprecated: "Use the function in LazUTF8 unit"
Compiler le paquet LCLBase 1.6.2: Succès
Compiler le paquet LCL 1.6.2: Succès - Conseils : 2
gtk2wsdialogs.pp(46,40) Hint: Parameter "ACommonDialog" not used
gtk2wsforms.pp(967,8) Note: User defined: test with smaller minor versions and check where LM_CONFIGUREEVENT is needed.
Compiler le paquet fastbitmap 0.0: Succès - Avertissements : 10 - Conseils : 8
fastbitmapcore.pas(367,4) Warning: User defined: : GetInternalPixel Not used here
fastbitmapcore.pas(380,4) Warning: User defined: : SetInternalPixel Not used here
fastimage.pas(59,42) Hint: Parameter "WithThemeSpace" not used
ucrossplateform.pas(345,33) Hint: Function result variable does not seem to be initialized
ucrossplateform.pas(397,33) Hint: Function result variable does not seem to be initialized
ucrossplateform.pas(413,30) Hint: Local variable "cur" does not seem to be initialized
ucrossplateform.pas(416,35) Hint: Local variable "freq" does not seem to be initialized
ucrossplateform.pas(449,4) Warning: User defined: Needs to be implemented
ucrossplateform.pas(534,19) Warning: Symbol "DecimalSeparator" is deprecated
ucrossplateform.pas(209,34) Hint: Parameter "device" not used
ucrossplateform.pas(892,6) Warning: User defined: : Not impleted on your OS
ucrossplateform.pas(972,4) Warning: User defined: : Not implemented on you OS
ucrossplateform.pas(1002,4) Warning: User defined: : Not implemented on you OS
ucrossplateform.pas(169,26) Hint: Parameter "DriveChar" not used
ucrossplateform.pas(1046,4) Warning: User defined: : Not implemented on you OS
ucrossplateform.pas(1141,4) Warning: User defined: : Not implemented on you OS
ucrossplateform.pas(1158,17) Warning: Symbol "CommandLine" is deprecated
ucrossplateform.pas(31,13) Hint: Unit "unixutil" not used in ucrossplateform
Compiler le paquet LazOpenGLContext 0.0.1: Succès
Compilation du projet - Cible : bin/linux/Test-x86_64 : Code de sortie 256 - Erreurs : 1
Fatal: Impossible de trouver system utilisé par Test. Vérifiez que tous les fichiers "ppu" du paquet soient présents dans le répertoire de sortie. "ppu" dans un répertoire incorrect = /usr/lib/fpc/3.0.0/units/x86_64-linux/rtl/system.ppu..

[Jipété]

Si mais ce que je voulais dire c'est que ce fichier peux rentrer en conflit avec un autre fichier du même non présent dans les dossiers sources de Lazarus.

Du coup j'ai ouvert tous les .pas du projet et pour tous j'ai dit "Ajouter le fichier de l'éditeur au projet" et maintenant je bloque comme toi sur ucrossplateform...

Et la plein d'erreurs (c'est quand même pas évident de faire quelques chose de portable) sur ce j'ai modifié pas mal de petites choses dans le fichier uCrossplateform (et dire que certain code provienne du wiki pfff ).

Ouais ouais, je suis dessus aussi, et pour le moment je coince là :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
procedure QueryPerformanceCounter(var val: Int64);
{$IFDEF WINDOWS}
begin
  Windows.QueryPerformanceCounter(val);
end;
{$ENDIF}
{$IFDEF LINUX}
var
  tz: timeval;
begin
  fpgettimeofday(@tz, nil);
  val := tz.tv_sec - vProgStartSecond; // l'animal ne connait pas cette variable (qui arriverait dans la procédure comment, au fait ?)
  val := val * 1000000;
  val := val + tz.tv_usec;
end;
{$ENDIF}

et j'en ai une autre plus bas :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
function getCurrentNumVer: TInt4Array;
var
  vInfoSize,
  aDword,
  vValueSize: dword;
  vInfo:      pointer;
  vValue:     PVSFixedFileInfo; // inconnu suite à déplacement de "fileinfo" dans {$IFDEF WINDOWS}

Mais tu as dû les voir aussi...

Bon cela étant fait je lance le projet Test et la paf j'obtiens :
[--snip--]
Compilation du projet - Cible : bin/linux/Test-x86_64 : Code de sortie 256 - Erreurs : 1
Et toujours ce problemes avec le code Erreur 256
Une petite idée, sur ce que je n'ai pas fait ?

Essaye de remettre les paramètres Projet / Options / Configuration et cible à "default"...

Je viens de retenter de compiler et j'ai eu ce message :
Fatal: Impossible de trouver system utilisé par Test. Vérifiez que tous les fichiers "ppu" du paquet soient présents dans le répertoire de sortie. "ppu" dans un répertoire incorrect = /usr/lib/fpc/3.0.0/units/x86_64-linux/rtl/system.ppu..


j'ai vérifié il est bien présent pourtant ???

Est-ce que les .pas font bien partie du projet (ce que j'ai fait comme expliqué tout en haut : "Ajouter...") ?
De ce que j'en ai vu, j'aurais tendance à dire non, or je pense qu'ils devraient l'être.

[BeanzMaster]

Du coup j'ai ouvert tous les .pas du projet et pour tous j'ai dit "Ajouter le fichier de l'éditeur au projet" et maintenant je bloque comme toi sur ucrossplateform...


Ouais ouais, je suis dessus aussi, et pour le moment je coince là :

Tiens voila le fichier modifié

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
//==============================================================================
// uCrossPlateform.pas
//------------------------------------------------------------------------------
// Historique :
// 20/11/16 - BeanzMaster - Creation
//------------------------------------------------------------------------------
// Description :
// Unité regroupant des procedure et fonctions compatibles sur plusieur OS :
// Windows, Linux et Mac.
//------------------------------------------------------------------------------
// Credits :
//
//------------------------------------------------------------------------------
//==============================================================================
unit ucrossplateform;
//==============================================================================
 
{$I beanz.inc}
 
//==============================================================================
 
interface
 
//==============================================================================
 
uses
{$IFDEF WINDOWS}
  Windows,
{$ENDIF}
{$IFDEF LINUX}
  BaseUnix, UnixUtil, Unix,
{$ENDIF}
{$IFDEF X11_SUPPORT}
  xlib,
{$ENDIF}
  LCLVersion,  LCLType,  FileUtil, LazUtf8, lazfileutils, types,
  Classes, SysUtils, DateUtils,  // SyncObjs,
  UCommonTypes;
 
 
//==============================================================================
{$IFNDEF FPC}
  //----------------------------------------------------------------------------
  // Ces nouveaux types ont été ajoutés pour être en mesure de gérer des pointeurs
  // vers des entiers en mode 64 bits, car dans FPC 'Integer' le type est toujours
  // 32 bits (ou 16 bits en mode Pascal), mais dans Delphi il est spécifique à la
  // plate-forme et peut être 16 , 32 ou 64 bits.
  //----------------------------------------------------------------------------
  type
    Int = {$IFDEF CPU64}Int64{$ELSE}LongInt{$ENDIF};
    UInt = {$IFDEF CPU64}UInt64{$ELSE}LongWord{$ENDIF};
 
    DWORD = Types.DWORD; {$NODEFINE DWORD}
    TPoint = Types.TPoint;{$NODEFINE TPoint}
    PPoint = Types.PPoint;{$NODEFINE PPoint}
    TRect = Types.TRect;  {$NODEFINE TRect}
    PRect = Types.PRect;  {$NODEFINE PRect}
 
{$ELSE}
  type
    Int = {$IFDEF CPU64}Int64{$ELSE}Integer{$ENDIF};
    UInt = {$IFDEF CPU64}UInt64{$ELSE}Cardinal{$ENDIF};
 
    DWORD = System.DWORD;
    TPoint = Types.TPoint;
    PPoint = ^TPoint;
    TRect = Types.TRect;
    PRect = ^TRect;
 
{$ENDIF}
 
 
Type
  TPlatformInfo = record
    Major: DWORD;
    Minor: DWORD;
    Revision: DWORD;
    Version: string;
    PlatformId   :DWORD;
    ID: string;
    CodeName: string;
    Description: string;
    ProductBuildVersion: string;
  end;
 
Type
  TPlatformVersion =
    (
      pvUnknown,
      pvWin95,
      pvWin98,
      pvWinME,
      pvWinNT3,
      pvWinNT4,
      pvWin2000,
      pvWinXP,
      pvWin2003,
      pvWinVista,
      pvWinSeven,
      pvWin2008,
      pvWin8,
      pvWin10,
 
      pvLinuxArc,
      pvLinuxDebian,
      pvLinuxopenSUSE,
      pvLinuxFedora,
      pvLinuxGentoo,
      pvLinuxMandriva,
      pvLinuxRedHat,
      pvLinuxTurboLinux,
      pvLinuxUbuntu,
      pvLinuxXandros,
      pvLinuxOracle,
      pvAppleMacOSX
    );
 
Type
  TDeviceCapabilities = record
    Xdpi, Ydpi: integer; // Nombre de pixel logique par pouce.
    Depth: integer; // profondeur de couleur (bit).
    NumColors: integer; // Nombre d'entrées dans la table des couleurs de l'appareil.
  end;
 
  //Surveillance de la mémoire HEAP/RAM
  // --- Rolf
Type
    PHeapMRec = ^THeapMRec;
    THeapMRec = record
      Extra:                                 string;
      case integer of
        // Heap
  {$IFDEF FPC}
        0: (MaxHeapSize:                     PtrUInt;   // Taille maximum autorisée pour le tas, en octets
            MaxHeapUsed:                     PtrUInt;   // Taille maximum utilisée pour le tas, en octets
            CurrHeapSize:                    PtrUInt;   // Taiile du tas en cours, en octets
            CurrHeapUsed:                    PtrUInt;   // Taiile du tas utilisé en cours, en octets
            CurrHeapFree:                    PtrUInt);  // Taiile libre du tas en cours, en octets
  {$ELSE}
        0: (AllocatedSmallBlockCount:        cardinal;
            TotalAllocatedSmallBlockSize:    NativeUInt;
            ReservedSmallBlockAddressSpace:  NativeUInt;
            AllocatedMediumBlockCount:       cardinal;
            TotalAllocatedMediumBlockSize:   NativeUInt;
            ReservedMediumBlockAddressSpace: NativeUInt;
            AllocatedLargeBlockCount:        cardinal;
            TotalAllocatedLargeBlockSize:    NativeUInt;
            ReservedLargeBlockAddressSpace:  NativeUInt);
  {$ENDIF}
        // Ram
        1: (MemoryLoad:                      cardinal;
            TotalPhysical:                   UInt64;
            AvailPhysical:                   UInt64;
            TotalPageFile:                   UInt64;
            AvailPageFile:                   UInt64;
            TotalVirtual:                    UInt64;
            AvailVirtual:                    UInt64);
      end;
 
//==============================================================================
 
//------------------------------------------------------------------------------
// Fonctions sur les disques, dossiers et fichiers
//------------------------------------------------------------------------------
 
// Retourne les lettres des disques
function GetDriveLetters:string ;
// Retourne le nom d'un disque
function GetVolumeLabel (DriveChar: char): string;
// Retourne le dossier de l'application en cours
function GetAppPath : string;
// Defini le dossier de notre executable
procedure SetExeDirectory;
// Retourne le chemin relatif
function GetRelativePath(const S: string): string;
// Fix les problème de délimiteur de path suivant le systeme
procedure FixPathDelimiter(var S: string);
// Retrourne TRUE si l'acces en écriture d'un dossier est possible
function IsDirectoryWriteable(const AName: string): Boolean;
// Ouvre un fichier HTML ou une Url dans le navigateur par defaut
procedure ShowHTMLUrl(Url: string);
// Retourne le répertoire temporaire de l'OS
function GetTempFolderPath : string;
 
//------------------------------------------------------------------------------
// Fonctions d'informations sur le systeme
//------------------------------------------------------------------------------
 
// Renvoi le format de la decimal de notre systeme
function GetDecimalSeparator: Char;
// Definit le format décimal "." ou "," habituellement
procedure SetDecimalSeparator(AValue: Char);
 
// Retourne les infos sur l'OS
function GetPlatformInfo: TPlatformInfo;
// Retrourne la version de l'OS
function GetPlatformVersion : TPlatformVersion;
// Retrourne la version de l'OS  sous forme de chaine de caratères
function GetPlatformVersionAsString : string;
 
// Retourne des informations sur la mémoire, sous forme de chaine de caratères
function GetMemoryStatusAsString:String;
 
// Retourne les carateristique d'affichage de l'appareil
function GetDeviceCapabilities: TDeviceCapabilities;
// Retourne le nombre de bit pour l'affichage
function GetCurrentColorDepth: Integer;
// Retourne la largeur de l'affichage en DPI
function GetDeviceLogicalPixelsX(device: HDC): Integer;
// Retourne les carateristique d'affichage de l'appareil sous forme de chaine de caratères
function GetDeviceCapabilitiesAsString: String;
 
// Retourne le nom de fichier de l'application en cours
function GetAppFileName : string;
// Retourne les lettres des disques sous forme de chaine de cractères séparé par une virgule
function GetVersionExeAsString: string;
 
// Retourne les informations sur l'application en cours
// /!\ Attention vous devez activer et definir ces infos dans les options votre projet,
// sinon c'est plantage direct
function GetAppInfosAsString:String;
 
// Retourne le nom du CPU, sous forme de chaine de caratères
function GetCPUName : string;
// Retourne le nombres de thread maximum (nombre de coeur du processeur)
function GetMaxThreads : byte;
// Retourne le nombre processeur (coeur)
function GetLogicalProcessorCount: Integer;
 
//------------------------------------------------------------------------------
// Fonctions Timers
//------------------------------------------------------------------------------
 
function RDTSC: Int64;
function Get_TickCount: int64;
function NowPrecise: TDateTime;
function StartPrecisionTimer: Int64;
function StopPrecisionTimer(const precisionTimer: Int64): Double;
function PrecisionTimerLap(const precisionTimer: Int64): Double;
 
 
var
   PerformanceFrequency: Int64;
//==============================================================================
//==============================================================================
implementation
 
uses
 {$IFDEF FPC}
   resreader, fileinfo, resource, versionresource,process,forms,
   {$IFDEF WINDOWS}
    ShellApi,
    JwaWinBase,{, JwaWinNt}
    winpeimagereader; {need this for reading exe info}
   {$ENDIF}
   {$IFDEF LINUX}
     LCLProc,
     elfreader; {needed for reading ELF executables}
   {$ENDIF}
   {$IFDEF DARWIN}
     XMLRead,
     DOM,
     machoreader; {needed for reading MACH-O executables};
   {$ENDIF}
 {$ELSE}
   ShellApi;
 {$ENDIF}
//==============================================================================
 
type
  TInt4Array     = array[0..3] of integer;
 
//==============================================================================
 
var
 
 //NowPreciseLock: TCriticalSection;
 vInvPerformanceCounterFrequency: Double;
 vInvPerformanceCounterFrequencyReady: Boolean = False;
 
//==============================================================================
 
 
 
//------------------------------------------------------------------------------
// Retourne le chemin relatif
function GetRelativePath(const S: string): string;
var
{$IFNDEF FPC}
  path: string;
{$ELSE}
  path: UTF8String;
{$ENDIF}
begin
    Result := S;
    path := ExtractFilePath(s);
    path := IncludeTrailingPathDelimiter(path);
 
  if (Pos(path, S) = 1) then
    system.Delete(Result, 1, Length(path));
 
end;
 
//------------------------------------------------------------------------------
// QueryPerformanceCounter
 
{$IFDEF UNIX}
var
  vProgStartSecond: int64;
 
procedure Init_vProgStartSecond;
var
  tz: timeval;
begin
  fpgettimeofday(@tz, nil);
  vProgStartSecond := tz.tv_sec;
end;
{$ENDIF}
 
procedure QueryPerformanceCounter(var val: Int64);
{$IFDEF WINDOWS}
begin
  Windows.QueryPerformanceCounter(val);
end;
{$ENDIF}
{$IFDEF LINUX}
var
  tz: timeval;
begin
  fpgettimeofday(@tz, nil);
  val := tz.tv_sec - vProgStartSecond;
  val := val * 1000000;
  val := val + tz.tv_usec;
end;
{$ENDIF}
 
//------------------------------------------------------------------------------
// Equivalent à GetTickCount/64 mais portable
function Get_TickCount: Int;
begin
{$IFDEF WINDOWS}
  {$IFDEF CPU64}result := GetTickCount64{$ELSE}result := GetTickCount{$ENDIF};
{$ENDIF}
{$IFDEF LINUX}
  QueryPerformanceCounter(result);
{$ENDIF}
end;
 
//------------------------------------------------------------------------------
// Version precise de Now(), renvoie un resultat en secondes
function NowPrecise: TDateTime;
var
  {$IFDEF LINUX}T: TimeVal;{$ENDIF}
  {$IFDEF WINDOWS}TimerValue: Int64;{$ENDIF}
begin
//  Result := Now;
  //try
    //NowPreciseLock.Acquire;
    {$IFDEF WINDOWS}
    QueryPerformanceCounter(TimerValue);
    //Result := Int64(TimeStampToMSecs(DateTimeToTimeStamp(Now)) * 1000) // an alternative Win32 timebase
    Result := TimerValue / PerformanceFrequency;
    {$ENDIF}
 
    {$IFDEF LINUX}
    fpgettimeofday(@t, nil);
     // Build a 64 bit microsecond tick from the seconds and microsecond longints
    Result := t.tv_sec + t.tv_usec / 1000000;
    {$ENDIF}
 
    Result := Result * OneSecond;
    //Result := (Trunc(Now / OneSecond) + Frac(Result)) * OneSecond;
  //finally
    //NowPreciseLock.Release;
  //end;
end;
 
//------------------------------------------------------------------------------
// QueryPerformanceFrequency
function QueryPerformanceFrequency(var val: Int64): Boolean;
{$IFDEF WINDOWS}
begin
  Result := Boolean(Windows.QueryPerformanceFrequency(val));
end;
{$ENDIF}
{$IFDEF LINUX}
begin
  val := 1000000;
  Result := True;
end;
{$ENDIF}
 
//------------------------------------------------------------------------------
// StartPrecisionTimer
function StartPrecisionTimer: Int64;
begin
  QueryPerformanceCounter(Result);
end;
 
//------------------------------------------------------------------------------
// PrecisionTimeLap
function PrecisionTimerLap(const precisionTimer: Int64): Double;
begin
  Result := StopPrecisionTimer(precisionTimer);
end;
 
//------------------------------------------------------------------------------
// StopPrecisionTimer
function StopPrecisionTimer(const precisionTimer: Int64): Double;
var
  cur, freq: Int64;
begin
  QueryPerformanceCounter(cur);
  if not vInvPerformanceCounterFrequencyReady then
  begin
    QueryPerformanceFrequency(freq);
    vInvPerformanceCounterFrequency := 1.0 / freq;
    vInvPerformanceCounterFrequencyReady := True;
  end;
  Result := (cur - precisionTimer) * vInvPerformanceCounterFrequency;
end;
 
//------------------------------------------------------------------------------
// RDTSC
function RDTSC: Int64;
{$IFDEF FPC}
begin
  raise exception.create('Using uCrossPlatform.RDTSC with FPC is a bad idea!');
  Result := 0;
end;
{$ELSE}
asm
   db $0f, $31
end;
{$ENDIF}
 
//------------------------------------------------------------------------------
// Retourne le nombre processeur (coeur)
function GetLogicalProcessorCount: Integer;
{$IFDEF WINDOWS}
var
  SystemInfo: _SYSTEM_INFO;
begin
  GetSystemInfo(SystemInfo);
  Result := SystemInfo.dwNumberOfProcessors;
end;
{$ELSE}
Begin
  {$MESSAGE Warn 'Needs to be implemented'}
  Result:=0;
end;
{$ENDIF}
//------------------------------------------------------------------------------
// Ouvre un fichier HTML ou une Url dans le navigateur par defaut
procedure ShowHTMLUrl(Url: string);
begin
{$IFDEF WINDOWS}
  ShellExecute(0, 'open', PChar(Url), nil, nil, SW_SHOW);
{$ENDIF}
{$IFDEF LINUX}
  fpSystem(PChar('env xdg-open ' + Url));
{$ENDIF}
end;
 
//------------------------------------------------------------------------------
// Retourne le dossier de l'application en cours
function GetAppPath : string;
var
{$IFNDEF FPC}
  path: string;
{$ELSE}
  path: UTF8String;
{$ENDIF}
begin
{$IFNDEF FPC}
  path := ExtractFilePath(ParamStr(0));
  path := IncludeTrailingPathDelimiter(path);
{$ELSE}
  path := ExtractFilePath(ParamStrUTF8(0));
  path := IncludeTrailingPathDelimiter(path);
{$ENDIF}
  result:=path;
end;
 
//------------------------------------------------------------------------------
// Retourne le nom de fichier de l'application en cours
function GetAppFileName : string;
var
{$IFNDEF FPC}
  path: string;
{$ELSE}
  path: UTF8String;
{$ENDIF}
begin
{$IFNDEF FPC}
  path := ExtractFileName(ParamStr(0));
{$ELSE}
  path := ExtractFileName(ParamStrUTF8(0));
{$ENDIF}
  result:=path;
end;
 
//------------------------------------------------------------------------------
// Defini le dossier de notre executable
procedure SetExeDirectory;
var
{$IFNDEF FPC}
  path: string;
{$ELSE}
  path: UTF8String;
{$ENDIF}
begin
    path := GetAppPath();
{$IFNDEF FPC}
    SetCurrentDir(path);
{$ELSE}
    SetCurrentDirUTF8(path);
{$ENDIF}
end;
 
//------------------------------------------------------------------------------
// Renvoi le format de la decimal de notre systeme
function GetDecimalSeparator: Char;
begin
  Result :=
{$IFDEF FPC}
  {$IF (lcl_release > 29) }
  DefaultFormatSettings.
  {$IFEND}
{$ENDIF}
{$IFDEF GLS_DELPHI_XE_UP}
  FormatSettings.
  {$ENDIF}
  DecimalSeparator;
end;
 
//------------------------------------------------------------------------------
// Definit le format décimal "." ou "," habituellement
procedure SetDecimalSeparator(AValue: Char);
begin
{$IFDEF FPC}
  DefaultFormatSettings.DecimalSeparator := AValue;
{$ENDIF}
{$IFDEF DELPHI_XE_UP}
  FormatSettings. DecimalSeparator := AValue;
{$ENDIF}
end;
 
//------------------------------------------------------------------------------
// Fix les problème de délimiteur de path suivant le systeme
procedure FixPathDelimiter(var S: string);
var
  I: Integer;
begin
  for I := Length(S) downto 1 do
    if (S[I] = '/') or (S[I] = '\') then
      S[I] := PathDelim;
end;
 
//------------------------------------------------------------------------------
// Retourne les infos sur l'OS
function GetPlatformInfo: TPlatformInfo;
var
  {$IFDEF MSWINDOWS}
  OSVersionInfo : windows.TOSVersionInfo;
  //LPOSVERSIONINFOA; //
  {$ENDIF}
  {$IFDEF UNIX}
    {$IFNDEF DARWIN}
  ReleseList: TStringList;
    {$ENDIF}
  str: String;
    {$IFDEF DARWIN}
  Documento: TXMLDocument;
  Child: TDOMNode;
  i:integer;
    {$ENDIF}
  {$ENDIF}
begin
  {$IFDEF WINDOWS}
  With Result do
  begin
    OSVersionInfo.dwOSVersionInfoSize := sizeof(TOSVersionInfo);
 
    if not windows.GetVersionEx(OSVersionInfo) then Exit;
 
    Minor := OSVersionInfo.DwMinorVersion;
    Major := OSVersionInfo.DwMajorVersion;
    Revision := OSVersionInfo.dwBuildNumber;
    PlatformId := OSVersionInfo.dwPlatformId;
    Version :=  InttoStr(OSVersionInfo.DwMajorVersion)+'.'+InttoStr(OSVersionInfo.DwMinorVersion)+' Build : '+InttoStr(OSVersionInfo.dwBuildNumber);
  end;
  {$ENDIF}
  {$IFDEF LINUX}
  {$IFNDEF DARWIN}
  ReleseList := TStringList.Create;
 
  with Result,ReleseList do
  begin
    if FileExists('/etc/lsb-release')  then
      LoadFromFile('/etc/lsb-release')
    else Exit;
 
    ID := Values['DISTRIB_ID'];
    Version := Values['DISTRIB_RELEASE'];
    CodeName := Values['DISTRIB_CODENAME'];
    Description := Values['DISTRIB_DESCRIPTION'];
    Destroy;
  end;
  {$ENDIF}
  {$IFDEF DARWIN}
  if FileExists('System/Library/CoreServices/ServerVersion.plist')  then
    ReadXMLFile(Documento, 'System/Library/CoreServices/ServerVersion.plist')
  else Exit;
  Child := Documento.DocumentElement.FirstChild;
 
  if Assigned(Child) then
  begin
    with Child.ChildNodes do
    try
      for i := 0 to (Count - 1) do
      begin
        if Item[i].FirstChild.NodeValue='ProductBuildVersion' then
          Result.ProductBuildVersion:=Item[i].NextSibling.FirstChild.NodeValue;
        if Item[i].FirstChild.NodeValue='ProductName' then
          Result.ID:=Item[i].NextSibling.FirstChild.NodeValue;
        if Item[i].FirstChild.NodeValue='ProductVersion' then
          Result.Version:=Item[i].NextSibling.FirstChild.NodeValue;
      end;
    finally
      Free;
    end;
  end;
  {$ENDIF}
  //Major.Minor.Revision
  str:=Result.Version;
  if str='' then Exit;
  Result.Major:=StrtoInt( Copy(str, 1, Pos('.',str)-1) );
  Delete(str, 1, Pos('.', str) );
 
  //10.04
  if Pos('.', str) = 0 then
  begin
    Result.Minor:=StrtoInt( Copy(str, 1, Length(str)) );
    Result.Revision:=0;
  end else
  //10.6.5
    begin
       Result.Minor:=StrtoInt( Copy(str, 1, Pos('.',str)-1) );
       Delete(str, 1, Pos('.', str) );
       Result.Revision:=StrtoInt( Copy(str, 1, Length(str)) );
    end;
  {$ENDIF}
end;
 
//------------------------------------------------------------------------------
// Retrourne la version de l'OS
function GetPlatformVersion : TPlatformVersion;
{$IFDEF Unix}
var
  i: integer;
const
VersStr : array[TPlatformVersion] of string = (
  '',  '',  '',  '',  '',  '',
  '',  '',  '',  '',  '',  '',
  '', '',
  'Arc',
  'Debian',
  'openSUSE',
  'Fedora',
  'Gentoo',
  'Mandriva',
  'RedHat',
  'TurboLinux',
  'Ubuntu',
  'Xandros',
  'Oracle',
  'Mac OS X'
  );
{$ENDIF}
begin
  Result := pvUnknown;
  {$IFDEF WINDOWS}
  with GetPlatformInfo do
  begin
        if Version='' then Exit;
        case Major of
          0..2: Result := pvUnknown;
          3:  Result := pvWinNT3;              // Windows NT 3
          4:  case Minor of
                0: if PlatformId = VER_PLATFORM_WIN32_NT
                   then Result := pvWinNT4     // Windows NT 4
                   else Result := pvWin95;     // Windows 95
                10: Result := pvWin98;         // Windows 98
                90: Result := pvWinME;         // Windows ME
              end;
          5:  case Minor of
                0: Result := pvWin2000;         // Windows 2000
                1: Result := pvWinXP;          // Windows XP
                2: Result := pvWin2003;        // Windows 2003
              end;
          6:  case Minor of
                0: Result := pvWinVista;         // Windows Vista
                1: Result := pvWinSeven;          // Windows Seven
                2: Result := pvWin2008;        // Windows 2008
                3..4: Result := pvUnknown;
              end;
          7..8:  Result := pvWin8;
          9..10:  Result := pvWin10;
        end;
   end;
  {$ENDIF}
  {$IFDEF LINUX}
  with GetPlatformInfo do
  begin
    if Version='' then Exit;
    For i:= 13 to Length(VersStr)-1 do
     if ID=VersStr[TPlatformVersion(i)] then
       Result := TPlatformVersion(i);
  end;
  {$ENDIF}
end;
 
//------------------------------------------------------------------------------
// Retrourne la version de l'OS  sous forme de chaine de caratères
function GetPlatformVersionAsString : string;
const
  VersStr : array[TPlatformVersion] of string = (
    'Inconnu',
    'Windows 95',
    'Windows 98',
    'Windows ME',
    'Windows NT 3',
    'Windows NT 4',
    'Windows 2000',
    'Windows XP',
    'Windows 2003',
    'Windows Vista',
    'Windows Seven',
    'Windows 2008',
    'Windows 8',
    'Windows 10',
 
    'Linux Arc',
    'Linux Debian',
    'Linux openSUSE',
    'Linux Fedora',
    'Linux Gentoo',
    'Linux Mandriva',
    'Linux RedHat',
    'Linux TurboLinux',
    'Linux Ubuntu',
    'Linux Xandros',
    'Linux Oracle',
    'Apple MacOSX');
begin
  Result := VersStr[GetPlatformVersion];
end;
 
//------------------------------------------------------------------------------
// Retrourne TRUE si l'acces en écriture d'un dossier est possible
function IsDirectoryWriteable(const AName: string): Boolean;
var
  LFileName: String;
{$IFDEF WINDOWS}
  LHandle: THandle;
{$ENDIF}
begin
  LFileName := IncludeTrailingPathDelimiter(AName) + 'chk.tmp';
{$IFDEF WINDOWS}
  LHandle := CreateFile(PChar(LFileName), GENERIC_READ or GENERIC_WRITE, 0, nil,
    CREATE_NEW, FILE_ATTRIBUTE_TEMPORARY or FILE_FLAG_DELETE_ON_CLOSE, 0);
  Result := LHandle <> INVALID_HANDLE_VALUE;
  if Result then
    CloseHandle(LHandle);
{$ELSE}
  Result := fpAccess(PChar(LFileName), W_OK) <> 0;
{$ENDIF}
end;
 
//------------------------------------------------------------------------------
// Retourne les carateristique d'affichage de l'appareil
function GetDeviceCapabilities: TDeviceCapabilities;
{$IFDEF WINDOWS}
var
  Device: HDC;
begin
  Device := GetDC(0);
  try
    result.Xdpi := GetDeviceCaps(Device, LOGPIXELSX);
    result.Ydpi := GetDeviceCaps(Device, LOGPIXELSY);
    result.Depth := GetDeviceCaps(Device, BITSPIXEL);
    result.NumColors := GetDeviceCaps(Device, NUMCOLORS);
  finally
    ReleaseDC(0, Device);
  end;
end;
{$ELSE}
{$IFDEF X11_SUPPORT}
var
  dpy: PDisplay;
begin
  dpy := XOpenDisplay(nil);
  Result.Depth := DefaultDepth(dpy, DefaultScreen(dpy));
  XCloseDisplay(dpy);
 
  Result.Xdpi := 96;
  Result.Ydpi := 96;
  Result.NumColors := 1;
end;
{$ELSE}
begin
  {$MESSAGE Warn 'Needs to be implemented'}
end;
{$ENDIF}
 
{$ENDIF}
//------------------------------------------------------------------------------
// Retourne les carateristique d'affichage de l'appareil sous forme de chaine de caratères
function GetDeviceCapabilitiesAsString: String;
Var
  s:String;
begin
  s:='';
  with GetDeviceCapabilities() do
  begin
    s:=  'Resolution : '+Inttostr(Screen.Width)+'x'+Inttostr(Screen.Height)+#13#10;
    s:=s+'DPI        : '+ Inttostr(Xdpi) +'x'+inttostr(Ydpi)+#13#10;
    s:=s+'Format     : '+ Inttostr(Depth)+' Bits'+#13#10;
    //s:=s+'Couleurs : '+ Inttostr(NumColors);
  end;
  result:=s;
end;
 
//------------------------------------------------------------------------------
// Retourne la largeur de l'affichage en DPI
function GetDeviceLogicalPixelsX(device: HDC): Integer;
begin
  result := GetDeviceCapabilities().Xdpi;
end;
 
//------------------------------------------------------------------------------
//  Retourne le nombre de bit pour l'affichage
function GetCurrentColorDepth: Integer;
begin
  result := GetDeviceCapabilities().Depth;
end;
 
//------------------------------------------------------------------------------
// Retourne les N° de version majeur et mineur de l'appli, le N° de révision, et
// le Build ;
function getCurrentNumVer: TInt4Array;
{$IFDEF WINDOWS}
var
  vInfoSize,
  aDword,
  vValueSize: dword;
  vInfo:      pointer;
  vValue:     PVSFixedFileInfo;
begin
  ZeroMemory(@Result,SizeOf(Result));
  aDword:=0;
  vValueSize:=0;
  vValue:=nil;
  try
 
    {$IFDEF FPC}
      vInfoSize:=GetFileVersionInfoSizeW(pWideChar(UTF8Decode(ParamStrUTF8(0))),aDword);
    {$ELSE}
      vInfoSize:=GetFileVersionInfoSizeW(pWideChar(UTF8Decode(ParamStr(0))),aDword);
    {$ENDIF}
 
    if vInfoSize=0 then exit;
    GetMem(vInfo,vInfoSize);
    {$IFDEF FPC}
       GetFileVersionInfoW(pWideChar(UTF8Decode(ParamStrUTF8(0))),0,vInfoSize,vInfo);
    {$ELSE}
        GetFileVersionInfoW(pWideChar(UTF8Decode(ParamStr(0))),0,vInfoSize,vInfo);
    {$ENDIF}
    VerQueryValueW(vInfo,'\',pointer(vValue),vValueSize);
    Result[0]:=vValue^.dwFileVersionMS shr 16;
    Result[1]:=vValue^.dwFileVersionMS and $FFFF;
    Result[2]:=vValue^.dwFileVersionLS shr 16;
    Result[3]:=vValue^.dwFileVersionLS and $FFFF ;
    FreeMem(vInfo,vInfoSize);
  except
    Result[0]:=-1;
  end;
end;
{$ELSE}
begin
    {$message warn : Not impleted on your OS }
    Result[0]:=0;
    Result[1]:=0;
    Result[2]:=0;
    Result[3]:=0;
end;
{$endif}
 
//------------------------------------------------------------------------------
// Retourne les N° de version de l'application en cours sous forme de chaine de caratères
function GetVersionExeAsString: string;
var
  nVer: TInt4Array;
begin
  nVer   := getCurrentNumVer;
  Result := IntToStr(nVer[0]) + '.' + IntToStr(nVer[1]) + '.'
          + IntToStr(nVer[2]) + '.' + IntToStr(nVer[3]);
end;
 
// Retourne les informations sur l'application en cours
function getAppInfosAsString:String;
var
  FileVerInfo: TFileVersionInfo;
  s:string;
begin
 
  FileVerInfo:=TFileVersionInfo.Create(nil);
  result:='Pas d''informations';
  try
    s:='';
    FileVerInfo.FileName:=getAppFileName();
    FileVerInfo.ReadFileInfo;
    s:=s+'Nom originel       : '+FileVerInfo.VersionStrings.Values['OriginalFilename']+#13#10;
    s:=s+'Companie           : '+FileVerInfo.VersionStrings.Values['CompanyName']+#13#10;
    s:=s+'Description        : '+FileVerInfo.VersionStrings.Values['FileDescription']+#13#10;
    s:=s+'Version            : '+FileVerInfo.VersionStrings.Values['FileVersion']+#13#10;
    s:=s+'Copyright          : '+FileVerInfo.VersionStrings.Values['LegalCopyright']+#13#10;
    s:=s+'Nom interne        : '+FileVerInfo.VersionStrings.Values['InternalName']+#13#10;
    s:=s+'Nom du produit     : '+FileVerInfo.VersionStrings.Values['ProductName']+#13#10;
    s:=s+'Version du produit : '+FileVerInfo.VersionStrings.Values['ProductVersion']+#13#10;
  finally
    FileVerInfo.Free;
    result:=s;
  end;
end;
 
//------------------------------------------------------------------------------
// Retourne les lettres des disques sous forme de chaine de cractères séparé par une virgule
function GetDriveLetters:string ;
{$IFDEF WINDOWS}
var
  vDrivesSize: cardinal;
  vDrives:     array[0..128] of char;
  vDrive:      pChar;
  s:string;
begin
 
  try
    s:='';
    vDrivesSize:=GetLogicalDriveStrings(SizeOf(vDrives),vDrives);
    if vDrivesSize=0 then  // no drive found, no further processing needed
    begin
      result:='';
      exit;
    end;
 
    vDrive:=vDrives;
 
    while vDrive^<>#0 do
    begin
      if (s<>'') then s:=s+', ';
      s:=s+StrPas(vDrive);
      inc(vDrive,Length(vDrive)+1);
    end;
  finally
    result:=s;
  end;
end;
{$ELSE}
begin
  {$message warn : Not implemented on you OS}
  result:='Not implemented';
end;
{$ENDIF}
 
//------------------------------------------------------------------------------
// Retourne le nom d'un disque
function GetVolumeLabel (DriveChar: char): string;
{$IFDEF WINDOWS}
var
  NotUsed:            DWORD;
  VolumeFlags:        DWORD;
  VolumeSerialNumber: DWORD;
  Buf:                array [0..MAX_PATH] of char;
begin
  Result:='';
  NotUsed:=0;
  VolumeFlags:=0;
  GetVolumeInformation(pChar(DriveChar + ':\'),
                       Buf,
                       SizeOf(Buf),
                       @VolumeSerialNumber,
                       NotUsed,
                       VolumeFlags,
                       nil,
                       0);
  SetString(Result,Buf,StrLen(Buf));
end;
{$ELSE}
begin
  {$message warn : Not implemented on you OS}
  result:='Not implemented';
end;
{$ENDIF}
 
 
//------------------------------------------------------------------------------
// Retourne des informations sur la mémoire, sous forme de chaine de caratères
function GetMemoryStatusAsString:String;
{$IFDEF WINDOWS}
var mSS: TMemoryStatusEx;
    dkFree,
    dkTotal: int64;
  //  i: integer;
  //  aPitem: PParseItem;
    s:string;
begin
  dkFree  := DiskFree(0);                                  // drive 0 = current;
  dkTotal := DiskSize(0);
  try
    mSS.dwLength := SizeOf(mSS);
    GlobalMemoryStatusEx(mSS);
 
    s:='';
    With mSS Do
    begin
      s:=s+Format('  Mémoire Total : %2.0n MB',[mSS.ullTotalPhys/OneMegabyte])+#13#10;
      s:=s+Format('  Mémoire Libre : %2.0n MB  => utilisée : %d%%',[mSS.ullAvailPhys/OneMegabyte,mSS.dwMemoryLoad])+#13#10;
      s:=s+#13#10;
      s:=s+Format('  Fichier Swap Total : %2.0n MB',[ullTotalPageFile/OneMegabyte])+#13#10;
      s:=s+Format('  Fichier Swap Libre : %2.0n MB',[ullAvailPageFile/OneMegabyte])+#13#10;
      s:=s+#13#10;
      s:=s+Format('  Mémoire Virtuelle Total : %2.0n MB',[ullTotalVirtual/OneMegabyte])+#13#10;
      s:=s+Format('  Mémoire Virtuelle Libre : %2.0n MB',[ullAvailVirtual/OneMegabyte])+#13#10;
      s:=s+#13#10;
      s:=s+Format('  Disque Total : %2.0n MB',[dkTotal/OneMegabyte])+#13#10;
      s:=s+Format('  Disque Libre : %2.0n MB (%f%%)',[dkFree/OneMegabyte,(dkFree/dkTotal)*100]);
    end;
   finally
    result:=s;
   end;
end;
{$ELSE}
begin
  {$message warn : Not implemented on you OS}
  result:='Not implemented';
end;
{$ENDIF}
 
//------------------------------------------------------------------------------
function GetCPUBrandString : string;
{$IFDEF CPU32}
var s:array[0..48] of ansichar;
begin
 
  fillchar(s,sizeof(s),0);
  //if CPUIDAvail then begin
    asm
      //check if necessary extended CPUID calls are
      //supported, if not return null string
      mov eax,080000000h
      CPUID
      cmp eax,080000004h
      jb @@endbrandstr
      //get first name part
      mov eax,080000002h
      CPUID
      mov longword(s[0]),eax
      mov longword(s[4]),ebx
      mov longword(s[8]),ecx
      mov longword(s[12]),edx
      //get second name part
      mov eax,080000003h
      CPUID
      mov longword(s[16]),eax
      mov longword(s[20]),ebx
      mov longword(s[24]),ecx
      mov longword(s[28]),edx
      //get third name part
      mov eax,080000004h
      CPUID
      mov longword(s[32]),eax
      mov longword(s[36]),ebx
      mov longword(s[40]),ecx
      mov longword(s[44]),edx
    @@endbrandstr:
    end;
    result:=string(s);
  {$ELSE}
begin
    result := 'Processeur AMD/INTEL 64 bit';
  {$ENDIF}
 
end;
 
//------------------------------------------------------------------------------
// Retourne le nom du CPU, sous forme de chaine de caratères
function GetCPUName : string;
var s : string;
begin
  s := GetCPUBrandString;
  {$IFDEF CPU32}
  if s <> '' then begin
    s := stringreplace(s,'  ','',[rfReplaceAll]);
    s := stringreplace(s,'CPU','',[rfIgnoreCase]);
    s := stringreplace(s,'Processor','',[rfIgnoreCase]);
    s := stringreplace(s,'(R)','',[rfReplaceAll,rfIgnoreCase]);
    s := stringreplace(s,'(TM)','',[rfReplaceAll,rfIgnoreCase]);
    s := stringreplace(s,'  ',' ',[rfReplaceAll]);
    if pos('@',s) <> 0 then delete(s,pos('@',s),10);
    result := trimright(s);
  end
  else result := s;
  {$ELSE}
  result := s;
  {$ENDIF}
 
end;
 
//------------------------------------------------------------------------------
// Retourne le nombres de thread maximum (nombre de coeur du processeur)
function GetMaxThreads : Byte;
begin
  result := strtointdef(sysutils.GetEnvironmentVariable('NUMBER_OF_PROCESSORS'), 1);
end;
 
//------------------------------------------------------------------------------
// Retourne le répertoire temporaire de l'OS
function GetTempFolderPath : string;
{$IFDEF WINDOWS}
var lng: DWORD; thePath: string;
begin
  SetLength(thePath, MAX_PATH);
  lng := GetTempPath(MAX_PATH, PChar(thePath));
  SetLength(thePath, lng);
  result := thePath;
end;
{$ELSE}
begin
  {$message warn : Not implemented on you OS}
  result:='Not implemented';
end;
{$ENDIF}
 
{$IFDEF LINUX}
function ExtractOSVersionFromSW_Vers(Index: Byte): String;
// Index 0: ProductName, 1: ProductVersion, 2: BuildVersion
var
  ProfProcess: TProcess;
  path: string;
  ProfStringList: TStringList;
begin
  Result := '';
  path := 'sh -c "/usr/bin/sw_vers"';
  try
    ProfProcess := Tprocess.Create(nil);
    ProfProcess.CommandLine := path;
    ProfProcess.Options := ProfProcess.Options + [poUsePipes, poWaitOnExit];
    ProfProcess.Execute;
  except
    exit;
  end;
  try
    ProfStringList := TStringList.Create;
    ProfStringList.LoadFromStream(ProfProcess.Output);
  except
    exit;
  end;
 
  ProfProcess.Terminate(0);
  ProfStringList.NameValueSeparator:=':';
  Result:=Trim(ProfstringList.ValueFromIndex[Index]);
  FreeAndNil(ProfProcess);FreeAndNil(ProfStringList);
end;
{$ENDIF}
//==============================================================================
initialization
 
// preparation for high resolution timer
 
 
{$IFDEF UNIX}
  Init_vProgStartSecond;
{$ENDIF}
QueryPerformanceFrequency(PerformanceFrequency);
 
//NowPreciseLock := TCriticalSection.Create;
 
finalization
 
//NowPreciseLock.Free;
 
end.

Essaye de remettre les paramètres Projet / Options / Configuration et cible à "default"...

Idem même erreur

Est-ce que les .pas font bien partie du projet (ce que j'ai fait comme expliqué tout en haut : "Ajouter...") ?
De ce que j'en ai vu, j'aurais tendance à dire non, or je pense qu'ils devraient l'être.

Ca doit être ailleur, faut que je jette un oeil dans le LPI car j'ai refait un nouveau projet avec juste :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
unit umainform;
 
//{$mode objfpc}{$H+}
{$I ../../Beanz.inc}
 
interface
 
uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Menus,
  ActnList, FastBitmapCore, FastImage;
 
type
 
  { TMainForm }
 
  TMainForm = class(TForm)
    actLoadImage: TAction;
    ActionList1: TActionList;
    MainMenu1: TMainMenu;
    MenuItem1: TMenuItem;
    MenuItem10: TMenuItem;
    MenuItem11: TMenuItem;
    MenuItem2: TMenuItem;
    MenuItem3: TMenuItem;
    MenuItem4: TMenuItem;
    MenuItem5: TMenuItem;
    MenuItem6: TMenuItem;
    MenuItem7: TMenuItem;
    MenuItem8: TMenuItem;
    MenuItem9: TMenuItem;
    OpenDialog: TOpenDialog;
    SaveDialog: TSaveDialog;
    procedure actLoadImageExecute(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
    BackgroundColor: TCompactColor;
    TestImage: TFastImage;
  end;
 
var
  MainForm: TMainForm;
 
implementation
 
{$R *.lfm}
 
 
{ TMainForm }
 
procedure TMainForm.FormCreate(Sender: TObject);
begin
  With BackgroundColor Do
  Begin
    Red := 0;
    Green := 0;
    Blue := 0;
    Alpha := 255;
  End;
  TestImage := TFastImage.Create(nil);
  TestImage.Parent:=self;
  TestImage.Align:=alClient;
  TestImage.Picture.Width:=TestImage.Parent.ClientWidth;
  TestImage.Picture.Height:=TestImage.Parent.ClientHeight;
  TestImage.Center:=true;
  TestImage.Stretch:=true;
  TestImage.Proportional:=true;
  TestImage.Picture.Clear(BackgroundColor);
  TestImage.Picture.Changed();
end;
 
procedure TMainForm.actLoadImageExecute(Sender: TObject);
Var
  StartTime: TDateTime;
  LoadTime: TDateTime;
Begin
  With OpenDialog Do
    If Execute Then
      Begin
        StartTime := Now();
        TestImage.Picture.LoadFromFile(Filename);
        LoadTime := Now()-StartTime;
        //If UseOpenGLAction.Checked Then Repaint;
        ShowMessage('Fast Bitmap Load Time: '+FormatFloat('0.00', MSecsPerDay*LoadTime)+'ms');
 
      End;
end;
 
procedure TMainForm.FormShow(Sender: TObject);
begin
 
end;
 
end.

Ca compile et je peux charger mon image :


par contre j'ai du rajouter "{$DEFINE LCLGTK2}" dans le fichier beanz.inc et j'ai du également rajouter LCL en dependance dans le package pour qu'il me trouve les units {$IFDEF LCLGTK2}GDK2, Gtk2Def,{$ENDIF} dans FastBitmapCore

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
{$IFDEF LINUX}
 
  {$DEFINE LCLGTK2} 
 
  {$IFDEF LCLQT}
    // Mode d'affichage BGRA
    {$DEFINE BGRAIMAGE}
  {$ELSE}
    // Mode d'affichage RGBA
    {$DEFINE RGBAIMAGE}
  {$ENDIF}
  {$DEFINE NO_ASM_OPTIMIZATIONS}
  {$DEFINE UNIX}
  {$UNDEF WGL_SUPPORT}
  //Activer le support de X Window
  {$DEFINE X11_SUPPORT}
  {$DEFINE GLX_SUPPORT}
{$ENDIF}

par contre ici l'image n'est pas redimensionner comme sous Windows, faut que je jette un oeil au source de TImage voir comment il affiche les données

Et par contre toujours la meme erreur de Linking, impossible de reconstruire l'EDI

Code de sortie 512 maintenant
lazarus.pp(154,1) Error: Error while linking

[BeanzMaster]

Bon cet aprem j'ai fais ça à l'arrache en 30 minutes, je suis pas allez au bout des choses alors voila une petite mise à jour (tu va être content Jipete )
J'ai créé 4 methodes avec les composants de Mitchell tout est dans le screen qui suit :



et voila également le zip avec le projet (sans les package BGRABitmap et GR32, c'est trop volumineux et ca passe pas), on pourrais également faire une méthode supplémentaire en se basant sur "UBitmapRawImageData.pas"
graphictest.zip

On pourrais encore augmenter la vitesse, au lieux d'utiliser le TFastBitmap qui est dans "UFastBitmap.pas" on pourrait se servir de TCompactImage de l'unit "CompImages.pas" on supprimerait ainsi le "move" ou la boucle "for x for y", regardes les 2 units sont tres similaires

A+

[Jipété]

Bon cet aprem j'ai fait ça à l'arrache en 30 minutes, je suis pas allé au bout des choses alors voila une petite mise à jour (tu vas être content Jipete )

Rhôôô la méthode 4 elle déchire sa race ! Bravo Beanz, ça c'est du boulot !
Par contre, je ne comprends pas trop les résultats de RawImage.Data Move et particulièrement la 3^e colonne, quand on compare avec Method 4.

J'étudie ça demain, là il est pas d'heure, mais je ne pouvais pas résister à cette belle surprise que tu nous fais

Mais en plus je sens venir une autre version, dans tes propos ? Quand tu auras atteint le bout des choses ? Waouh ! Vivement la suite...

[Jipété]

Bonjour,

Je suis parti de ton .zip, il a fallu que je rajoute ça dans UMainForm et dans le .lpr : {$IFDEF GRAPHICS32}UGraphics32Method,{$ENDIF} + un clic droit / Supprimer sur la ligne concernée dans Projet / Inspecteur de projet mais bon, on y arrive...

Ensuite, comme je voulais me concentrer sur les méthodes les plus performantes, j'ai commenté plein de lignes dans procedure TMainForm.RegisterDrawMethods; et il en sort ça, en choisissant pf24bit à l'option PixelFormat tout en bas :



Si quelqu'un pouvait m'expliquer l'incohérence (pour moi) de ce 9xxx dans la 3^e ligne de la 3^e colonne, parce que je ne me l'explique pas...
Si ce n'était ce point, la Method 4 du TComp.Image remporterait le pompon, mais là, je reste perplexe (et je ne suis pas du tout spécialiste des FPS et autres benchmarcks...)
Pi d'abord, qu'est-ce que ça signifie exactement, "Draw FPS" ?

Merci,

[BeanzMaster]

Bonsoir,

Si quelqu'un pouvait m'expliquer l'incohérence (pour moi) de ce 9xxx dans la 3^e ligne de la 3^e colonne, parce que je ne me l'explique pas...
Si ce n'était ce point, la Method 4 du TComp.Image remporterait le pompon, mais là, je reste perplexe (et je ne suis pas du tout spécialiste des FPS et autres benchmarcks...)
Pi d'abord, qu'est-ce que ça signifie exactement, "Draw FPS" ?

Merci,

Bon alors je t'explique le Draw FPS c'est le temps moyen que met la procedure DrawFrame pour copier les données du FastBitmap vers le TImage donc 1 seule image, le FPS la 1ere colonne c'est l'estimation de la totalité de l'animation.

Il faut surtout garder en tête la 1ere colonne. sur ce j'ai fais les modifs que je parlais dans mon post. A savoir utiliser TCompactImage à la place de TFastBitmap les résultats, sont inégaux des fois c'est le DataRawMove qui l'emporte et parfois la methode 5 pour le "Draw FPS" et "FPS" , mais le plus souvent c'est la methode 5 qui l'emporte (du moins chez moi). Il n'y a pas une grande différence entre les 2. Tout du moins cela depend de comment on assigne les couleurs dans notre buffer. A ce propos j'ai quelques soucis de conversion car :
- le FastBitmap original code les couleurs en 32bits format RGBA (si je ne me trompe pas) via un LongWord (cardinal) .
- Le TCompactImage utilise pour assigner les pixels TFPColor qui lui est sur 64bit via Colors[x,y]
- Le TCompactImage utilise entre 2 une donnée de TCompactColor (record) sur 32bits
Du coup je me perd dans les conversions de couleur d'un format à l'autre, et je me mélange les pédales avec les déplacements de bits avec ShR et ShL, j'avoue je suis perdu sur ce coup, et l'affichage est incorrect.

Sinon au regard du FPS Glabal c'est la methode 4 qui l'emporte haut la main ici

Malgré ça le test reste viable à mon avis, juste ce problemes avec les couleurs, à régler

voila un screen des resultats et en dessous le zip du projet



graphictestCompactImage.zip

[BeanzMaster]

Du coup je me perd dans les conversions de couleur d'un format à l'autre, et je me mélange les pédales avec les déplacements de bits avec ShR et ShL, j'avoue je suis perdu sur ce coup, et l'affichage est incorrect.

Ben en fait non mon code est bon, le problème c'est au niveau du PixelFormat


J'ai juste modifié dans la procedure RandomImage dans compimage pour avoir un dégradé Gris au lieu de rouge

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

acolor:=(Trunc(Sin((X + Trunc(Index / Count * Width)) mod Width / Width * pi) * 255)) and $ffffff ;

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
var tmp:integer;
...
tmp:=(Trunc(Sin((X + Trunc(Index / Count * Width)) mod Width / Width * pi) * 255)) ;
acolor := (tmp or (tmp shl 16) or (tmp shl 8)) and $ffffff;

en 24bits seule la méthode "TBitmap.RawImage.Data" fonctionne correctement et la méthode 4 y'a un soucis mais je sais pas pourquoi le dégradé gris ne s'affiche par correctement:
- 1) resultats de tous les test


- 2) affichages :



--> Pour la methode 5 c'est pareil que l'image ci-dessous




- 3)
voila le résultat de tous les tests en forçant l'affichage en 32bits et là pas de soucis, mais les FPS fondent a vu d'oeil


La methode 5 reste plus rapide que "TBitmap.RawImage.Data.Move" de pas grand chose
La methode 4 elle envoie du lourd à tous les coups

Juste pour le fun le test avec une resolution de 1920x1080 c'est kikif les 3 methodes sont aux coudes à coudes

[Jipété]

Salut bonsoir,

Ben en fait non mon code est bon, le problème c'est au niveau du PixelFormat

Hé bien je te félicite d'avoir tant avancé, et si bien, car ce matin j'ai passé beaucoup de temps dans tes .zip et je m'y suis perdu... C'est salement compliqué, tout ça...

(comme tout, en informatique tu me diras : si je reprends l'analogie de la voiture, et que j'aie besoin d'aller faire les courses, je sors et je trouve tout un tas de cartons, l'un contient une culasse fraîchement polie, l'autre autant de pistons que nécessaires, bien emballés chacun dans un film plastique, dans un troisième tu auras les segments, etc., jusqu'au 37 215^e carton, et bien sûr tu n'as pas la notice précise et détaillée, t'as juste un torchon mal ficelé et comportant des erreurs [je pense au wiki sur le FastBitmap qui m'a occupé une bonne partie de l'aprème, sans voir le bout du tunnel hélas])

Pour en revenir à ton zip avec la méthode 5, ce qui m'a surpris, c'est que tu as dégagé les tests de base du TBitmap qui s'appuie maintenant sur le truc à Mitchell, si j'ai bien décodé, et donc on ne peut plus trop comparer grand chose...


J'ai pas trop le temps de m'étendre plus, ce soir (réunion d'assoss'), j'essayerai demain de mieux creuser Mitchell...