Discussion :

[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...

[BeanzMaster]

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...

Oui et non, on a encore le zip de mon post précédent, c'est que c'était beaucoup rapide de changer le TFastBitmap par TCompactImage que surcharger tout le bouzin pour accepter les 2 composants. Mais c'est vrai ca serai sympa d'avoir les 2 dans le même projet. J'y jetterai un oeil dimanche. Avec mes horaires coupées et juste 1h30/2h en gros l'apres-midi c'est pas le top pour se concentrer. Et le soir idem.

[Jipété]

Salut,

non, je n'ai pas oublié ce sujet, mais j'ai eu d'autres chats à fouetter...

c'est que c'était beaucoup rapide de changer le TFastBitmap par TCompactImage que surcharger tout le bouzin pour accepter les 2 composants.

C'est ce que je me suis dit, d'autant plus que ça n'a pas l'air très simple, tout ça...
Entre le fouillis du TFastBitmap et le peu de possibilités du TCompactImage, c'est un peu la misère je trouve, et à bien y réfléchir je me demande pourquoi j'ai mis les bricolages à Mitchell sur le tapis, je n'arrive quasiment pas à m'en servir dès que ça devient un peu pointu.
Faudrait que j'étudie à nouveau ses deux exemples, mais j'ai peur que ça ne m'avance pas beaucoup : il aurait pu mettre un peu de commentaires, qu'on avance autrement que par essais et échecs...

Sans compter la déception de ce GraphicTest où l'on a du mal à comparer les candidats, ce qui serait quand même intéressant car il ne servirait à rien de se casser la tête à essayer de faire fonctionner le dernier de la classe (je sais bien que ce n'est pas le cas, mais c'est l'idée).

[BeanzMaster]

Salut,

c'est un peu la misère je trouve, et à bien y réfléchir je me demande pourquoi j'ai mis les bricolages à Mitchell sur le tapis, je n'arrive quasiment pas à m'en servir dès que ça devient un peu pointu.
Faudrait que j'étudie à nouveau ses deux exemples, mais j'ai peur que ça ne m'avance pas beaucoup : il aurait pu mettre un peu de commentaires, qu'on avance autrement que par essais et échecs...

Bonsoir, ha ha ha J'ai eu un peu de temps ce soir de rejeter un coup d'oeil, de faire un peu le ménage, et au final j'ai pu dégager l'essentiel des compos de Mitchell dans un package alla BGRABitmap et je suis entrain de fignoler un TFastImage que l'on pourra poser sur notre form. Le truc qui m'a un peu pris la tête c'est avec les couleurs BGRA et RGBA, mais c'est bon maintenant, reste encore quelque ajustement et ça sera parfait et restera plus qu'a implementer quelques fonctions de dessin (ligne, cercle ect....) dans L'ex TCompactImage. Par contre je me demande si TCompactImage est vraiment nécessaire et si on ne pourra juste s'appuyer sur TRawImage en terme d'optimisation.

Par contre pour des raisons de simplicité j'ai modifié une ligne, j'ai rajouté un test IF dans la procedure Setpixel du composant TFPCustomImage de l'unit "FPImage.inc" afin de pouvoir utiliser "procedure SetInternalPixel (x,y:integer; Value:integer); virtual; abstract; et function GetInternalPixel (x,y:integer) : integer; virtual; abstract;", au lieu de créer de nouvelles procedures avec des noms a rallonges et accéder directement à un variable "Pixels" deja existante, car par default c'est pour utiliser une palette de couleur, bref c'est pas grand choses et ça ne risque rien.

Code :

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

1
2
3
4
5
6
procedure TFPCustomImage.SetPixel (x,y:integer; Value:integer);
begin
  if (GetUsePalette = true) then CheckPaletteIndex (Value);  //---> Test rajouté
  CheckIndex (x,y); // Un nom de procedure mal choisi, car il test si x et y sont <0 ou >Width/Height
  SetInternalPixel (x,y,Value);
end;

En fait les compos de Mitchell (TCompactImage, TCompactColor et TXXXCompactImage) sont relativement très proche de la librairie BGRA. Ils utilisent la même technique "StretchDIBits" pour ce qui est d'afficher un "Buffer" sur le canvas.

Tiens voila un bout de code de BGRABitmap <> TCompactColor

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
  TBGRAPixel = packed record
  private
    function GetClassIntensity: word;
    function GetClassLightness: word;
    procedure SetClassIntensity(AValue: word);
    procedure SetClassLightness(AValue: word);
  public
    {$IFDEF BGRABITMAP_RGBAPIXEL}
    red, green, blue, alpha: byte;
    {$ELSE}
    blue, green, red, alpha: byte;
    {$ENDIF}
    procedure FromRGB(ARed,AGreen,ABlue: Byte; AAlpha: Byte = 255);
    procedure FromColor(AColor: TColor; AAlpha: Byte = 255);
    procedure FromString(AStr: string);
    procedure FromFPColor(AColor: TFPColor);
    procedure ToRGB(out ARed,AGreen,ABlue,AAlpha: Byte); overload;
    procedure ToRGB(out ARed,AGreen,ABlue: Byte); overload;
    function ToColor: TColor;
    function ToString: string;
    function ToGrayscale(AGammaCorrection: boolean = true): TBGRAPixel;
    function ToFPColor: TFPColor;
    class Operator := (Source: TBGRAPixel): TColor;
    class Operator := (Source: TColor): TBGRAPixel;
    property Intensity: word read GetClassIntensity write SetClassIntensity;
    property Lightness: word read GetClassLightness write SetClassLightness;
  end;
  TBGRAPixelBuffer = packed array of TBGRAPixel;

et l'equivalent de TLCLCompactImage.DrawTo

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
if TBGRAPixel_RGBAOrder then SwapRedBlue;
  if Opaque then
  begin
    info := DIBitmapInfo(Width, Height);
    if LineOrder = riloTopToBottom then
      StretchDIBits(ACanvas.Handle, Rect.Left, Rect.Bottom, Rect.Right -
        Rect.Left, Rect.Top - Rect.Bottom,
        0, 0, Width, Height, Data, info, DIB_RGB_COLORS, SRCCOPY)
    else
      StretchDIBits(ACanvas.Handle, Rect.Left, Rect.Top, Rect.Right -
        Rect.Left, Rect.Bottom - Rect.Top,
        0, 0, Width, Height, Data, info, DIB_RGB_COLORS, SRCCOPY);
  end
  else
  begin
    if Empty then exit;
    if LineOrder = riloTopToBottom then VerticalFlip;
    LoadFromBitmapIfNeeded;
    ACanvas.StretchDraw(Rect, Bitmap);
    if LineOrder = riloTopToBottom then VerticalFlip;
  end;
  if TBGRAPixel_RGBAOrder then SwapRedBlue;

Sans compter la déception de ce GraphicTest où l'on a du mal à comparer les candidats, ce qui serait quand même intéressant car il ne servirait à rien de se casser la tête à essayer de faire fonctionner le dernier de la classe (je sais bien que ce n'est pas le cas, mais c'est l'idée).

Oui en fait ce test ne porte que sur le temps que met une méthode pour copier un buffer vers le canvas et par sur l'acces des "pixels" de ce buffer. Ce qui à mon avis est bien plus important pour le traitement d'image.
Voila gràce à ce nouveau petit paquet et TFastImage on pourra créer quelques tests de vitesses simplement et les comparés avec le TImage natif et les solutions fournis dans le graphictest et sur la page du wiki.
Je devais pouvoir poster une 1er exemple demain dans la journée.

