Lazarus

Free Pascal => Beginners => Topic started by: Petri on July 11, 2022, 01:03:00 am

Title: Never code like this
Post by: Petri on July 11, 2022, 01:03:00 am
Never code like this unless you are much more an algorithmic artist like me than a coder and you only want to make colorful  pictures.
Code: Pascal  [Select][+][-]
  1. program pointsbypoint;
  2. uses graph,Crt,math;
  3. VAR     gd,gm                   :       integer;
  4.         PathToDriver    :       string = '';
  5.         color                   :       word;
  6.         maxx,maxy               :       smallint;
  7.         x,y,x0,y0,x1,y1,x2,y2   :       word;
  8.         dist1,dist2,image               :       word;
  9.         xp,yp,
  10.         factor1,factor2,factor3 :       Real;
  11. PROCEDURE MYINITIALIZATION;
  12. BEGIN
  13.    Randomize;
  14.    gd:=detect;  
  15.    gm:=0;
  16.    InitGraph(gd,gm,PathToDriver);
  17.    IF GraphResult<>grok THEN
  18.    BEGIN
  19.      closegraph;
  20.      halt;
  21.    END;
  22.    maxx:=GetMaxX;
  23.    maxy:=GetMaxY;
  24. END;
  25. PROCEDURE LETSSTART;
  26. BEGIN
  27.    Randomize;
  28.    x0:=Random(maxx);
  29.    y0:=Random(maxy);
  30.    x1:=Random(maxx);
  31.    y1:=Random(maxy);
  32.    x2:=Random(maxx);
  33.    y2:=Random(maxy);
  34.    factor1:=Random(1000)/10000;
  35.    factor2:=Random(1000)/10000;
  36.    factor3:=Random(1000)/10000;
  37. END;
  38. BEGIN
  39.         MYINITIALIZATION;
  40.         FOR image:=1 TO 10 DO
  41.                 BEGIN;
  42.                         LETSSTART;
  43.                         for x:=0 to (maxx-1) do
  44.                                 for y:=0 to (maxy-1) do
  45.                                         begin
  46.                                                 xp:=x*factor1;
  47.                                                 yp:=y*factor2;
  48.                                                 dist1:=trunc(Sqrt(((x0-x1)*(x0-x1)+(y0-y1)*(y0-y1))));
  49.                                                 dist2:=trunc(Sqrt(((x0-x2)*(x0-x2)+(y0-y2)*(y0-y2))));
  50.                                                 color:=abs(trunc(0.0005*(sin(factor3*xp)*x+0.001*dist2)*(yp-xp)*0.002*dist1));
  51.                                                 IF Keypressed THEN halt;
  52.                                                 PutPixel(x,y,color);
  53.                                         end;
  54.                 END;
  55. END.
Title: Re: Never code like this
Post by: creaothceann on July 19, 2022, 11:05:57 am
Code: Pascal  [Select][+][-]
  1. program PointsByPoint;
  2. uses
  3.         CRT, Graph, Math;
  4.  
  5.  
  6. function InitGraphics : boolean;
  7. var
  8.         Driver, Mode : SmallInt;
  9. begin
  10.         Driver := Graph.Detect;
  11.         Mode   := 0;
  12.         InitGraph(Driver, Mode, '');
  13.         Result := (GraphResult = grOK);
  14.         if not Result then CloseGraph;
  15. end;
  16.  
  17.  
  18. var
  19.         MaxX, MaxY : SmallInt;
  20.  
  21.  
  22. procedure Render(
  23.         const x0, y0 : Word;  const Factor1 : Real;
  24.         const x1, y1 : Word;  const Factor2 : Real;
  25.         const x2, y2 : Word;  const Factor3 : Real);
  26. var
  27.         Color        : Word;
  28.         Dist1, Dist2 : Word;
  29.         x, y         : Word;
  30.         xp, yp       : Real;
  31. begin
  32.         Dec(MaxX);
  33.         Dec(MaxY);
  34.         for y := 0 to MaxY do begin
  35.                 yp := y * Factor2;
  36.                 for x := 0 to MaxX do begin
  37.                         xp    := x * Factor1;
  38.                         Dist1 := Trunc(Sqrt(((x0 - x1) * (x0 - x1) + (y0 - y1) * (y0 - y1))));
  39.                         Dist2 := Trunc(Sqrt(((x0 - x2) * (x0 - x2) + (y0 - y2) * (y0 - y2))));
  40.                         Color := Abs(Trunc(0.0005 * (Sin(Factor3 * xp) * x + 0.001 * Dist2) * (yp - xp) * 0.002 * Dist1));
  41.                         PutPixel(x, y, Color);
  42.                         // writing to a line array in main RAM and transferring that line at once would probably be much faster
  43.                 end;
  44.                 if KeyPressed then Halt;
  45.         end;
  46. end;
  47.  
  48.  
  49. begin
  50.         if not InitGraphics then Halt;
  51.         Randomize;
  52.         MaxX := GetMaxX;
  53.         MaxY := GetMaxY;
  54.         Render(
  55.                 Random(MaxX), Random(MaxY), Random(1000) / 10000,
  56.                 Random(MaxX), Random(MaxY), Random(1000) / 10000,
  57.                 Random(MaxX), Random(MaxY), Random(1000) / 10000);
  58. end.
