Skip to content

Commit f964150

Browse files
RetroNick2020RetroNick2020
committed
update
1 parent ddbf694 commit f964150

3 files changed

Lines changed: 145 additions & 7 deletions

File tree

‎freepascal/Graph with fcl-image/project1.lpi‎

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,33 @@
1919
</General>
2020
<BuildModes>
2121
<Item Name="default" Default="True"/>
22+
<Item Name="win32">
23+
<CompilerOptions>
24+
<Version Value="11"/>
25+
<PathDelim Value="\"/>
26+
<Target>
27+
<Filename Value="project1"/>
28+
</Target>
29+
<SearchPaths>
30+
<IncludeFiles Value="$(ProjOutDir)"/>
31+
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
32+
</SearchPaths>
33+
<CodeGeneration>
34+
<TargetCPU Value="i386"/>
35+
<TargetOS Value="win32"/>
36+
</CodeGeneration>
37+
<Linking>
38+
<Debugging>
39+
<DebugInfoType Value="dsDwarf2Set"/>
40+
</Debugging>
41+
<Options>
42+
<Win32>
43+
<GraphicApplication Value="True"/>
44+
</Win32>
45+
</Options>
46+
</Linking>
47+
</CompilerOptions>
48+
</Item>
2249
</BuildModes>
2350
<PublishOptions>
2451
<Version Value="2"/>

‎freepascal/Graph with fcl-image/project1.lpr‎

Lines changed: 118 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,13 @@
11
program project1;
22
{$mode objfpc}{$H+}
33

4-
uses ptcgraph,ptccrt,FPImage,FPReadBMP;
4+
uses ptcgraph,ptccrt,FPImage,FPReadGIF;
5+
6+
type
7+
XGFHeadFP = Packed Record
8+
Width,Height : LongInt;
9+
reserved : LongInt;
10+
end;
511

612
function RGB16m(r,g,b : byte) : longword;
713
begin
@@ -34,7 +40,25 @@ procedure Convert16BitRGBTo8Bit(R16, G16, B16: Word; var r,g,b : byte);
3440
b:=Round(B16 / 65535 * 255);
3541
end;
3642