Le plus gros avantage de BGRABitmap selon moi est que l'on peux traiter des images de tailles infinie, seule limitation la mémoire du pc. Cette librairie qui était simple à ces début devient une vraie usine à gaz (support de la 3D et OpenGL...).
Sous Delphi j'avais l'habitude d'utiliser GR32 qui était excellent et facilement extensible a mon humble avis.

Bonne soirée

[Jipété]

Hello,

Oui en fait ce test ne porte que sur le temps que met une méthode pour copier un buffer vers le canvas et par sur l'accès des "pixels" de ce buffer. Ce qui à mon avis est bien plus important pour le traitement d'image.
Voila grâce à ce nouveau petit paquet et TFastImage on pourra créer quelques tests de vitesses simplement et les comparer avec le TImage natif et les solutions fournies dans le graphictest et sur la page du wiki.

Oh lala, mais tu te décarcasses à mort, tu vas nous refaire un compo formule 1

Cependant, ce point me chagrine :

Par contre pour des raisons de simplicité j'ai modifié une ligne, j'ai rajouté un test IF dans la procedure Setpixel du composant TFPCustomImage de l'unit "FPImage.inc" afin de pouvoir utiliser "procedure SetInternalPixel (x,y:integer; Value:integer); virtual; abstract; et function GetInternalPixel (x,y:integer) : integer; virtual; abstract;", au lieu de créer de nouvelles procedures avec des noms a rallonges et accéder directement à un variable "Pixels" deja existante, car par default c'est pour utiliser une palette de couleur, bref c'est pas grand choses et ça ne risque rien.

pour la bonne et simple raison qu'en cas de mise à jour de fpc-src on est mal !
Crée une nouvelle procédure, ça sera plus sécurisé, àmha.
Je n'aime pas toucher aux sources qui ne dépendent pas de moi.

Le plus gros avantage de BGRABitmap selon moi est que l'on peux traiter des images de tailles infinie, seule limitation la mémoire du pc. Cette librairie qui était simple à ces début devient une vraie usine à gaz (support de la 3D et OpenGL...).

À ce propos, on peut lire ce commentaire de Roland :

La bibliothèque de composants basés sur BGRABitmap, c'est BGRAControls. Et puisque nous parlons d'ennuis lors de la réinstallation de composants, je te dirai que personnellement je n'utilise pas ces composants, parce que j'ai eu une ou deux fois un problème lors d'une tentative d'installation (ce qui est effectivement exaspérant), raison pour laquelle je préfère m'en passer.

J'ai cependant réussi à les installer, ce matin, mais je me retrouve maintenant avec 2 onglets dans la palette : t'as raison, une usine à gaz,

Sous Delphi j'avais l'habitude d'utiliser GR32 qui était excellent et facilement extensible a mon humble avis.

Vi, mais tout fout le camp, c'est bien connu...

Bon dimanche,

[BeanzMaster]

Salut à tous, me revoilà

Ce petit projet m'a permis de faire un peu de ménage dans quelques un de mes codes source. Et m'a permis de mieux comprendre certaines chose sur les "Bitmaps" avec FPC.
Malgré quelques déboire notamment avec une variable de type TPoint, ou sa valeur disparaissait d'une procédure à l'autre et quelques soucis avec les accès aux pointers. Voila un Benchmark sur les différentes façon d'accéder aux pixels d'un Bitmap. Tout fonctionne très bien chez moi sous Win 10 64bit et y'a pas de fuite de mémoire. Et en plus tout est "In French" Un petit screen de la bête :



et voila les sources complètes pour tester : fastbitmap.zip

Vous trouverez dans le zip un package "FastBitmap.LPK" à installer. Celui-ci vous ajoutera un jolie nouvel onglet avec 1 composant TFastImage.
J'ai essayé de commenter du mieux que je pouvais les sources (FastBitmap.pas, CustomFastBitmapHandler.pas, LCLFastBitmapHandler.pas)
Ensuite dans le dossier Demos 2 sous dossiers avec 2 petits test. 1 le Benchmark et le 2 c'est l'exemple de Mitchell

Bon on peux maintenant pousser plus loin en ajoutant un affichage avec transparence (du moins sous windows) en utilisant AlphaBlend au lieu de StrechBit. On peux bien sur aussi ajouter toutes les fonctions de dessins usuel à notre TFastBitmap (line, circle, rectangle ect...)

Voila chez vous les tests en terme de perf ça donne quoi ?

Bonne soirée

[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]

Salut et bravo !


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,

Salut et merci
En fait pour le TRect il est déclaré dans l'unit Types, et dans l'unit Windows d'ou l'erreur, j'ai pas inclue "Types" pour la version Linux

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...

Oups vu que je peux tester que sous Windows (pour l'instant, faut que je termine de trier mon ancien DD pour installer un disto Linux)
J'ai oublié de renommer cette variable par FFastBitmap

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...

Bonne question, ben en fait Mitchell a fait comme ça.
Tu dois obligatoirement passer un TFastBitmap pour l'afficher. Apres lorsque tu modifies le bitmap pas besoin de reassigner. Voila le pourquoi.
Mais c'est pas bête, comme question, du coup j'y avait pas penser, mais j'ai fait une petite mise à jour. J'ai viré ces "Custom/LCLHandler" et j'ai incorporé la fonction DrawTo directement dans le TFastBitmap. Du fait que la porté entre la procédure DrawTo et les données (RawImage.Data du TFastBitmap) est moins longue on gagne encore quelques FPS.

Bref voilà comme je le disais j'ai déjà fait quelques mises à jour (j'ai aussi rajouté des tests dans le bitmap)
Je vais avoir un peu plus de temps ce week-end. Je referais un autre zip. En Attendant un screen du benchmark mise à jour



Par contre les FPS et temps ne sont pas la moyenne, c'est le temps de la derniere Frame.

[Jipété]

Bonjour,

Voilà les retours :

En fait pour le TRect il est déclaré dans l'unit Types, et dans l'unit Windows d'ou l'erreur, j'ai pas inclue "Types" pour la version Linux

Je fais donc ainsi, dans LCLFastBitmapHandler :

Code :

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

1
2
3
4
5
6
7
8
Uses
  SysUtils,
  {$IFDEF WINDOWS}Windows,{$ENDIF}
  {$IFDEF LCLGTK2}Types, GDK2, Gtk2Def,{$ENDIF}
  {$IFDEF LCLQT}Types, QT4, QTWidgets, QTObjects,{$ENDIF}
  {$IFDEF LCLCARBON}Types, MacOSAll, CarbonCanvas,{$ENDIF}// rajouté 'Types' ici aussi, mais rien pour tester...
  // voir http://www.developpez.net/forums/d1610633/autres-langages/pascal/lazarus/info-font-graphisme-pointu/#post8804742
  Graphics, GraphType, CustomFastBitmapHandler;

Mais c'est plus compliqué que de juste rajouter Types, parce qu'après l'avoir fait, main.pas(125,32) Error: Wrong number of parameters specified for call to "DrawTo" là (ligne 5) :

Code :

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

1
2
3
4
5
6
Procedure TMainForm.FormPaint(Sender: TObject);
Begin
  If (UseFastBitmapAction.Checked) Then
  begin
    TestLCLImage.DrawTo(Canvas);
  end

