Skip to content

Commit

Permalink
BAM pRGB support
Browse files Browse the repository at this point in the history
  • Loading branch information
@RetroNick2020
RetroNick2020 committed Jan 23, 2024
1 parent badb7fd commit 638be23
Show file tree
Hide file tree
Showing 6 changed files with 172 additions and 22 deletions.
4 changes: 2 additions & 2 deletions rmabout.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,8 +8,8 @@ interface
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,lclintf;

Const
ProgramName ='Raster Master v3.3 R100';
ProgramLicense = 'Released January 19 - 2024 under MIT License';
ProgramName ='Raster Master v3.4 R101';
ProgramLicense = 'Released January 22 - 2024 under MIT License';

type

Expand Down
1 change: 1 addition & 0 deletions rmexportprops.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -178,6 +178,7 @@ procedure TImageExportForm.UpdateComboBoxes(compiler : integer);
ComboMask.Items.Clear;
ComboImage.Items.Add('None');
ComboImage.Items.Add('Put Image');
ComboImage.Items.Add('Put RGB Image');
ComboMask.Items.Add('None');
ComboMask.Items.Add('Inverted');
ComboImage.ItemIndex:=EO.Image;
Expand Down
4 changes: 4 additions & 0 deletions rmmain.lfm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -663,6 +663,10 @@ object RMMainForm: TRMMainForm
Caption = 'Put+Mask Data Statements'
OnClick = BAMPutDataClick
end
object BAMRGBPutData: TMenuItem
Caption = 'Put RGB Data Statements'
OnClick = BAMPutDataClick
end
end
object FreeBASIC: TMenuItem
Caption = 'FreeBASIC - QB Mode'
Expand Down
5 changes: 4 additions & 1 deletion rmmain.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -74,6 +74,7 @@ TRMMainForm = class(TForm)
fpRayLibCustom: TMenuItem;
gccRayLibCustom: TMenuItem;
EditProperties: TMenuItem;
BAMRGBPutData: TMenuItem;
QBJS: TMenuItem;
qbjsRGBAFuchsia: TMenuItem;
qbjsRGBAIndex0: TMenuItem;
Expand Down Expand Up @@ -2004,6 +2005,7 @@ procedure TRMMainForm.BAMPutDataClick(Sender: TObject);
ExportDialog.FileName:='';
Case (Sender As TMenuItem).Name of 'BAMPutData' :ExportDialog.Filter := 'BAM Put Data Statements|*.bas';
'BAMPutPlusMaskData' :ExportDialog.Filter := 'BAM Put+Mask Data Statements|*.bas';
'BAMRGBPutData' :ExportDialog.Filter := 'BAM Put RGB Data Statements|*.bas';

End;

Expand All @@ -2013,7 +2015,7 @@ procedure TRMMainForm.BAMPutDataClick(Sender: TObject);
begin
Case (Sender As TMenuItem).Name of 'BAMPutData' : error:=WriteXGFToCode(x,y,x2,y2,BAMLan,ExportDialog.FileName);
'BAMPutPlusMaskData' : error:=WriteXgfWithMaskToCode(x,y,x2,y2,BAMLan,ExportDialog.FileName);

'BAMRGBPutData' : error:=WriteXGFToCodeEx(x,y,x2,y2,BAMLan,RGBExportFormat,ExportDialog.FileName);
End;

if (error<>0) then
Expand Down Expand Up @@ -2422,6 +2424,7 @@ function TRMMainForm.ExportTextFileToClipboard(Sender: TObject) : boolean;

'BAMPutData' : error:=WriteXGFToCode(x,y,x2,y2,BAMLan,FileName);
'BAMPutPlusMaskData' : error:=WriteXgfWithMaskToCode(x,y,x2,y2,BAMLan,FileName);
'BAMRGBPutData' : error:=WriteXGFToCodeEx(x,y,x2,y2,BAMLan,RGBExportFormat,FileName);

