Recent

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

Roland57

  • Sr. Member
  • ****
  • Posts: 421
    • msegui.net
Re: Never code like this
« Reply #15 on: August 19, 2022, 08:10:57 am »
Hi BobDog. Great! (Geany is also my favourite editor.)

I edited my example, trying to organize it a little better (without essential change).

@Fred

Thanks for testing and information.
My projects are on Gitlab and on Codeberg.

PascalDragon

  • Hero Member
  • *****
  • Posts: 5446
  • Compiler Developer
Re: Never code like this
« Reply #16 on: August 19, 2022, 08:56:37 am »
I have to create a .so symlink to libXxf86dga.so.1 otherwise the compilation fails at linking:

Code: Bash  [Select][+][-]
  1. sudo ln -s /usr/lib/x86_64-linux-gnu/libXxf86dga.so.1 /usr/lib/x86_64-linux-gnu/libXxf86dga.so

That means that you haven't installed the correct development package. ::)

Roland57

  • Sr. Member
  • ****
  • Posts: 421
    • msegui.net
Re: Never code like this
« Reply #17 on: August 19, 2022, 09:18:30 am »
I tried to make another example, using a dynamic array of byte, in order to be able to draw in fullscreen mode (for example). I get an "access violation" on the PutImage instruction.

Would someone know how to do that?

Code: Pascal  [Select][+][-]
  1. type
  2.   TImage = packed record
  3.     width, height, reserved: longint;
  4.     data: array of byte;
  5.   end;
  6.  
« Last Edit: August 19, 2022, 06:25:59 pm by Roland57 »
My projects are on Gitlab and on Codeberg.

AlexTP

  • Hero Member
  • *****
  • Posts: 2386
    • UVviewsoft
Re: Never code like this
« Reply #18 on: August 19, 2022, 09:25:21 am »
Not sure but maybe "data: array of byte;" has special internal leading field. It makes crash. What you need is "array[0..1] of byte" and then use indexes out-of-range, with "Range checks off" of course.

PascalDragon

  • Hero Member
  • *****
  • Posts: 5446
  • Compiler Developer
Re: Never code like this
« Reply #19 on: August 19, 2022, 09:47:09 am »
I tried to make another example, using a dynamic array of byte, in order to be able to draw in fullscreen mode (for example). I get an "access violation" on the PutImage instruction.

You can't use a dynamic array here, because - as AlexTP hinted at - it isn't a plain field like a static array. Instead it's internally a Pointer, so your record essentially looks like this:

Code: Pascal  [Select][+][-]
  1. type
  2.   TImage = packed record
  3.     width, height, reserved: longint;
  4.     data: Pointer;
  5.   end;

I hope you can see how PutImage can not handle that correctly.

Fred vS

  • Hero Member
  • *****
  • Posts: 3158
    • StrumPract is the musicians best friend
Re: Never code like this
« Reply #20 on: August 19, 2022, 12:23:33 pm »
I have to create a .so symlink to libXxf86dga.so.1 otherwise the compilation fails at linking:

Code: Bash  [Select][+][-]
  1. sudo ln -s /usr/lib/x86_64-linux-gnu/libXxf86dga.so.1 /usr/lib/x86_64-linux-gnu/libXxf86dga.so

That means that you haven't installed the correct development package. ::)

That means that I did not find a Xxf86dga-dev package.  :-X

[EDIT]  Ooops, I just found it it is libxxf86dga-dev ( all in minuscule )
« Last Edit: August 19, 2022, 12:29:03 pm by Fred vS »
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: 421
    • msegui.net
Re: Never code like this
« Reply #21 on: August 19, 2022, 12:28:01 pm »
@PascalDragon

Thanks. So what is the solution?

@AlexTP

Thanks, but I don't see how to do what you say.
My projects are on Gitlab and on Codeberg.

Fred vS

  • Hero Member
  • *****
  • Posts: 3158
    • StrumPract is the musicians best friend