et comme je ne sais pas ce que tu avais en tête, je ne peux pas savoir par quoi compléter ce DrawTo à qui il manque bien un TRect, l'infobulle me le confirme...
Je ne comprends pas comment cette ligne de code peut compiler chez toi

Je m'en sors comme ça : la Var qui est plus bas est "remontée" de quelques lignes et rajoutée là où je suppose qu'elle doit aller (ligne 8) :

Code :

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

1
2
3
4
5
6
7
8
9
Var
  WindowRect: TRect;
 
Procedure TMainForm.FormPaint(Sender: TObject);
Begin
  If (UseFastBitmapAction.Checked) Then
  begin
    TestLCLImage.DrawTo(Canvas, WindowRect);
  end

ça, ça compile

Je mets en place la création dynamique de FastImage1, je compile j'exécute je demande à ouvrir une image j'ai le message avec le timing mais image noire... Essai avec .bmp, .jpg et .png = pareil. Normal ? Pas normal ?

Est-ce que ça aurait un rapport avec ça :

J'ai oublié de renommer cette variable par FFastBitmap

si FFastBitmap --> lclfastbitmaphandler.pas(78,25) Error: Identifier not found "FFastBitmap" ;
si FastBitmap ça coince dessous --> lclfastbitmaphandler.pas(80,25) Error: Identifier not found "FRawImage" ;

Renommé FRawImage en RawImage, ça compile comme ça et ça s'exécute sans AV ni autre misère, sauf qu'on ne voit toujours pas d'image...
Ou alors c'est l'utilisation de ce DrawTo(Canvas, WindowRect); ?

Le bench (rappel : ma machine n'est pas un foudre de guerre, mais au moins ça me permet de comparer différentes manières de faire) :

Code :

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

1
2
3
fastim : Fast Bitmap Average Draw Time: 22.81ms (43.84fps)
openGl : Fast Bitmap Average Draw Time: 38.68ms (25.85fps)
bitmap : Fast Bitmap Average Draw Time: 229.41ms (4.36fps)

En mode bitmap, le dégradé du fond va vers le bleu, c'est rigolo -- Je sais que quelque part rouge et bleu sont inversés, mais je ne sais plus où...

Deux petites remarques :
1-) dans le menu Edit, l'entrée "Image Info" porte un nom trompeur : ça fait référence à l'objet Image utilisé pour travailler dans le programme quand le nom fait plutôt penser à des infos relatives au fichier image chargé par le menu File...

2-) j'ai passé la propriété Align du OpenGLControl de alLeft à alClient, parce qu'une moitié de dessin ça le faisait pas !

Allez, on continue, on y est presque

EDIT : oublié de préciser que j'ai découvert ce matin un bug dans le code à Mitchell, pas dans le Mandelbrot mais dans l'autre : incapable d'ouvrir une image .bmp sous Linux (ok avec .jpg et .png, pas fait d'autres tests), ça n'affiche que de la daube, comme quand on va taper ailleurs en mémoire...
J'ai essayé toutes les variantes de FRawImage.Description qu'on trouve dans GraphType sans aucun résultat probant...


à gauche l'original, à droite le résultat
/EDIT

[BeanzMaster]

Bonjour,

Voilà les retours :


Je fais donc ainsi, dans LCLFastBitmapHandler :

Code :

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

1
2
3
4
5
6
7
8
Uses
  SysUtils,
  {$IFDEF WINDOWS}Windows,{$ENDIF}
  {$IFDEF LCLGTK2}Types, GDK2, Gtk2Def,{$ENDIF}
  {$IFDEF LCLQT}Types, QT4, QTWidgets, QTObjects,{$ENDIF}
  {$IFDEF LCLCARBON}Types, MacOSAll, CarbonCanvas,{$ENDIF}// rajouté 'Types' ici aussi, mais rien pour tester...
  // voir http://www.developpez.net/forums/d1610633/autres-langages/pascal/lazarus/info-font-graphisme-pointu/#post8804742
  Graphics, GraphType, CustomFastBitmapHandler;

Mais c'est plus compliqué que de juste rajouter Types, parce qu'après l'avoir fait, main.pas(125,32) Error: Wrong number of parameters specified for call to "DrawTo" là (ligne 5) :

Code :

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

1
2
3
4
5
6
Procedure TMainForm.FormPaint(Sender: TObject);
Begin
  If (UseFastBitmapAction.Checked) Then
  begin
    TestLCLImage.DrawTo(Canvas);
  end

et comme je ne sais pas ce que tu avais en tête, je ne peux pas savoir par quoi compléter ce DrawTo à qui il manque bien un TRect, l'infobulle me le confirme...
Je ne comprends pas comment cette ligne de code peut compiler chez toi

Je m'en sors comme ça : la Var qui est plus bas est "remontée" de quelques lignes et rajoutée là où je suppose qu'elle doit aller (ligne 8) :
....
ça, ça compile

Salut oups ! mea culpa, j'aurais pas du inclure le projet "Test" dans le zip car je n'avais pas fait la mise à jour en conséquence. Toi qui a déja pas mal de déboires.
Je m'excuses de t'avoir fait perdre du temps. Mais toutes tes questions et problèmes, m'ont permis de corriger pas mal de petits bugs au bout du comptes.

Alors voila les sources mises à jour

fastbitmap.zip

Le programme "Test" devrait maintenant fonctionner. (enfin j'espere, car sur Windows c'est tout bon)
Pour le programme "Benchmark" j'ai aussi rajouté quelques petits test de méthodes et celui-ci aussi devrait fonctionner sans problèmes

[Jipété]

Salut,

Le programme "Test" devrait maintenant fonctionner. (enfin j'espère, car sur Windows c'est tout bon)

T'as bien de la chance...

J'ai fait exactement comme hier : commenter ce qui concerne FastImage pour ne pas avoir à installer le composant, et essayer de compiler, et paf !, sur un fichier qui n'a absolument pas été touché et qui hier compilait sans problème...


Le fichier est exactement le même que celui d'hier, à la virgule près, et dans le même chemin : encore un mystère (ou un truc planqué dans les options du projet ? Essaye de ne pas trop trifouiller là-dedans, c'est laborieux à la réception, après. Un exemple : je déplace tous les fichiers complémentaires dans un dossier "modules" dans "test", j'accorde les chemins en conséquence, je compile et je me rends compte que "ça" me recrée 3 fichiers (fastbitmapcore.pas, fastfonts.pas, fastimage.pas) dans le dossier racine ; pourquoi ? Comment ? Nobody knows et surtout, je n'avais pas ce comportement farfelu hier...)

Et face à ça je suis comme une poule qui aurait trouvé un couteau...

[BeanzMaster]

Salut,


T'as bien de la chance...

J'ai fait exactement comme hier : commenter ce qui concerne FastImage pour ne pas avoir à installer le composant, et essayer de compiler, et paf !, sur un fichier qui n'a absolument pas été touché et qui hier compilait sans problème...


Le fichier est exactement le même que celui d'hier, à la virgule près, et dans le même chemin : encore un mystère (ou un truc planqué dans les options du projet ? Essaye de ne pas trop trifouiller là-dedans, c'est laborieux à la réception, après. Un exemple : je déplace tous les fichiers complémentaires dans un dossier "modules" dans "test", j'accorde les chemins en conséquence, je compile et je me rends compte que "ça" me recrée 3 fichiers (fastbitmapcore.pas, fastfonts.pas, fastimage.pas) dans le dossier racine ; pourquoi ? Comment ? Nobody knows et surtout, je n'avais pas ce comportement farfelu hier...)

