added compile error messages, added basic support for colors

bgrapascalscript.pas

@@ -7,6 +7,9 @@ interface
 uses
   Classes, SysUtils, BGRABitmap, BGRABitmapTypes;
 
+type
+  TBGRAColor= LongWord;
+
 var
   BitmapArray: array of TBGRABitmap;
 
@@ -15,14 +18,31 @@ procedure bgra_Initialization;
 procedure bgra_Finalization;
 procedure bgra_AddBitmap(id: Integer);
 
+function rgb(red,green,blue: byte): TBGRAColor;
+function rgba(red,green,blue,alpha: byte): TBGRAColor;
+function getBlue(AColor: TBGRAColor): byte;
+function getGreen(AColor: TBGRAColor): byte;
+function getRed(AColor: TBGRAColor): byte;
+function getAlpha(AColor: TBGRAColor): byte;
+function setBlue(AColor: TBGRAColor; AValue: byte): TBGRAColor;
+function setGreen(AColor: TBGRAColor; AValue: byte): TBGRAColor;
+function setRed(AColor: TBGRAColor; AValue: byte): TBGRAColor;
+function setAlpha(AColor: TBGRAColor; AValue: byte): TBGRAColor;
+
 {Constructors}
 // Note: overloaded procedures not supported, use unique identifiers
 procedure bgra_Create(id: Integer);
+procedure bgra_CreateWithSize(id: Integer; AWidth, AHeight: integer);
+procedure bgra_Fill(id: Integer; AColor: TBGRAColor);
+procedure bgra_SetPixel(id: Integer; x,y: integer; AColor: TBGRAColor);
+function bgra_GetPixel(id: Integer; x,y: integer): TBGRAColor;
 procedure bgra_CreateFromFile(id: Integer; AFilename: string);
 procedure bgra_Destroy(id: Integer);
 
 implementation
 
+uses Dialogs;
+
 procedure bgra_Initialization;
 begin
   //
@@ -33,11 +53,7 @@ var
   i: integer;
 begin
   for i:= 0 to High(BitmapArray) do
-  begin
-    if BitmapArray[i] <> nil then
-      BitmapArray[i].Free;
-    BitmapArray[i] := nil;
-  end;
+    FreeAndNil(BitmapArray[i]);
   BitmapArray := nil;
 end;
 
@@ -45,8 +61,57 @@ procedure bgra_AddBitmap(id: Integer);
 begin
   if id + 1 > length(BitmapArray) then
     SetLength(BitmapArray, id + 1);
-  if BitmapArray[id] <> nil then
-    BitmapArray[id].Free;
+  FreeAndNil(BitmapArray[id]);
+end;
+
+function rgb(red, green, blue: byte): TBGRAColor;
+begin
+  result := blue + (green shl 8) + (red shl 16) + $ff000000;
+end;
+
+function rgba(red, green, blue, alpha: byte): TBGRAColor;
+begin
+  result := blue + (green shl 8) + (red shl 16) + (alpha shl 24);
+end;
+
+function getBlue(AColor: TBGRAColor): byte;
+begin
+  result := AColor and $ff;
+end;
+
+function getGreen(AColor: TBGRAColor): byte;
+begin
+  result := (AColor shr 8) and $ff;
+end;
+
+function getRed(AColor: TBGRAColor): byte;
+begin
+  result := (AColor shr 16) and $ff;
+end;
+
+function getAlpha(AColor: TBGRAColor): byte;
+begin
+  result := AColor shr 24;
+end;
+
+function setBlue(AColor: TBGRAColor; AValue: byte): TBGRAColor;
+begin
+  result := (AColor and $ffffff00) or AValue;
+end;
+
+function setGreen(AColor: TBGRAColor; AValue: byte): TBGRAColor;
+begin
+  result := (AColor and $ffff00ff) or (AValue shl 8);
+end;
+
+function setRed(AColor: TBGRAColor; AValue: byte): TBGRAColor;
+begin
+  result := (AColor and $ff00ffff) or (AValue shl 16);
+end;
+
+function setAlpha(AColor: TBGRAColor; AValue: byte): TBGRAColor;
+begin
+  result := (AColor and $00ffffff) or (AValue shl 24);
 end;
 
 procedure bgra_Create(id: Integer);
@@ -55,6 +120,32 @@ begin
   BitmapArray[id] := TBGRABitmap.Create;
 end;
 