Re: Never code like this
« Reply #22 on: August 19, 2022, 12:31:54 pm »
@PascalDragon

Thanks. So what is the solution?


See my post just before yours.
A other solution is to dynamically load libXxf86dga.so.1 + create the header of all methods and not install the dev package.
« Last Edit: August 19, 2022, 02:09:25 pm by Fred vS »
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: 421
    • msegui.net
Re: Never code like this
« Reply #23 on: August 19, 2022, 12:49:08 pm »
See my post just before yours.

My question is about setting the image size at run time.  :)
My projects are on Gitlab and on Codeberg.

Fred vS

  • Hero Member
  • *****
  • Posts: 3158
    • StrumPract is the musicians best friend
Re: Never code like this
« Reply #24 on: August 19, 2022, 01:01:45 pm »
See my post just before yours.

My question is about setting the image size at run time.  :)

Ooops, ok, sorry.  :-[
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

PascalDragon

  • Hero Member
  • *****
  • Posts: 5446
  • Compiler Developer
Re: Never code like this
« Reply #25 on: August 19, 2022, 01:55:00 pm »
@PascalDragon

Thanks. So what is the solution?

Not tested and only restricted to the important bits, but it should point you in the right direction:

Code: Pascal  [Select][+][-]
  1. type
  2.   THeader = packed record
  3.     Width, Height, Reserved: LongInt;
  4.   end;
  5.  
  6.   TImage = packed record
  7.     Header: THeader;
  8.     Data: array[0..0] of Byte;
  9.   end;
  10.   PImage = ^TImage;
  11.  
  12. var
  13.   img: PImage;
  14. begin
  15.   // I'll leave out anything that's not really relevant
  16.   img := PImage(GetMem(SizeOf(THeader) + ColorWidth * Width * Height));
  17.   // you can now pass Data on to Cairo like you did in your code
  18.   CairoDraw(img);
  19.   // and then just do a PutImage
  20.   PutImage(0, 0, img, NormalPut);
  21.   FreeMem(img);
  22. end.

Roland57

  • Sr. Member
  • ****
  • Posts: 421
    • msegui.net
Re: Never code like this
« Reply #26 on: August 19, 2022, 06:23: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. program CairoTest;
  2.  
  3. uses
  4. {$IFDEF unix}
  5.   cThreads,
  6. {$ENDIF}
  7.   SysUtils,
  8.   ptcCrt,
  9.   ptcGraph,
  10.   Cairo;
  11.  
  12. const
  13.   COLOR_WIDTH = 4;
  14.  
  15. type
  16.   THeader = packed record
  17.     Width, Height, Reserved: longint;
  18.   end;
  19.  
  20.   TImage = packed record
  21.     Header: THeader;
  22.     Data: array[0..0] of byte;
  23.   end;
  24.  
  25.   PImage = ^TImage;
  26.  
  27. function CreateImage(const AWidth, AHeight: integer): PImage;
  28. begin
  29.   result := PImage(GetMem(SizeOf(THeader) + COLOR_WIDTH * AWidth * AHeight));
  30.   result^.Header.Width  := AWidth;
  31.   result^.Header.Height := AHeight;
  32. end;
  33.  
  34. procedure FreeImage(const AImage: PImage; const AWidth, AHeight: integer);
  35. begin
  36.   FreeMem(AImage, SizeOf(THeader) + COLOR_WIDTH * AWidth * AHeight);
  37. end;
  38.  
  39. var
  40.   fe: cairo_font_extents_t;
  41.  
  42. procedure InitFonts(surf: pcairo_t; fonttype: pchar);
  43. begin
  44.   cairo_select_font_face(surf, fonttype, CAIRO_FONT_SLANT_NORMAL, CAIRO_FONT_WEIGHT_BOLD);
  45.   cairo_font_extents(surf, @fe);
  46. end;
  47.  
  48. procedure Print(surf: pcairo_t; x, y: single; text: pchar; size, rd, gr, bl: single);
  49. var
  50.   te: cairo_text_extents_t;
  51. begin
  52.   cairo_set_font_size(surf, size);
  53.   cairo_text_extents(surf, text, @te);
  54.   cairo_move_to(surf, x - te.width / 2 + te.x_bearing, y + te.height / 2 - fe.descent);
  55.   cairo_set_source_rgb(surf, rd, gr, bl);
  56.   cairo_show_text(surf, text);
  57.   cairo_stroke(surf);
  58. end;
  59.  
  60. procedure CairoDraw(var AImage: TImage);
  61. var
  62.   sfc: pcairo_surface_t;
  63.   ctx: pcairo_t;
  64.   str: integer;
  65. begin
  66.   str := cairo_format_stride_for_width(CAIRO_FORMAT_ARGB32, AImage.Header.Width);
  67.   sfc := cairo_image_surface_create_for_data(@AImage.Data[0], CAIRO_FORMAT_ARGB32, AImage.Header.Width, AImage.Header.Height, str);
  68.   ctx := cairo_create(sfc);
  69.   cairo_set_source_rgb(ctx, 1.0, 1.0, 0.0);
  70.   cairo_paint(ctx);
  71.  
  72.   InitFonts(ctx, {$IFDEF windows}'Georgia'{$ELSE}'Cantarell'{$ENDIF});
  73.   Print(ctx, 200, 50, 'Hello', 35, 0, 0.5, 1);
  74.   Print(ctx, 200, 150, 'Press any key to quit!', 20, 1, 0, 0);
  75.  
  76.   cairo_scale(ctx, AImage.Header.Width, AImage.Header.Height);
  77.   cairo_set_line_width(ctx, 0.1);
  78.   cairo_arc_negative(ctx, 0.5, 0.5, 0.4, PI / 2, 3 * PI / 2);
  79.   cairo_set_source_rgb(ctx, 0.0, 1.0, 0.0);
  80.   cairo_stroke(ctx);
  81.   cairo_destroy(ctx);
  82.   //cairo_surface_write_to_png(sfc, pchar('image.png'));
  83.   cairo_surface_destroy(sfc);
  84. end;
  85.  
  86. var
  87.   gd, gm, err: smallint;
  88.   img: PImage;
  89.   iw, ih: integer;
  90.  
  91. begin
  92.   WindowTitle := 'How to draw with Cairo in a ptcGraph window';
  93.   //FullScreenGraph := TRUE;
  94.   DetectGraph(gd, gm);
  95.   InitGraph(gd, gm, '');
  96.   err := GraphResult;
  97.  
  98.   if err = grOK then
  99.   begin
  100.     iw := Succ(GetMaxX);
  101.     ih := Succ(GetMaxY);
  102.     img := CreateImage(iw, ih);
  103.     CairoDraw(img^);
  104.     PutImage(0, 0, img^, NormalPut);
  105.     ReadKey;
  106.     CloseGraph;
  107.     FreeImage(img, iw, ih);
  108.   end;
  109. end.
« Last Edit: August 19, 2022, 11:12:01 pm by Roland57 »
My projects are on Gitlab and on Codeberg.

Roland57

  • Sr. Member
  • ****
  • Posts: 421
    • msegui.net
Re: Never code like this
« Reply #27 on: August 19, 2022, 11:10:23 pm »
An animated example.

Code: Pascal  [Select][+][-]
  1. program Cardioid1;
  2.  
  3. {
  4.   Animation illustrating a method for drawing a cardioid
  5.   https://mathimages.swarthmore.edu/index.php/Cardioid
  6. }
  7.  
  8. uses
  9. {$IFDEF unix}
  10.   cThreads,
  11. {$ENDIF}
  12.   SysUtils,
  13.   ptcCrt,
  14.   ptcGraph,
  15.   Cairo;
  16.  
  17. const
  18.   COLOR_WIDTH = 4;
  19.  
  20. type
  21.   THeader = packed record
  22.     Width, Height, Reserved: longint;
  23.   end;
  24.  
  25.   TImage = packed record
  26.     Header: THeader;
  27.     Data: array[0..0] of byte;
  28.   end;
  29.  
  30.   PImage = ^TImage;
  31.  
  32. function CreateImage(const AWidth, AHeight: integer): PImage;
  33. begin
  34.   result := PImage(GetMem(SizeOf(THeader) + COLOR_WIDTH * AWidth * AHeight));
  35.   result^.Header.Width  := AWidth;
  36.   result^.Header.Height := AHeight;
  37. end;
  38.  
  39. procedure FreeImage(const AImage: PImage; const AWidth, AHeight: integer);
  40. begin
  41.   FreeMem(AImage, SizeOf(THeader) + COLOR_WIDTH * AWidth * AHeight);
  42. end;
  43.  
  44. function Cardioid(const AWidth, AHeight: integer): pcairo_surface_t;
  45. const
  46.   R = 0.15;
  47.   X = -R;
  48.   Y = 0;
  49. var
  50.   ctx: pcairo_t;
  51.   a, xx, yy: double;
  52. const
  53.   D = 0.3;
  54. begin
  55.   result := cairo_image_surface_create(CAIRO_FORMAT_ARGB32, AWidth, AHeight);
  56.   ctx := cairo_create(result);
  57.   cairo_scale(ctx, AWidth, AHeight);
  58.   cairo_translate(ctx, 1 / 2, 1 / 2);
  59.  
  60.   a := 0;
  61.   while a < 2 * PI do
  62.   begin
  63.     xx := 2 * R * Cos(a) * (1 + Cos(a)) + X;
  64.     yy := 2 * R * Sin(a) * (1 + Cos(a)) + Y;
  65.    
  66.     if a = 0 then
  67.       cairo_move_to(ctx, xx, yy)
  68.     else
  69.       cairo_line_to(ctx, xx, yy);
  70.    
  71.     a := a + PI / 49;
  72.   end;
  73.  
  74.   cairo_set_line_width(ctx, 1 / 300);
  75.   cairo_set_source_rgb(ctx, 1, 0, 0);
  76.   cairo_stroke(ctx);
  77.   cairo_destroy(ctx);
  78. end;
  79.  
  80. procedure CairoDraw(var AImage: TImage; const ABackground: pcairo_surface_t; const AAngle: double);
  81. var
  82.   sfc: pcairo_surface_t;
  83.   ctx: pcairo_t;
  84.   str: integer;
  85. const
  86.   R = 0.15;
  87.   X = -R;
  88.   Y = 0;
  89. var
  90.   xx, yy, rr: double;
  91. const
  92.   D = 0.3;
  93. var
  94.   dx, dy: double;
  95.   xx1, yy1, xx2, yy2: double;
  96. begin
  97.   str := cairo_format_stride_for_width(CAIRO_FORMAT_ARGB32, AImage.Header.Width);
  98.   sfc := cairo_image_surface_create_for_data(@AImage.Data[0], CAIRO_FORMAT_ARGB32, AImage.Header.Width, AImage.Header.Height, str);
  99.   ctx := cairo_create(sfc);
  100.  
  101.   cairo_set_source_rgb(ctx, 1.0, 1.0, 1.0);
  102.   cairo_paint(ctx);
  103.  
  104.   cairo_set_source_surface(ctx, ABackground, 0, 0);
  105.   cairo_paint(ctx);
  106.  
  107.   cairo_scale(ctx, AImage.Header.Width, AImage.Header.Height);
  108.   cairo_translate(ctx, 0.5, 0.5);
  109.  
  110.   cairo_set_line_width(ctx, 1 / 400);
  111.  
  112.   cairo_set_source_rgb(ctx, 0, 0, 1);
  113.   cairo_arc(ctx, 0, 0, R, 0, 2 * PI);
  114.   cairo_stroke(ctx);
  115.  
  116.   cairo_set_source_rgb(ctx, 0, 0, 0);
  117.   cairo_arc(ctx, X, Y, 1 / 150, 0, 2 * PI);
  118.   cairo_fill(ctx);
  119.  
  120.   xx := R * Cos(AAngle);
  121.   yy := R * Sin(AAngle);
  122.  
  123.   dx := xx - X;
  124.   dy := yy - Y;
  125.  
  126.   rr := Sqrt(Sqr(dx) + Sqr(dy));
  127.  
  128.   xx1 := xx - (D / rr) * dx;
  129.   yy1 := yy - (D / rr) * dy;
  130.   xx2 := xx + (D / rr) * dx;
  131.   yy2 := yy + (D / rr) * dy;
  132.  
  133.   cairo_set_source_rgba(ctx, 1, 0, 0, 0.5);
  134.   cairo_move_to(ctx, xx1, yy1);
  135.   cairo_line_to(ctx, xx2, yy2);
  136.   cairo_stroke(ctx);
  137.  
  138.   cairo_set_source_rgb(ctx, 0, 0, 0);
  139.   cairo_arc(ctx, xx, yy, 1 / 150, 0, 2 * PI);
  140.   cairo_arc(ctx, xx1, yy1, 1 / 150, 0, 2 * PI);
  141.   cairo_arc(ctx, xx2, yy2, 1 / 150, 0, 2 * PI);
  142.   cairo_fill(ctx);
  143.  
  144.   cairo_destroy(ctx);
  145.   cairo_surface_destroy(sfc);
  146. end;
  147.  
  148. const
  149.   SURFACE_WIDTH = 360;
  150.   SURFACE_HEIGHT = 360;
  151.  
  152. var
  153.   gd, gm, err: smallint;
  154.   img: PImage;
  155.   iw, ih, it, il: integer;
  156.   card: pcairo_surface_t;
  157.   ang: double;
  158.  
  159. begin
  160.   card := Cardioid(SURFACE_WIDTH, SURFACE_HEIGHT);
  161.  
  162.   WindowTitle := 'A method for drawing a cardioid';
  163.   gd := VESA;
  164.   gm := m640x480x16m;
  165.   InitGraph(gd, gm, '');
  166.   err := GraphResult;
  167.  
  168.   if err = grOK then
  169.   begin
  170.     SetBkColor($808080);
  171.     ClearDevice;
  172.    
  173.     iw := SURFACE_WIDTH;
  174.     ih := SURFACE_HEIGHT;
  175.     il := (Succ(GetMaxX) - iw) div 2;
  176.     it := (Succ(GetMaxY) - ih) div 2;
  177.    
  178.     img := CreateImage(iw, ih);
  179.    
  180.     ang := 0;
  181.     while not KeyPressed do
  182.     begin
  183.       CairoDraw(img^, card, ang);
  184.       PutImage(il, it, img^, NormalPut);
  185.      
  186.       Delay(60);
  187.      
  188.       ang := ang + PI / 18;
  189.       if ang > 2 * pi then
  190.         ang := ang - 2 * pi;
  191.     end;
  192.    
  193.     ReadKey;
  194.     CloseGraph;
  195.     FreeImage(img, iw, ih);
  196.   end;
  197.  
  198.   cairo_surface_destroy(card);
  199. end.
My projects are on Gitlab and on Codeberg.

Fred vS

  • Hero Member
  • *****
  • Posts: 3158
    • StrumPract is the musicians best friend
Re: Never code like this
« Reply #28 on: August 20, 2022, 01:02:09 am »
An animated example.

Totally impressed, the animation is very fluid, here on Linux 64 bit, binary is only 600k and no memory leak, big WOW!  ;D

Fre;D
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

BobDog

  • Sr. Member
  • ****
  • Posts: 394
Re: Never code like this
« Reply #29 on: August 20, 2022, 06:04:08 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.  

 

TinyPortal © 2005-2018