lasarus_compotents/bgrabitmap/test/bgralape/basic_functions.inc

procedure MyGetScanLine{$i lape.func}
begin
  PBGRAPixel(Result^) := target.ScanLine[PInt32(Params^[0])^];
  WillInvalidateBitmap(targetIndex);
end;

procedure MyGetBitmapWidth{$i lape.func}
begin
  Int32(Result^) := target.Width;
end;

procedure MyGetBitmapHeight{$i lape.func}
begin
  Int32(Result^) := target.Height;
end;

procedure MyPtInClipRect{$i lape.func}
begin
  LongBool(Result^) := target.PtInClipRect(PInt32(Params^[0])^,PInt32(Params^[1])^);
end;

procedure MyPtInRectPointFirst{$i lape.func}
type PPoint = ^TPoint;
  PRect = ^TRect;
begin
  LongBool(Result^) := PtInRect(PPoint(Params^[0])^,PRect(Params^[1])^);
end;

procedure MyPtInRectPointLast{$i lape.func}
type PPoint = ^TPoint;
  PRect = ^TRect;
begin
  LongBool(Result^) := PtInRect(PPoint(Params^[1])^,PRect(Params^[0])^);
end;

procedure MyGetClipRect{$i lape.func}
begin
  TRect(Result^) := target.ClipRect;
end;

procedure MySetClipRect{$i lape.proc}
type PRect = ^TRect;
begin
  target.ClipRect := PRect(Params^[0])^;
end;

procedure MySetNoClip{$i lape.proc}
begin
  target.NoClip;
end;

procedure MyBGRA3{$i lape.func}
begin
  TBGRAPixel(Result^) := BGRA(PByte(Params^[0])^,PByte(Params^[1])^,PByte(Params^[2])^);
end;

procedure MyBGRA4{$i lape.func}
begin
  TBGRAPixel(Result^) := BGRA(PByte(Params^[0])^,PByte(Params^[1])^,PByte(Params^[2])^,PByte(Params^[3])^);
end;

procedure MySetPixel{$i lape.proc}
begin
  target.SetPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
end;

procedure MyNormalPixel{$i lape.proc}
begin
  target.DrawPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
end;

procedure MyLinearPixel{$i lape.proc}
begin
  target.FastBlendPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
end;

procedure MyXorPixel{$i lape.proc}
begin
  target.XorPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
end;

procedure MyErasePixel{$i lape.proc}
begin
  target.ErasePixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PByte(Params^[2])^);
end;

procedure MyDrawPixel{$i lape.proc}
begin
  case TDrawMode(PInt32(Params^[3])^) of
  dmSet: target.SetPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
  dmSetExceptTransparent: if PBGRAPixel(Params^[2])^.alpha = 255 then target.SetPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
  dmLinearBlend: target.FastBlendPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
  dmDrawWithTransparency: target.DrawPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
  dmXor: target.XorPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
  end;
end;

procedure MyAlphaPixel{$i lape.proc}
begin
  target.AlphaPixel(PInt32(Params^[0])^,PInt32(Params^[1])^,PByte(Params^[2])^);
end;

procedure MyGetPixel{$i lape.func}
begin
  TBGRAPixel(Result^) := target.GetPixel(PInt32(Params^[0])^,PInt32(Params^[1])^);
end;

procedure MyGetPixelSingle{$i lape.func}
begin
  TBGRAPixel(Result^) := target.GetPixel(PSingle(Params^[0])^,PSingle(Params^[1])^);
end;

procedure MyGetPixelSingleCycleX{$i lape.func}
begin
  TBGRAPixel(Result^) := target.GetPixelCycle(PSingle(Params^[0])^,PSingle(Params^[1])^,rfLinear,true,false);
end;

procedure MyGetPixelSingleCycleY{$i lape.func}
begin
  TBGRAPixel(Result^) := target.GetPixelCycle(PSingle(Params^[0])^,PSingle(Params^[1])^,rfLinear,false,true);
end;

procedure MyGetPixelSingleCycleXY{$i lape.func}
begin
  TBGRAPixel(Result^) := target.GetPixelCycle(PSingle(Params^[0])^,PSingle(Params^[1])^,rfLinear,true,true);
end;

procedure MyFill{$i lape.proc}
begin
  target.Fill(PBGRAPixel(Params^[0])^);
end;

