### Bookstore

 Computer Math and Games in Pascal (preview) Lazarus Handbook

### Author Topic: Never code like this  (Read 2543 times)

#### Fred vS

• Hero Member
• Posts: 2836
##### Re: Never code like this
« Reply #30 on: August 20, 2022, 06:31:28 pm »

Another animation (Some old code set for libcairo).
Code: Pascal  [Select][+][-]
1.
2.
3. program graphics;
4.
5. {\$macro on}
6. {\$define colour:=}
7.
8. uses
9. ptcCrt, ptcGraph,Cairo,sysutils,math;
10.
11. const
12. xres=1024;
13. yres=768;
14. bytesPerPixel=4;
15.
16.
17. Type V2=object
18.      x,y,dx,dy:single;
20.      colour r,g,b,a:single;
21.      an :Single ;    //'angular distance
22.      da :Single;     //'angular speed
24.      End;
25.
26.   type aov=array[1..5] of v2;
27.
28.
30.     begin
32.     r:=rr;g:=gg;b:=bb;a:=aa;
33.     end;
34.
35.
36.
37. type
38.   TImage = packed record
39.     width, height, reserved: longint;
40.     data: array[0..xres * yres * bytesPerPixel - 1] of byte;
41.   end;
42.
43.
44.  function HandleBallCollisions(Var b:aov):boolean ;
45. Var
46.   L,impulsex,impulsey,dot,impactx,impacty: single;
47.   ma,mb,f1,f2: single;
48.   n1,n2: Integer;
49.   flag:boolean=false;
50.   at1,at2:single;
51. Begin
52. at1:=0;
53. at2:=0;
54.   For n1 :=low(b) To high(b) -1 Do
55.     Begin
56.       For n2 :=n1+1 To high(b) Do
57.         Begin
58.           L := Sqrt( (b[n1].x-b[n2].x)*(b[n1].x-b[n2].x) + (b[n1].y-b[n2].y)*(b[n1].y-b[n2].y));
60.             Begin
61.             flag:=true;
62.               impulsex := (b[n1].x-b[n2].x)/L ;
63.               impulsey := (b[n1].y-b[n2].y)/L ;
64.               // in case of large overlap (non analogue motion)
67.
68.               impactx := b[n1].dx-b[n2].dx ;
69.               impacty := b[n1].dy-b[n2].dy ;
70.               dot := impactx*impulsex+impacty*impulsey ;
73.               ma := ma*ma;   // weigh by area (radius squared)
74.               mb := mb*mb;
75.               f1 := 2*mb/(ma+mb);   // ball weight factors
76.               f2 := 2*ma/(ma+mb);
77.               b[n1].dx:= b[n1].dx-dot*impulsex *f1;
78.               b[n1].dy:= b[n1].dy-dot*impulsey *f1;
79.               b[n2].dx:=b[n2].dx+ dot*impulsex *f2 ;
80.               b[n2].dy:= b[n2].dy+dot*impulsey *f2 ;
81.
82.             at1:=(Arctan2(b[n1].dy,b[n1].dx));at2:=(Arctan2(b[n2].dy,b[n2].dx));
83.                 at1:=Sign(at1)*Ifthen(at1<0,pi+at1,pi-at1);
84.                 at2:=Sign(at2)*Ifthen(at2<0,pi+at2,pi-at2);
85.                 b[n1].da:=at1;
86.                 b[n2].da:=at2 ;
87.
88.             End;
89.         End;
90.     End;
91.     exit(flag);
92. End;
93.
94. procedure HandleEdges(var b:aov);
95.      var i,r:integer;
96.      begin
97.
98.      for i:=low(b) to high(b) do
99.      begin
101.      if (b[i].x<r) then
102.      begin
103.       b[i].x:=r;b[i].dx:=-b[i].dx;
104.       b[i].da:=Abs(Arctan2(b[i].dy,b[i].dx))*Sign(b[i].dy);
105.      end;
106.
107.      if (b[i].x>(xres-r)) then
108.      begin
109.       b[i].x:=xres-r;b[i].dx:=-b[i].dx;
110.       b[i].da:=-Abs(Arctan2(b[i].dy,b[i].dx))*Sign(b[i].dy)
111.      end;
112.
113.      if (b[i].y<r) then
114.      begin
115.       b[i].y:=r;b[i].dy:=-b[i].dy;
116.       b[i].da:=-Abs(Arctan2(b[i].dy,b[i].dx))*Sign(b[i].dx);
117.      end;
118.
119.      if (b[i].y>(yres-r)) then
120.      begin
121.       b[i].y:=yres-r;b[i].dy:=-b[i].dy;
122.       b[i].da:=Abs(Arctan2(b[i].dy,b[i].dx))*Sign(b[i].dx)
123.      end;
124.      end;
125.      end;
126.
127.
128. procedure InitFonts(surf: pcairo_t;fonttype:pchar);
129. begin
130.     cairo_select_font_face (surf,fonttype, CAIRO_FONT_SLANT_NORMAL, CAIRO_FONT_WEIGHT_BOLD);
131. End;
132.
133. procedure print(surf: pcairo_t;x,y:single;text:pchar;size,colour rd,gr,bl,al:single);
134. begin
135.    cairo_set_font_size (surf,(size));
136.    cairo_move_to (surf,x,y);
137.     cairo_set_source_rgba(surf,colour rd,gr,bl,al);
138.     cairo_show_text(surf, text);
139.     cairo_stroke(surf);
140. End;
141.
142. procedure line(surf:pcairo_t;x1,y1,x2,y2,thickness,colour r,g,b,a:single;CapOption:boolean);
143. begin
144.     cairo_set_line_width(surf, (thickness));
145.     cairo_set_source_rgba (surf,r,g,b,a);
146.     cairo_move_to(surf, (x1), (y1));
147.     cairo_line_to(surf,(x2),(y2));
148.     If Capoption Then
149.         cairo_set_line_cap(surf,CAIRO_LINE_CAP_ROUND)
150.     Else
151.         cairo_set_line_cap(surf,CAIRO_LINE_CAP_SQUARE);
152.     cairo_stroke(surf);
153. End;
154.
156. begin
157.     cairo_set_line_width(surf,thickness);
158.     cairo_set_source_rgba( surf,r,g,b,a);
160.     If Capoption Then
161.         cairo_set_line_cap(surf,CAIRO_LINE_CAP_ROUND)
162.     Else
163.         cairo_set_line_cap(surf,CAIRO_LINE_CAP_SQUARE);
164.     cairo_stroke(surf);
165. End;
166.
168. begin
169.     cairo_set_line_width(surf,(1));
170.     cairo_set_source_rgba( surf,r,g,b,a);
172.     cairo_fill(surf);
173.     cairo_stroke(surf);
174. End;
175.
176. procedure rectangle(surf:pcairo_t;x,y,wide,high,thickness,colour r,g,b,a:single);
177. begin
178.     cairo_set_line_width(surf, thickness);
179.     cairo_set_source_rgba( surf,r,g,b,a);
180.     cairo_move_to(surf, x, y);
181.     cairo_rectangle(surf,x,y,wide,high);
182.     cairo_stroke(surf);
183. End;
184.
185. procedure rectanglefill(surf:pcairo_t;x,y,wide,high,colour r,g,b,a:single);
186. begin
187.     cairo_set_source_rgba (surf,r,g,b,a);
188.     cairo_move_to(surf, (x), (y));
189.     cairo_rectangle(surf,(x),(y),(wide),(high));
190.     cairo_fill(surf);
191.     cairo_stroke(surf);
192. End;
193.
194.
195. procedure SetBackgroundColour(c: pcairo_t;colour r,g,b:single);
196. begin
197.     cairo_set_source_rgb( c,r,g,b);
198.     cairo_paint(c);
199.      cairo_stroke(c);
200. End;
201.
202. procedure texture(c:pcairo_t;xpos,ypos,size,colour r1,g1,b1,a1,colour r2,g2,b2,a2,an:Single;num:integer);
203. var
204. l,tx,ty:single;
205. s:ansistring;
206. begin
207.     circlefill(c,xpos,ypos,size,r1,g1,b1,a1);
208.     l:=size/3;
209.     cairo_save(c);
210.     tx:=xpos-l;ty:=ypos+l/1.5;
211.     cairo_translate(c,xpos,ypos);
212.     cairo_rotate(c, an);
213.     cairo_translate(c,-xpos,-ypos);
214.     str(num,s);
215.     print(c,tx,ty,pchar(s),size,r2,g2,b2,a2);
216.     cairo_restore(c);
217. End;
218.
219.  procedure MoveAndDraw(c:pcairo_t;var b:aov);
220.      var i:integer;
221.      begin
222.      for i:=low(b) to high(b) do
223.      begin
224.      b[i].x:=b[i].x+b[i].dx;
225.      b[i].y:=b[i].y+b[i].dy;
228.      1-b[i].r,1-b[i].g,1-b[i].b,1,b[i].an,i);
229.      end;
230.      end;
231.
232.    Function Regulate(const MyFps:int32;var fps:int32):int32;
233.  const
234.  timervalue:double =0;_lastsleeptime:double=0;t3:double=0;frames:double=0;
235.     Var t,sleeptime:double;
236.     begin
237.     t:=gettickcount64/1000;
238.     frames:=frames+1;
239.     If (t-t3)>=1.0 Then begin t3:=t;fps:=trunc(frames);frames:=0; end;
240.      sleeptime:=(_lastsleeptime+((1/myfps)-(t)+timervalue)*1000);
241.     If (sleeptime<1) Then sleeptime:=1;
242.     _lastsleeptime:=sleeptime;
243.     timervalue:=t;
244.     exit( trunc(sleeptime));
245. End;
246.
247. var
248.  gd, gm: SmallInt;
249.  i:integer;
250.  size:word=0;
251.  surface: pcairo_surface_t;
252.  context:pcairo_t;
253.  T:timage;
254.  c:ansistring;
255.  b:aov;
256.  fps:int32=0;
257.
258. begin
259.
260. T.width:=xres;
261. T.height:=yres;
262.
263. {==========  set up graph =========}
264.       gd := VESA;
265.       gm :=   m1024x768x16m;
266.       InitGraph(gd, gm, '');
267.       if GraphResult <> grok then  halt;
268.
269.       size:=cairo_format_stride_for_width(CAIRO_FORMAT_ARGB32,xres);
270.       surface := cairo_image_surface_create_for_data(T.data, CAIRO_FORMAT_ARGB32, xres, yres, size);
271.       context := cairo_create(surface);
272.       initfonts(context,'georgia');
273.   b[1].x:=0;   // to eliminate fpc warning
274.
275. b[1].setf(100,100,1.75*3,1.75*3.5,35,colour 1,0.5,0,1);
276. b[2].setf(300,300,0,0,35,colour 0,1,0,1);
277. b[3].setf(400,400,0,0,40,colour 0,0,1,1);
278. b[4].setf(500,500,0,0,30,colour 0,0.5,1,1);
279. b[5].setf(200,200,0,0,20,colour 1,1,1,1);
280.
281.       while  not KeyPressed do
282.       begin
283.       SetBackgroundColour(context,colour 0.5,0.5,0);
284.        rectangle(context,20,yres-33,200,30,2,colour 0,0,0,1);
285.        c:='Version  '+cairo_version_string();
286.        print(context,22,yres-10,pchar(c),20,colour 0.5,0,0,1);
287.        HandleEdges(b);
288.        HandleBallCollisions(b);
289.        MoveAndDraw(context,b);
290.         str(fps,c);
291.        print(context,50,30,pchar('Framerate  '+ c),15,colour 1,0.5,1,1);
292.        print(context,50,100,pchar('Press any key to finish'),20,colour 0,0,1,0.5);
293.       PutImage(0, 0, T, NormalPut);
294.       sleep(regulate(60,fps));
295.       end;
296.
297.      closegraph;
298. end.
299.

