· 5 years ago · Feb 26, 2021, 07:32 PM
1{
2Ported to FPC by Nikolay Nikolov (nickysn@users.sourceforge.net)
3}
4
5{
6 Tunnel demo for OpenPTC 1.0 C++ API
7 Originally coded by Thomas Rizos (rizos@swipnet.se)
8 Adapted for OpenPTC by Glenn Fiedler (ptc@gaffer.org)
9 This source code is licensed under the GNU GPL
10}
11
12program Tunnel;
13
14{$MODE objfpc}
15{$MACRO ON}
16{$define xSize:=800}
17{$define ySize:=600}
18
19
20uses
21 ptc, Math;
22
23type
24 { tunnel class }
25 TTunnel = class
26 public
27 constructor Create;
28 destructor Destroy; override;
29 procedure setup;
30 procedure draw(buffer: PUint32; t: Single);
31 private
32 { tunnel data }
33 screenX: Integer;
34 screenY: Integer;
35 tunnel: PUint32;
36 texture: PUint8;
37 end;
38
39constructor TTunnel.Create;
40begin
41 { allocate tables }
42 screenX:= xSize;
43 screenY:= ySize;
44 tunnel := GetMem(screenX*screenY*SizeOf(Uint32));
45 texture := GetMem(256*256*2*SizeOf(Uint8));
46 { setup }
47 setup;
48end;
49
50destructor TTunnel.Destroy;
51begin
52 { free tables }
53 FreeMem(tunnel);
54 FreeMem(texture);
55
56 inherited Destroy;
57end;
58
59procedure TTunnel.setup;
60var
61 index: Integer;
62 x, y: Integer;
63 angle, angle1, angle2, radius, u, v: Double;
64begin
65 { tunnel index }
66 index := 0;
67
68 { generate tunnel table }
69 for y := 300 DownTo -299 do
70 for x := -400 to 399 do
71 begin
72 { calculate angle from center }
73 angle := arctan2(y, x) * 256 / pi / 2;
74
75 { calculate radius from center }
76 radius := sqrt(x * x + y * y);
77
78 { clamp radius to minimum }
79 if radius < 1 then
80 radius := 1;
81
82 { texture coordinates }
83 u := angle;
84 v := 6000 / radius;
85
86 { calculate texture index for (u,v) }
87 tunnel[index] := (Trunc(v) and $FF) * 256 + (Trunc(u) and $FF);
88 Inc(index);
89 end;
90
91 { generate blue plasma texture }
92 index := 0;
93 angle2 := pi * 2/256 * 230;
94 for y := 0 to 256 * 2 - 1 do
95 begin
96 angle1 := pi * 2/256 * 100;
97 for x := 0 to 256-1 do
98 begin
99 texture[index] := Trunc(sin(angle1)*80 + sin(angle2)*40 + 128);
100 angle1 := angle1 + pi*2/256*3;
101 Inc(index);
102 end;
103 angle2 := angle2 + pi * 2/256 *2;
104 end;
105end;
106
107procedure TTunnel.draw(buffer: PUint32; t: Single);
108var
109 x, y: Integer;
110 scroll: Uint32;
111 i: Integer;
112begin
113 { tunnel control functions }
114 x := Trunc(sin(t) * 99.9);
115 y := Trunc(t * screenY);
116
117 { calculate tunnel scroll offset }
118 scroll := ((y and $FF) shl 8) + (x and $FF);
119
120 { loop through each pixel }
121 for i := 0 to xSize*ySize-1 do
122 { lookup tunnel texture }
123 buffer[i] := texture[tunnel[i] + scroll];
124end;
125
126var
127 format: IPTCFormat;
128 console: IPTCConsole;
129 surface: IPTCSurface;
130 TheTunnel: TTunnel = nil;
131 time, delta: Single;
132 buffer: PUint32;
133 setscreenX: Integer;
134 setscreenY: Integer;
135
136begin
137setscreenX:= xSize;
138setscreenY:= ySize;
139 try
140 try
141 { create format }
142 format := TPTCFormatFactory.CreateNew(32, $00FF0000, $0000FF00, $000000FF);
143
144 { create console }
145 console := TPTCConsoleFactory.CreateNew;
146
147 { open console }
148 console.open('Tunnel demo', setscreenX, setscreenY, format);
149
150 { create surface }
151 surface := TPTCSurfaceFactory.CreateNew(setscreenX, setscreenY, format);
152
153 { create tunnel }
154 TheTunnel := TTunnel.Create;
155
156 { time data }
157 time := 0;
158 delta := 0.03;
159
160 { loop until a key is pressed }
161 while not console.KeyPressed do
162 begin
163 { lock surface }
164 buffer := surface.lock;
165 try
166 { draw tunnel }
167 TheTunnel.draw(buffer, time);
168 finally
169 { unlock surface }
170 surface.unlock;
171 end;
172
173 { copy to console }
174 surface.copy(console);
175
176 { update console }
177 console.update;
178
179 { update time }
180 time := time + delta;
181 end;
182 finally
183 TheTunnel.Free;
184 if Assigned(console) then
185 console.close;
186 end;
187 except
188 on error: TPTCError do
189 { report error }
190 error.report;
191 end;
192end.
193