procedure MyAlphaFill{$i lape.proc}
begin
  target.AlphaFill(PByte(Params^[0])^);
end;

procedure MyPutImage{$i lape.proc}
begin
  target.PutImage(PInt32(Params^[0])^,PInt32(Params^[1])^, GetBitmap(PInt32(Params^[2])^), TDrawMode(PInt32(Params^[3])^), PByte(Params^[4])^);
end;

procedure MyNewBitmap{$i lape.func}
var idx: integer;
  bmp: TBGRABitmap;
begin
  bmp := TBGRABitmap.Create(PInt32(Params^[0])^,PInt32(Params^[1])^);
  idx := NewBitmapEntry;
  Int32(result^) := idx;
  bitmaps[idx].Bitmap := bmp;
  bitmaps[idx].Registered := false;
end;

procedure MyNewBitmapFromColor{$i lape.func}
var idx: integer;
  bmp: TBGRABitmap;
begin
  bmp := TBGRABitmap.Create(PInt32(Params^[0])^,PInt32(Params^[1])^,PBGRAPixel(Params^[2])^);
  idx := NewBitmapEntry;
  Int32(result^) := idx;
  bitmaps[idx].Bitmap := bmp;
  bitmaps[idx].Registered := false;
end;

procedure MyNewBitmapFromFile{$i lape.func}
var idx: integer;
  bmp: TBGRABitmap;
begin
  bmp := TBGRABitmap.Create(PlpString(Params^[0])^,true);
  idx := NewBitmapEntry;
  Int32(result^) := idx;
  bitmaps[idx].Bitmap := bmp;
  bitmaps[idx].Registered := false;
end;

procedure MySelectedBitmap{$i lape.func}
begin
  Int32(result^) := targetIndex;
end;

procedure MyFreeBitmap{$i lape.proc}
var idx: integer;
begin
  idx := PInt32(Params^[0])^;
  if idx = targetIndex then
    raise exception.Create('You cannot free the active bitmap');
  FreeBitmap(idx);
end;

procedure MyLockBitmap{$i lape.proc}
var idx: integer;
begin
  idx := PInt32(Params^[0])^;
  if (idx >= 0) and (idx < length(bitmaps)) then
    inc(bitmaps[idx].LockedCount);
end;

procedure MyUnlockBitmap{$i lape.proc}
var idx: integer;
begin
  idx := PInt32(Params^[0])^;
  if (idx >= 0) and (idx < length(bitmaps)) then
  begin
    if bitmaps[idx].LockedCount <= 0 then
      raise exception.Create('Bitmap is not locked');
    dec(bitmaps[idx].LockedCount);
  end;
end;

procedure MySelectBitmap{$i lape.proc}
var idx: integer;
begin
  idx := PInt32(Params^[0])^;
  SetTargetBitmap(idx);
end;

procedure MySetBitmapSize{$i lape.proc}
begin
  if (targetIndex >= 0) and (targetIndex < length(bitmaps)) then
  begin
    if (bitmaps[targetIndex].LockedCount <> 0) then
      raise exception.Create('Bitmap is locked');
    target.SetSize(PInt32(Params^[0])^,PInt32(Params^[1])^);
  end;
end;

procedure MyAssignBitmap{$i lape.proc}
begin
  target.Assign(GetBitmap(PInt32(Params^[0])^));
end;

procedure MyDuplicateBitmap{$i lape.func}
var copy: TBGRABitmap;
  srcIdx,idx: integer;
begin
  srcIdx := PInt32(Params^[0])^;
  copy := GetBitmap(srcIdx).Duplicate;
  idx := NewBitmapEntry;
  bitmaps[idx].Bitmap := copy;
  bitmaps[idx].Invalidated := false;
  bitmaps[idx].Registered := false;
  Int32(result^) := idx;
end;

