Recent

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

Petri

  • New member
  • *
  • Posts: 9
Never code like this
« 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.

creaothceann

  • Full Member
  • ***
  • Posts: 117
Re: Never code like this
« Reply #1 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.

Weiss

  • New Member
  • *
  • Posts: 22
Re: Never code like this
« Reply #2 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?

Fred vS

  • Hero Member
  • *****
  • Posts: 2734
    • StrumPract is the musicians best friend
Re: Never code like this
« Reply #3 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.
« Last Edit: August 04, 2022, 02:42:33 am 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

QuinnMartin

  • New Member
  • *
  • Posts: 13
Re: Never code like this
« Reply #4 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.

BobDog

  • Sr. Member
  • ****
  • Posts: 329
Re: Never code like this
« Reply #5 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.

Roland57

  • Sr. Member
  • ****
  • Posts: 310
Re: Never code like this
« Reply #6 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!  :)
« Last Edit: August 17, 2022, 07:16:46 pm by Roland57 »

BobDog

  • Sr. Member
  • ****
  • Posts: 329
Re: Never code like this
« Reply #7 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))
« Last Edit: August 18, 2022, 12:38:21 am by BobDog »

Roland57

  • Sr. Member
  • ****
  • Posts: 310
Re: Never code like this
« Reply #8 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

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.  

BobDog

  • Sr. Member
  • ****
  • Posts: 329
Re: Never code like this
« Reply #9 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??





PascalDragon

  • Hero Member
  • *****
  • Posts: 4573
  • Compiler Developer
Re: Never code like this
« Reply #10 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).

Roland57

  • Sr. Member
  • ****
  • Posts: 310
Re: Never code like this
« Reply #11 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.



Roland57

  • Sr. Member
  • ****
  • Posts: 310
Re: Never code like this
« Reply #12 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.
« Last Edit: August 18, 2022, 06:53:12 pm by Roland57 »

Fred vS

  • Hero Member
  • *****
  • Posts: 2734
    • StrumPract is the musicians best friend
Re: Never code like this
« Reply #13 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
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: 329
Re: Never code like this
« Reply #14 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.  

 

TinyPortal © 2005-2018