Et face à ça je suis comme une poule qui aurait trouvé un couteau...

Salut, chelou ce truc car je n'ai rien touché dans ce fichier Dans les options du projet "Test" j'ai rien touché non plus a part les option des dossiers et nom de fichiers de sortie, et dans "Compilation et editions des liens" j'ai coché l'option "(-O2 Optimisations Lentes)(-O3) essayes de changer avec le niveau 1 et décoche dans "edition des liens l'option "Lier Intelligemment -XX" Linux prend peut-etre mal ces paramètres, mais j'en doute. Le reste c'est celui de base de Mitchell Sinon t'es sur que c'est le fichiers FreeType.pas du package. Car j'ai un peu près eu le même problème au début car il y en a un autre fichier freetype.pas dans les sources de lazarus ? de plus cette unité est celle fournis par Mitchell

Je viens de recompiler le projet test en de-commentant les lignes servant à la création dynamique du TFastImage et juste changer comme ça

Code :

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

1
2
3
4
5
6
7
8
9
10
Procedure TMainForm.FormCreate(Sender: TObject);
...
  TestImage := TFastImage.Create(nil);
  TestImage.Parent:=self;
  TestImage.Align:=alClient;
  TestImage.Picture.Width:=TestImage.Parent.ClientWidth;
  TestImage.Picture.Height:=TestImage.Parent.ClientWidth;
  TestImage.Picture.Clear(BackgroundColor);
  TestImage.Picture.Changed();
...

J'ai également supprimer la dépendance LCL et remplacé par LCLBase dans le package "FastBitmap". Tout fonctionne chez moi

Sinon le projet "Benchmark" il compile ou pas ? le seul truc que je viens de voir maintenant j'ai oublié de dé-commenté la ligne "UpdatePropertie" dans FastBitmapCore.pas

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
//------------------------------------------------------------------------------
// Change la taille de TFastBitmap
//------------------------------------------------------------------------------
Procedure TFastBitmap.SetSize(AWidth, AHeight: Integer);
Begin
  If (AWidth<>Width) Or (AHeight<>Height) Then
    Begin
      ReAllocMem(Data, FastPixelSize*AWidth*AHeight);
      Inherited SetSize(AWidth, AHeight);
      FBytesPerLine := FBytesPerPixel * AWidth;
      {$IFDEF DEBUG_ON}
      ShowMessage('FastBitmapCore.SetSize : '+inttostr(Width)+'x'+inttostr(Height)
                 +#13#10+'Bytes per Pixel : '+inttostr(FBytesPerPixel)
                 +#13#10+'Bytes per line : '+inttostr(FBytesPerLine));
      {$ENDIF}
      SetLength(FFastScanLine,Height);
      ComputeFastScanLine;
 
      updateProperties; // C'est ICI
 
      DoOnChange(self);
    End;
End;

[Jipété]

dans "Compilation et editions des liens" j'ai coché l'option "(-O3 Optimisations Lentes)(-O3) essayes de changer avec le niveau 1 et décoche dans "edition des liens l'option "Lier Intelligemment -XX" Linux prend peut-être mal ces paramètres, mais j'en doute

J'ai + ou - les mêmes réglages, habituellement. Je ne pense pas que ça soit là, voir + bas...

Sinon t'es sur que c'est le fichiers FreeType.pas du package.

Ben quand même, t'as la copie d'écran sous les yeux avec la ligne en erreur en surbrillance bleue et le fichier ouvert sur la ligne indiquée en orange, facilement retrouvable. Qu'est-ce qu'il te faut de plus ?

Car j'ai un peu près eu le même problème au début car il y en a un autre fichier freetype.pas dans les sources de lazarus ? de plus cette unité est celle fournis par Mitchell

Je l'avais remarqué, et j'avais bien compris que ça venait de chez lui. Pourquoi ce problème chez moi aujourd'hui et pas hier ? Un grand mystère...
M'en suis sorti en commentant tout ce qui était en rapport avec TestFont et du coup ça compile.
Mais l'exécution est dramatique ! Je ne mets pas de copie d'écran car c'est trop moche et je n'ai pas le temps, là maintenant : en gros je lui fais ouvrir une jolie image en noir et blanc et je me retrouve avec un canvas plein de raies verticales noires, blanches, grises...
Un pb de 24/32 bits probablement -- je verrai + tard.

Je viens de recompiler le projet test en de-commentant les lignes servant à la création dynamique du TFastImage et juste changé comme ça

Oui, c'est comme ça que je fonctionne.

J'ai également supprimé la dépendance LCL et remplacé par LCLBase dans le package "FastBitmap". Tout fonctionne chez moi

Je l'avais vu, je me faisais remonter les bretelles par le compilo,

Sinon le projet "Benchmark" il compile ou pas ? le seul truc que je viens de voir maintenant j'ai oublié de dé-commenté la ligne "UpdatePropertie" dans FastBitmapCore.pas

Pas testé encore : j'ai faim, j'ai toujours pas eu le temps de manger...

[BeanzMaster]

J'ai + ou - les mêmes réglages, habituellement. Je ne pense pas que ça soit là, voir + bas...

Ben quand même, t'as la copie d'écran sous les yeux avec la ligne en erreur en surbrillance bleue et le fichier ouvert sur la ligne indiquée en orange, facilement retrouvable. Qu'est-ce qu'il te faut de plus ?

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.

Afin de pouvoir tester sous Linux me suis installer une machine virtuelle avec Linux Mint Sarah. Tout c'est bien passé. Installation de l'os puis de Lazarus 1.6.2 depuis le DEB sur le site. Sauf que pour compiler les projets j'ai du reconstruire l'edi
"Outils"->"Configurer la creation de Lazarus" mais impossible de lier le programme Lazarus je me prend la même erreur que ci-dessous. Bon pas grave les sources elles ont compilé sans problème.
Ensuite j'ai repris les sources du dernier zip que j'ai posté ici. 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 ). Bon cela étant fait je lance le projet Test et la paf j'obtiens :

