1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
{
Test for the basic graph operations - PutPixel, GetPixel and HLine/VLine
drawing with different colours and write modes
Test draws random pixels and H/V lines with the graph unit and performs the
same operations in memory. Finally it reads the whole resulting image, pixel
by pixel, via GetPixel and compares the result with the expected value from
the PixArray
Useful for testing the platform-specific parts of the FPC graph unit (in
various modes and operating systems)
This test works also with TP7
}
program DrawTest;
uses
Graph;
type
TTestParams = record
Driver: Integer;
Mode: Integer;
NumberOfObjectsToDraw: Integer;
ProbabilityPixel: Integer;
ProbabilityHLine: Integer;
ProbabilityVLine: Integer;
end;
TPixelColor = Word;
PRow = ^TRow;
TRow = array [0..1279] of TPixelColor;
var
XRes, YRes: Integer;
PixArray: array [0..1023] of PRow;
procedure InitPixArray(AXRes, AYRes: Integer);
var
Y: Integer;
begin
XRes := AXRes;
YRes := AYRes;
for Y := 0 to AYRes - 1 do
begin
GetMem(PixArray[Y], AXRes * SizeOf(TPixelColor));
FillChar(PixArray[Y]^, AXRes * SizeOf(TPixelColor), 0);
end;
end;
procedure FreePixArray;
var
Y: Integer;
begin
for Y := 0 to YRes - 1 do
FreeMem(PixArray[Y], XRes * SizeOf(TPixelColor));
end;
procedure TestFinalResult;
var
X, Y: Integer;
begin
for Y := 0 to YRes - 1 do
for X := 0 to XRes - 1 do
if GetPixel(X, Y) <> PixArray[Y]^[X] then
begin
CloseGraph;
Writeln('Error at X = ', X, ', Y = ', Y);
Halt(1);
end;
end;
procedure TestPutPixel(X, Y: Integer; Color: TPixelColor);
begin
PutPixel(X, Y, Color);
PixArray[Y]^[X] := Color;
end;
procedure DirectPutPixel(X, Y: Integer; Color: TPixelColor; WriteMode: Integer);
begin
case WriteMode of
NormalPut, OrPut, NotPut: PixArray[Y]^[X] := Color;
XORPut, AndPut: PixArray[Y]^[X] := PixArray[Y]^[X] xor Color;
{ TODO: add some sort of SetWriteModeExtended to the FPC graph unit, so
we can test these as well: }
{ OrPut: PixArray[Y]^[X] := PixArray[Y]^[X] or Color;}
{ AndPut: PixArray[Y]^[X] := PixArray[Y]^[X] and Color;}
{ NotPut: PixArray[Y]^[X] := Color xor GetMaxColor;}
end;
end;
procedure TestHLine(Y, X1, X2: Integer; Color: TPixelColor; WriteMode: Integer);
var
tmp, X: Integer;
begin
SetWriteMode(WriteMode);
SetColor(Color);
Line(X1, Y, X2, Y);
if X1 > X2 then
begin
tmp := X1;
X1 := X2;
X2 := tmp;
end;
for X := X1 to X2 do
begin
DirectPutPixel(X, Y, Color, WriteMode);
end;
SetWriteMode(NormalPut);
end;
procedure TestVLine(X, Y1, Y2: Integer; Color: TPixelColor; WriteMode: Integer);
var
tmp, Y: Integer;
begin
SetWriteMode(WriteMode);
SetColor(Color);
Line(X, Y1, X, Y2);
if Y1 > Y2 then
begin
tmp := Y1;
Y1 := Y2;
Y2 := tmp;
end;
for Y := Y1 to Y2 do
begin
DirectPutPixel(X, Y, Color, WriteMode);
end;
SetWriteMode(NormalPut);
end;
procedure TestDraw(const TestParams: TTestParams);
var
I: Integer;
R: Integer;
begin
for I := 1 to TestParams.NumberOfObjectsToDraw do
begin
R := Random(TestParams.ProbabilityPixel + TestParams.ProbabilityHLine + TestParams.ProbabilityVLine);
if R < TestParams.ProbabilityPixel then
TestPutPixel(Random(XRes), Random(YRes), Random(GetMaxColor + 1))
else
if (R >= TestParams.ProbabilityPixel) and (R < TestParams.ProbabilityPixel + TestParams.ProbabilityHLine) then
TestHLine(Random(YRes), Random(XRes), Random(XRes), Random(GetMaxColor + 1), Random(NotPut + 1))
else
TestVLine(Random(XRes), Random(YRes), Random(YRes), Random(GetMaxColor + 1), Random(NotPut + 1));
end;
end;
procedure PerformTest(const TestParams: TTestParams);
var
GraphDriver, GraphMode: Integer;
begin
GraphDriver := TestParams.Driver;
GraphMode := TestParams.Mode;
InitGraph(GraphDriver, GraphMode, 'C:\TP\BGI');
InitPixArray(GetMaxX + 1, GetMaxY + 1);
TestDraw(TestParams);
TestFinalResult;
FreePixArray;
CloseGraph;
Writeln('Ok');
end;
var
TestsCount: Integer;
TestParams: TTestParams;
Code: Integer;
I: Integer;
begin
if ParamCount <> 3 then
begin
Writeln('Usage: ', ParamStr(0), ' <driver number> <mode number> <tests count>');
Writeln;
Writeln('For example: ', ParamStr(0), ' 9 2 20');
Writeln('performs 20 tests in 640x480x16 VGA mode (VGA = 9, VGAHi = 2)');
Halt;
end;
Val(ParamStr(1), TestParams.Driver, Code);
Val(ParamStr(2), TestParams.Mode, Code);
Val(ParamStr(3), TestsCount, Code);
Randomize;
for I := 1 to TestsCount do
begin
TestParams.NumberOfObjectsToDraw := Random(30000);
TestParams.ProbabilityPixel := Random(10);
TestParams.ProbabilityHLine := Random(2);
TestParams.ProbabilityVLine := Random(2);
PerformTest(TestParams);
end;
end.
|
