Recent

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

Fred vS

  • Hero Member
  • *****
  • Posts: 2836
    • StrumPract is the musicians best friend
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;
  19.      radius:integer;
  20.      colour r,g,b,a:single;
  21.      an :Single ;    //'angular distance
  22.      da :Single;     //'angular speed
  23.      procedure SetF(xx,yy,ddx,ddy:single;rradius:integer;rr,gg,bb,aa:single);
  24.      End;
  25.      
  26.   type aov=array[1..5] of v2;    
  27.    
  28.      
  29.     procedure V2.SetF(xx,yy,ddx,ddy:single;rradius:integer;colour rr,gg,bb,aa:single);
  30.     begin
  31.     x:=xx;y:=yy;dx:=ddx;dy:=ddy;radius:=rradius;
  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));
  59.           If L< (b[n1].radius+b[n2].radius) Then
  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)
  65.               b[n1].x := b[n2].x+(b[n1].radius+b[n2].radius)*impulsex ;
  66.               b[n1].y := b[n2].y+(b[n1].radius+b[n2].radius)*impulsey ;
  67.  
  68.               impactx := b[n1].dx-b[n2].dx ;
  69.               impacty := b[n1].dy-b[n2].dy ;
  70.               dot := impactx*impulsex+impacty*impulsey ;
  71.               ma := b[n1].radius;
  72.               mb := b[n2].radius;
  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
  100.      r:=b[i].radius;
  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.  
  155. procedure circle(surf:pcairo_t;cx,cy,radius,start,finish,thickness,colour r,g,b,a:single;Capoption:boolean);
  156. begin
  157.     cairo_set_line_width(surf,thickness);
  158.     cairo_set_source_rgba( surf,r,g,b,a);
  159.     cairo_arc(surf,(cx),(cy),(radius),(start),(finish));
  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.  
  167. procedure circlefill(surf:pcairo_t;cx,cy,radius,r,g,b,a:single);
  168. begin
  169.     cairo_set_line_width(surf,(1));
  170.     cairo_set_source_rgba( surf,r,g,b,a);
  171.     cairo_arc(surf,(cx),(cy),(radius),(0),(2*pi));
  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;
  226.      b[i].an:=b[i].an+ b[i].da*(1/b[i].radius);
  227.      texture(c,b[i].x,b[i].y,b[i].radius,b[i].r,b[i].g,b[i].b,b[i].a,
  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!

To do your code working for Unix systems, just  add cthreads unit in uses section:
 
Code: Pascal  [Select][+][-]
  1. uses
  2.     {$IFDEF unix}
  3.       cThreads,
  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!

 

TinyPortal © 2005-2018