Discussion :

[Jipété]

Bonjour,

je retrouve un vieux programme qui fonctionne bien (sous Linux) dans une machine 32 bits et qui me fait un Access Violation avec le même code dans une machine 64 bits,

Le problème se situe sur la ligne 5 du bout de code ci-dessous (qui fait partie d'une usine à gaz servant à redimensionner une image .bmp, GG en a parlé là https://www.developpez.net/forums/d1...e/#post7298397 (zip dispo en suivant le lien) et j'avoue qu'à l'époque j'ai été bluffé par les résultats, regardez :

-- attention, le code ne fonctionne qu'avec des images-sources en bmp, en ce qui me concerne [peut-être lié à des histoires de 24 <> 32 bits, je ne sais pas encore]) :

Code :

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

1
2
3
4
5
6
7
    SetLength(pixR, HR, WR); // HR,WR: 2 integer
    for y := 0 to HR - 1 do begin
      for x := 0 to WR - 1 do begin
        pixR[y, x] := Scan0 + y * MLS + x * Bpp;
        PRGBQuad(pixR[y, x])^ := ColorVersClQuad(clWhite);
      end;
    end;

à gauche l'image de départ, à droite le résultat d'un zoom à 600 % où les curieux attentifs remarqueront une différence de rendu au niveau de la pointe bleue de la mine du crayon entre l'image de Gilbert et la mienne, différence que je n'ai pas eu le temps de creuser.

Le souci, donc, c'est que ça compile bien sauf un

"Warning: Conversion between ordinals and pointers is not portable"

remonté par la ligne qui va planter par un AV à l'exécution...

Qu'en dire de plus ? Je peux apporter des précisions, genre à la ligne précédant le bout de code, on trouve un pixR qui est en fait un

Code :

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

1
2
type
  tScanYX = array of array of integer; // Tableau des adresses des pixels

et je rappelle ce qu'est un PRGBQUAD :

Code :

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

1
2
3
4
5
6
7
8
9
  PRGBQuad = ^TRGBQUAD et
  tagRGBQUAD = record
          rgbBlue : BYTE;
          rgbGreen : BYTE;
          rgbRed : BYTE;
          rgbReserved : BYTE;
       end;
  TRGBQuad = tagRGBQUAD;
  RGBQUAD = tagRGBQUAD;

Quant au ColorVersClQuad, il est bricolé ainsi :

Code :

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

1
2
3
4
5
6
7
8
9
function ColorVersClQuad(cl: tColor): tRGBQuad;
begin
  with Result do begin
    rgbRed   := GetRValue(cl);
    rgbGreen := GetGValue(cl);
    rgbBlue  := GetBValue(cl);
    rgbReserved := 255; // jpt
  end;
end;

avec function GetRValue(RGB : DWORD) : BYTE; inline; dans winapih.inc et on ne va pas plus profond. Et pareil pour G et B.
De mémoire, je crois bien que c'est moi qui ai rajouté dans le code 32 bits la ligne rgbReserved.

Enfin, plus loin dans le code, on trouve Rouge := ColorVersClQuad(clRed); et 5 autres lignes pour les 5 autres couleurs basiques.
La souris sur Rouge montre var Rouge: tRGBQuad = tagRGBQUAD = record alors par mimétisme, j'invente Blanc := ColorVersClQuad(clWhite); mais ça ne change rien à l'AV...

À vos claviers, pour les bonnes idées et les pistes lumineuses,

[acaumes]

Bonjour,

Qu'en dire de plus ? Je peux apporter des précisions, genre à la ligne précédant le bout de code, on trouve un pixR qui est en fait un

Code :

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

1
2
type
  tScanYX = array of array of integer; // Tableau des adresses des pixels

Pour autant que je voie, tu transformes un pixr en pointeur. vers une structure RGB... Or si j'en crois tes dires, pixr est en fin de comptes un tableau d'entiers. Pour pouvoir contenir un pointeur en bits il te faut plus qu’un entier qui ne fait que 32 bits
Lazarus préconise ptrint ou ptrUInt pour cela...

Cordialement

[tourlourou]

Bonsoir, acaumes a raison ; pour le vérifier : que donnent SizeOf(integer), SizeOf(Pointer) et SizeOf(TRGBQuad) sur les 2 machines ?

[Jipété]

Merci à toi !

Pour autant que je voie, tu transformes un pixr en pointeur. vers une structure RGB... Or si j'en crois tes dires, pixr est en fin de comptes un tableau d'entiers.

Oh moi, je n'ai pas fait grand chose (les pointeurs sont mes bêtes noires...), je me suis contenté de recopier le bloc par copier/coller et d'aller chercher des détails par Ctrl-Click.
Après, je ne sais pas traduire ces lignes cabalistiques en phrases intelligibles,

Pour pouvoir contenir un pointeur en bits il te faut plus qu’un entier qui ne fait que 32 bits
Lazarus préconise ptrint ou ptrUInt pour cela...

J'ai testé les deux, j'ai même tenté le longint, dans tous les cas c'est l'AV...

Bonsoir Yves,

et pour te répondre, hop !, la machine 64 bits :

Code :

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

1
2
3
4
showmessage(inttostr(SizeOf(integer))); // 4
showmessage(inttostr(SizeOf(Pointer))); // 8
showmessage(inttostr(SizeOf(TRGBQuad))); // 4
showmessage(inttostr(SizeOf(longint))); // 4

Pour la machine 32 bits, je suis en train d'en construire une nouvelle, please wait...

[Volid]

Il existe aussi d'autres codes avec le même problème avant la partie que tu as postée
Scan0 est un entier qui reçoit la valeur d'un pointeur de 8 octets sur la plateforme de 64bit

Code :

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

1
2
3
 
Scan0 := Integer(Result.ScanLine[0]); 
MLS := Integer(Result.ScanLine[1]) - Scan0;

Pour commencer il faut réécrire la déclaration comme suit:

Code :

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

1
2
type
  tScanYX = array of array of PRGBQuad;

ou

Code :

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

1
2
type
  tScanYX = array of array of NativeInt;

[tourlourou]

Le début de la ligne PRGBQuad(pixR[y, x])^ := ColorVersClQuad(clWhite); signifie que tu demandes au compilateur de prendre un entier sur 4 octets (pixR[y, x]) comme un pointeur de 8 octets sur TRGBQuad (PRGBQuad).

Forcément, ça coince !

Si le TRGBQuad occupe 4 octets lui aussi, il serait plus judicieux de transtyper directement : TRGBQuad(pixR[y, x]) := ColorVersClQuad(clWhite); sans que ceci ne lève les objections de Volid...

[Jipété]

Si le TRGBQuad occupe 4 octets lui aussi, il serait plus judicieux de transtyper directement : TRGBQuad(pixR[y, x]) := ColorVersClQuad(clWhite); sans que ceci ne lève les objections de Volid...

On verra ça dessus après avoir réglé ça dessous :

Pour commencer il faut réécrire la déclaration comme suit:

Code :

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

1
2
type
  tScanYX = array of array of PRGBQuad;

ou

Code :

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

1
2
type
  tScanYX = array of array of NativeInt;

Vi, mais ça ne le fait pas trop :

Code :

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

1
2
type
  tScanYX = array of array of PRGBQuad;

Cette ligne coince à la compil :

Code :

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

1
2
3
4
94      for x := 0 to WS - 1 do
95        pixS[y, x] := Scan0 + y * MLS + x * Bpp;
-       avec un curseur clignotant ici ^ et le message d''erreur à la compil est là :
-> ustretchxbrv4.pas(95,39) Error: Incompatible types: got "Int64" expected "PRGBQUAD"

Mais en remplaçant PRGBQUAD par NativeInt, ça compile et ça plante bien ailleurs !

rasterimage.inc ligne 464 :

Code :

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

1
2
3
4
5
6
7
8
9
function TRasterImage.GetRawImage: TRawImage;
var
  p: PRawImage; // <-- ce truc c'est PRawImage = ^TRawImage; dans GraphType
begin
  p := GetRawImagePtr; // <--- cette ligne 
  if p = nil
  then Result{%H-}.Init
  else Result := p^;
end;

et ça plante si je veux agrandir l'image.
Si je la réduis ça fonctionne.

GraphType ligne 204 :

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
  TRawImage = object
    Description: TRawImageDescription;
    Data: PByte;
    DataSize: PtrUInt;
    Mask: PByte;
    MaskSize: PtrUInt;
    Palette: PByte;
    PaletteSize: PtrUInt;
 
    // don't use a constructor here, it will break compatibility with a record
    procedure Init;
    procedure CreateData(AZeroMem: Boolean);
 
    procedure FreeData;
    procedure ReleaseData;
    procedure ExtractRect(const ARect: TRect; out ADst: TRawImage);
 
    function  GetLineStart(ALine: Cardinal): PByte;
    procedure PerformEffect(const ADrawEffect: TGraphicsDrawEffect; CreateNewData: Boolean = True; FreeOldData: boolean = false);
    function  ReadBits(const APosition: TRawImagePosition; APrec, AShift: Byte): Word;
    procedure ReadChannels(const APosition: TRawImagePosition; out ARed, AGreen, ABlue, AAlpha: Word);
    procedure ReadMask(const APosition: TRawImagePosition; out AMask: Boolean);
    procedure WriteBits(const APosition: TRawImagePosition; APrec, AShift: Byte; ABits: Word);
    procedure WriteChannels(const APosition: TRawImagePosition; ARed, AGreen, ABlue, AAlpha: Word);
    procedure WriteMask(const APosition: TRawImagePosition; AMask: Boolean);
 
    function  IsMasked(ATestPixels: Boolean): Boolean;
    function  IsTransparent(ATestPixels: Boolean): Boolean;
    function  IsEqual(AImage: TRawImage): Boolean;
  end;
  PRawImage = ^TRawImage;

[Volid]

N'oublie pas de faire test avec la proposition de acoumes sur les types préconisés par Lazarus : Ptrint ou PtrUInt

Cette ligne coince à la compil

Certes pour utiliser le type array of array of PRGBQuad une modification est nécessaire pour le faire fonctionner car on attend une adresse et l'expression Scan0 + y * MLS + x * Bpp; renvoie valeur entière, un transtypage est nécessaire.

Je préfère l'utilisation classique de scanline qui renvoie l'adresse du premier pixel pour chaque ligne

redéclare Scan0 comme Scan0: PIntegerArray;

remplacer le code entre le commentaire
// BitMap-Source

et cette ligne
Rouge := ColorVersClQuad(clRed);

Code proposé:

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
 // BitMap-Source
    BmpS.PixelFormat := pf32bit;
    WS := BmpS.Width;
    HS := BmpS.Height;
    SetLength(pixS, HS, WS);
    for y := 0 to HS - 1 do
    begin
      Scan0 := BmpS.ScanLine[y];
      for x := 0 to WS - 1 do
           pixS[y, x] := @Scan0[x];
    end;
    // BitMap-result
    Result := tBitMap.Create; kech := abs(kech);
    WR := iKech * WS; HR := iKech * HS;
    with Result do begin
       PixelFormat := pf32bit;
       width := WR; height := HR
    end;
 
    SetLength(pixR, HR, WR);
    for y := 0 to HR - 1 do
    begin
      Scan0 := Result.ScanLine[y];
      for x := 0 to WR - 1 do begin
        pixR[y, x] := @Scan0[x];
        PRGBQuad(pixR[y, x])^ := ColorVersClQuad(clWhite);
        PRGBQuad(pixR[y, x])^.rgbReserved := 0;
      end;
    end;

[Jipété]

N'oublie pas de faire test avec la proposition de acoumes sur les types préconisés par Lazarus : Ptrint ou PtrUInt

Fait.

redéclare Scan0 comme Scan0: PIntegerArray;

Fait.

remplacer le code entre le commentaire
// BitMap-Source

et cette ligne
Rouge := ColorVersClQuad(clRed);

Et ça je me le garde pour demain, parce que ce soir je suis mort !

Le plus rigolo, c'est que pendant que tu postais ton code, j'en terminais un de mon côté, en remplaçant toutes ces merdouilles de variables trop courtes par de l'Int64 partout où je le "sentais", et je suis arrivé au même résultat que toi, à savoir :

• réduction : rien de changé, ça fonctionne toujours bien ;
• agrandissement : le canvas s'agrandit correctement mais il n'y a pas d'image, juste un fond bleu à 0 0 128.

On verra ça demain.
Dans l'attente, pour les insomniaques, j'ai trouvé ça, dans systemh.inc :

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
  { NativeInt and NativeUInt are Delphi compatibility types. Even though Delphi
    has IntPtr and UIntPtr, the Delphi documentation for NativeInt states that
    'The size of NativeInt is equivalent to the size of the pointer on the
    current platform'. Because of the misleading names, these types shouldn't be
    used in the FPC RTL. Note that on i8086 their size changes between 16-bit
    and 32-bit according to the memory model, so they're not really a 'native
    int' type there at all. }
  NativeInt  = Type PtrInt;
  NativeUInt = Type PtrUInt;
 
  Int8    = ShortInt;
  Int16   = SmallInt;
  Int32   = Longint;
  IntPtr  = PtrInt;
  UInt8   = Byte;
  UInt16  = Word;
  UInt32  = Cardinal;
  UIntPtr = PtrUInt;

et où sont les Int64 et UInt64 ? Pas fini ce truc...

et çà :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
{$ifdef CPU64}
  SizeInt = Int64;
  SizeUInt = QWord;
  PtrInt = Int64;
  PtrUInt = QWord;
  ValSInt = int64;
  ValUInt = qword;
  CodePointer = Pointer;
  CodePtrInt = PtrInt;
  CodePtrUInt = PtrUInt;
{$endif CPU64}

et un test rapide est concluant : dans

Code :

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

1
2
3
4
5
procedure TForm1.FormCreate(Sender: TObject);
begin
{$ifdef CPU64}
showmessage(inttostr(SizeOf(int64))); // 8
{$endif CPU64}

Merci pour tout, see you tomorrow.

[Jipété]

Bonjour,

On verra ça demain.

Demain est là, j'ai tenté le remplacement de code proposé, ça me donne le même résultat bleu qu'hier soir...
Et pareil avec cet ajout en 2^e ligne :

Code :

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

    Bpp := 4; // ajout

Ne sachant plus trop quoi penser, je m'en vais finir l'install de la nouvelle machine virtuelle à base de Debian12-32bits pour répondre aux questions sur la longueur des variables et autres pointeurs.

À pluche,

[tourlourou]

Ne sachant plus trop quoi penser, je m'en vais finir l'install de la nouvelle machine virtuelle à base de Debian12-32bits pour répondre aux questions sur la longueur des variables et autres pointeurs.

Aucun doute qu'ils seront tous à 4 octets... ce qui permettait le fonctionnement en 32 Bits de tous ces transtypages.

[anapurna]

Salut

As-tu simplement essayé de transtyper l'affectation ?

Je vois un truc du genre :
au début tu as

Code :

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

for x := 0 to WS - 1 do pixS[y, x] := Scan0 + y * MLS + x * Bpp;

et tu le transformes en

Code :

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

for x := 0 to WS - 1 do pixS[y, x] := Integer(Scan0 + y * MLS + x * Bpp);

[Jipété]

Aucun doute qu'ils seront tous à 4 octets... ce qui permettait le fonctionnement en 32 Bits de tous ces transtypages.

Dès que la machine est prête, je te dis. Mais c'est long à installer, je n'en reviens pas...

as-tu simplement essayé de transtyper l'affectation

je vois un truc du genre
au début tu as

Code :

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

for x := 0 to WS - 1 do pixS[y, x] := Scan0 + y * MLS + x * Bpp;

et tu le transformes en

Code :

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

for x := 0 to WS - 1 do pixS[y, x] := Integer(Scan0 + y * MLS + x * Bpp);

J'ai tenté, le compilateur n'était pas d'accord, il m'a fallu utiliser PIntegerArray et ça ne change rien, l'image est encore toute bleue si je l'agrandis...

[Volid]

Vous n'avez pas encore changé la partie du code que j'ai mentionnée avant pour pouvoir utiliser Scan0 autant que PIntegerArray (@Scan0[x]; )

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
 // BitMap-Source
    BmpS.PixelFormat := pf32bit;
    WS := BmpS.Width;
    HS := BmpS.Height;
    SetLength(pixS, HS, WS);
    for y := 0 to HS - 1 do
    begin
      Scan0 := BmpS.ScanLine[y];
      for x := 0 to WS - 1 do
           pixS[y, x] := @Scan0[x];
    end;
    // BitMap-result
    Result := tBitMap.Create; kech := abs(kech);
    WR := iKech * WS; HR := iKech * HS;
    with Result do begin
       PixelFormat := pf32bit;
       width := WR; height := HR
    end;
 
    SetLength(pixR, HR, WR);
    for y := 0 to HR - 1 do
    begin
      Scan0 := Result.ScanLine[y];
      for x := 0 to WR - 1 do begin
        pixR[y, x] := @Scan0[x];
        PRGBQuad(pixR[y, x])^ := ColorVersClQuad(clWhite);
        PRGBQuad(pixR[y, x])^.rgbReserved := 0;
      end;
    end;

[Jipété]

Vous n'avez pas encore changé la partie du code que j'ai mentionnée avant pour pouvoir utiliser Scan0 autant que PIntegerArray (@Scan0[x]; )

Si si, ce matin, la preuve :

j'ai tenté le remplacement de code proposé, ça me donne le même résultat bleu qu'hier soir...
Et pareil avec cet ajout en 2^e ligne :

Code :

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

    Bpp := 4; // ajout

Ne sachant plus trop quoi penser, je m'en vais finir l'install de la nouvelle machine virtuelle à base de Debian12-32bits pour répondre aux questions sur la longueur des variables et autres pointeurs.

Installation de la MV terminée, ça aura été une abomination de lenteur mais j'y suis arrivé, et au bout du compte, je pars d'un bête 1^er test basique,

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
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs,
  LCLIntf, LCLType;
type
  { TForm1 }
  TForm1 = class(TForm)
    procedure FormActivate(Sender: TObject);
  private
  public
  end;
var
  Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormActivate(Sender: TObject);
begin
  showmessage(inttostr(SizeOf(integer))); // 
  showmessage(inttostr(SizeOf(Pointer))); // 
  showmessage(inttostr(SizeOf(TRGBQuad)));// 
  showmessage(inttostr(SizeOf(longint))); // 
end;
end.

mais sa compil, c'est la cata :

Code :

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

1
2
3
4
5
Compilation du projet, Cible : /tmp/project1 : Code de sortie 1, Erreurs : 2, Avertissements : 2
Warning: linker: /usr/bin/ld*: /usr/lib/fpc/3.2.2/units/i386-linux/rtl/si_c21.o*: dans la fonction «*SI_C21_$$__FPC_LIBC21_START*»*:
Error: si_c21.pp:(.text.n_si_c21_$$__fpc_libc21_start+0x27)*: référence indéfinie vers «*__libc_csu_fini*»
Warning: linker: /usr/bin/ld*: si_c21.pp:(.text.n_si_c21_$$__fpc_libc21_start+0x2c)*: référence indéfinie vers «*__libc_csu_init*»
project1.lpr(24,1) Error: Error while linking

Un peu désespérant, alors on va se passer des variables en 32-bits

[Jipété]

Compte-rendu demain, ce soir je suis mort de chez mort et j'ai les yeux qui vont finir par rouler sur le clavier alors stop !

Mais ça fonctionne, hé ouais !



Cadeau pour vous faire patienter :

[Jipété]

Bonjour,

Compte-rendu demain,

Dont acte :

Hier, dans l'unité uStretchXBRV4, qui ne comporte qu'une énorme (presque 500 lignes dans la section B) fonction StretchXBR (plus une autre toute petite ainsi qu'une procédure toute petite également, qui comptent pour peanuts dans la section A), j'ai donc passé certaines variables de Integer à NativeInt (Scan0, MLS, tScanXY) ainsi que le transtypage genre Scan0 := Integer(BmpS.ScanLine[0]); --> Scan0 := NativeInt(BmpS.ScanLine[0]); et pareil pour MLS.
J'ai aussi commenté (au départ c'était juste parce que je n'arrivais pas à transtyper) dans Bitmap-result les 2 lignes

Code :

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

1
2
        PRGBQuad(pixR[y, x])^ := ColorVersClQuad(clWhite);
        PRGBQuad(pixR[y, x])^.rgbReserved := 0;

et ma foi, ça a l'air de fonctionner sans,

Tout le bloc Affichage des coeffs ayant déjà été commenté en 2019 pour cause d'indisponibilité du TRichEdit dans Lazarus, on peut s'en passer.

J'ai amélioré le clamping rajouté en 2019 dan la sous-fonction RGBtoYUC par ces tests juste avant le result :

Code :

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

1
2
3
    if y > 255 then y := 255;
    if u > 255 then u := 255;
    if v > 255 then v := 255;

Et la fin de la fonction (section Achever) avait déjà été modifiée en 2019 because function GetBrushOrgEx est inconnue sous Lazarus.

Mais je constate ce matin que le fichier uManipBMPV4.pas, que je n'ai pas touché hier, comporte lui aussi un tScanYX = array of array of integer; et ses acolytes Scan0 et MLS, qu'il va donc falloir que je regarde de plus près.

Et je n'ai pas touché au fichier uDemoV4 mis à part le remplacement suggéré par le compilateur de GetTickCount par GetTickCount64.

Ceci étant dit, il reste deux trucs qui m'ennuient :

• le prog n'est pas fichu de me proposer de choisir les fichiers .png ;
• il y a un petit souci de géométrie, regardez le travail de GG en haut et le mien dessous, au niveau de la pointe bleue du crayon, et pour essayer de corriger ça, j'ai peur d'y passer des années, d'autant plus que le rendu des couleurs n'est pas exactement le même,

Ensuite je vais faire du tri, j'ai 3 versions plus ou moins similaires, laquelle est la meilleure ? À voir.
Et il va me falloir revisiter l'ihm du prog, un peu brouillonne, et enfin étudier les options et réglages divers, mais c'est un taf d'hiver, ça,

C't'à peu près tout pour le moment,

[Volid]

j'ai donc passé certaines variables de Integer à NativeInt (Scan0, MLS, tScanXY)

Il était plus raisonnable d'enregistrer les pixels dans le tableaux mais on a choisi l'enregistrement des adresses et avec des pointeurs de 64 bits ils occupent plus de mémoire que l'image .. en plus dans certains cas le bitmap est enregistré inversé verticalement Scanline[0] renvoie l'adresse de la dernière ligne ou inversement et ça pose un sérieux problème

Code :

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

pixS : array of array of tRGBQuad

et dans la fonction getPixelIn retirer le transtypage

Code :

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

result := pixS[yy, xx];

Essaie ce code, j'ai changé vers le format RGB plus simple et sans transparence cette dernière pose problème sous Lazarus..

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
unit uStretchXBRV4;
 
{$MODE Delphi}
 
      //   Redimensionner un BitMap avec la méthode XBR pour un facteur d'échelle de valeur quelconque
      //   Code expérimental - Version 3
      //   Développé sous Selphi-5
      //   Gilbert GEYER, novembre 2012
      //   Développé par une série de modifications du XBR4bis de Barbichette
      //   Pour la théorie du XBR voir ici : http://board.byuu.org/viewtopic.php?f=10&t=2248
 
 
interface
 
uses SysUtils, Math, Graphics;
type
 
  TObjectProc  = procedure of object;
function StretchXBR(const BmpS: tBitMap; ScaleFactor: Single; const ProgressCallBack: TObjectProc = nil): tBitMap;
 
implementation
 
type
 
  PRGBQuad = ^TRGBQuad;
 
  tagRGBQUAD = packed record
    rgbBlue: Byte;
    rgbGreen: Byte;
    rgbRed: Byte;
   // rgbReserved: Byte;
  end;
  TRGBQuad = tagRGBQUAD;
   RGBQUAD = tagRGBQUAD;
 TRGBQuadArray = array[0..$FFFFFF] of TRGBQuad;
 PRGBQuadArray = ^ TRGBQuadArray;
 
function clQuadMix2K(const c1, c2: tRGBQuad; const kc1: Single): tRGBQuad;
begin
  with Result do begin
    rgbRed := round(c1.rgbRed * kc1 + c2.rgbRed * (1.0 - kc1));
    rgbGreen := round(c1.rgbGreen * kc1 + c2.rgbGreen * (1.0 - kc1));
    rgbBlue := round(c1.rgbBlue * kc1 + c2.rgbBlue * (1.0 - kc1));
  end;
end;
function clQuadEgales(c1, c2: tRGBQuad): boolean;
begin Result := (c1.rgbRed = c2.rgbRed) and (c1.rgbGreen = c2.rgbGreen) and (c1.rgbBlue = c2.rgbBlue);
end;
// A) UTILITAIRES DIVERS
 
 
// B) Méthode XBR pour un ScaleFoctor de valeur quelconque ---------------------
 
function StretchXBR(const BmpS: tBitMap; ScaleFactor: Single; const ProgressCallBack: TObjectProc = nil): tBitMap;
label Achever;
type
  tScanYX = array of PRGBQuadArray; // Tableaux des adresses des pixels
  Tvoisins = array[-2..2, -2..2] of TRGBQuad; // Matrice des couleurs voisines du pixel-source
  tCoeffs = array of array of Single; // Matrice des coefficients de pondération pour dégradés de couleurs
const R2: Single = 1.41421356737; // racine carrée de 2
var
  xs, ys, xoutMin, youtMin,  Lig, Col: integer;
  Voisins: Tvoisins;
 
 
  kech: Single; // coefficient d'échelle
  ikech: integer; // coefficient d'échelle
  mikech: Single; // moitié du coefficient d'échelle
  kDiaTri, kDiaAst, kUP_2, kLeft_2, kLeft_UP_2, kTmpRota: tCoeffs; // Matrices des coefficients de pondération pour dégradés de couleurs
 
  WS, HS: integer;
  WR, HR: integer;
 
  pixS, pixR: tScanYX;
 
const
  pg_red_mask = $FF0000;
  pg_green_mask = $00FF00;
  pg_blue_mask = $0000FF;
 
  procedure Initialisations; // Initialisation des BitMaps et des paramètres constants
  var x, y: integer;
    Scan0: PIntegerArray; // Valeur du pointeur d'entrée dans le Bitmap.
    dx, dy, Rm, Ri, kechR2, depb: Single;
  begin
    Kech := iKech;
    miKech := Kech / 2;
    kechR2 := Kech * R2;
// BitMap-Source
  //  BmpS.PixelFormat := pf24bit;
    WS := BmpS.Width;
    HS := BmpS.Height;
    SetLength(pixS, HS);
 
    for y := 0 to HS - 1 do
    begin
      pixS[y] := BmpS.ScanLine[y];
    end;
    // BitMap-result
    Result := tBitMap.Create; kech := abs(kech);
    WR := iKech * WS; HR := iKech * HS;
    with Result do begin
       PixelFormat := pf24bit;
       width := WR;
       height := HR
    end;
 
    SetLength(pixR, HR);
    for y := 0 to HR - 1 do
    begin
      pixR[y] :=  Result.ScanLine[y];
    end;
 
    // Précalculs des coefficients de pondération pour dégradés :
    // Initialisations pour les Coins Sud-Est :
 
    //¨ Left_UP_2 Version Quart d'Astroïde ("triangle" avec hypothénuse en arc de cercle)
    SetLength(kLeft_UP_2, iKech, iKech);
    dy := 0.0; Rm := kech - 1.0;
    while dy < Kech do begin
      dx := 0.0;
      while dx < Kech do begin
        y := trunc(dy); x := trunc(dx);
        Ri := Hypot(dx, dy);
        if Ri >= Rm then begin
          kLeft_UP_2[y, x] := (Ri - Rm) / (kechR2 - Rm); // Coin dégradé en arcs de cercle
          if kLeft_UP_2[y, x] > 1.0 then kLeft_UP_2[y, x] := 1.0;
        end else kLeft_UP_2[y, x] := 0.0;
        dx := dx + 0.25;
      end;
      dy := dy + 0.25;
    end;
    // DIA version Triangulaire :
    SetLength(kDiaTri, iKech, iKech);
    dy := 0.0;
    while dy < Kech do begin
      dx := 0.0;
      while dx < Kech do begin
        y := trunc(dy); x := trunc(dx);
        if (dx + dy >= 1.5 * kech) then begin
          depb := dx + dy - 1.5 * kech;
          // Epaisseur dégradée du bord du coin = 1 pixel ici
          if depb <= 1 then kDiaTri[y, x] := 0.5 else kDiaTri[y, x] := 1.0;
        end else kDiaTri[y, x] := 0.0;
        dx := dx + 0.25;
      end;
      dy := dy + 0.25;
    end;
 
    // DIA Version Quart d'Astroïde décentré d'un pixel :
    SetLength(kDiaAst, iKech, iKech);
    dy := 0.0; Rm := mikech + 1;
    while dy < Kech do begin
      dx := 0.0;
      while dx < Kech do begin
        y := trunc(dy); x := trunc(dx);
        Ri := Hypot(dx - mikech + 1, dy - mikech + 1);
        if (Ri >= Rm) and (dx >= miKech - 1) and (dy >= miKech - 1) then begin
          kDiaAst[y, x] := (Ri - Rm) / (Rm * R2 - Rm);
        end else kDiaAst[y, x] := 0.0;
        dx := dx + 0.25;
      end;
      dy := dy + 0.25;
    end;
    kDiaAst[iKech - 1, iKech - 1] := 1.0;
 
    // Up_2 Version Triangulaire :
    SetLength(kUP_2, iKech, iKech);
    dy := 0.0;
    while dy < Kech do begin
      dx := 0.0;
      while dx < Kech do begin
        y := trunc(dy); x := trunc(dx);
        if (2 * dy + dx >= 2 * kech) then begin
          depb := 2 * dy + dx - 2.0 * kech;
          // Epaisseur dégradée du bord du coin = 1 pixel ici :
          if depb <= 1 then kUP_2[y, x] := 0.5 else kUP_2[y, x] := 1.0;
        end else kUP_2[y, x] := 0.0;
        dx := dx + 0.25;
      end;
      dy := dy + 0.25;
    end;
 
    // Left_2 Version Triangulaire :
    SetLength(kLeft_2, iKech, iKech);
    dy := 0.0;
    while dy < Kech do begin
      dx := 0.0;
      while dx < Kech do begin
        y := trunc(dy); x := trunc(dx);
        if (2 * dx + dy >= 2 * kech) then begin
          depb := 2 * dx + dy - 2.0 * kech;
          // Epaisseur dégradée du bord du coin = 1 pixel ici :
          if depb <= 1 then kLeft_2[y, x] := 0.5 else kLeft_2[y, x] := 1.0;
        end else kLeft_2[y, x] := 0.0;
        dx := dx + 0.25;
      end;
      dy := dy + 0.25;
    end;
 
    SetLength(kTmpRota, iKech, iKech);
 
 
  end; // Initialisations
 
  function RGBtoYUV(c: longint): longint;
  //       Conversion de l'espace colorimétrique RGB vers l'espace YUV
  var r, g, b, y, u, v: cardinal;
  begin
    r := (c and pg_red_mask) shr 16;
    g := (c and pg_green_mask) shr 8;
    b := (c and pg_blue_mask);
    y := ((r shl 4) + (g shl 5) + (b shl 2)); // Y = Luminance
    u := (-r - (g shl 1) + (b shl 2)); // U et V = Chrominance
    v := ((r shl 1) - (g shl 1) - (b shl 1));
    result := y + u + v;
  end;
 
  function ClQuadVerscLongint(c: tRGBQuad): longint;
  // Simple conversion d'une couleur du type RGBQuad vers le type longint utilisé par RGBtoYUV
  begin
    Result := (c.rgbRed shl 16) + (c.rgbGreen shl 8) + c.rgbBlue;
  end;
 
  function df(A, B: tRGBQuad): longint;
  var AL, BL: longint;
  begin
    AL := ClQuadVerscLongint(A); BL := ClQuadVerscLongint(B);
    result := abs(RGBtoYUV(Al) - RGBtoYUV(BL));
    // Result renvoie une valeur qui augmente lorsque la couleur A contraste de plus en plus avec celle de la couleur B
    // Result-maxi = 13005 dans le cas d'un contraste maxi Noir/Blanc.
  end;
 
  function eq(A, B: tRGBQuad): boolean;
  begin
    result := df(A, B) < 155;
  end;
 
  function ifThenClQuad(condition: boolean; OK: tRGBQuad; NOK: tRGBQuad): tRGBQuad;
  begin
    if condition then result := OK else result := NOK;
  end;
 
  procedure RotateVoisins; //paramètre matrice: Tvoisins,  Rotation de la matrice des couleurs voisines dans le sens des aiguilles d'une montre.
  var tmp: Tvoisins; Co, Li: integer;
  begin
    for Li := -2 to 2 do
      for Co := -2 to 2 do
        tmp[-Li, Co] := Voisins[Co, Li];
    Voisins := tmp;
  end;
 
  procedure RotateCoeffs; // Rotation des matrices de coefficients de pondération pour le traitement des angles
  var Co, Li: integer;
  begin
    // kLeft_UP_2 :
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kTmpRota[Co, iKech - Li - 1] := kLeft_UP_2[Li, Co];
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kLeft_UP_2[Li, Co] := kTmpRota[Li, Co];
 
    // kDiaTri :
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kTmpRota[Co, iKech - Li - 1] := kDiaTri[Li, Co];
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kDiaTri[Li, Co] := kTmpRota[Li, Co];
 
    // kDiaAst :
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kTmpRota[Co, iKech - Li - 1] := kDiaAst[Li, Co];
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kDiaAst[Li, Co] := kTmpRota[Li, Co];
 
    // kUP_2 :
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kTmpRota[Co, iKech - Li - 1] := kUP_2[Li, Co];
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kUP_2[Li, Co] := kTmpRota[Li, Co];
 
    // kLeft_2 :
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kTmpRota[Co, iKech - Li - 1] := kLeft_2[Li, Co];
    for Li := 0 to iKech - 1 do
      for Co := 0 to iKech - 1 do kLeft_2[Li, Co] := kTmpRota[Li, Co];
  end; // RotateCoeffs;
 
  procedure SetPixelOut(ixr, iyr :integer; clPixOut:tRGBQuad); //paramètres : ixr,iyr: integer; clPixOut: tRGBQuad
  begin
    if (ixr >= 0) and (iyr >= 0) and (ixr < WR) and (iyr < HR) then
      pixR[iyr, ixr] := clPixOut;
  end;
 
  procedure TracerCoin(xx, yy: integer; Coin: tCoeffs; nc: tRGBQuad);
  //        Dégradé de couleurs dans le coin correspondant s'il a été détecté un bord à 63,43° le nécessitant
  //        nc = Nouvelle couleur
  var x, y: integer;
   clPixOut: tRGBQuad;
  begin
    for y := 0 to iKech - 1 do begin
      for x := 0 to iKech - 1 do begin
        if Coin[x, y] <> 0.0 then begin
          clPixOut := clQuadMix2K(nc, voisins[0, 0], Coin[x, y]);
           SetPixelOut(xx + x, yy + y, clPixOut);
 
          // Pour repérage éventuel des zones touchées :
          { if Coin = kLeft_UP_2 then clPixOut := Vert else
            if Coin = kDiaTri then clPixOut := Rouge else
              if Coin = kDiaAst then clPixOut := Aqua else
                if Coin = kUp_2 then clPixOut := Bleu else
                  if Coin = kLeft_2 then clPixOut := Fuchsia;
          SetPixelOut; }
        end;
      end;
    end;
    //ixr := xx + (iKech shr 1); iyr := yy + (iKech shr 1); clPixOut:=nc; SetPixelOut; //< pour repérage éventuel de la couleur nc
  end; // TracerCoin
 
  procedure FILTRE_KXBR(v: Tvoisins);
  var
    ex2, ex3: boolean;
    le, li: integer;
    ke, ki: integer; px: tRGBQuad;
  begin
    // les voisins sont-ils de la même couleur ?
    // si oui, on ne fait rien : le carré reste entièrement de la même couleur que le voisins[0, 0]
    if (clQuadEgales(v[0, 0], v[0, 1])) or (clQuadEgales(v[0, 0], v[1, 0])) then EXIT;
    // si non, recherche des bords :
 
    le := (df(v[1, -1], v[0, 0]) + df(v[0, 0], v[-1, 1]) + df(v[0, 2], v[1, 1]) + df(v[1, 1], v[2, 0])) + (df(v[0, 1], v[1, 0]) shl 2);
    li := (df(v[-1, 0], v[0, 1]) + df(v[0, 1], v[1, 2]) + df(v[0, -1], v[1, 0]) + df(v[1, 0], v[2, 1])) + (df(v[0, 0], v[1, 1]) shl 2);
    // si le < li : bord globalement du bas gauche vers haut droit : Sud-Est
    // les autres sens seront traité lors des rotations
 
    if (le < li) and ((not eq(v[1, 0], v[0, -1]) and not eq(v[1, 0], v[1, -1]))
      or (not eq(v[0, 1], v[-1, 0]) and not eq(v[0, 1], v[-1, 1]))
      or (eq(v[0, 0], v[1, 1])
      and ((not eq(v[1, 0], v[2, 0]) and not eq(v[1, 0], v[2, 1]))
      or (not eq(v[0, 1], v[0, 2]) and not eq(v[0, 1], v[1, 2]))))
      or eq(v[0, 0], v[-1, 1])
      or eq(v[0, 0], v[1, -1])) then
    begin
      ke := df(v[1, 0], v[-1, 1]);
      ki := df(v[0, 1], v[1, -1]);
      ex2 := (not clQuadEgales(v[0, 0], v[1, -1])) and (not clQuadEgales(v[0, -1], v[1, -1]));
      ex3 := (not clQuadEgales(v[0, 0], v[-1, 1])) and (not clQuadEgales(v[-1, 0], v[-1, 1]));
 
      // On choisit la nouvelle couleur à appliquer
      px := ifThenClQuad((df(v[0, 0], v[1, 0]) <= df(v[0, 0], v[0, 1])), v[1, 0], v[0, 1]);
 
      if ((ke shl 1) <= ki) and ex3 and (ke >= (ki shl 1)) and ex2 then
      begin // LEFT_UP_2
        TracerCoin(xoutMin, youtMin, kLeft_UP_2, px);
      end else
        if ((ke shl 1) <= ki) and ex3 then
        begin // LEFT_2
          TracerCoin(xoutMin, youtMin, kLEFT_2, px);
        end else
          if (ke >= (ki shl 1)) and ex2 then
          begin // UP_2
            TracerCoin(xoutMin, youtMin, kUP_2, px);
          end else
          begin // DIA Triangulaire
            TracerCoin(xoutMin, youtMin, kDiaTri, px);
          end
    end else
      if le <= li then begin // Pointes d'angles : DIA Quart d'Astéroïde
        px := ifThenClQuad(df(v[0, 0], v[1, 0]) <= df(v[0, 0], v[0, 1]), v[1, 0], v[0, 1]);
        TracerCoin(xoutMin, youtMin, kDiaAst, px);
      end;
  end; // FILTRE_KX
 
  function getPixelIn(xx, yy: integer): tRGBQuad;
  begin
    if xx < 0 then xx := 0;
    if yy < 0 then yy := 0;
    if xx >= WS then xx := WS - 1;
    if yy >= HS then yy := HS - 1;
    result := pixS[yy, xx];
  end;
 
begin
  if BmpS.PixelFormat <> pf24bit then
    raise Exception.Create('Uniquement le format pf24bit est supporté');
  ScaleFactor := abs(ScaleFactor);
  if ScaleFactor <= 1.0 then begin // Si ScaleFactor <= 1.0 XBR n'apporte rien donc simple réduction de taille rapide avec StretchBlt
    Result := tBitMap.Create;
  //  BmpS.PixelFormat := pf32bit;
    Result.Assign(BmpS);
    iKech := round(ScaleFactor);
    Exit;
  end else // sinon utilisation du XBR :
    if ScaleFactor >= 8.0 then Kech := Scalefactor
    else Kech := 8.0; // Si ScaleFactor < 8.0 on procède à un XBR avec 8 et qui sera suivi d'un ajustement de taille rapide avec StretchBlt
  iKech := round(Kech);
 
  Initialisations;
 
  for ys := 0 to HS - 1 do begin
    for xs := 0 to WS - 1 do begin
 
      for Col := -2 to 2 do
        for Lig := -2 to 2 do begin
          voisins[Col, Lig] := getPixelIn(xs + Col, Lig + ys);
        end;
 
      xoutMin := xs * ikech;
      youtMin := ys * ikech; // Angle Supérieur Gauche du carré à traiter
 
      for Col := 0 to iKech - 1 do // Tracé préalable du carré plein monochrome Avant recherche de bords éventuels
        for Lig := 0 to iKech - 1 do begin
           SetPixelOut(xoutMin + Col, youtMin + Lig, voisins[0, 0]);
          ; //SetPixelOut utilise ixr, iyr, clPixOut
        end;
 
      FILTRE_KXBR(voisins);
      RotateVoisins;
      RotateCoeffs;
      FILTRE_KXBR(voisins);
      RotateVoisins;
      RotateCoeffs;
      FILTRE_KXBR(voisins);
      RotateVoisins;
      RotateCoeffs;
      FILTRE_KXBR(voisins);
      RotateCoeffs;
      //ixr:=xoutMin; iyr:=youtMin; clPixOut:=Rouge; SetPixelOut; //<- Pour Visu éventuelle de la Trame
    end;
  //  if ToucheCla(VK_ESCAPE) then EXIT;
    if Assigned(ProgressCallBack) then ProgressCallBack;
  end;
 
end; // StretchXBR
 
end. ///////////////////////////////////////////////////////////////////////////

[Jipété]

... et sans transparence, cette dernière pose problème sous Lazarus...

Ah bon ?

Tiens, regarde, un TImage rempli d'un dégradé configurable par le curseur et dont le coin supérieur gauche est posé sur un TShape blanc, tout ça avec d'autres contrôles sur une bête fiche et zou !
(copie d'écran réduite aux 2/3)


Mais il faut un bitmap avec pf32bit !
(et je ne me souviens pas si ça fonctionne avec Windows).

Et il va falloir remettre les mains dans le cambouis, en passant d'un OS 32 bits à un 64 bits : l'option "Utiliser un fichier .bmp" ne fonctionne plus...
Enfin, l'ouverture oui mais le rendu non, on dirait mes premiers rendus quand je démarrais cette étude :
à gauche le fichier choisi vu dans l'afficheur Linux, à droite le rendu généré par le prog et, , on perd les lignes colorées du haut et du bas, la partie centrale est dans les choux et la transparence a disparu...


Je verrai ça plus tard...
(je sens venir de belles crises de désespoir si un jour on nous invente des OS 128 bits...)

====
Allez, je regarde ton code...

[Volid]

Tiens, regarde, un TImage rempli d'un dégradé configurable par le curseur et dont le coin supérieur gauche est posé sur un TShape blanc, tout ça avec d'autres contrôles sur une bête fiche et zou !

Désolé je ne voulais pas vous induire en erreur mais il n'a pas fallu sortir du cadre de l'actuel projet, j'ai fait des tests sur plusieurs bitmaps certains tournent en noir après l'appel de la fonction StretchXBR et la tentative de transformation de la bitmap de l'entrée BmpS.PixelFormat := pf32bit; au sein du même fonction .. après vérification le problème est du au Pixelformat qui était de 8bit ce même code fonctionne correctement sous Delphi, malgré ca j'étais déterminé pour basculer vers le format RGB car je vois mal qu'on change de l'image de l'entrée donc on opte pour le format standard pf24Bit le plus utilisé.