Messages - Avertissements : 1
Warning: other sources path of "Test" contains "/usr/share/lazarus/1.6.2/lcl", which belongs to package "LCLBase" --> Pourris comme message car si tu mets pas LCLBAse dans le package ça compile pas et si tu ne mets pas LCL dans le projet ça compile pas aussi (ps c'est pareil avec la version Windows)

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

Compilation du projet - Cible : bin/linux/Test-x86_64 : Code de sortie 256 - Erreurs : 1
Test.lpr(20,1) Error: Error while linking

Et toujours ce problemes avec le code Erreur 256, Bon pour l'ide je peux comprendre je suis pas rooté mais la je comprend pas surtout que j'ai tous les droits sur ce dossier et qu'il se trouve sur /home/username/lazarus/ etc...

Une petite idée, sur ce que je n'ai pas fait ?
J'avoue que cela faisait bien longtemps que je n'avais pas utilisé un OS Linux

[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]

Vraiment bizarre je viens de tester le projet "Benchmark" le seul truc que j'ai eu a faire c'est de renommer les noms de quelques units en minuscule et pas de soucis ça à compiler direct sans problemes.

Le seul bug ce sont les tests avec le TImage natif rien ne s'affiche dans la fenêtre prévisualisation sinon le TFastImage fonctionne nickel . Trop bizarre !!

la le test en cours


le test fini

[Jipété]

Ola !

Le seul bug ce sont les tests avec le TImage natif rien ne s'affiche dans la fenêtre prévisualisation sinon le TFastImage fonctionne nickel . Trop bizarre !!

Ah lol, quand j'ai vu cette copie d'écran de ton EDI, j'ai eu l'impression d'être dans un logiciel de développement d'images numériques,

Tiens voila le fichier modifié

Trop gentil, merci, mais j'ai constaté, après l'avoir mis en place, que je retombais sur ces erreurs de FileInfo et autre PVSFixedFileInfo inconnues dans la vieille version de ma machine de prod', et comme je n'ai aucune intention de migrer tant que je n'aurai pas une vraie TListView comme carotte sous le nez, ben, après avoir constaté que ce module je n'en avais rien à faire, je l'ai supprimé.
Et je retombe sur le problème de FreeType et son prop défini à tort (voir copie d'écran d'hier).

Bon, j'en ai un peu marre, là, suis à deux doigts de renoncer parce que je ne vois pas quoi chercher où.

Parce que le pire, c'est que si cet après-midi je pouvais dépasser cette erreur en commentant FastFont.pas, ce soir, même commenté j'ai l'erreur...

Alors, après avoir viré tout ce qui référençait FastFont (parce que le commenter là où il était utilisé ça ne suffisait pas...), après avoir viré les fichiers, j'ai encore trouvé une erreur qui me surprend, ou plutôt, c'est le fait que tu puisses compiler qui me surprend...
L'erreur dans CustomFastBitmapHandler :


Ma solution dans FastBitmapCore :


Bon, avec ça je compile. Et je ne vais pas plus loin tant que je ne pourrai pas ouvrir correctement les .bmp, .jpg et .png. Car ce n'est pas la peine de faire des benchs pour un outil qu'on ne pourrait pas utiliser ensuite.
Non ?

EDIT : une question et une image...
La question dans FastBitmapCore :

Code :

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

1
2
3
4
5
6
7
8
//------------------------------------------------------------------------------
// Renvoit des informations sur le "RawImage"
//------------------------------------------------------------------------------
Function TFastBitmap.Description: String;
Begin
  UpdateProperties; // pourquoi cette instruction était-elle commentée ?
  Result := StringReplace(FRawImage.Description.AsString, ' ', LineEnding, [rfReplaceAll]);
End;

L'image, après avoir décommenté l'instruction ci-dessus. En bas le fichier original, ouvert dans un viewer quelconque, en haut ce qui s'affiche dans l'outil (à noter la bande cyan à gauche toute) et à droite les informations grâce à l'instruction décommentée, si ça peut aider à comprendre ce résultat presque tout noir...
Le fichier est un bête .bmp :

[BeanzMaster]

Ola !

L'erreur dans CustomFastBitmapHandler :

T'as plus besoin de ce fichier, tout est dans fastbitmapcore

Bon, avec ça je compile. Et je ne vais pas plus loin tant que je ne pourrai pas ouvrir correctement les .bmp, .jpg et .png. Car ce n'est pas la peine de faire des benchs pour un outil qu'on ne pourrait pas utiliser ensuite.
Non ?

EDIT : une question et une image...
La question dans FastBitmapCore :

Code :

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

1
2
3
4
5
6
7
8
//------------------------------------------------------------------------------
// Renvoit des informations sur le "RawImage"
//------------------------------------------------------------------------------
Function TFastBitmap.Description: String;
Begin
  UpdateProperties; // pourquoi cette instruction était-elle commentée ?
  Result := StringReplace(FRawImage.Description.AsString, ' ', LineEnding, [rfReplaceAll]);
End;

L'image, après avoir décommenté l'instruction ci-dessus. En bas le fichier original, ouvert dans un viewer quelconque, en haut ce qui s'affiche dans l'outil (à noter la bande cyan à gauche toute) et à droite les informations grâce à l'instruction décommentée, si ça peut aider à comprendre ce résultat presque tout noir...
Le fichier est un bête .bmp :

Le probleme vient en fait de la procedure setinternalcolor, les handler pour charger les images se servent de la propriété Color[] pour remplir le buffer

voila l'unit FastBitmapCore corrigée, maintenant ton image devrait s'afficher

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
//==============================================================================
// FastBitmapCore.pas
//------------------------------------------------------------------------------
// Historique :
// 18/11/16 - BeanzMaster - Creation
//------------------------------------------------------------------------------
// Description :
// Composant graphique optimisé pour l'affichage d'un Bitmap en 32bits
// Creation suite à une discussion sur :
// http://www.developpez.net/forums/d1610633/autres-langages/pascal/lazarus/info-font-graphisme-pointu/
//------------------------------------------------------------------------------
// Credits :
// Composant original :  FCL Compact Image Unit (c) 2016, Paul F. Michell.
//------------------------------------------------------------------------------
//==============================================================================
Unit FastBitmapCore;
//==============================================================================
 
{$I beanz.inc}
 
//==============================================================================
Interface
 
Uses
  Classes, SysUtils, Types, Graphics, GraphType,
  {$IFDEF WINDOWS}Windows,{$ENDIF}
  {$IFDEF LCLGTK2}GDK2, Gtk2Def,{$ENDIF}
  {$IFDEF LCLQT}QT4, QTWidgets, QTObjects,{$ENDIF}
  {$IFDEF LCLCARBON}MacOSAll, CarbonCanvas,{$ENDIF}
  GL, GLU,{ GLExt,}
  FPImage, FPReadBMP, FPReadJPEG, FPReadPNG, FPReadTGA, FPReadXPM;
 
//==============================================================================
Type
  TColorFormat = (cfRGBA,cfBGRA);
 
//------------------------------------------------------------------------------
// Les macros, ici permettent de choisir la spécification des données du bitmap
// BGRA ou RGBA suivant votre OS, ou comment vous désirez utiliser le bitmap
// Pour Windows le format d'affichage par defaut est BGRA
// cf fichier beanz.inc pour modifier les options de compilations
//------------------------------------------------------------------------------
Type
  TCompactColor = Packed Record
    {$IFDEF BGRAIMAGE}
    Blue, Green, Red, Alpha: Byte;
    {$ELSE}
    Red, Green, Blue, Alpha: Byte;
    {$ENDIF}
  End;
  TCompactColorPointer = ^TCompactColor;
 
//------------------------------------------------------------------------------
const
  FastPixelSize = SizeOf(TCompactColor);
  // Quelques constantes pour les couleurs
Const
  ccolAlphaOpaque = 255;
  ccolAlphaTransparent = 0;
  {$IFDEF BRGAIMAGE}
  ccolTransparent: TCompactColor= (Blue: $00; Green: $00; Red: $00; Alpha: $00);
  ccolBlack: TCompactColor	= (Blue: $00; Green: $00; Red: $00; Alpha: $ff);
  ccolBlue: TCompactColor	= (Blue: $ff; Green: $00; Red: $00; Alpha: $ff);
  ccolGreen: TCompactColor	= (Blue: $00; Green: $ff; Red: $00; Alpha: $ff);
  ccolCyan: TCompactColor	= (Blue: $ff; Green: $ff; Red: $00; Alpha: $ff);
  ccolMagenta: TCompactColor	= (Blue: $ff; Green: $00; Red: $ff; Alpha: $ff);
  ccolYellow: TCompactColor	= (Blue: $ff; Green: $ff; Red: $00; Alpha: $ff);
  ccolWhite: TCompactColor	= (Blue: $ff; Green: $ff; Red: $ff; Alpha: $ff);
  ccolGray: TCompactColor	= (Blue: $80; Green: $80; Red: $80; Alpha: $ff);
  ccolLtGray: TCompactColor	= (Blue: $c0; Green: $c0; Red: $c0; Alpha: $ff);
  ccolDkRed: TCompactColor	= (Blue: $00; Green: $00; Red: $80; Alpha: $ff);
  ccolDkGreen: TCompactColor	= (Blue: $00; Green: $80; Red: $00; Alpha: $ff);
  ccolDkCyan: TCompactColor	= (Blue: $00; Green: $80; Red: $80; Alpha: $ff);
  ccolDkBlue: TCompactColor     = (Blue: $80; Green: $00; Red: $00; Alpha: $ff);
  ccolDkMagenta: TCompactColor	= (Blue: $80; Green: $00; Red: $80; Alpha: $ff);
  ccolDkYellow: TCompactColor	= (Blue: $80; Green: $80; Red: $00; Alpha: $ff);
{$ENDIF}
 
 
//===[ TFASTBITMAP ]============================================================
// Object optimizé pour utilisé un Bitmap en 32bit (RGBA)
// Pour l'affichage et le chargement de fichiers bitmap on utilise un objet
// descendant de TCustomFastBitmapHandler (TLCLFastBitmapHandler) ou le composant
// visuel TFastImage
// On peux également, directement copier les données accessibles via la propriété
// "Data" avec la procedure Move(Src,Dest,Size) ou parcourir les données via
// Pixel[x,y],Colors[x,y] ou accéder aux données à l'aide de pointeurs
//------------------------------------------------------------------------------
Type
  TFastBitmap = class(TFPCustomImage)
  private
    FBytesPerPixel : Integer;
    FBytesPerLine : Integer;
    FColorFormat : TColorFormat;
 
    FImageBitmap: Graphics.TBitmap;
    FRawImage: TRawImage;
 
    FFastScanLine : array of integer;
 
    FOnChange: TNotifyEvent;
 
    procedure setColorFormat(value:TColorFormat);
 
    procedure SetRawPixel (x,y:integer; Color: TCompactColor); inline;
    function GetRawPixel (x,y:integer) : TCompactColor;
    procedure ComputeFastScanLine;
  Protected
    Data: TCompactColorPointer;
 
    procedure DoOnChange(Sender: TObject); virtual;
    Function GetInternalColor(x, y: Integer): TFPColor; Override;
    Function GetInternalPixel({%H-}x, {%H-}y: Integer): Integer; Override;
    Procedure SetInternalColor (x, y: Integer; Const Value: TFPColor); Override;
    Procedure SetInternalPixel({%H-}x, {%H-}y: Integer; {%H-}Value: Integer); Override;
    Function GetFastScanLineAddr(y:integer):Integer;
    Function GetImageBitmap: Graphics.TBitmap;
  Public
    constructor Create(AWidth, AHeight: integer); override;
    Destructor Destroy; Override;
    Procedure Clear(Color: TCompactColor);
    Procedure SetSize(AWidth, AHeight: Integer); Override;
 
    //function LoadFromFile(Filename: string): boolean;
 
    Function GetPixelAddress(X, Y: Integer): TCompactColorPointer; inline;
    Function ScanLine(y:integer):TCompactColorPointer;
 
    Function Description: String;
 
    Procedure UpdateData;
    Procedure UpdateProperties;
 
    procedure Changed(); //Procedure Update
 
    Procedure DrawTo(Canvas: TCanvas;R:Types.TRect);
    Procedure DrawToOpenGL(DisplayRect: Types.TRect);
 
 
    //Property Data: TCompactColorPointer Read FData Write FData;
    function getData:TCompactColorPointer;
 
    property BytesPerLine : Integer read FBytesPerLine write FBytesPerLine;
    property BytePerPixel : Integer read FBytesPerPixel;
    property Pixel[x,y:integer] : TCompactColor read GetRawPixel write SetRawPixel;
 
 
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
 
    Property ImageBitmap: Graphics.TBitmap Read GetImageBitmap;   //fastbitmapcore.pas(135,35) Error: This kind of property cannot be published
    Property RawImage: TRawImage Read FRawImage; //fastbitmapcore.pas(136,36) Error: This kind of property cannot be published
 
 
  published
    property Width;
    property Height;
    property ColorFormat : TColorFormat Read FColorFormat write setColorFormat;
    property OnProgress;
 
  End;
 
//==============================================================================
 
Function RGBToIntColor(r,g,b:byte):Integer;
Function CompactColor(r,g,b,a:byte):TCompactColor;
 
//==============================================================================
 
Implementation
 
//==============================================================================
 
  {$IFDEF DEBUG_ON}uses Dialogs; {$ENDIF}
//==============================================================================
 
Const
  GL_BGRA_EXT = $80E1;
 
 
function FPColorToCompactColor(Const Value:TFPColor):TCompactColor;
begin
  Result.Red := Value.Red ShR 8;
  Result.Green := Value.Green ShR 8;
  Result.Blue := Value.Blue ShR 8;
  Result.Alpha := Value.Alpha ShR 8;
end;
 
function CompactColorToFPColor(Const RGBA: TCompactColor) : TFPcolor;
 
begin
  with Result do
  begin
    Red   :=(RGBA.Red shl 8) or RGBA.Red;
    Green :=(RGBA.Green shl 8) or RGBA.Green;
    Blue  :=(RGBA.Blue shl 8) or RGBA.Blue;
    Alpha :=255-RGBA.Alpha;
    Alpha :=(RGBA.Alpha shl 8) or RGBA.Alpha
  end;
end;
 
Function RGBToFPColor(Const RGB : TCompactColor) : TFPColor;
 
begin
  with Result do
    begin  {Use only the high byte to convert the color}
      Red   :=(RGB.Red shl 8) or RGB.Red;
      Green :=(RGB.Green shl 8) or RGB.Green;
      Blue  :=(RGB.Blue shl 8) or RGB.Blue;
      Alpha := AlphaOpaque;
    end;
end;
//------------------------------------------------------------------------------
// Renvoie une couleur au format TCompacColor
//------------------------------------------------------------------------------
Function CompactColor(r,g,b,a:byte):TCompactColor;
begin
  with result do
  begin
    red := r;
    blue := g;
    green := b;
    alpha := a;
  end;
end;
 
//------------------------------------------------------------------------------
// Convertion couleur RGB 24bit vers un "Integer"
//------------------------------------------------------------------------------
Function RGBToIntColor(r,g,b:byte):Integer;
begin
  result:=(r or (g shl 8) or (b shl 16)) and $ffffff;
end;
 
//------------------------------------------------------------------------------
// Inverse les composantes "Blue" et "Red" d'un TCompactColor
//------------------------------------------------------------------------------
function SwapBRComponent(Value: Cardinal): Cardinal;
begin
//  Result := (Value and $00ff00) or ((Value shr 16) and $ff) or ((Value and $ff) shl 16);
  Result := Value;
  TCompactColor(Result).Red := TCompactColor(Value).Blue;
  TCompactColor(Result).Blue := TCompactColor(Value).Red;
end;
 
 
//===[ TFASTBITMAP ]============================================================
 
//------------------------------------------------------------------------------
// Creation de TFastBitmap en spécifiant sa largeur et hauteur
//------------------------------------------------------------------------------
Constructor TFastBitmap.Create(AWidth, AHeight: integer);
Begin
  inherited Create(AWidth, AHeight);
  ReAllocMem(Data, FastPixelSize*AWidth*AHeight);
  FBytesPerPixel := FastPixelSize;
  FBytesPerLine := FBytesPerPixel * AWidth;
  UsePalette:=false;
  FImageBitmap := Graphics.TBitmap.Create;
  {$IFDEF BGRAIMAGE}
  setColorFormat(cfBGRA);
  {$ELSE}
  setColorFormat(cfRGBA);
  {$ENDIF}
end;
 
//------------------------------------------------------------------------------
// Destruction de TFastBitmap
//------------------------------------------------------------------------------
Destructor TFastBitmap.Destroy;
Begin
  FImageBitmap.Free;
  FImageBitmap:=nil;
  ReAllocMem(Data, 0);
  FreeMem(Data);
  SetLength(FFastScanLine,0);
  FOnChange:=nil;
  Inherited Destroy;
End;
 
Function TFastBitmap.GetData:TCompactColorPointer;
begin
  result:=Data;
end;
//------------------------------------------------------------------------------
// Change la taille de TFastBitmap
//------------------------------------------------------------------------------
Procedure TFastBitmap.SetSize(AWidth, AHeight: Integer);
Begin
  If (AWidth<>Width) Or (AHeight<>Height) Then
    Begin
      ReAllocMem(Data, FastPixelSize*AWidth*AHeight);
      Inherited SetSize(AWidth, AHeight);
      FBytesPerLine := FBytesPerPixel * AWidth;
      {$IFDEF DEBUG_ON}
      ShowMessage('FastBitmapCore.SetSize : '+inttostr(Width)+'x'+inttostr(Height)
                 +#13#10+'Bytes per Pixel : '+inttostr(FBytesPerPixel)
                 +#13#10+'Bytes per line : '+inttostr(FBytesPerLine));
      {$ENDIF}
      SetLength(FFastScanLine,Height);
      ComputeFastScanLine;
      updateProperties;
      DoOnChange(self);
    End;
End;
 
//------------------------------------------------------------------------------
// Definit le format de couleur cfRGBA ou cfBGRA (default)
//------------------------------------------------------------------------------
Procedure TFastBitmap.setColorFormat(value:TColorFormat);
Begin
  if (FColorFormat = Value) then exit;
  FColorFormat := Value;
  updateProperties;
  DoOnChange(self);
End;
 
//------------------------------------------------------------------------------
// Fonction interne à TFastBitmap, calcul des "scanlines"
// On se sert du tableau FFascanLine pour optimiser l'acces à un pixel.
// On evite ainsi une multiplication lorsque l'on doit modifier plusieurs pixels en une fois
//------------------------------------------------------------------------------
procedure TFastBitmap.ComputeFastScanLine;
Var
  y:Integer;
begin
  if BytesPerLine=0 then Exit;
  For y:=0 to Height-1 do
  begin
    FFastScanLine[y]:=y*Width; //FBytesPerLine
  end;
end;
 
//------------------------------------------------------------------------------
// Retourne l'adresse physique d'une ligne dans notre bitmap
//------------------------------------------------------------------------------
Function TFastBitmap.GetFastScanLineAddr(y:integer):Integer;
begin
  result:=FFastScanLine[y];
end;
 
//------------------------------------------------------------------------------
// Retourne le pointeur de type TCompactColorPointer à la position x,y
//------------------------------------------------------------------------------
function TFastBitmap.GetPixelAddress(X, Y: Integer): TCompactColorPointer;
Var
  xx,yy:integer;
begin
  yy:=FFastScanLine[y];
  xx:=yy+x;
  Result := TCompactColorPointer(Data + xx);
end;
 
//------------------------------------------------------------------------------
// Retourne un pointeur "TCompactColorPointer" de la ligne y du bitmap
//------------------------------------------------------------------------------
Function TFastBitmap.ScanLine(y:integer):TCompactColorPointer;
Var
  yy:integer;
begin
  yy:=FFastScanLine[y];
  result:=TCompactColorPointer(Data+yy);
End;
 
//------------------------------------------------------------------------------
// Non utilisé ici car on fonctionne en 32bit
// Cette procedure est utilisé pour des images avec une palette
// Retourne l'index de la couleur d'un pixel dans la palette
// cf : TFPCustomImage pour plus d'informations
//------------------------------------------------------------------------------
Function TFastBitmap.GetInternalPixel(x, y: Integer): Integer;
begin
  {$MESSAGE warn : GetInternalPixel Not used here }
  result:=0;
 
end;
//------------------------------------------------------------------------------
// Non utilisé ici car on fonctionne en 32bit
// Cette procedure est utilisé pour des images avec une palette
// Definit la couleur d'un pixel avec la couleur d'index Value
// presente dans la palette si définie
// cf : TFPCustomImage pour plus d'informations
//------------------------------------------------------------------------------
Procedure TFastBitmap.SetInternalPixel(x, y: Integer; Value: Integer);
begin
  {$MESSAGE warn : SetInternalPixel Not used here }
end;
 
//------------------------------------------------------------------------------
// Renvoit des informations sur le "RawImage"
//------------------------------------------------------------------------------
Function TFastBitmap.Description: String;
Begin
 // UpdateProperties;
  Result := StringReplace(FRawImage.Description.AsString, ' ', LineEnding, [rfReplaceAll]);
End;
 
//------------------------------------------------------------------------------
// Retourne une couleur de type TCompactColor à la position x,y
//------------------------------------------------------------------------------
Function TFastBitmap.GetRawPixel(x, y: Integer): TCompactColor;
Var
  xx,yy:integer;
begin
  yy:=FFastScanLine[y];
  xx:=yy+x;
  //Result:=FPixelsData[xx];
  Result:=TCompactColorPointer(Data+xx)^;
End;
 
//------------------------------------------------------------------------------
// Definie la couleur d'un pixel à la position x,y avec une couleur de type TCompactColor
//------------------------------------------------------------------------------
Procedure TFastBitmap.SetRawPixel(x, y: Integer; Color: TCompactColor);
Var
  xx,yy:integer;
begin
  //yy:=GetFastScanLineAddr(y); // Moins rapide que la ligne ci-dessous car la "porté" est plus grande
  yy:=FFastScanLine[y]; // yy:=y*width; petite optimisation on evite ainsi une multiplication
  xx:=yy+x;
  // Les 2 fonctions ci-dessous ce valent, la 1ere etant une peu plus performante d'un poil
  TCompactColorPointer(Data+xx)^:=Color;
  //FPixelsData[xx] := Color;
End;
 
//------------------------------------------------------------------------------
// Retourne une couleur de type FPColor à la position x,y
//------------------------------------------------------------------------------
Function TFastBitmap.GetInternalColor(x, y: Integer): TFPColor;
Var
  Color: TCompactColor;
Begin
  Color := Data[x+y*Width];
  With Color Do
    Begin
      Result.Red := (Red ShL 8)+Red;
      Result.Green := (Green ShL 8)+Green;
      Result.Blue := (Blue ShL 8)+Blue;
      Result.Alpha := (Alpha ShL 8)+Alpha;
    End;
End;
 
//------------------------------------------------------------------------------
// Definie la couleur d'un pixel à la position x,y avec une couleur de type TFPColor
//------------------------------------------------------------------------------
Procedure TFastBitmap.SetInternalColor(x, y: Integer; Const Value: TFPColor);
(*Var
  Color: TCompactColor;*)
Begin
(*  Color.Red := Value.Red ShR 8;
  Color.Green := Value.Green ShR 8;
  Color.Blue := Value.Blue ShR 8;
  Color.Alpha := Value.Alpha ShR 8; *)
  //Data[x+y*width] := Color;
  //Pixel[x,y]:=Color;
  setRawPixel(x,y,FPColorToCompactColor(Value));
End;
 
//------------------------------------------------------------------------------
// Efface le bitmap avec une couleur de type TFPColor
//------------------------------------------------------------------------------
Procedure TFastBitmap.Clear(Color: TCompactColor);
Begin
  FillDWord(Data^, Width*Height, DWord(Color));
End;
 
//------------------------------------------------------------------------------
// Mise à jour des donnée du "RawImage" par rapport au TFastBitmap
//------------------------------------------------------------------------------
Procedure TFastBitmap.UpdateProperties;
begin
  Case FColorFormat of
    cfBGRA :
      begin
        FRawImage.Description.Init_BPP32_B8G8R8A8_BIO_TTB(Width, Height);
      end;
    cfRGBA :
      begin
        FRawImage.Description.Init_BPP32_R8G8B8A8_BIO_TTB(Width, Height);
      end;
  end;
end;
 
Procedure TFastBitmap.UpdateData;
begin
  FRawImage.Data := PByte(Data);
  FRawImage.DataSize := FRawImage.Description.BytesPerLine*Height;
end;
 
//------------------------------------------------------------------------------
// Procedure Interne de notification en cas de modification du bitmap
//------------------------------------------------------------------------------
procedure TFastBitmap.DoOnChange(Sender:TObject);
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;
 
//------------------------------------------------------------------------------
// Notification que le bitmap à changé
//------------------------------------------------------------------------------
procedure TFastBitmap.Changed();
begin
  DoOnChange(self);
end;
 
//------------------------------------------------------------------------------
// Retourne un TBitmap
//------------------------------------------------------------------------------
Function TFastBitmap.GetImageBitmap: Graphics.TBitmap;
Begin
  UpdateProperties;
  UpdateData;
  FImageBitmap.LoadFromRawImage(FRawImage, false);
  Result := FImageBitmap;
End;
 
//------------------------------------------------------------------------------
// Affiche un TFastBitmap sur un "Canvas"
//------------------------------------------------------------------------------
Procedure TFastBitmap.DrawTo(Canvas: TCanvas;R:Types.TRect);
{$IFDEF WINDOWS}
Var
  BitsInfo: TBitmapInfo;
Begin
  UpdateData;
  With BitsInfo.bmiHeader Do
    Begin
      biSize := SizeOf(TBitmapInfoHeader);
      biWidth := Width;
      biHeight := -Height; { Note: negative height flags image as bottom to top scanline order. }
      biPlanes := 1;
      biBitCount := 32; //FRawImage.Description.BitsPerPixel;
      biCompression := BI_RGB;
      biSizeImage :=  Sizeof(Data);
      biXPelsPerMeter := 0;
      biYPelsPerMeter := 0;
      biClrUsed := 0;
      biClrImportant := 0;
    End;
  Canvas.Lock;
  StretchDIBits(Canvas.Handle, R.Left, R.Top, (R.Right-R.Left), (R.Bottom-R.Top),  0, 0, Width, Height,  RawImage.Data,
               // 0, 0, FastBitmap.Width, FastBitmap.Height, RawImage.Data,
                BitsInfo, DIB_RGB_COLORS, SRCCOPY);
  Canvas.Unlock;
End;
{$ELSE}{$IFDEF LCLGTK2}
Begin
  UpdateData;
  gdk_draw_rgb_32_image(TGTKDeviceContext(Canvas.Handle).Drawable,
                        TGTKDeviceContext(Canvas.Handle).GC, R.Left, R.Top, (R.Right-R.Left), (R.Bottom-R.Top), //Width / Height ???
                        GDK_RGB_DITHER_NORMAL,
                        RawImage.Data, RawImage.Description.BytesPerLine);
End;
 
{$ELSE}{$IFDEF LCLQT}
Var
  QtImage: TQtImage;
  QtContext: TQtDeviceContext;
 // Rect: TRect;
Begin
  UpdateData;
  QtImage := TQtImage.Create(RawImage.Data, Width, Height, QImageFormat_ARGB32);
  //Rect := R; //Types.Rect(0, 0, FCompactImage.Width, FCompactImage.Height);
  QtContext := TQtDeviceContext(Canvas.Handle);
  QtContext.drawImage(@R, QtImage.Handle, @R, Nil, @R);
  QtImage.Free;
End;
{$ELSE}{$IFDEF LCLCARBON}
Var
  Image: CGImageRef;
  BitmapReference: CGContextRef;
Begin
  UpdateData;
  BitmapReference := CGBitmapContextCreate(RawImage.Data, Width, Height,
                                           8, 4*Width,
                                           CGColorSpaceCreateWithName(kCGColorSpaceGenericRGB),
                                           kCGImageAlphaPremultipliedLast);
  Image := CGBitmapContextCreateImage(BitmapReference);
 // TCarbonDeviceContext(Canvas.Handle).DrawCGImage(0, 0, FCompactImage.Width, FCompactImage.Height, Image);
  TCarbonDeviceContext(Canvas.Handle).DrawCGImage(R.Left, R.Top, (R.Right-R.Left), (R.Bottom-R.Top), Image);
  CGImageRelease(Image);
  CGContextRelease(BitmapReference);
End;
{$ELSE}
Begin
  UpdateData;
  GetImageBitmap;
  Canvas.Lock;
  //Canvas.Draw(0,0, ImageBitmap);
  Canvas.Draw(R.Left, R.Top, ImageBitmap);
  Canvas.Unlock;
End;
{$ENDIF}{$ENDIF}{$ENDIF}
{$ENDIF}
 
Procedure TFastBitmap.DrawToOpenGL(DisplayRect: TRect);
Begin
  UpdateData;
  glClearColor(0.0, 0.0, 0.0, 1.0);
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  glMatrixMode(GL_PROJECTION);
  glLoadIdentity;
  glOrtho(0, Width, 0, Height, 0, 1);
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
  glDisable(GL_DEPTH_TEST);
  glViewport(DisplayRect.Left, DisplayRect.Bottom, DisplayRect.Right, DisplayRect.Top);
  Case FColorFormat of
    cfBGRA :
      begin
        glDrawPixels(Width, Height, GL_BGRA_EXT, GL_UNSIGNED_BYTE, Data);
      end;
    cfRGBA :
      begin
        glDrawPixels(Width, Height, GL_RGBA, GL_UNSIGNED_BYTE, Data);
      end;
  end;
  glRasterPos2i(0, Height);
  glPixelZoom(1.0, -1.0);
End;
 
//==============================================================================
 
End.