Title: Re: Never code like this
Post by: Weiss on August 04, 2022, 12:33:10 am
In FPC graph unit, how do we save graph into an image file? I made a little application to process numerical data into nice graphs. But don't see any function within graph unit that would relate to saving results. 

Turbo Pascal 6 speaks about saving image onto heap by assigning it to a pointer. I am still digging through all this, but  it will be appreciated if someone gave me a little hint. What do I do with a pointer, how do I save image to file?

Sorry for silly questions, low time student here.  I was going to post a separate topic, but I see your graph is saved, how do you do that?
Title: Re: Never code like this
Post by: Fred vS on August 04, 2022, 02:40:36 am
... I see your graph is saved, how do you do that?

Hello.

At the bottom of the picture of the OP, there is the Windows taskbar.
So maybe it was a screenshot when the program was running.
Title: Re: Never code like this
Post by: QuinnMartin on August 17, 2022, 04:56:06 pm
>writing to a line array in main RAM and transferring that line at once would probably be much faster

How would do you do that?

I've never been very impressed with the speed of canvas line and pixel drawing in Delphi, and I figure Lazarus isn't much faster.  Even with double buffering it's slow.
Title: Re: Never code like this
Post by: BobDog on August 17, 2022, 05:50:00 pm

My fpc 3.2.2 doesn't accept result.(Windows)
I have to
{$mode objfpc}
to use result.
(Geany)
Can anybody tell me how to get a pointer to a graph screen.
I want to try libcairo with the unit graph.
thank you.
Title: Re: Never code like this
Post by: Roland57 on August 17, 2022, 07:14:27 pm
Can anybody tell me how to get a pointer to a graph screen.
I want to try libcairo with the unit graph.
thank you.

Not exactly what you ask for, but here is an example of drawing with AggPas in a ptcGraph window. Maybe you could adapt it.

If you succeed, I would be very interested to see the result!  :)
Title: Re: Never code like this
Post by: BobDog on August 18, 2022, 12:33:26 am
Thanks Roland.
Having no luck so far.
I can't even get your source to compile

agg_pixfmt_rgb_packed  not found

and I cannot compile the unit pctgraph
(... Error: Illegal unit name: ptcgraph (expecting PROGRAM))
Title: Re: Never code like this
Post by: Roland57 on August 18, 2022, 07:02:06 am
Having no luck so far.
I can't even get your source to compile

The example uses a modified version of AggPas, but I don't remember how I got that modified version.  :-[