'FBPutData' : error:=WriteXGFToCode(x,y,x2,y2,FBinQBModeLan,FileName);
'FBPutPlusMaskData' : error:=WriteXgfWithMaskToCode(x,y,x2,y2,FBinQBModeLan,FileName);
Expand Down
38 changes: 21 additions & 17 deletions rres.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -178,6 +178,7 @@ function ImageIndexToFormat(Compiler,ImageIndex : integer) : integer;
end;
BAMLan:begin
case ImageIndex of 1:format:=PutImageExportFormat;
2:format:=RGBExportFormat;
end;
end;
QB64Lan:begin
Expand Down Expand Up @@ -326,9 +327,9 @@ function GetRESImageSize(width,height,nColors,Lan,ImageType : integer) : longint
end;
BAMLan:begin
Case ImageFormat of PutImageExportFormat:size:=GetXImageSizeBAM(width,height,ncolors);
RGBExportFormat:size:=GetRGBXImageSizeBAM(width,height);
end;
end;

QB64Lan:begin
Case ImageFormat of RGBAFuchsiaExportFormat:size:=ResRayLibImageSize(width,height,RGBASize);
RGBAIndex0ExportFormat:size:=ResRayLibImageSize(width,height,RGBASize);
Expand Down Expand Up @@ -680,10 +681,6 @@ procedure WriteBasicRMInit(var data : BufferRec);
RayLibRGBACustomExportFormat:size:=RayLibImageSize(width,height,RGBASize);
RayLibRGBExportFormat:size:=RayLibImageSize(width,height,RGBSize);
end;
// if (EO.Image > 0) and (EO.Image < 4) then
// begin
// size:=RayLibImageSize(width,height,EO.Image);
// end;
end;


Expand Down Expand Up @@ -741,17 +738,13 @@ procedure WriteBasicRMInit(var data : BufferRec);
end;
end;

// if (EO.Image > 0) then //we have an image
if ImageExportFormat > 0 then
begin
// if (EO.Image = 1) and ((EO.Lan = FBinQBModeLan) or (EO.Lan = ABLan) or (EO.Lan = QBLan) or (EO.Lan = GWLan) or (EO.Lan = PBLan)) then size := size div 2; //we writing basic integers for Image format 1
if ImageExportFormat > 0 then
begin
if (ImageExportFormat = PutImageExportFormat) and (EO.Lan in [BAMLan,FBinQBModeLan,ABLan,QBLan,GWLan,PBLan]) then size := size div 2; //we writing basic integers for Image format 1

if (ImageExportFormat = RGBExportFormat) and (EO.Lan =BAMLan) then size := size div 2; //we writing basic integers for BAM RGB format
if (ImageExportFormat = MouseImageExportFormat) and (EO.Lan in [FBinQBModeLan,QBLan,GWLan,PBLan]) then size := size div 2; //we writing basic integers for Image format 1


WriteBasicVariable(data,EO.Lan,EO.Name,'Size',size);
// if ((EO.Lan = QB64Lan) or (EO.Lan = FBLan)) and ((EO.Image > 0) and (EO.Image < 4)) then
if ((EO.Lan = QB64Lan) or (EO.Lan = QBJSLan) or (EO.Lan = FBLan)) then
begin
if ImageExportFormat in [RGBAFuchsiaExportFormat,RGBAIndex0ExportFormat,RGBACustomExportFormat,RGBExportFormat,RayLibRGBAFuchsiaExportFormat,RayLibRGBAIndex0ExportFormat,RayLibRGBExportFormat] then
Expand All @@ -761,13 +754,17 @@ procedure WriteBasicRMInit(var data : BufferRec);
WriteBasicVariable(data,EO.Lan,EO.Name,'Format',Format); // for QB64/Freebasic RayLib formats
end;
end;
if (ImageExportFormat = RGBExportFormat) and (EO.Lan = BAMLan) then
begin
Format:=4;
WriteBasicVariable(data,EO.Lan,EO.Name,'Format',Format);
end;

WriteBasicVariable(data,EO.Lan,EO.Name,'Width',width);
WriteBasicVariable(data,EO.Lan,EO.Name,'Height',height);
WriteBasicVariable(data,EO.Lan,EO.Name,'Colors',nColors);
WriteBasicVariable(data,EO.Lan,EO.Name,'Id',i);