+procedure bgra_CreateWithSize(id: Integer; AWidth, AHeight: integer);
+begin
+  bgra_AddBitmap(id);
+  BitmapArray[id] := TBGRABitmap.Create(AWidth,AHeight);
+end;
+
+procedure bgra_Fill(id: Integer; AColor: TBGRAColor);
+begin
+  if Assigned(BitmapArray[id]) then
+    BitmapArray[id].Fill(TBGRAPixel({$IFDEF ENDIAN_BIG}SwapEndian{$ENDIF}(AColor)));
+end;
+
+procedure bgra_SetPixel(id: Integer; x, y: integer; AColor: TBGRAColor);
+begin
+  if Assigned(BitmapArray[id]) then
+    BitmapArray[id].SetPixel(x,y,TBGRAPixel({$IFDEF ENDIAN_BIG}SwapEndian{$ENDIF}(AColor)));
+end;
+
+function bgra_GetPixel(id: Integer; x, y: integer): TBGRAColor;
+begin
+  if Assigned(BitmapArray[id]) then
+    result := {$IFDEF ENDIAN_BIG}SwapEndian{$ENDIF}(TBGRAColor(BitmapArray[id].GetPixel(x,y)))
+  else
+    result := 0;
+end;
+
 procedure bgra_CreateFromFile(id: Integer; AFilename: string);
 begin
   bgra_AddBitmap(id);
@@ -63,7 +154,7 @@ end;
 
 procedure bgra_Destroy(id: Integer);
 begin
-  BitmapArray[id].Free;
+  FreeAndNil(BitmapArray[id]);
 end;
 
 initialization

test/test_bgrapascalscript/umain.lfm

@@ -6,7 +6,7 @@ object Form1: TForm1
   Caption = 'Form1'
   ClientHeight = 550
   ClientWidth = 644
-  LCLVersion = '1.2.4.0'
+  LCLVersion = '1.0.10.0'
   object Memo1: TMemo
     Left = 8
     Height = 530
@@ -15,18 +15,25 @@ object Form1: TForm1
     Lines.Strings = (
       'Program Test_BGRAPascalScript;'
       ''
+      'var c: TBGRAColor;'
+      ' i: integer;'
       'begin'
-      '  bgra_CreateFromFile(0,''16.png'');'
-      '  //bgra_Destroy(0);'
+      '  bgra_CreateWithSize(0, 256,1);'
+      '  c := rgb(255,255,0); //yellow'
+      '  for i := 0 to 255 do'
+      '  begin'
+      '    bgra_SetPixel(0, i,0, c);'
+      '    c := setGreen(c, getGreen(c)-1);'
+      '  end;'
       'end.'
     )
     TabOrder = 0
   end
   object Button1: TButton
     Left = 464
-    Height = 35
+    Height = 25
     Top = 8
-    Width = 112
+    Width = 83
     AutoSize = True
     Caption = '1 - Execute'
     OnClick = Button1Click
@@ -34,9 +41,9 @@ object Form1: TForm1
   end
   object Button2: TButton
     Left = 464
-    Height = 35
+    Height = 25
     Top = 44
-    Width = 85
+    Width = 65
     AutoSize = True
     Caption = '2 - Test'
     Enabled = False

test/test_bgrapascalscript/umain.pas

@@ -40,12 +40,22 @@ implementation
 { TForm1 }
 
 procedure TForm1.Button1Click(Sender: TObject);
+var
+  i: Integer;
+  s: String;
 begin
   PSScript1.Script := Memo1.Lines;
   if PSScript1.Compile then
   begin
     PSScript1.Execute;
     Button2.Enabled := True;
+  end else
+  begin
+     s := 'Compile error.' + LineEnding;
+     for i := 0 to PSScript1.CompilerMessageCount-1 do
+       with PSScript1.CompilerMessages[i] do
+         s += '('+inttostr(Row)+','+inttostr(Col)+') '+MessageToString+LineEnding;
+     ShowMessage(s);
   end;
 end;
 

upsi_bgrapascalscript.pas

@@ -53,18 +53,49 @@ end;
 (*----------------------------------------------------------------------------*)
 procedure SIRegister_BGRAPascalScript(CL: TPSPascalCompiler);
 begin