In case you would try it, I put the example with modified AggPas here: aggpas-ptcgraph-example.zip (https://www.msegui.net/roland/temp/aggpas-ptcgraph-example.zip)

But even without compiling the example, you could take inspiration from it. The interesting part is how the example uses the PutImage procedure.

and I cannot compile the unit pctgraph
(... Error: Illegal unit name: ptcgraph (expecting PROGRAM))

I don't know how you got that error.

To be sure, can you compile this simple program?

Code: Pascal  [Select][+][-]
  1. program Hello;
  2.  
  3. uses
  4. {$IFDEF unix}
  5.   cThreads,
  6. {$ENDIF}
  7.   ptcCrt, ptcGraph;
  8.  
  9. var
  10.   s: string;
  11.   gd, gm: smallint;
  12.   err: smallint;
  13.  
  14. begin
  15.   gd := VGA;
  16.   gm := VGAHi;
  17.   InitGraph(gd, gm, '');
  18.   SetBkColor(Blue);
  19.   SetColor(Yellow);
  20.   err := GraphResult;
  21.   if err = grOK then
  22.   begin
  23.     s := 'Hello world by ptcGraph';
  24.     OutTextXY(
  25.       (GetMaxX - TextWidth (s)) div 2,
  26.       (GetMaxY - TextHeight(s)) div 2,
  27.       s
  28.     );
  29.     ReadKey;
  30.     CloseGraph;
  31.   end;
  32. end.
  33.  
Title: Re: Never code like this
Post by: BobDog on August 18, 2022, 08:50:01 am

Hi Roland.
roland.pas(7,3) Fatal: Can't find unit ptcCrt used by Hello.
I'll need to get a pointer to a graphics screen buffer for libcairo --(cairo_image_surface_create_for_data(pointer, ...)
I can do it OK with a gfx screen (screenptr), but this means using another .dll file.
I could perhaps just use the console, I have not looked into that yet.
Thanks for the aggpas link, I'll have a look through that for inspiration??




Title: Re: Never code like this
Post by: PascalDragon on August 18, 2022, 08:52:24 am
My fpc 3.2.2 doesn't accept result.(Windows)
I have to
{$mode objfpc}
to use result.

The default mode of FPC is FPC which is more compatible to TP than to Delphi and which means that the Result variable inside functions is not activated. You either need to use one of the Object Pascal modes (ObjFPC or Delphi) or you need to explicitly enable the corresponding modeswitch ($ModeSwitch Result). Alternatively you can always use the name of the function as the result variable (this also works when Result is available).
Title: Re: Never code like this
Post by: Roland57 on August 18, 2022, 09:45:05 am
roland.pas(7,3) Fatal: Can't find unit ptcCrt used by Hello.

I wonder whether something is not broken in your FPC installation. AFAIK ptcCrt is shipped with FPC...

I could perhaps just use the console, I have not looked into that yet.

Do you wish to use ptcGraph, or are you looking for any way to draw (in a window) with Cairo?

It's easy to create an image in a console program. And you can also draw with Cairo in a standard Lazarus window. I posted a collection of examples here (https://forum.lazarus.freepascal.org/index.php/topic,57657.msg428978.html#msg428978).


Title: Re: Never code like this
Post by: Roland57 on August 18, 2022, 01:21:42 pm
Draw using Cairo in a window created with ptcGraph.  :)

Code: Pascal  [Select][+][-]
  1. program CairoTest;
  2.  
  3. uses
  4. {$IFDEF unix}
  5.   cThreads,
  6. {$ENDIF}
  7.   ptcCrt, ptcGraph, Cairo;
  8.  
  9. const
  10.   IMAGE_WIDTH  = 800;
  11.   IMAGE_HEIGHT = 600;
  12.   COLOR_WIDTH  =   4;
  13.  
  14. type
  15.   TImage = packed record
  16.     width, height, reserved: longint;
  17.     data: array[0..IMAGE_WIDTH * IMAGE_HEIGHT * COLOR_WIDTH - 1] of byte;
  18.   end;
  19.  
  20. procedure CairoDraw(var AImage: TImage);
  21. var
  22.   surface: pcairo_surface_t;
  23.   context: pcairo_t;
  24.   stride: integer;
  25. begin
  26.   stride := cairo_format_stride_for_width(CAIRO_FORMAT_ARGB32, IMAGE_WIDTH);
  27.   surface := cairo_image_surface_create_for_data(AImage.data, CAIRO_FORMAT_ARGB32, IMAGE_WIDTH, IMAGE_HEIGHT, stride);
  28.   context := cairo_create(surface);
  29.   cairo_set_source_rgb(context, 1.0, 1.0, 0.0);
  30.   cairo_paint(context);
  31.   cairo_scale(context, IMAGE_WIDTH, IMAGE_HEIGHT);
  32.   cairo_set_line_width(context, 0.1);
  33.   cairo_arc_negative(context, 0.5, 0.5, 0.4, PI / 2, 3 * PI / 2);
  34.   cairo_set_source_rgb(context, 0.0, 1.0, 0.0);
  35.   cairo_stroke(context);
  36.   cairo_destroy(context);
  37.   //cairo_surface_write_to_png(surface, pchar('image.png'));
  38.   cairo_surface_destroy(surface);
  39. end;
  40.  
  41. var
  42.   gd, gm, err: smallint;
  43.   image: TImage;
  44.  
  45. begin
  46.   FillByte(image, SizeOf(image), 0);
  47.  
  48.   image.width := IMAGE_WIDTH;
  49.   image.height := IMAGE_HEIGHT;
  50.  
  51.   CairoDraw(image);
  52.  
  53.   gd := VESA;
  54.   gm := m800x600x16m;
  55.   InitGraph(gd, gm, '');
  56.   err := GraphResult;
  57.   if err = grOK then
  58.   begin
  59.    {SetBkColor($FF00FF);
  60.     ClearDevice;
  61.     ReadKey;}
  62.     PutImage(0, 0, image, NormalPut);
  63.     ReadKey;
  64.     CloseGraph;
  65.   end;
  66. end.

