lazbarcode: Add sample project QRCodeGenerator.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8688 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/lazbarcodes/examples/qrcodegenerator/fpwritegif.pas

@@ -0,0 +1,846 @@
+{
+Copyright (c) 2007-2023, Udo Schmal <udo.schmal@t-online.de>
+
+Permission to use, copy, modify, and/or distribute the software for any purpose
+with or without fee is hereby granted, provided that the above copyright notice
+and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+PERFORMANCE OF THIS SOFTWARE.
+
+https://www.gocher.me/FPWriteGIF
+}
+
+unit FPWriteGIF;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FPImage, FPReadGif;
+
+type TColor = -$7FFFFFFF - 1..$7FFFFFFF;
+
+const
+// GIF record separators
+  kGifImageSeparator: byte = $2c;
+  kGifExtensionSeparator: byte = $21;
+  kGifTerminator: byte = $3b;
+  kGifLabelGraphic: byte = $f9;
+  kGifBlockTerminator: byte = $00;
+// LZW encode table sizes
+  kGifCodeTableSize = 4096;
+// Raw rgb value
+  clNone = TColor($1FFFFFFF);
+  AlphaOpaque = $FF;
+  AlphaTransparent = 0;
+  MaxArr = (MaxLongint div Sizeof(integer)) - 1;
+
+type
+  APixel8 = array[0..MaxArr] of Byte;
+  PAPixel8 = ^APixel8;
+
+  TRGBQuadArray256 = array[0..256] of TFPCompactImgRGBA8BitValue;
+  TOpenColorTableArray = array of TColor;
+  TColorTableArray = array[0..$FF] of TColor;
+
+  TOctreeNode = class; // Forward definition so TReducibleNodes can be declared
+  TReducibleNodes = array[0..7] of TOctreeNode;
+  TOctreeNode = class(TObject)
+    IsLeaf: Boolean;
+    PixelCount: Integer;
+    RedSum, GreenSum, BlueSum: Integer;
+    Next: TOctreeNode;
+    Child: TReducibleNodes;
+    constructor Create(const Level: Integer; var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
+    destructor Destroy; override;
+  end;
+
+  TFPWriterGIF = class(TFPCustomImageWriter)
+  private
+    fHeader: TGifHeader;
+    fDescriptor: TGifImageDescriptor; // only one image supported
+    fGraphicsCtrlExt: TGifGraphicsControlExtension;
+    fTransparent: Boolean;
+    fBackground: TColor;
+    fPixels: PAPixel8;
+    fPixelList: PChar; // decoded pixel indices
+    fPixelCount: longint; // number of pixels
+    fColorTable: TColorTableArray;
+    fColorTableSize: integer;
+
+    procedure SaveToStream(Destination: TStream);
+  protected
+    procedure InternalWrite(Stream: TStream; Img: TFPCustomImage); override;
+  public
+    constructor Create; override;
+    destructor Destroy; override;
+  end;
+
+implementation
+{$REGION ' - TOctreeNode - '}
+constructor TOctreeNode.Create(const Level: Integer; var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
+var i: Integer;
+begin
+  PixelCount := 0;
+  RedSum := 0;
+  GreenSum := 0;
+  BlueSum := 0;
+  for i := Low(Child) to High(Child) do
+    Child[i] := nil;
+  IsLeaf := (Level = 8);
+  if IsLeaf then
+  begin
+    Next := nil;
+    Inc(LeafCount);
+  end
+  else
+  begin
+    Next := ReducibleNodes[Level];
+    ReducibleNodes[Level] := Self;
+  end
+end;
+
+destructor TOctreeNode.Destroy;
+var i: Integer;
+begin
+  for i := Low(Child) to High(Child) do
+    Child[i].Free
+end;
+{$ENDREGION}
+
+{$REGION ' - TFPWriterGIF. - '}
+constructor TFPWriterGIF.Create;
+begin
+  inherited Create;
+end;
+
+destructor TFPWriterGIF.Destroy;
+begin
+  inherited Destroy;
+end;
+
+// save the current GIF definition to a stream object
+// at first, just write it to our memory stream fSOURCE
+procedure TFPWriterGIF.SaveToStream(Destination: TStream);
+var
+  LZWStream: TMemoryStream; // temp storage for LZW
+  LZWSize: integer; // LZW minimum code size
+
+  // these LZW encode routines sqrunch a bitmap into a memory stream
+  procedure LZWEncode();
+  var
+    rPrefix: array[0..kGifCodeTableSize-1] of integer; // string prefixes
+    rSuffix: array[0..kGifCodeTableSize-1] of integer; // string suffixes
+    rCodeStack: array[0..kGifCodeTableSize-1] of byte; // encoded pixels
+    rSP: integer; // pointer into CodeStack
+    rClearCode: integer; // reset decode params
+    rEndCode: integer; // last code in input stream
+    rCurSize: integer; // current code size
+    rBitString: integer; // steady stream of bits to be decoded
+    rBits: integer; // number of valid bits in BitString
+    rMaxVal: boolean; // max code value found?
+    rCurX: integer; // position of next pixel
+    rCurY: integer; // position of next pixel
+    rCurPass: integer; // pixel line pass 1..4
+    rFirstSlot: integer; // for encoding an image
+    rNextSlot: integer; // for encoding
+    rCount: integer; // number of bytes read/written
+    rLast: integer; // last byte read in
+    rUnget: boolean; // read a new byte, or use zLast?
+
+    procedure LZWReset;
+    var i: integer;
+    begin
+      for i := 0 to (kGifCodeTableSize - 1) do
+      begin
+        rPrefix[i] := 0;
+        rSuffix[i] := 0;
+      end;
+      rCurSize := LZWSize + 1;
+      rClearCode := (1 shl LZWSize);
+      rEndCode := rClearCode + 1;
+      rFirstSlot := (1 shl (rCurSize - 1)) + 2;
+      rNextSlot := rFirstSlot;
+      rMaxVal := false;
+    end;
+
+    // save a code value on the code stack
+    procedure LZWSaveCode(Code: integer);
+    begin
+      rCodeStack[rSP] := Code;
+      inc(rSP);
+    end;
+
+    // save the code in the output data stream
+    procedure LZWPutCode(code: integer);
+    var
+      n: integer;
+      b: byte;
+    begin
+      // write out finished bytes
+      // a literal "8" for 8 bits per byte
+      while (rBits >= 8) do
+      begin
+        b := (rBitString and $ff);
+        rBitString := (rBitString shr 8);
+        rBits := rBits - 8;
+        LZWStream.Write(b, 1);
+      end;
+      // make sure no junk bits left above the first byte
+      rBitString := (rBitString and $ff);
+      // and save out-going code
+      n := (code shl rBits);
+      rBitString := (rBitString or n);
+      rBits := rBits + rCurSize;
+    end;
+
+    // get the next pixel from the bitmap, and return it as an index into the colormap
+    function LZWReadBitmap: integer;
+    var
+      n: integer;
+      j: longint;
+      p: PChar;
+    begin
+      if (rUnget) then
+      begin
+        n := rLast;
+        rUnget := false;
+      end
+      else
+      begin
+        inc(rCount);
+        j := (rCurY * fDescriptor.Width) + rCurX;
+        if ((0 <= j) and (j < fPixelCount)) then
+        begin
+          p := fPixelList + j;
+          n := ord(p^);
+        end
+        else
+          n := 0;
+        // if first pass, make sure CurPass was initialized
+        if (rCurPass = 0) then rCurPass := 1;
+        inc(rCurX); // inc X position
+        if (rCurX >= fDescriptor.Width) then // bumping Y ?
+        begin
+          rCurX := 0;
+          inc(rCurY);
+        end;
+      end;
+      rLast := n;
+      result := n;
+    end;
+
+  var
+    i,n,
+    cc: integer; // current code to translate
+    oc: integer; // last code encoded
+    found: boolean; // decoded string in prefix table?
+    pixel: byte; // lowest code to search for
+    ldx: integer; // last index found
+    fdx: integer; // current index found
+    b: byte;
+  begin
+    // init data block
+    fillchar(rCodeStack, sizeof(rCodeStack), 0);
+    rBitString := 0;
+    rBits := 0;
+    rCurX := 0;
+    rCurY := 0;
+    rCurPass := 0;
+    rLast := 0;
+    rUnget:= false;
+
+    LZWReset;
+    // all within the data record
+    // always save the clear code first ...
+    LZWPutCode(rClearCode);
+    // and first pixel
+    oc := LZWReadBitmap;
+    LZWPutCode(oc);
+    // nothing found yet (but then, we haven't searched)
+    ldx := 0;
+    fdx := 0;
+    // and the rest of the pixels
+    rCount := 1;
+    while (rCount <= fPixelCount) do
+    begin
+      rSP := 0; // empty the stack of old data
+      n := LZWReadBitmap; // next pixel from the bitmap
+      LZWSaveCode(n);
+      cc := rCodeStack[0]; // beginning of the string
+      // add new encode table entry
+      rPrefix[rNextSlot] := oc;
+      rSuffix[rNextSlot] := cc;
+      inc(rNextSlot);
+      if (rNextSlot >= kGifCodeTableSize) then
+        rMaxVal := true
+      else if (rNextSlot > (1 shl rCurSize)) then
+        inc(rCurSize);
+      // find the running string of matching codes
+      ldx := cc;
+      found := true;
+      while (found and (rCount <= fPixelCount)) do
+      begin
+        n := LZWReadBitmap;
+        LZWSaveCode(n);
+        cc := rCodeStack[0];
+        if (ldx < rFirstSlot) then
+          i := rFirstSlot
+        else
+          i := ldx + 1;
+        pixel := rCodeStack[rSP - 1];
+        found := false;
+        while ((not found) and (i < rNextSlot)) do
+        begin
+          found := ((rPrefix[i] = ldx) and (rSuffix[i] = pixel));
+          inc(i);
+        end;
+        if (found) then
+        begin
+          ldx := i - 1;
+          fdx := i - 1;
+        end;
+      end;
+      // if not found, save this index, and get the same code again
+      if (not found) then
+      begin
+        rUnget := true;
+        rLast := rCodeStack[rSP-1];
+        dec(rSP);
+        cc := ldx;
+      end
+      else
+        cc := fdx;
+      // whatever we got, write it out as current table entry
+      LZWPutCode(cc);
+      if ((rMaxVal) and (rCount <= fPixelCount)) then
+      begin
+        LZWPutCode(rClearCode);
+        LZWReset;
+        cc := LZWReadBitmap;
+        LZWPutCode(cc);
+      end;
+      oc := cc;
+    end;
+    LZWPutCode(rEndCode);
+    // write out the rest of the bit string
+    while (rBits > 0) do
+    begin
+      b := (rBitString and $ff);
+      rBitString := (rBitString shr 8);
+      rBits := rBits - 8;
+      LZWStream.Write(b, 1);
+    end;
+  end;
+
+var i: integer;
+begin
+  Destination.Position := 0;
+  with fHeader do
+  begin
+    // write the GIF signature
+    // if only one image, and no image extensions, then GIF is GIF87a,
+    // else use the updated version GIF98a
+    // we just added an extension block; the signature must be version 89a
+    Destination.Write(Signature, 3);
+    Destination.Write(Version, 3);
+    // write the overall GIF screen description to the source stream
+    Destination.Write(ScreenWidth, 2); // logical screen width
+    Destination.Write(ScreenHeight, 2); // logical screen height
+    Destination.Write(Packedbit, 1); // packed bit fields (Global Color valid, Global Color size, Sorted, Color Resolution)
+    Destination.Write(BackgroundColor, 1); // background color
+    Destination.Write(AspectRatio, 1); // pixel aspect ratio
+    if (Packedbit and $80)>0 then //Global Color valid
+      // write out color gobal table with RGB values
+      for i := 0 to fColorTableSize-1 do
+        Destination.Write(fColorTable[i], 3);
+  end;
+  // write out graphic extension for this image
+  Destination.Write(kGifExtensionSeparator, 1); // write the extension separator
+  Destination.Write(kGifLabelGraphic, 1); // write the extension label
+  Destination.Write(fGraphicsCtrlExt.BlockSize, 1); // block size (always 4)
+  Destination.Write(fGraphicsCtrlExt.Packedbit, 1); // packed bit field
+  Destination.Write(fGraphicsCtrlExt.DelayTime, 2); // delay time
+  Destination.Write(fGraphicsCtrlExt.ColorIndex, 1); // transparent color
+  Destination.Write(fGraphicsCtrlExt.Terminator, 1); // block terminator
+  // write actual image data
+  Destination.Write(kGifImageSeparator, 1);
+  // write the next image descriptor shortcut to the record fields
+  with fDescriptor do
+  begin
+    // write the basic descriptor record
+    Destination.Write(Left, 2); // left position
+    Destination.Write(Top, 2); // top position
+    Destination.Write(Width, 2); // size of image
+    Destination.Write(Height, 2); // size of image
+    Destination.Write(Packedbit, 1); // packed bit field
+    // there is no local color table defined we use global
+    LZWSize := 8; // the LZW minimum code size
+    Destination.Write(LZWSize, 1);
+    LZWStream := TMemoryStream.Create; // init the storage for compressed data
+    try
+      LZWEncode(); // encode the image and save it in LZWStream
+      // write out the data stream as a series of data blocks
+      LZWStream.Position := 0;
+      while (LZWStream.Position < LZWStream.Size) do
+      begin
+        i := LZWStream.Size - LZWStream.Position;
+        if (i > 255) then i := 255;
+        Destination.Write(i, 1);
+        Destination.CopyFrom(LZWStream, i);
+      end;
+    finally
+      FreeAndNil(LZWStream);
+    end;
+    Destination.Write(kGifBlockTerminator, 1); // block terminator
+  end;
+  Destination.Write(kGifTerminator, 1); // done with writing
+end;
+
+procedure TFPWriterGIF.InternalWrite(Stream: TStream; Img: TFPCustomImage);
+var
+  CT: TOpenColorTableArray;
+  Palette: TList;
+  PaletteHasAllColours: Boolean;
+  Mappings: array[BYTE, BYTE] of TList;
+  Tree: TOctreeNode;
+  LeafCount: Integer;
+  ReducibleNodes: TReducibleNodes;
+  LastColor: TColor;
+  LastColorIndex: Byte;
+
+  // convert TFPCustomImage TFPColor to TColor
+  function FPColorToTColor(const FPColor: TFPColor): TColor;
+  begin
+    result := TColor(((FPColor.Red shr 8) and $ff) or (FPColor.Green and $ff00) or ((FPColor.Blue shl 8) and $ff0000));
+  end;
+
+  // try to make color table of all colors
+  function MakeColorTableOfAllColors(): Boolean;
+  var
+    Flags: array[Byte, Byte] of TBits;
+    x, y, ci: Cardinal;
+    Red, Green, Blue: Byte;
+    Cnt: word;
+  begin
+    result := false;
+    // init Flags
+    for y := 0 to $FF do
+      for x := 0 to $FF do
+        Flags[x, y] := nil;
+    try
+      for ci := 0 to $ff do
+        CT[ci] := 0;
+      Cnt := 0;
+      for y := 0 to Img.Height - 1 do
+        for x := 0 to Img.Width - 1 do
+        begin
+          Red := Byte(Img.Colors[x, y].red shr 8);
+          Green := Byte(Img.Colors[x, y].green shr 8);
+          Blue := Byte(Img.Colors[x, y].blue shr 8);
+          if (Flags[Red, Green]) = nil then
+          begin
+            Flags[Red, Green] := Classes.TBits.Create;
+            Flags[Red, Green].Size := 256;
+          end;
+          if not Flags[Red, Green].Bits[Blue] then
+          begin
+            CT[Cnt] := FPColorToTColor(Img.Colors[x, y]);
+            if Cnt = $ff then exit;
+            inc(Cnt);
+            Flags[Red, Green].Bits[Blue] := true;
+          end;
+        end;
+      result := true;
+      PaletteHasAllColours := true;
+    finally // free Flags
+      for y := 0 to $FF do
+        for x := 0 to $FF do
+          if Flags[x, y] <> nil then
+            FreeAndNil(Flags[x, y]);
+    end;
+    fColorTableSize := High(CT) + 1;
+    for x := 0 to fColorTableSize - 1 do
+      fColorTable[x] := CT[x];
+    LastColor := clNone;
+  end;
+
+  procedure MakeColorTableofReducedColors();
+    procedure AddColor(var Node: TOctreeNode; const r, g, b: Byte; const Level: Integer; var ReducibleNodes: TReducibleNodes);
+    const mask: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
+    var Index, Shift: Integer;
+    begin
+      if Node = nil then
+        Node := TOctreeNode.Create(Level, LeafCount, ReducibleNodes);
+      if Node.IsLeaf then
+      begin
+        Inc(Node.PixelCount);
+        Inc(Node.RedSum, r);
+        Inc(Node.GreenSum, g);
+        Inc(Node.BlueSum, b)
+      end
+      else
+      begin
+        Shift := 7 - Level;
+        Index := (((r and mask[Level]) shr Shift) shl 2) or (((g and mask[Level]) shr Shift) shl 1) or
+          ((b and mask[Level]) shr Shift);
+        AddColor(Node.Child[Index], r, g, b, Level + 1, ReducibleNodes)
+      end
+    end;
+
+    procedure ReduceTree(var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
+    var
+      RedSum, BlueSum, GreenSum, Children, i: Integer;
+      Node: TOctreeNode;
+    begin
+      i := 7;
+      while (i > 0) and (ReducibleNodes[i] = nil) do
+        dec(i);
+      Node := ReducibleNodes[i];
+      ReducibleNodes[i] := Node.Next;
+      RedSum := 0;
+      GreenSum := 0;
+      BlueSum := 0;
+      Children := 0;
+      for i := Low(ReducibleNodes) to High(ReducibleNodes) do
+        if Node.Child[i] <> nil then
+        begin
+          Inc(RedSum, Node.Child[i].RedSum);
+          Inc(GreenSum, Node.Child[i].GreenSum);
+          Inc(BlueSum, Node.Child[i].BlueSum);
+          Inc(Node.PixelCount, Node.Child[i].PixelCount);
+          Node.Child[i].Free;
+          Node.Child[i] := nil;
+          inc(Children)
+        end;
+      Node.IsLeaf := true;
+      Node.RedSum := RedSum;
+      Node.GreenSum := GreenSum;
+      Node.BlueSum := BlueSum;
+      Dec(LeafCount, Children - 1)
+    end;
+
+    procedure GetPaletteColors(const Node: TOctreeNode; var RGBQuadArray: TRGBQuadArray256; var Index: integer);
+    var i: integer;
+    begin
+      if Node.IsLeaf then
+      begin
+        with RGBQuadArray[Index] do
+        begin
+          try
+            r := Byte(Node.RedSum div Node.PixelCount);
+            g := Byte(Node.GreenSum div Node.PixelCount);
+            b := Byte(Node.BlueSum div Node.PixelCount);
+            a := 0;
+          except
+            r := 0;
+            g := 0;
+            b := 0;
+            a := 0;
+          end;
+          a := 0
+        end;
+        inc(Index);
+      end
+      else
+        for i := Low(Node.Child) to High(Node.Child) do
+          if Node.Child[i] <> nil then
+            GetPaletteColors(Node.Child[i], RGBQuadArray, Index)
+    end;
+
+    procedure SetPalette(Pal: array of TColor; Size: integer);
+    var
+      PalSize, i: integer;
+      Col: PFPCompactImgRGB8BitValue;
+      x, y: Cardinal;
+      Red, Green, Blue: Byte;
+      Pcol: PInteger;
+      DistanceSquared, SmallestDistanceSquared: integer;
+      R1, G1, B1: Byte;
+    begin
+      if Size <> -1 then PalSize := Size else PalSize := High(Pal) + 1;
+      for i := 0 to PalSize - 1 do
+      begin
+        GetMem(Col, SizeOf(TFPCompactImgRGB8BitValue));
+        Col^.r := Byte(Pal[i]);
+        Col^.g := Byte(Pal[i] shr 8);
+        Col^.b := Byte(Pal[i] shr 16);
+        Palette.Add(Col);
+      end;
+      for y := 0 to $ff do
+        for x := 0 to $ff do
+          Mappings[y,x] := nil;
+      for y := 0 to Img.Height - 1 do
+        for x := 0 to Img.Width - 1 do
+        begin
+          Red := Byte(Img.Colors[x, y].red shr 8);
+          Green := Byte(Img.Colors[x, y].green shr 8);
+          Blue := Byte(Img.Colors[x, y].blue shr 8);
+          //Small reduction of color space
+          dec(Red, Red mod 3);
+          dec(Green, Green mod 3);
+          dec(Blue, Blue mod 3);
+          if (Mappings[Red, Green]) = nil then
+          begin
+            Mappings[Red, Green] := TList.Create;
+            Mappings[Red, Green].Count := 256;
+          end;
+          if (Mappings[Red, Green].Items[Blue] = nil) then
+          begin
+            GetMem(Pcol, SizeOf(integer));
+            PCol^ := 0;
+            SmallestDistanceSquared := $1000000;
+            for i := 0 to Palette.Count - 1 do
+            begin
+              R1 := PFPCompactImgRGB8BitValue(Palette[i])^.r;
+              G1 := PFPCompactImgRGB8BitValue(Palette[i])^.g;
+              B1 := PFPCompactImgRGB8BitValue(Palette[i])^.b;
+              DistanceSquared := (Red - R1) * (Red - R1) + (Green - G1) * (Green - G1) + (Blue - B1) * (Blue - B1);
+              if DistanceSquared < SmallestDistanceSquared then
+              begin
+                PCol^ := i;
+                if (Red = R1) and (Green = G1) and (Blue = B1) then break;
+                SmallestDistanceSquared := DistanceSquared;
+              end
+            end;
+            Mappings[Red, Green].Items[Blue] := PCol;
+          end;
+        end;
+    end;
+
+    procedure DeleteTree(var Node: TOctreeNode);
+    var i: integer;
+    begin
+      for i := Low(TReducibleNodes) to High(TReducibleNodes) do
+        if Node.Child[i] <> nil then
+          DeleteTree(Node.Child[i]);
+      FreeAndNil(Node);
+    end;
+
+  var
+    i, j, Index: integer;
+    QArr: TRGBQuadArray256;
+  begin
+    PaletteHasAllColours := false;
+    Tree := nil;
+    LeafCount := 0;
+    for i := Low(ReducibleNodes) to High(ReducibleNodes) do
+      ReducibleNodes[i] := nil;
+    if (Img.Height > 0) and (Img.Width > 0) then
+      for j := 0 to Img.Height - 1 do
+        for i := 0 to Img.Width - 1 do
+        begin
+          AddColor(Tree, Byte(Img.Colors[i,j].red shr 8), Byte(Img.Colors[i,j].green shr 8), Byte(Img.Colors[i,j].blue shr 8), 0, ReducibleNodes);
+          while LeafCount > 256 do
+            ReduceTree(LeafCount, ReducibleNodes)
+        end;
+    Index := 0;
+    GetPaletteColors(Tree, QArr, Index);
+    for i := 0 to LeafCount - 1 do
+      CT[i] := (QArr[i].b shl 16) + (QArr[i].g shl 8) + QArr[i].r;
+    fColorTableSize := LeafCount;
+    for i := 0 to fColorTableSize - 1 do
+      fColorTable[i] := CT[i];
+    LastColor := clNone;
+    SetPalette(fColorTable, LeafCount);
+    if Tree <> nil then DeleteTree(Tree);
+  end;
+
+  procedure ClearMappings;
+  var i, j, k: integer;
+  begin
+    { wp: Avoids crash at FreeMem - may result in a memory leak !!!!
+    for j := 0 to $FF do
+      for i := 0 to $FF do
+      begin
+        if Assigned(Mappings[i, j]) then
+        begin
+          for k := 0 to $FF do
+            FreeMem(Mappings[i, j].Items[k], SizeOf(TColor));
+          Mappings[i, j].Free;
+        end;
+        Mappings[i, j] := nil;
+      end;
+      }
+  end;
+
+  procedure SetPixel(X, Y: Integer; Value: TColor);
+  var
+    Val: integer;
+    PCol: PInteger;
+    R, G, B: byte;
+  begin
+    if not ((Img.Width >= X) and (Img.Height >= Y) and (X > -1) and (Y > -1)) then exit;
+    Val := -1;
+    if LastColor = Value then
+      Val := LastColorIndex
+    else
+    begin
+      if PaletteHasAllColours then
+      begin
+        TFPCompactImgRGBA8BitValue(Value).a := 0;
+        for Val := 0 to fColorTableSize - 1 do
+          if fColorTable[Val] = Value then break;
+      end
+      else
+      begin
+        B := Byte(Value shr 16);
+        B := B - (B mod 3);
+        G := Byte(Value shr 8);
+        G := G - (G mod 3);
+        R := Byte(Value);
+        R := R - (R mod 3);
+        Val := -1;
+        if Mappings[R, G] <> nil then
+        begin
+          PCol := Mappings[R, G].Items[B];
+          if PCol <> nil then Val := PCol^;
+        end;
+      end;
+      LastColor := Value;
+      LastColorIndex := Val;
+    end;
+    fPixels^[Y * Img.Width + X] := Val;
+  end;
+
+  // find the color within the color table; returns 0..255, -1 if color not found
+  function FindColorIndex(c: TColor): integer;
+  var i: integer;
+  begin
+    i := 0;
+    result := -1;
+    while (i<fColorTableSize) and (result < 0) do
+    begin
+      if (fColorTable[i] = c) then result := i;
+      inc(i);
+    end;
+  end;
+
+  function lsb(w: word): byte;
+  begin
+    result := 0;
+    while ((w shr result) and 1) = 0 do inc(result);
+  end;
+
+var
+  x, y: cardinal;
+  i, n, ci: integer;
+  b: byte;
+  pptr: PChar;
+begin
+  if not ((Img.Width < 1) or (Img.Height < 1)) then
+  try
+    fTransparent := false;
+    // translate 64bit image to 8bit colortable image
+    Palette := TList.Create;
+    fColorTableSize := 0;
+    SetLength(CT, 256);
+    //try to make optimized palette on original Data.
+    if not MakeColorTableOfAllColors() then
+      MakeColorTableofReducedColors(); // to mutch colors, reduce colors
+    GetMem(fPixels, Img.Height * Img.Width);
+    for y := 0 to Img.Height - 1 do
+      for x := 0 to Img.Width - 1 do
+      begin
+        SetPixel(x, y, FPColorToTColor(Img.Colors[x, y]));
+        if not fTransparent then
+          if Img.Colors[x, y].alpha = AlphaTransparent then
+          begin
+            fBackground := FPColorToTColor(Img.Colors[x, y]);
+            fTransparent := true;
+          end;
+      end;
+    // color count must be a power of 2
+    if (fColorTableSize <= 2) then fColorTableSize := 2
+    else if (fColorTableSize <= 4) then fColorTableSize := 4
+    else if (fColorTableSize <= 8) then fColorTableSize := 8
+    else if (fColorTableSize <= 16) then fColorTableSize := 16
+    else if (fColorTableSize <= 32) then fColorTableSize := 32
+    else if (fColorTableSize <= 64) then fColorTableSize := 64
+    else if (fColorTableSize <= 128) then fColorTableSize := 128
+    else fColorTableSize := 256;
+  finally
+    for i := 0 to Palette.Count - 1 do
+      FreeMem(Palette[i], SizeOf(TFPCompactImgRGB8BitValue));
+    Palette.Clear;
+    ClearMappings;
+    Palette.Free;
+  end;
+
+  // create a new gif image record from the given 8bit colortable image
+  with fHeader do
+  begin
+    Signature := 'GIF';
+    Version := '89a';
+    ScreenWidth := Img.Width;
+    ScreenHeight := Img.Height;
+    b := lsb(fColorTableSize)-1;
+    Packedbit := (Packedbit and $8F) or (b shl 4); // Color Resolution
+    Packedbit := (Packedbit and $F7); // not sorted
+    Packedbit := (Packedbit and $F8) or b;
+    BackgroundColor := 0;
+    Packedbit := Packedbit or $80; // Global Color valid
+  end;
+
+  // make a descriptor record, color map for this image, and space for a pixel list
+  with fDescriptor do
+  begin
+    Left := 0;
+    Top := 0;
+    Width := Img.Width;
+    Height := Img.Height;
+    Packedbit := 0; // or $80 = but non local Color Table; or $40 = but not interlaced; or $20 but not sorted
+  end;
+
+  fPixelList := nil; // make empty pixel list
+  fPixelCount := Img.Width * Img.Height;
+  fPixelList := allocmem(fPixelCount);
+  if (fPixelList = nil) then OutOfMemoryError;
+  // and the color table
+  // the first call attempts to use all colors in the bitmap
+  // if too many colors, the 2nd call uses only most significat 8 bits of color
+  for ci:=0 to fPixelCount-1 do
+  begin
+    pptr := fPixelList + ci;
+    pptr^ := Chr(fPixels^[ci]);
+  end;
+
+  // set transparency for this image
+  with fGraphicsCtrlExt do
+  begin
+    BlockSize := 4;
+    Packedbit := $00;
+    ColorIndex := 0;
+    if (fTransparent) then
+    begin
+      n := FindColorIndex(fBackground);
+      if (n < 0) then n := FindColorIndex(fBackground and $00E0E0E0);
+      if (n < 0) then n := FindColorIndex(fBackground and $00C0E0E0);
+      if (n > -1) then
+      begin
+        Packedbit := Packedbit or $01; // transparent color given (Packedbit or $01)
+        ColorIndex := n; //transparent color index
+      end;
+    end;
+    DelayTime := 0;
+    Terminator := 0; // allways 0
+  end;
+
+  SaveToStream(Stream);
+
+  if (fPixelList <> nil) then FreeMem(fPixelList);
+  FreeMem(fPixels);
+  fPixels := nil;
+end;
+{$ENDREGION}
+
+initialization
+  ImageHandlers.RegisterImageWriter ('GIF Graphics', 'gif', TFPWriterGif);
+end.

components/lazbarcodes/examples/qrcodegenerator/main.lfm

@@ -0,0 +1,166 @@
+object MainForm: TMainForm
+  Left = 403
+  Height = 326
+  Top = 256
+  Width = 380
+  Caption = 'QRCode Generator'
+  ClientHeight = 326
+  ClientWidth = 380
+  Constraints.MinWidth = 300
+  OnActivate = FormActivate
+  OnDestroy = FormDestroy
+  LCLVersion = '2.3.0.0'
+  object btnCreateQR: TButton
+    AnchorSideLeft.Control = Owner
+    AnchorSideTop.Control = edText
+    AnchorSideTop.Side = asrBottom
+    Left = 8
+    Height = 25
+    Top = 64
+    Width = 108
+    AutoSize = True
+    BorderSpacing.Left = 8
+    BorderSpacing.Top = 16
+    Caption = 'Create QR code'
+    OnClick = btnCreateQRClick
+    TabOrder = 0
+  end
+  object edText: TEdit
+    AnchorSideLeft.Control = Owner
+    AnchorSideTop.Control = Label1
+    AnchorSideTop.Side = asrBottom
+    AnchorSideRight.Control = Owner
+    AnchorSideRight.Side = asrBottom
+    Left = 8
+    Height = 23
+    Top = 25
+    Width = 364
+    Anchors = [akTop, akLeft, akRight]
+    BorderSpacing.Left = 8
+    BorderSpacing.Top = 2
+    BorderSpacing.Right = 8
+    OnChange = edTextChange
+    TabOrder = 1
+    Text = 'https://www.lazarus-ide.org/'
+  end
+  object btnSaveAsGIF: TButton
+    AnchorSideLeft.Control = btnCreateQR
+    AnchorSideTop.Control = btnCreateQR
+    AnchorSideTop.Side = asrBottom
+    AnchorSideRight.Control = btnCreateQR
+    AnchorSideRight.Side = asrBottom
+    Left = 8
+    Height = 25
+    Top = 97
+    Width = 108
+    Anchors = [akTop, akLeft, akRight]
+    BorderSpacing.Top = 8
+    Caption = 'Save as GIF'
+    OnClick = btnSaveAsGIFClick
+    TabOrder = 2
+    Visible = False
+  end
+  object btnSaveAsBMP: TButton
+    AnchorSideLeft.Control = btnCreateQR
+    AnchorSideTop.Control = btnSaveAsGIF
+    AnchorSideTop.Side = asrBottom
+    AnchorSideRight.Control = btnCreateQR
+    AnchorSideRight.Side = asrBottom
+    Left = 8
+    Height = 25
+    Top = 130
+    Width = 108
+    Anchors = [akTop, akLeft, akRight]
+    BorderSpacing.Top = 8
+    Caption = 'Save as BMP'
+    OnClick = btnSaveAsBMPClick
+    TabOrder = 3
+    Visible = False
+  end
+  object StatusBar: TStatusBar
+    Left = 0
+    Height = 23
+    Top = 303
+    Width = 380
+    Panels = <>
+  end
+  object btnSaveAsPNG: TButton
+    AnchorSideLeft.Control = btnCreateQR
+    AnchorSideTop.Control = btnSaveAsBMP
+    AnchorSideTop.Side = asrBottom
+    AnchorSideRight.Control = btnCreateQR
+    AnchorSideRight.Side = asrBottom
+    Left = 8
+    Height = 25
+    Top = 163
+    Width = 108
+    Anchors = [akTop, akLeft, akRight]
+    BorderSpacing.Top = 8
+    Caption = 'Save as PNG'
+    OnClick = btnSaveAsPNGClick
+    TabOrder = 5
+    Visible = False
+  end
+  object btnSaveAsJPEG: TButton
+    AnchorSideLeft.Control = btnCreateQR
+    AnchorSideTop.Control = btnSaveAsPNG
+    AnchorSideTop.Side = asrBottom
+    AnchorSideRight.Control = btnCreateQR
+    AnchorSideRight.Side = asrBottom
+    Left = 8
+    Height = 25
+    Top = 196
+    Width = 108
+    Anchors = [akTop, akLeft, akRight]
+    BorderSpacing.Top = 8
+    Caption = 'Save as JPEG'
+    OnClick = btnSaveAsPNGClick
+    TabOrder = 6
+    Visible = False
+  end
+  object Label1: TLabel
+    AnchorSideLeft.Control = Owner
+    AnchorSideTop.Control = Owner
+    Left = 8
+    Height = 15
+    Top = 8
+    Width = 100
+    BorderSpacing.Left = 8
+    BorderSpacing.Top = 8
+    Caption = 'Text to be encoded'
+  end
+  object btnSaveAsSVG: TButton
+    AnchorSideLeft.Control = btnCreateQR
+    AnchorSideTop.Control = btnSaveAsJPEG
+    AnchorSideTop.Side = asrBottom
+    AnchorSideRight.Control = btnCreateQR
+    AnchorSideRight.Side = asrBottom
+    Left = 8
+    Height = 25
+    Top = 229
+    Width = 108
+    Anchors = [akTop, akLeft, akRight]
+    BorderSpacing.Top = 8
+    Caption = 'Save as SVG'
+    OnClick = btnSaveAsSVGClick
+    TabOrder = 7
+    Visible = False
+  end
+  object btnSaveAsEPS: TButton
+    AnchorSideLeft.Control = btnCreateQR
+    AnchorSideTop.Control = btnSaveAsSVG
+    AnchorSideTop.Side = asrBottom
+    AnchorSideRight.Control = btnCreateQR
+    AnchorSideRight.Side = asrBottom
+    Left = 8
+    Height = 25
+    Top = 262
+    Width = 108
+    Anchors = [akTop, akLeft, akRight]
+    BorderSpacing.Top = 8
+    Caption = 'Save as EPS'
+    OnClick = btnSaveAsEPSClick
+    TabOrder = 8
+    Visible = False
+  end
+end

components/lazbarcodes/examples/qrcodegenerator/main.pas

@@ -0,0 +1,170 @@
+unit main;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
+  ComCtrls, LCLIntf,
+  fpimage, fpWriteGIF,
+  ubarcodes;
+
+type
+  TMyGifImage = class(TGifImage)
+  protected
+    class function GetWriterClass: TFPCustomImageWriterClass; override;
+  end;
+
+  { TMainForm }
+
+  TMainForm = class(TForm)
+    btnCreateQR: TButton;
+    btnSaveAsGIF: TButton;
+    btnSaveAsBMP: TButton;
+    btnSaveAsSVG: TButton;
+    btnSaveAsPNG: TButton;
+    btnSaveAsJPEG: TButton;
+    btnSaveAsEPS: TButton;
+    edText: TEdit;
+    Label1: TLabel;
+    StatusBar: TStatusBar;
+    procedure btnCreateQRClick(Sender: TObject);
+    procedure btnSaveAsEPSClick(Sender: TObject);
+    procedure btnSaveAsGIFClick(Sender: TObject);
+    procedure btnSaveAsBMPClick(Sender: TObject);
+    procedure btnSaveAsPNGClick(Sender: TObject);
+    procedure btnSaveAsSVGClick(Sender: TObject);
+    procedure edTextChange(Sender: TObject);
+    procedure FormActivate(Sender: TObject);
+    procedure FormDestroy(Sender: TObject);
+  private
+    QRCode: TBarcodeQR;
+    procedure EnableButtons(Enable: Boolean);
+    procedure SaveQRCodeToImage(AFileName: String; AImageClass: TFPImageBitmapClass);
+
+  public
+
+  end;
+
+var
+  MainForm: TMainForm;
+
+implementation
+
+{$R *.lfm}
+
+class function TMyGifImage.GetWriterClass: TFPCustomImageWriterClass;
+begin
+  Result := TFPWriterGIF;
+end;
+
+{ TMainForm }
+
+procedure TMainForm.btnCreateQRClick(Sender: TObject);
+begin
+  QRCode.Free;
+  QRCode := TBarcodeQR.Create(self);
+  QRCode.Text := edText.Text;
+  QRCode.Top := btnCreateQR.Top;
+  QRCode.Left := btnCreateQR.Left + btnCreateQR.Width + 10;
+  QRCode.Width := 168;
+  QRCode.Height := 168;
+  QRCode.Generate;
+  QRCode.Parent := self;
+
+  EnableButtons(true);
+  StatusBar.simpleText := 'QRCode generated.';
+end;
+
+procedure TMainForm.btnSaveAsEPSClick(Sender: TObject);
+var
+  fn: String;
+begin
+  if QRCode = nil then
+    exit;
+  fn := 'qrcode.eps';
+  QRCode.SaveToEpsFile(fn);
+  StatusBar.SimpleText := 'QRCode saved to "' + fn + '".';
+end;
+
+procedure TMainForm.btnSaveAsGIFClick(Sender: TObject);
+begin
+  SaveQRCodeToImage('qrcode', TMyGifImage);
+end;
+
+procedure TMainForm.btnSaveAsBMPClick(Sender: TObject);
+begin
+  SaveQRCodeToImage('qrcode', TBitmap);
+end;
+
+procedure TMainForm.btnSaveAsPNGClick(Sender: TObject);
+begin
+  SaveQRCodeToImage('qrcode', TPortableNetworkGraphic);
+end;
+
+procedure TMainForm.btnSaveAsSVGClick(Sender: TObject);
+var
+  fn: String;
+begin
+  if QRCode = nil then
+    exit;
+  fn := 'qrcode.svg';
+  QRCode.SaveToSvgFile(fn);
+  StatusBar.SimpleText := 'QRCode saved to "' + fn + '".';
+end;
+
+procedure TMainForm.edTextChange(Sender: TObject);
+begin
+  EnableButtons(false);
+end;
+
+procedure TMainForm.FormActivate(Sender: TObject);
+begin
+  ClientHeight := btnSaveAsEPS.Top + btnSaveAsEPS.Height + StatusBar.Height + 16;
+end;
+
+procedure TMainForm.EnableButtons(Enable: Boolean);
+begin
+  btnSaveAsGIF.Visible := Enable;
+  btnSaveAsBMP.Visible := Enable;
+  btnSaveAsPNG.Visible := Enable;
+  btnSaveAsJPEG.Visible := Enable;
+  btnSaveAsSVG.Visible := Enable;
+  btnSaveAsEPS.Visible := Enable;
+  if not Enable then StatusBar.SimpleText := '';
+end;
+
+procedure TMainForm.FormDestroy(Sender: TObject);
+begin
+  QRCode.Free;
+end;
+
+procedure TMainForm.SaveQRCodeToImage(AFileName: String; AImageClass: TFPImageBitmapClass);
+var
+  ext: String;
+begin
+  if QRCode = nil then
+    exit;
+
+  if AImageClass = TBitmap then
+    ext := '.bmp'
+  else if AImageClass = TMyGifImage then
+    ext := '.gif'
+  else if AImageClass = TPortableNetworkGraphic then
+    ext := '.png'
+  else if AImageClass = TJpegImage then
+    ext := '.jpg'
+  else
+    raise Exception.Create('Image format not supported.');
+
+  AFileName := ChangeFileExt(AFileName, ext);
+  QRCode.SaveToFile(AFileName, AImageClass);
+
+  StatusBar.SimpleText := 'QRCode saved to "' + AFileName + '".';
+end;
+
+initialization
+  TPicture.RegisterFileFormat('.gif', 'gif', TMyGifImage);
+end.
+

components/lazbarcodes/examples/qrcodegenerator/qrcodegen.lpi

@@ -0,0 +1,87 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <PathDelim Value="\"/>
+    <General>
+      <Flags>
+        <CompatibilityMode Value="True"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="qrcodegen"/>
+      <Scaled Value="True"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <XPManifest>
+        <DpiAware Value="True"/>
+      </XPManifest>
+      <Icon Value="0"/>
+    </General>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <RequiredPackages Count="2">
+      <Item1>
+        <PackageName Value="lazbarcodes"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="LCL"/>
+      </Item2>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="qrcodegen.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="QRCodeGen"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="main.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="MainForm"/>
+        <HasResources Value="True"/>
+        <ResourceBaseClass Value="Form"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="qrcodegen"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Debugging>
+        <DebugInfoType Value="dsDwarf3"/>
+      </Debugging>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

components/lazbarcodes/examples/qrcodegenerator/qrcodegen.lpr

@@ -0,0 +1,25 @@
+program QRCodeGen;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  cthreads,
+  {$ENDIF}
+  {$IFDEF HASAMIGA}
+  athreads,
+  {$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, main
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Scaled:=True;
+  Application.Initialize;
+  Application.CreateForm(TMainForm, MainForm);
+  Application.Run;
+end.
+