- CL.AddDelphiFunction('Procedure bgra_Create( id : Integer)');
- CL.AddDelphiFunction('Procedure bgra_CreateFromFile( id : Integer; AFilename : string)');
- CL.AddDelphiFunction('Procedure bgra_Destroy( id : Integer)');
+  CL.AddTypeS('TBGRAColor','LongWord');
+  CL.AddDelphiFunction('function rgb(red,green,blue: byte): TBGRAColor;');
+  CL.AddDelphiFunction('function rgba(red,green,blue,alpha: byte): TBGRAColor;');
+  CL.AddDelphiFunction('function getBlue(AColor: TBGRAColor): byte;');
+  CL.AddDelphiFunction('function getGreen(AColor: TBGRAColor): byte;');
+  CL.AddDelphiFunction('function getRed(AColor: TBGRAColor): byte;');
+  CL.AddDelphiFunction('function getAlpha(AColor: TBGRAColor): byte;');
+  CL.AddDelphiFunction('function setBlue(AColor: TBGRAColor; AValue: byte): TBGRAColor;');
+  CL.AddDelphiFunction('function setGreen(AColor: TBGRAColor; AValue: byte): TBGRAColor;');
+  CL.AddDelphiFunction('function setRed(AColor: TBGRAColor; AValue: byte): TBGRAColor;');
+  CL.AddDelphiFunction('function setAlpha(AColor: TBGRAColor; AValue: byte): TBGRAColor;');
+  CL.AddDelphiFunction('Procedure bgra_Create( id : Integer)');
+  CL.AddDelphiFunction('Procedure bgra_CreateWithSize( id : Integer; AWidth, AHeight: integer)');
+  CL.AddDelphiFunction('Procedure bgra_CreateFromFile( id : Integer; AFilename : string)');
+  CL.AddDelphiFunction('Procedure bgra_Fill( id : Integer; AColor: TBGRAColor)');
+  CL.AddDelphiFunction('procedure bgra_SetPixel(id: Integer; x,y: integer; AColor: TBGRAColor);');
+  CL.AddDelphiFunction('function bgra_GetPixel(id: Integer; x,y: integer): TBGRAColor;');
+  CL.AddDelphiFunction('Procedure bgra_Destroy( id : Integer)');
+  CL.AddDelphiFunction('Procedure ShowMessage( const AMessage: string)');
 end;
 
 (* === run-time registration functions === *)
 (*----------------------------------------------------------------------------*)
 procedure RIRegister_BGRAPascalScript_Routines(S: TPSExec);
 begin
- S.RegisterDelphiFunction(@bgra_Create, 'bgra_Create', cdRegister);
- S.RegisterDelphiFunction(@bgra_CreateFromFile, 'bgra_CreateFromFile', cdRegister);
- S.RegisterDelphiFunction(@bgra_Destroy, 'bgra_Destroy', cdRegister);
+  S.RegisterDelphiFunction(@rgb, 'rgb', cdRegister);
+  S.RegisterDelphiFunction(@rgba, 'rgba', cdRegister);
+  S.RegisterDelphiFunction(@bgra_Create, 'bgra_Create', cdRegister);
+  S.RegisterDelphiFunction(@bgra_CreateWithSize, 'bgra_CreateWithSize', cdRegister);
+  S.RegisterDelphiFunction(@bgra_CreateFromFile, 'bgra_CreateFromFile', cdRegister);
+  S.RegisterDelphiFunction(@bgra_Fill, 'bgra_Fill', cdRegister);
+  S.RegisterDelphiFunction(@getRed, 'getRed', cdRegister);
+  S.RegisterDelphiFunction(@getGreen, 'getGreen', cdRegister);
+  S.RegisterDelphiFunction(@getBlue, 'getBlue', cdRegister);
+  S.RegisterDelphiFunction(@getAlpha, 'getAlpha', cdRegister);
+  S.RegisterDelphiFunction(@setRed, 'setRed', cdRegister);
+  S.RegisterDelphiFunction(@setGreen, 'setGreen', cdRegister);
+  S.RegisterDelphiFunction(@setBlue, 'setBlue', cdRegister);
+  S.RegisterDelphiFunction(@setAlpha, 'setAlpha', cdRegister);
+  S.RegisterDelphiFunction(@bgra_SetPixel, 'bgra_SetPixel', cdRegister);
+  S.RegisterDelphiFunction(@bgra_GetPixel, 'bgra_GetPixel', cdRegister);
+  S.RegisterDelphiFunction(@bgra_Destroy, 'bgra_Destroy', cdRegister);
+  S.RegisterDelphiFunction(@ShowMessage, 'ShowMessage', cdRegister);
 end;