Observations and suggestions welcome.
Title: Re: Never code like this
Post by: Fred vS on August 18, 2022, 05:36:37 pm
Draw using Cairo in a window created with ptcGraph.  :)

Code: Pascal  [Select][+][-]
  1. program CairoTest;
  2.  
  3. uses
  4. {$IFDEF unix}
  5.   cThreads,
  6. {$ENDIF}
  7.   ptcCrt, ptcGraph, Cairo;
  8.  
  9. const
  10.   IMAGE_WIDTH  = 800;
  11.   IMAGE_HEIGHT = 600;
  12.   COLOR_WIDTH  =   4;
  13.  
  14. type
  15.   TImage = packed record
  16.     width, height, reserved: longint;
  17.     data: array[0..IMAGE_WIDTH * IMAGE_HEIGHT * COLOR_WIDTH - 1] of byte;
  18.   end;
  19.  
  20. var
  21.   gd, gm: smallint;
  22.   err: smallint;
  23.   surface: pcairo_surface_t;
  24.   context: pcairo_t;
  25.   image: TImage;
  26.   stride: integer;
  27.  
  28. begin
  29.   image.width := IMAGE_WIDTH;
  30.   image.height := IMAGE_HEIGHT;
  31.   stride := cairo_format_stride_for_width(CAIRO_FORMAT_ARGB32, IMAGE_WIDTH);
  32.   surface := cairo_image_surface_create_for_data(image.data, CAIRO_FORMAT_ARGB32, IMAGE_WIDTH, IMAGE_HEIGHT, stride);
  33.   context := cairo_create(surface);
  34.   cairo_set_source_rgb(context, 1.0, 1.0, 0.0);
  35.   cairo_paint(context);
  36.   cairo_scale(context, IMAGE_WIDTH, IMAGE_HEIGHT);
  37.   cairo_set_line_width(context, 0.1);
  38.   cairo_arc_negative(context, 0.5, 0.5, 0.4, PI / 2, 3 * PI / 2);
  39.   cairo_set_source_rgb(context, 0.0, 1.0, 0.0);
  40.   cairo_stroke(context);
  41.   cairo_destroy(context);
  42.   //cairo_surface_write_to_png(surface, pchar('image.png'));
  43.   cairo_surface_destroy(surface);
  44.  
  45.   gd := VESA;
  46.   gm := m800x600x16m;
  47.   InitGraph(gd, gm, '');
  48.   SetBkColor(White);
  49.   err := GraphResult;
  50.   if err = grOK then
  51.   begin
  52.     PutImage(0, 0, image, NormalPut);
  53.     ReadKey;
  54.     CloseGraph;
  55.   end;
  56. end.

Observations and suggestions welcome.

Hello Roland.

Very nice!

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
Title: Re: Never code like this
Post by: BobDog on August 18, 2022, 11:56:28 pm