procedure RegisterBasicFunctions(Compiler: TLapeCompiler);
begin
  Compiler.addGlobalFunc('function GetScanLine(y: Int32) : PBGRAPixel;', @MyGetScanline);
  Compiler.addGlobalFunc('function BitmapWidth : Int32;', @MyGetBitmapWidth);
  Compiler.addGlobalFunc('function BitmapHeight : Int32;', @MyGetBitmapHeight);
  Compiler.addGlobalFunc('procedure FillBitmap(c: TBGRAPixel);', @MyFill);
  Compiler.addGlobalFunc('procedure FillBitmapAlpha(alpha: byte);', @MyAlphaFill);
  Compiler.addGlobalFunc('function BGRA(red,green,blue,alpha: byte): TBGRAPixel;', @MyBGRA4);
  Compiler.addGlobalFunc('function BGRA(red,green,blue: byte): TBGRAPixel; overload;', @MyBGRA3);
  Compiler.addGlobalFunc('function PtInClipRect(x, y: Int32): LongBool;', @MyPtInClipRect);
  Compiler.addGlobalFunc('function GetClipRect: TRect;', @MyGetClipRect);
  Compiler.addGlobalFunc('procedure SetClipRect(ARect: TRect);', @MySetClipRect);
  Compiler.addGlobalFunc('function PtInRect(const APoint: TPoint; const ARect: TRect): LongBool;', @MyPtInRectPointFirst);
  Compiler.addGlobalFunc('function PtInRect(const ARect: TRect; const APoint: TPoint): LongBool; overload;', @MyPtInRectPointLast);
  Compiler.addGlobalFunc('procedure NoClip;', @MySetNoClip);
  Compiler.addGlobalFunc('procedure SetPixel(x,y: Int32; c: TBGRAPixel);', @MySetPixel);
  Compiler.addGlobalFunc('procedure NormalPixel(x,y: Int32; c: TBGRAPixel);', @MyNormalPixel);
  Compiler.addGlobalFunc('procedure LinearPixel(x,y: Int32; c: TBGRAPixel);', @MyLinearPixel);
  Compiler.addGlobalFunc('procedure XorPixel(x,y: Int32; c: TBGRAPixel);', @MyXorPixel);
  Compiler.addGlobalFunc('procedure ErasePixel(x,y: Int32; alpha: byte);', @MyErasePixel);
  Compiler.addGlobalFunc('procedure AlphaPixel(x,y: Int32; alpha: byte);', @MyAlphaPixel);
  Compiler.addGlobalFunc('procedure _DrawPixel(x,y: Int32; c: TBGRAPixel; ADrawMode: Int32);', @MyDrawPixel);
  Compiler.addGlobalFunc('function GetPixel(x,y: Int32): TBGRAPixel;', @MyGetPixel);
  Compiler.addGlobalFunc('function GetPixel(x,y: single): TBGRAPixel; overload;', @MyGetPixelSingle);
  Compiler.addGlobalFunc('function GetPixelCycle(x,y: single): TBGRAPixel; overload;', @MyGetPixelSingleCycleXY);
  Compiler.addGlobalFunc('function GetPixelCycleX(x,y: single): TBGRAPixel; overload;', @MyGetPixelSingleCycleX);
  Compiler.addGlobalFunc('function GetPixelCycleY(x,y: single): TBGRAPixel; overload;', @MyGetPixelSingleCycleY);
  Compiler.addGlobalFunc('function CreateBitmap(width,height: Int32): TBGRABitmap;', @MyNewBitmap);
  Compiler.addGlobalFunc('function CreateBitmap(width,height: Int32; c: TBGRAPixel): TBGRABitmap; overload;', @MyNewBitmapFromColor);
  Compiler.addGlobalFunc('function CreateBitmap(filename: string): TBGRABitmap; overload;', @MyNewBitmapFromFile);
  Compiler.addGlobalFunc('function SelectedBitmap: TBGRABitmap;', @MySelectedBitmap);
  Compiler.addGlobalFunc('procedure TBGRABitmap.Free;', @MyFreeBitmap);
  Compiler.addGlobalFunc('procedure TBGRABitmap.Select;', @MySelectBitmap);
  Compiler.addGlobalFunc('procedure _PutImage(x,y: Int32; bmp: TBGRABitmap; ADrawMode: Int32; alpha: byte);', @MyPutImage);
  Compiler.addGlobalFunc('procedure TBGRABitmap._Lock;', @MyLockBitmap);
  Compiler.addGlobalFunc('procedure TBGRABitmap._Unlock;', @MyUnlockBitmap);
  Compiler.addGlobalFunc('procedure AssignBitmap(bmp: TBGRABitmap);', @MyAssignBitmap);
  Compiler.addGlobalFunc('procedure SetBitmapSize(width,height: integer);', @MySetBitmapSize);
  Compiler.addGlobalFunc('function TBGRABitmap.Duplicate: TBGRABitmap;', @MyDuplicateBitmap);
end;