37-
procedure DrawFPImage(x,y : integer;var fpimage: TFPCustomImage;gd : smallint);
43+
procedure CopyFPImagePalette(fpimage: TFPCustomImage;gd : smallint);
44+
var
45+
col : integer;
46+
maxcolor : integer;
47+
fpcol : TFPColor;
48+
r,g,b : byte;
49+
begin
50+
if fpimage.UsePalette = false then exit;
51+
maxcolor:=fpimage.Palette.Count;
52+
if maxcolor > 256 then maxcolor:=256;
53+
for col:=0 to maxcolor-1 do
54+
begin
55+
fpcol:=fpimage.Palette.Color[col];
56+
Convert16BitRGBTo8Bit(fpcol.Red,fpcol.Green,fpcol.Blue,r,g,b);
57+
setrgbpalette(col,r,g,b);
58+
end;
59+
end;
60+
61+
procedure DrawFPImage(x,y : integer; fpimage: TFPCustomImage;gd : smallint);
3862
var
3963
i,j : integer;
4064
fpcol : TFPColor;
@@ -75,27 +99,114 @@ procedure DrawFPImage(x,y : integer;var fpimage: TFPCustomImage;gd : smallint);
7599
PutPixel(x+i,y+j,RGB32k(r ,g ,b ));
76100
end;
77101
end;
102+
end
103+
else if gd = d8bit then
104+
begin
105+
CopyFPImagePalette(fpimage,gd);
106+
for j:=0 to fpimage.Height-1 do
107+
begin
108+
for i:=0 to fpimage.Width-1 do
109+
begin
110+
PutPixel(x+i,y+j,fpimage.Pixels[i,j]);
111+
end;
112+
end;
113+
end;
114+
end;
115+
116+
function GetPutImageSize(width,height,gd : integer) : longint;
117+
begin
118+
//all FP simulated Graph modes 256 (8 bit),32000(15 bit),64000 (16 bit) colors take word (2 bytes) per pixel
119+
//16 million color (24 bit) take 4 bytes
120+
if (gd=D8Bit) or (gd=D16bit) or (gd=D15bit) then GetPutImageSize:=sizeof(XGFHeadFP)+(width*2)*height
121+
else GetPutImageSize:=sizeof(XGFHeadFP)+(width*4)*height;
122+
end;
123+
124+
procedure FPImageToPutImage(fpimage: TFPCustomImage;var PImage;gd : smallint);
125+
var
126+
i,j : integer;
127+
fpcol : TFPColor;
128+
r,g,b : byte;
129+
DataLong :array[1..1] OF LongWord absolute PImage;
130+
DataWord :array[1..1] OF Word absolute PImage;
131+
DataHead :XGFHeadFP absolute PImage;
132+
count : integer;
133+
begin
134+
//form the PutImage header
135+
DataHead.Width:=fpimage.Width;
136+
DataHead.Height:=fpimage.Height;
137+
DataHead.reserved:=0;
138+
count:=7;
139+
if (gd=D24bit) then count:=4;
140+
141+
for j:=0 to fpimage.Height-1 do
142+
begin
143+
for i:=0 to fpimage.Width-1 do
144+
begin
145+
if gd = D8bit then
146+
begin
147+
DataWord[count]:=fpimage.Pixels[i,j];
148+
end
149+
else if gd = D24bit then
150+
begin
151+
fpcol:=fpimage.Colors[i,j];
152+
Convert16BitRGBTo8Bit(fpcol.Red,fpcol.Green,fpcol.Blue,r,g,b);
153+
DataLong[count]:=RGB16m(r ,g ,b );
154+
end
155+
else if gd = D16bit then
156+
begin
157+
fpcol:=fpimage.Colors[i,j];
158+
Convert16BitRGBTo8Bit(fpcol.Red,fpcol.Green,fpcol.Blue,r,g,b);
159+
DataWord[count]:=RGB64k(r ,g ,b );
160+
end
161+
else if gd = D15bit then
162+
begin
163+
fpcol:=fpimage.Colors[i,j];
164+
Convert16BitRGBTo8Bit(fpcol.Red,fpcol.Green,fpcol.Blue,r,g,b);
165+
DataWord[count]:=RGB32k(r ,g ,b );
166+
end;
167+
inc(count);
168+
end;
78169
end;
79170
end;
80171

172+
173+
81174
var
82175
gd,gm: smallint;
83176
image: TFPCustomImage;
84177
reader: TFPCustomImageReader;
178+
Size : longword;
179+
MyImage : Pointer;
85180
begin
86181
Image := TFPMemoryImage.Create(0,0);
87-
Reader := TFPReaderBMP.Create;
88-
Image.LoadFromFile('test.bmp', Reader);
182+
Image.UsePalette:=true;
183+
Reader := TFPReaderGIF.Create;
89184

90-
gd:=D24bit;
185+
Image.LoadFromFile('test2.gif', Reader);
186+
187+
gd:=D8bit;
91188
gm:=m1024x768;
92189
InitGraph(gd,gm,'');
93190

191+
//allocate memory for PutImage buffer
192+
size:=GetPutImageSize(Image.Width,Image.Height,gd);
193+
GetMem(MyImage,Size);
194+
195+
//draw image one pixel at time
94196
drawfpimage(0,0,image,gd);
95-
image.Free;
197+
198+
//convert image to PutImage format and display. convert once, display multiple times
199+
//faster than drawfpimage method
200+
FPImageToPutImage(Image,MyImage^,gd);
201+
CopyFPImagePalette(Image,gd);
202+
PutImage(100,100,MyImage^,0);
203+
204+
Image.Free;
96205
Reader.Free;
97-
delay(10000);
206+
Delay(10000);
98207
closegraph;
208+
//free PutImage memory buffer
209+
FreeMem(MyImage,Size);
99210
end.
100211

101212

‎freepascal/Graph with fcl-image/test2.gif‎

402 KB
Loading

0 commit comments

Comments
 (0)