//write loader code
// if (EO.Lan=ABLan) and ((EO.Image=2) or (EO.Image=3)) then //these are stored in strings so we need a diffent way
if (EO.Lan=ABLan) and (ImageExportFormat in [AmigaBOBExportFormat,AmigaVSpriteExportFormat]) then //these are stored in strings so we need a diffent way
begin
WriteAmigaBasicBobVSprite(data,EO.Lan,EO.Name,size);
Expand All @@ -777,15 +774,13 @@ procedure WriteBasicRMInit(var data : BufferRec);
WriteBasicVariable(data,EO.Lan,EO.Name,'Depth',nColorsToBitPlanes(nColors));
WriteAQBImageStub(data,EO.Lan,EO.Image,EO.Mask,EO.Name,size);
end
// else if (EO.Lan=FBLan) and ((EO.Image>0) and (EO.Image<4)) then
else if (EO.Lan=FBLan) then
begin
if (ImageExportFormat in [RGBAFuchsiaExportFormat,RGBAIndex0ExportFormat,RGBExportFormat]) then
begin
WriteFBBasicReadStub(data,EO.Lan,EO.Name,size); //FreeBASIC - not QB mode - RGB/RGBA Load code
end;
end
// else if (EO.Lan=QB64Lan) and ((EO.Image>0) and (EO.Image<4)) then
else if (EO.Lan=QB64Lan) then
begin
if (ImageExportFormat in [RGBAFuchsiaExportFormat,RGBAIndex0ExportFormat,RGBACustomExportFormat,RGBExportFormat]) then
Expand All @@ -797,6 +792,10 @@ procedure WriteBasicRMInit(var data : BufferRec);
WriteQB64RayLibReadStub(data,EO.Lan,EO.Name,size); //QB64 - Use RayLib Graphics
end;
end
else if (EO.Lan=BAMLan) then
begin
WriteBasicDimReadStub(data,EO.Lan,EO.Name,size); //loading stub for putimage code.
end
else if (EO.Lan=QBJSLan) then
begin
if (ImageExportFormat in [RGBAFuchsiaExportFormat,RGBAIndex0ExportFormat,RGBACustomExportFormat,RGBExportFormat]) then
Expand All @@ -810,7 +809,6 @@ procedure WriteBasicRMInit(var data : BufferRec);
end;
end;

// if (EO.Image = 1) and (EO.Mask > 0) then //we have putimage mask - except for
if (ImageExportFormat = PutImageExportFormat) and (EO.Mask > 0) then //we have putimage mask - except for
begin
WriteBasicVariable(data,EO.Lan,EO.Name+'Mask','Size',size);
Expand Down Expand Up @@ -999,6 +997,12 @@ procedure WriteBasicRMInit(var data : BufferRec);
WriteAQBBitMapCodeToBuffer(data.fText,0,0,height-1,width-1,EO.Name);
end;

if (EO.LAN=BAMLan) and (ImageExportFormat = RGBExportFormat) then
begin
WriteBasicLabel(data,EO.Lan,EO.Name);
WriteRGBXGFCodeToBuffer(data,0,0,height-1,width-1,EO.Lan,EO.Mask,EO.Name);
end;