Very impressive too, congrats!

Code: Pascal  [Select][+][-]
1. uses
2.     {\$IFDEF unix}
4.     {\$ENDIF}
I use Lazarus 2.2.0 32/64 and FPC 3.2.2 32/64 on Debian 11 64 bit, Windows 10, Windows 7 32/64, Windows XP 32,  FreeBSD 64.
Widgetset: fpGUI, MSEgui, Win32, GTK2, Qt.

https://github.com/fredvs
https://gitlab.com/fredvs
https://codeberg.org/fredvs

#### Roland57

• Sr. Member
• Posts: 310
##### Re: Never code like this
« Reply #31 on: August 20, 2022, 07:18:43 pm »
Another animation (Some old code set for libcairo).

Very nice! I will steal you your Regulate function.

#### PascalDragon

• Hero Member
• Posts: 4744
• Compiler Developer
##### Re: Never code like this
« Reply #32 on: August 20, 2022, 08:26:12 pm »
Not tested and only restricted to the important bits, but it should point you in the right direction:

Yes it works. Thanks!

Code: Pascal  [Select][+][-]
1. procedure FreeImage(const AImage: PImage; const AWidth, AHeight: integer);
2. begin
3.   FreeMem(AImage, SizeOf(THeader) + COLOR_WIDTH * AWidth * AHeight);
4. end;
5.

Please note that FreeMem also has an overload that does not need the size parameter, which simplifies your FreeImage a bit (this works, because the memory manager keeps track of the size of the memory it gives out).

#### Roland57

• Sr. Member
• Posts: 310
##### Re: Never code like this
« Reply #33 on: August 20, 2022, 08:51:23 pm »
Interesting. I didn't know. Thanks!