Hi Roland.
Your code:
Code: Pascal  [Select][+][-]
  1. program CairoTest;
  2.  
  3. uses
  4. {$IFDEF unix}
  5.   cThreads,
  6. {$ENDIF}
  7.   ptcCrt, ptcGraph, Cairo;
  8.  
  9. const
  10.   IMAGE_WIDTH  = 800;
  11.   IMAGE_HEIGHT = 600;
  12.   COLOR_WIDTH  =   4;
  13.  
  14. type
  15.   TImage = packed record
  16.     width, height, reserved: longint;
  17.     data: array[0..IMAGE_WIDTH * IMAGE_HEIGHT * COLOR_WIDTH - 1] of byte;
  18.   end;
  19.  
  20. var
  21.   gd, gm: smallint;
  22.   err: smallint;
  23.   surface: pcairo_surface_t;
  24.   context: pcairo_t;
  25.   image: TImage;
  26.   stride: integer;
  27.  
  28.  // font stuff------------------
  29.   var
  30. _fonts : cairo_font_extents_t ;
  31. _text  : cairo_text_extents_t;
  32.  
  33.  
  34. procedure InitFonts(surf: pcairo_t;fonttype:pchar);
  35. begin
  36.     cairo_select_font_face (surf,fonttype, CAIRO_FONT_SLANT_NORMAL, CAIRO_FONT_WEIGHT_BOLD);
  37.     cairo_font_extents (surf, @_fonts);
  38. End;
  39.  
  40. procedure print(surf: pcairo_t;x,y:single;text:pchar;size,rd,gr,bl:single);
  41. begin
  42.     cairo_set_font_size (surf,(size));
  43.     cairo_move_to (surf,  //                lower left corner of text
  44.     (x) - (_text.width / 2 + _text.x_bearing),
  45.     (y) + (_text.height / 2) - _fonts.descent);
  46.     cairo_set_source_rgb(surf,rd,gr,bl);
  47.     cairo_show_text(surf, text);
  48.     cairo_stroke(surf);
  49. End;
  50. //--------------------------------------
  51.  
  52. begin
  53.   image.width := IMAGE_WIDTH;
  54.   image.height := IMAGE_HEIGHT;
  55.   stride := cairo_format_stride_for_width(CAIRO_FORMAT_ARGB32, IMAGE_WIDTH);
  56.   surface := cairo_image_surface_create_for_data(image.data, CAIRO_FORMAT_ARGB32, IMAGE_WIDTH, IMAGE_HEIGHT, stride);
  57.   context := cairo_create(surface);
  58.   cairo_set_source_rgb(context, 1.0, 1.0, 0.0);
  59.   cairo_paint(context);
  60.  
  61.   initfonts(context,'georgia');
  62.   print(context,50,50,'Thank you Roland',35,0,0.5,1);
  63.   print(context,50,150,'Finally got it running in Geany ide.',20,1,0,0);
  64.  
  65.   cairo_scale(context, IMAGE_WIDTH, IMAGE_HEIGHT);
  66.   cairo_set_line_width(context, 0.1);
  67.   cairo_arc_negative(context, 0.5, 0.5, 0.4, PI / 2, 3 * PI / 2);
  68.   cairo_set_source_rgb(context, 0.0, 1.0, 0.0);
  69.   cairo_stroke(context);
  70.   cairo_destroy(context);
  71.   //cairo_surface_write_to_png(surface, pchar('image.png'));
  72.   cairo_surface_destroy(surface);
  73.  
  74.   gd := VESA;
  75.   gm := m800x600x16m;
  76.   InitGraph(gd, gm, '');
  77.   SetBkColor(White);
  78.   err := GraphResult;
  79.   if err = grOK then
  80.   begin
  81.     PutImage(0, 0, image, NormalPut);
  82.     ReadKey;
  83.     CloseGraph;
  84.   end;
  85. end.
  86.  
Title: Re: Never code like this
Post by: Roland57 on August 19, 2022, 08:10:57 am
Hi BobDog. Great! (Geany is also my favourite editor.)

I edited my example (https://forum.lazarus.freepascal.org/index.php/topic,59894.msg450612.html#msg450612), trying to organize it a little better (without essential change).

@Fred

Thanks for testing and information.
Title: Re: Never code like this
Post by: PascalDragon 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. ::)
Title: Re: Never code like this
Post by: Roland57 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.  
Title: Re: Never code like this
Post by: AlexTP 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.
Title: Re: Never code like this
Post by: PascalDragon 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.
Title: Re: Never code like this
Post by: Fred vS 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 )
Title: Re: Never code like this
Post by: Roland57 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.
Title: Re: Never code like this
Post by: Fred vS 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.
Title: Re: Never code like this
Post by: Roland57 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.  :)
Title: Re: Never code like this
Post by: Fred vS 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.  :-[
Title: Re: Never code like this
Post by: PascalDragon 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.
Title: Re: Never code like this
Post by: Roland57 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.
Title: Re: Never code like this
Post by: Roland57 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.
Title: Re: Never code like this
Post by: Fred vS 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
Title: Re: Never code like this
Post by: BobDog 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.  
Title: Re: Never code like this
Post by: Fred vS 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}
Title: Re: Never code like this
Post by: Roland57 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.  :)
Title: Re: Never code like this
Post by: PascalDragon 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 (https://www.freepascal.org/docs-html/rtl/system/freemem.html) 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).
Title: Re: Never code like this
Post by: Roland57 on August 20, 2022, 08:51:23 pm
Interesting. I didn't know. Thanks!
TinyPortal © 2005-2018