//RGBA/RayLib formats
if (EO.Lan in [FPLan,QB64Lan,QBJSLan,FBLan,gccLan]) and (ImageExportFormat in [RGBAFuchsiaExportFormat,
RGBAIndex0ExportFormat,
Expand Down
142 changes: 140 additions & 2 deletions rwxgf.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -95,6 +95,7 @@
BitPlaneWriterProc = Procedure(inByte : Byte; var Buffer : BufferRec; action : integer);

Function WriteXgfToCode(x,y,x2,y2,LanType : word;filename:string):word;
Function WriteXgfToCodeEx(x,y,x2,y2,LanType, ExportFormat : word;filename:string):word;
Function WriteXgfWithMaskToCode(x,y,x2,y2,LanType : word;filename:string):word;
Function WriteXgfToFile(x,y,x2,y2,LanType : word;filename:string):word;

Expand All @@ -105,12 +106,15 @@
procedure WriteXgfToBufferOW(x,y,x2,y2,Mask : word;var data : BufferRec);

function WriteXGFCodeToBuffer(var data : BufferRec;x,y,x2,y2,LanType,Mask : word; imagename:string):word;
function WriteRGBXGFCodeToBuffer(var data : BufferRec;x,y,x2,y2,LanType,Mask : word; imagename:string):word;

function GetXImageSize(width,height,ncolors : integer) : longint;
function GetXImageSizeFB(width,height : integer) : longint;
function GetXImageSizeFP(width,height : integer) : longint;
function GetXImageSizeOW(width,height,ncolors : integer) : longint;
function GetXImageSizeBAM(width,height,ncolors : integer) : longint;
function GetRGBXImageSizeBAM(width,height : integer) : longint;

function GetXImageSizeTMT(width,height,ncolors : integer) : longint;

procedure BitplaneWriterFile(inByte : Byte; var Buffer : BufferRec;action : integer);
Expand Down Expand Up @@ -372,6 +376,11 @@ function GetXImageSizeBAM(width,height,ncolors : integer) : longint;
GetXImageSizeBAM:=GetBPLSizeBAM(width,ncolors)*height+4;
end;

function GetRGBXImageSizeBAM(width,height : integer) : longint;
begin
GetRGBXImageSizeBAM:=width*3*height+4;
end;

function GetXImageSizeTMT(width,height,ncolors : integer) : longint;
begin
GetXImageSizeTMT:=GetBPLSizeTMT(width,ncolors)*height+4;
Expand Down Expand Up @@ -554,6 +563,49 @@ function GetXImageSizeFB(width,height : integer) : longint;
BitplaneWriter(0,data,2); //flush it
end;

Procedure WriteRGBXGFBufferBAM(BitPlaneWriter : BitPlaneWriterProc;var data :BufferRec; x,y,x2,y2,LanType : word);
Var
destlinebuf: Linebuftype;
Head : XgfHead;
Width : word;
Height : word;
BTW : word; //bytes to write to buffer
i,j,n : Word;
tempBuf : array[1..4] of byte;
PixelIndex : integer;
cr : TRMColorRec;
begin
Width:=x2-x+1;
Height:=y2-y+1;
BTW:=Width*3;

FixHead(Head,Width,Height,LanType);
Move(Head,tempBuf,sizeof(tempBuf));

for n:=1 to 4 do
begin
BitplaneWriter(tempBuf[n],data,1);
end;

for j:=0 to Height-1 do
begin
for i:=0 to Width-1 do
begin
PixelIndex:=GetPixel(x+i,y+j);
GetColor(PixelIndex,cr);
destLineBuf[i*3]:=cr.r;
destLineBuf[i*3+1]:=cr.g;
destLineBuf[i*3+2]:=cr.b;
end;

for n:=0 to BTW-1 do
begin
BitplaneWriter(destlinebuf[n],data,1);
end;
end;

BitplaneWriter(0,data,2); //flush it
end;

Procedure WriteXGFBufferBAM(BitPlaneWriter : BitPlaneWriterProc;var data :BufferRec; x,y,x2,y2,LanType : word);
Var
Expand Down Expand Up @@ -1215,7 +1267,8 @@ procedure BitplaneWriterBAMBasicCode(inByte : Byte; var Buffer : BufferRec;actio
end;


Function WriteBAMCodeToBuffer(var data :BufferRec;x,y,x2,y2 : word; imagename:string):word;

Function WriteBAMRGBCodeToBuffer(var data :BufferRec;x,y,x2,y2 : word; imagename:string):word;
var
Width,Height : Word;
Size : longword;
Expand All @@ -1225,6 +1278,34 @@ procedure BitplaneWriterBAMBasicCode(inByte : Byte; var Buffer : BufferRec;actio
begin
BWriter:=@BitplaneWriterBAMBasicCode;

width:=x2-x+1;
height:=y2-y+1;
nColors:=GetMaxColor+1;
Size:=GetRGBXImageSizeBAM(width,height);
{$I-}
BWriter(0,data,0); //init the data record
data.ArraySize:=size;

writeln(data.ftext,#39,' BAM Put Bitmap Code Created By Raster Master');
writeln(data.ftext,#39,' Size= ', Size div 2,' Width= ',width,' Height= ',height, ' Colors= ',nColors,' Format = RGB');
writeln(data.ftext,#39,' ',Imagename);
WriteRGBXGFBufferBAM(BWriter,data,x,y,x2,y2,BAMLan);
writeln(data.ftext);

{$I+}
WriteBAMRGBCodeToBuffer:=IORESULT;
end;


Function WriteBAMCodeToBuffer(var data :BufferRec;x,y,x2,y2 : word; imagename:string):word;
var
Width,Height : Word;
Size : longword;
nColors : integer;
BWriter : BitPlaneWriterProc;
begin
BWriter:=@BitplaneWriterBAMBasicCode;

width:=x2-x+1;
height:=y2-y+1;
nColors:=GetMaxColor+1;
Expand Down Expand Up @@ -1456,6 +1537,48 @@ procedure WriteXgfToBufferTMT(x,y,x2,y2,Mask : word;var data : BufferRec);
WriteXgfToCode:=IOResult;
end;

//This function will replace WriteXgfToCode eventually - just adding this to one language at time
Function WriteXgfToCodeEx(x,y,x2,y2,LanType, ExportFormat : word;filename:string):word;
var
data : BufferRec;
imagename : String;
imageid : word;
begin
SetCoreActive; // we are getting data from core object RMCoreBase
SetGWStartLineNumber(1000);
assign(data.fText,filename);
{$I-}
rewrite(data.fText);
imageid:=GetThumbIndex;
Imagename:=ExtractFileName(ExtractFileNameWithoutExt(filename));
case LanType of TPLan: WriteTPCodeToBuffer(data,x,y,x2,y2,imageid,imagename);
TCLan: WriteTCCodeToBuffer(data,x,y,x2,y2,imageid,imagename);

TMTLan: WriteTMTCodeToBuffer(data,x,y,x2,y2,imageid,imagename);

QBLan: WriteQBCodeToBuffer(data,x,y,x2,y2,imagename);
GWLan: WriteGWCodeToBuffer(data,x,y,x2,y2,imagename);
BAMLan:begin
Case ExportFormat of PutImageExportFormat:WriteBAMCodeToBuffer(data,x,y,x2,y2,imagename);
RGBExportFormat:WriteBAMRGBCodeToBuffer(data,x,y,x2,y2,imagename);
end;
end;
QPLan: WriteQPCodeToBuffer(data,x,y,x2,y2,imageid,imagename);
QCLan: WriteQCCodeToBuffer(data,x,y,x2,y2,imageid,imagename);

OWLan: WriteOWCodeToBuffer(data,x,y,x2,y2,imageid,imagename);

PBLan: WritePBCodeToBuffer(data,x,y,x2,y2,imagename);

FBinQBModeLan: WriteFBCodeToBuffer(data,x,y,x2,y2,imagename);
FPLan: WriteFPCodeToBuffer(data,x,y,x2,y2,imageid,imagename);

end;
close(data.fText);
{$I+}
WriteXgfToCodeEx:=IOResult;
end;

Function WriteXgfWithMaskToCode(x,y,x2,y2,LanType : word;filename:string):word;
var
data : BufferRec;
Expand Down Expand Up @@ -1505,7 +1628,7 @@ procedure WriteXgfToBufferTMT(x,y,x2,y2,Mask : word;var data : BufferRec);

function WriteXGFCodeToBuffer(var data : BufferRec;x,y,x2,y2,LanType,Mask : word; imagename:string):word;
var
omask : integer;
omask : integer;
imageid : word;
begin
imageId:=GetThumbIndex;
Expand Down Expand Up @@ -1534,6 +1657,21 @@ function WriteXGFCodeToBuffer(var data : BufferRec;x,y,x2,y2,LanType,Mask : word
WriteXGFCodeToBuffer:=data.Error;
end;

function WriteRGBXGFCodeToBuffer(var data : BufferRec;x,y,x2,y2,LanType,Mask : word; imagename:string):word;
var
omask : integer;
imageid : word;
begin
imageId:=GetThumbIndex;
omask:=GetMaskMode;
SetMaskMode(Mask);
case LanType of BAMLan: WriteBAMRGBCodeToBuffer(data,x,y,x2,y2,imagename);
end;
SetMaskMode(omask);
WriteRGBXGFCodeToBuffer:=data.Error;
end;



begin

Expand Down

0 comments on commit 638be23

Please sign in to comment.