[offtopic] FreePascal

For other topics related to the FreeBASIC project or its community.
marcov
Posts: 2778
Joined: Jun 16, 2005 9:45
Location: Eindhoven, NL
Contact:

Re: [offtopic] FreePascal

Postby marcov » Oct 18, 2018 14:40

I did some quick tests:

FPC 3.0.4/32 : 7.1s
FPC 3.3.1/32 (trunk, month old) : 7.5 SLOWER!
FPC 3.3.1/64 (trunk, month old): 4.7 faster.

So it seems that 32/64=3/2

this is the fact that 64-bit uses SSE2 instead of x87, which can be seen readily by passing -Cfsse3 to the 32-bit compiler.

The the 32-bit compiler also uses SSE, and the results are in the same magnitude as 64-bit.
Carlos Herrera
Posts: 78
Joined: Nov 28, 2011 13:29
Location: Dictatorship

Re: [offtopic] FreePascal

Postby Carlos Herrera » Oct 19, 2018 15:00

marcov wrote:...The the 32-bit compiler also uses SSE, and the results are in the same magnitude as 64-bit.

Speed is one factor, another is accuracy. Please consider the following program

Code: Select all

(*-----------------------------------------------------------------------*)
(* EPSMACH computes the machine accuracy u (1.0+u>1.0,1.0+u/2=1.0)       *)
(*-----------------------------------------------------------------------*)
VAR II: INTEGER;
VAR ONE,TWO,U,EPSMACH: double;
BEGIN
   II:= 0;
   ONE:=1.0; TWO:=2.0; U:=1.0;
    REPEAT
      U:=U/TWO;
      II:=II+1;
    UNTIL ( (ONE+U)=ONE );
    EPSMACH := TWO*U;
    writeln (II, EPSMACH);
    readln;
END.

which is adopted from O. Montenbruck, T. Pfleger, Astronomy on the Personal Computer (Springer, 1998).

Free Pascal (3.0.4) results are:
53, 2.2204460...E-16.
Exactly the same results are obtained for FB64, however, FB32 (1.05.0) gives
64, 1.0842921..E-19.

So, apparently FB32 uses x87 instruction set, which is more accurate but slower...
marcov
Posts: 2778
Joined: Jun 16, 2005 9:45
Location: Eindhoven, NL
Contact:

Re: [offtopic] FreePascal

Postby marcov » Oct 19, 2018 21:06

Carlos Herrera wrote:Free Pascal (3.0.4) results are:
53, 2.2204460...E-16.


Probably a 64-bit or -Cfsse2 variant then, since stock 3.0.4 (32-bit) gives

64 1.0842021724855044E-019
dodicat
Posts: 5943
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: [offtopic] FreePascal

Postby dodicat » Oct 20, 2018 1:03

my first pascal code since virtual pascal.

Code: Select all

 
program fibonacci;

uses
strutils;
   var
   z:integer;


Function fib(n :Integer): ansistring;
var
 n_,x,cn,dummy :longint;
 addup,addcarry,diff,LL:longint;
 sl,l,term:ansistring;
 label
 skip,oot,fin;

 Type 
  TA = Array[0..19] of longint;
  var
  addqmod,addbool:TA;
 // set lookup arrays
  begin
   for x:=0 to 9 do
   begin
   AddQmod[x]:=x+48;
   addqmod[x+10]:=x+48;
   addbool[x]:=0;
   addbool[x+10]:=1;
   end;
     // ====  first 4 numbers are  0 1 1 2  =====   according to wiki //
    if (n=1) then
    begin
      fib:='0';
      goto fin
      end;

    if (n=2) or (n=3) then
    begin
    fib:='1';
    goto fin;
    end;

    if (n=4) then
        fib:= '2'
        else
        begin
        sl:='1';
        l:='2' ;
    For x := 1 To n-4  do
    begin
    LL:=Length(l);
    diff:=0;
    if LL <> length(sl) then  diff:=1 ;
       addcarry:=0;
       term:='0'+l ;
      For n_ :=LL-1 downTo diff do
      begin
            addup:=ord(sl[n_-diff+1])+ord(l[n_+1])-96 ;
            ord(term[n_+1+1]):=ADDQmod[addup+addcarry] ;
            addcarry:=ADDbool[addup+addcarry];
        end;//next n_
           If addcarry=0 Then
             begin
           if term[1]='0' then term:=midstr(term,2,length(term)-1);Goto skip;
             end;
        If n_= 0      Then
          begin
          ord(term[1]):=addcarry+48  ;Goto skip;
          end;
           cn:=n_+1;
       For n_:=cn downTo 0 do
         dummy:=1;
       begin
            addup:=ord(l[n_+1])-48;
            ord(term[n_+1+1]):=ADDQmod[addup+addcarry];
            addcarry:=ADDbool[addup+addcarry];
            If (addcarry=0) Then goto oot;
       end; //next n_

        oot:
        ord(term[1]):=addcarry+48  ;
       if (addcarry=0) then
      begin
         if term[1]='0' then  term:=midstr(term,2,length(term)-1);
       end;
       skip:
        sl:=l ;
        l:=term;
        end;// next x
    fib:=term;
    end;{end if}
    fin:
    end;  {function}

// ===============   test function ============//
    begin
    writeln('num   fibonacci');
    for z:=1 to 500 do
      begin
    write(z); write('     ');
    writeln(fib(z));
    end;
    readln(z);  // stall exit
    end.

   

observation; The freepascal .chm files are grim. i had to google for help.
marcov
Posts: 2778
Joined: Jun 16, 2005 9:45
Location: Eindhoven, NL
Contact:

Re: [offtopic] FreePascal

Postby marcov » Oct 20, 2018 11:24

dodicat wrote:observation; The freepascal .chm files are grim. i had to google for help.


Unclear observation. Navigating, or content? For me they work fine.
dodicat
Posts: 5943
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: [offtopic] FreePascal

Postby dodicat » Oct 20, 2018 11:55

Marcov.
I had forgotten how to use VAL, it isn't in the ref.chm.
I had to google it.
I use ORD instead, but couldn't find it in the ref.chm either.
I use integer as parameter for fib, the ref.chm says it is either a smallint or a longint.
Looks like the 64 bit is longint and the 32 bit is shortint.
Maybe my code should have it as longint anyway.
Also the ref.chm crashes if I backspace in the index search if I want to change the search.
Win 10 of course, anything can happen.
marcov
Posts: 2778
Joined: Jun 16, 2005 9:45
Location: Eindhoven, NL
Contact:

Re: [offtopic] FreePascal

Postby marcov » Oct 20, 2018 12:53

dodicat wrote:Marcov.
I had forgotten how to use VAL, it isn't in the ref.chm.


True, it is in the units chm

I use ORD instead, but couldn't find it in the ref.chm either.


In RTL too, most procedure (real or internal) are.

I use integer as parameter for fib, the ref.chm says it is either a smallint or a longint.
Looks like the 64 bit is longint and the 32 bit is shortint.


No. Longint is 32-bit, integer is indeed 16-bit or 32-bit. 16-bit in TP and -like modes and 32-bit in most other modes.

Maybe my code should have it as longint anyway.
Also the ref.chm crashes if I backspace in the index search if I want to change the search.
Win 10 of course, anything can happen.


Note that the textmode IDE integrates all topics from registered helpfiles.

There are certainly issues, but mostly it works and is there.
dodicat
Posts: 5943
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: [offtopic] FreePascal

Postby dodicat » Oct 20, 2018 14:02

I have adapted the Dev-Pas ide .
I made a copy of ppcx64.exe, changed the name to ppc386.exe and popped it back into x86_64-win64 folder.
I set all the paths accordingly.
The text ide works OK, but a little awkward to work with.
Lazarus has the same problem as freepascal (no portable zip for win 10)?
The Dev-Pas ide is OK for what I want do in freepascal.
I'll remember to check all the help files next time.
Thank you.
dodicat
Posts: 5943
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: [offtopic] FreePascal

Postby dodicat » Oct 22, 2018 20:35

freepascal 64 bits optimized for speed, ~~ 750 ms.
freebasic 64 bits -O3 ~~ 550 ms.

Code: Select all

 

   program fac;
     uses
SysUtils,DateUtils;  { only for the timer }


   function factorial(num:longint):ansistring ; {standalone}
   type
     AT = array[0..99] of longint;
     var
     _mod,_div:at;
     fact,a,b,c:ansistring;
       pa,pb,pc:pchar;
     n,carry,ai:smallint;
    la,lb,i,j,z:longint;

      begin {create lookup  tables}
     for z:=0 to 99 do
     begin
     _mod[z]:= (z mod 10) +48;
     _div[z]:=  z div 10;
      end;  {created lookup tables}

       fact:='1';
      for z:=1 to num do
         begin
       a:=fact;Str(z,b);la:=Length(a);lb:=length(b);
       Setlength(c,la+lb);
       FillChar(c[1],la+lb,#48);
        pa:=@a[1]; {set pointers }
        pb:=@b[1];
        pc:=@c[1];
      for i:=la-1 downto 0 do
      begin
         carry:=0;ai:=ord(pa[i])-48 ;
      for j:= lb-1 downto 0 do
      begin
        n :=ai*(ord(pb[j])-48)+(ord(pc[i+j+1])-48)+carry;
        carry :=_Div[n];ord(pc[i+j+1]):=_Mod[n];
      end; {next j}
       ord(pc[i]):=ord(pc[i])+carry ;
      end; {next i}
      fact:=c;
      if c[1]='0' then fact:=copy(c,2,length(c)-1) ;
      end;{next z}
       factorial:=fact;
      end;{function}

 {===========  start ===========}
      var
      e:ansistring;
    num:longint;
  D1,D2: TDateTime;

       begin
       num:= 5000;
       writeln('factotial ',num,'  =  ');
       D1:=now;
       e:=  factorial(num);
       D2:=now;
       writeln(e);
       writeln( MilliSecondsBetween(D1, D2), ' milliseconds');
       readln(e);
       end.


 { '===========   freebasic code  ==================
   
Dim Shared As Ubyte _Mod_(0 To 99),_Div_(0 To 99)
For z As Long=0 To 99:_Mod_(z)=(z Mod 10+48):_Div_(z)=z\10:Next
   
    Function factorial(num As Long) As String
        Dim As String fact="1",a,b,c
        Dim As Ubyte n,carry,ai
        Dim As Long la,lb
        For z As Long=1 To num
            a=fact:b=Str(z):la=Len(a):lb=Len(b):c=String(la+lb,"0")
            For i As Long =la-1 To 0 Step -1
                carry=0:ai=a[i]-48
                For j As Long =lb-1 To 0 Step -1
                    n =ai*(b[j]-48)+(c[i+j+1]-48)+carry
                    carry =_Div_(n):c[i+j+1]=_Mod_(n)
                Next j
                c[i]+=carry
            Next i
            fact=Ltrim(c,"0")
        Next z
        Return fact
    End Function
    dim as double t1=timer
var f= factorial(5000)
dim as double t2=timer
print f
print (t2-t1)*1000;"  milliseconds"
sleep         }

 
dodicat
Posts: 5943
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: [offtopic] FreePascal

Postby dodicat » Oct 23, 2018 19:08

If somebody wants to try.
a short graphics.dll file for 64 bit freepascal.
file:
one.bas
pop into a folder and compile to .dll with freebasic 64 bit

Code: Select all

 
'one.bas --- a dll for 64 bit pascal
'compile with -dll
Extern "c"
Sub screen1 (Byval X As Integer, Byval Y As Integer,xres As Long,yres As Long,b As Long) Export
    Screenres xres,yres,b,,64
    Screencontrol(100, X, Y)
End Sub

Function createimage(w As Long,h As Long,clr As Ulong=Rgb(255,0,255)) As Any Ptr Export
    Return Imagecreate(w,h,clr)
End Function

Sub destroyimage(Byref i As Any Ptr) Export
    If i Then Imagedestroy i
End Sub

Sub putimage(i As Any Ptr,x As Long,y As Long,alph As Long=255) Export
    Put(x,y),i,Alpha, alph
End Sub

Sub font16 Export
    Dim As Integer x,y
    Screeninfo x,y
    Width x\8,y\16
End Sub

Sub clearcolor(c As Ulong) Export
    Color ,c
    Cls
End Sub

Function inkey1 As zstring Ptr Export
    Var i=Inkey
    Function= @i[0]
End Function

Function rgbcolor(r As Long,g As Long,b As Long,a As Long=64) As Ulong Export
    Return Rgba(r,g,b,a)
End Function

Sub drawstring (x As Long,y As Long, text As zstring Ptr,c As Ulong,i As Any Ptr=0) Export
    Draw String i,(x,y),*text,c
End Sub

Sub printdbl(n As Double,flag As Long=0) Export
    Select Case As Const flag
    Case 0:Print n
    Case 1:Print n,
    Case 2:Print n;
    Case Else
        Print n
    End Select
End Sub

Sub line1(x1 As Single,y1 As Single,x2 As Single,y2 As Single,c As Ulong,i As Any Ptr=0) Export
    Line i,(x1,y1)-(x2,y2),c
End Sub

Sub boxfill1(x1 As Single,y1 As Single,x2 As Single,y2 As Single,c As Ulong,i As Any Ptr=0) Export
    Line i,(x1,y1)-(x2,y2),c,bf
End Sub

Sub box1(x1 As Single,y1 As Single,x2 As Single,y2 As Single,c As Ulong,i As Any Ptr=0) Export
    Line i,(x1,y1)-(x2,y2),c,b
End Sub

Sub sleep1(t As Long) Export
    Sleep t
End Sub

Sub waitkey() Export
    Sleep
End Sub

Function randoms(n As Long) As Double Export
    Return Rnd*n
End Function

Sub circlefill1(x1 As Single,_
    y1 As Single,_
    rad As Single,_
    c As Ulong, _
    i As Any Ptr=0) Export
   
    Circle i,(x1,y1),rad,c,,,,f
End Sub

Sub circle1(x1 As Single,_
    y1 As Single,_
    rad As Single,_
    c As Ulong,_
    i As Any Ptr=0) Export
   
    Circle i,(x1,y1),rad,c
End Sub

Sub pset1(x1 As Single,y1 As Single,c As Ulong,im As Any Pointer=0) Export
    Pset im,(x1,y1),c
End Sub

Sub clearscreen1 Export
    Cls
End Sub

Sub endkey1 Export
    If Inkey=Chr(27) Then End
End Sub

Sub screenlock1 Export
    Screenlock
End Sub

Sub screenunlock1 Export
    Screenunlock
End Sub

Sub getmouse1( mx As Long Ptr, my As Long Ptr, mw As Long Ptr, mb As Long Ptr) Export
    Getmouse(*mx,*my,*mw,*mb)
End Sub
Sub locate1(x As Long,y As Long) Export
    Locate x,y
End Sub

Function framecounter() As Long Export
    Dim As Double t2=Timer
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function

Function regulate( MyFps As Long, fps As Long Ptr) As Long Export
    Static As Double timervalue,lastsleeptime,t3,frames
    frames+=1
    If (Timer-t3)>=1 Then t3=Timer:*fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

End Extern
 

pop this 64 bit freepascal code into the same folder and compile/run.

Code: Select all

 

program dll ;

uses
crt;   {only for beep}
 var
 e:integer;
 key,s:pchar;
 mx,my,mw,mb:integer;
 fps:integer;
 i:pointer;
 g:ansistring;
  procedure screen1(x:integer;y:integer;xres:integer;yres:integer;b:integer); external 'one.DLL';
  function  rgbcolor(red:integer;green:integer;blue:integer;alpha:integer=255):longword ; external 'one.DLL';
  procedure screenlock1;external 'one.DLL';
  procedure screenunlock1;external 'one.DLL';
  procedure clearcolor(c:longword); external 'one.DLL';
  procedure drawstring (x:integer;y:integer; text :ansistring;colour:longword;im:pointer=nil); external 'one.DLL';
  procedure clearscreen1 ; external 'one.DLL';
  procedure printdbl(n:double;flag :integer=0)external 'one.DLL';   // 0=newline 1= small space 2= big space
  procedure pset1(x1:single;y1:single;clr:longword;im:pointer=nil);external 'one.DLL';
  procedure circlefill1(x:single;y:single;rad:single;colour:longword;im:pointer=nil);external 'one.DLL';
  procedure circle1(x:single;y:single;rad:single;colour:longword;im:pointer=nil);external 'one.DLL';
  procedure line1(x1:single;y1:single;x2:single;y2:single;colour:longword;im:pointer=nil); external 'one.DLL';
  procedure box1(x1:single;y1:single;x2:single;y2:single;colour:longword;im:pointer=nil); external 'one.DLL';
  procedure boxfill1(x1:single;y1:single;x2:single;y2:single;colour:longword;im:pointer=nil); external 'one.DLL';
  procedure font16 ;external 'one.DLL';
  procedure getmouse1(out mx:integer;out my:integer;out mw:integer;out mb:integer); external 'one.DLL';
  procedure locate1(y:integer;x:integer); external 'one.DLL';
  procedure endkey1 ; external 'one.DLL';
  function inkey1 :pchar ; external 'one.DLL';
  procedure sleep1(t:integer); external 'one.DLL';
  function framecounter():Integer ; external 'one.DLL';
  procedure waitkey(); external 'one.DLL';
  Function regulate(MyFps:integer;out fps :integer):integer; external 'one.DLL';
  function randoms(n:integer):double; external 'one.DLL';
  function createimage(x:integer;y:integer;clr:longword):pointer; external 'one.DLL';
  procedure destroyimage(out i:pointer); external 'one.DLL';
  procedure putimage(i:pointer;x:integer;y:integer;alph:longword=255); external 'one.DLL';

procedure beep(f :integer=820;d:integer=100);
begin
  sound(f);
  delay(d);
  nosound;
end;
// create a moving ball//
type
 ball =object
x,y:single;
dx,dy:single;
procedure edges;
procedure move;
procedure draw;
end;

procedure ball.edges ;
begin
if x>780 then dx:=-dx;
if x<20 then dx:=-dx;
if y>580 then dy:=-dy;
if y<20 then dy:=-dy;
end;



procedure ball.move ;
begin
x:=x+dx ;
y:=y+dy ;
end;

procedure ball.draw ;
begin
circlefill1(x,y,20,rgbcolor(200,0,0));
end;

var
bl:ball;
var
x,y:integer;

begin
bl.x:=400;
bl.y:=300;
bl.dx:=1.5;
bl.dy:=1.3;

screen1(150,150,800,600,32);     //  set screen at 150,150 800 wide 600 high
font16;                          // optional - dosfont height = 16
clearcolor(rgbcolor(0,0,50));    // optional -- background colour

// make an image//

  i:=createimage(100,100,rgbcolor(200,0,0));
  for x:=10 to 90 do
  begin
  for y:=10 to 90 do
  begin
  pset1(x,y,rgbcolor(x,x xor y,y),i);    // create a pattern on image
  end;
  end;

  drawstring(20,20,'Image',rgbcolor(255,255,255),i);


//=============    START GRAPHICS =================//
while 1=1 do                     //  graphics loop
begin
key:=inkey1;                     // get a keypress
if key <>'' then g:=g+key;         // keep key value  if significant
 if key=' ' then g:='';           //  beep at space
screenlock1;                     // for smoothness lock the screen while drawing
clearscreen1;                    // clear at every frame
putimage(i,50,400);              // draw the image
// ball motion
bl.move;
bl.edges;
bl.draw;
drawstring(300,100,g,rgbcolor(200,200,200));                       // print string at location
drawstring(350,50,'hello, Press ecape to end.',rgbcolor(00,200,00)); //      ""
// basic shapes
circlefill1(400,300,100,rgbcolor(0,100,255));
circle1(400,300,110,rgbcolor(255,100,0));
boxfill1(450,350,550,450,rgbcolor(0,200,0,100));
box1(600,350,650,450,rgbcolor(0,200,0));
line1(20,550,400,590,rgbcolor(100,100,100));
for e:=1 to 5 do  // print some random numbers
begin
printdbl(randoms(1)); // print doubles
end;
getmouse1(mx,my,mw,mb); // retrieve mouse x,y and wheel and button
locate1(30,25);         // locate row,column
drawstring(200,450,'Mouse:',rgbcolor(0,100,100));
printdbl(mx,2);printdbl(my,2);printdbl(mw,2);printdbl(mb,2); // print the mouse returns
locate1(15,5);
drawstring(45,210,'Framerate',rgbcolor(200,0,0));
printdbl(fps);
 screenunlock1;              // unlock the screen
 sleep1(regulate(100,fps));  // sleep1(number of milliseconds), in this case sleep to get 100 frames per second
 if key=chr(27) then break
end;{while}


destroyimage(i); // delete the pointer
beep;


end. 
Roland Chastain
Posts: 851
Joined: Nov 24, 2011 19:49
Location: Dakar, Senegal
Contact:

Re: [offtopic] FreePascal

Postby Roland Chastain » Oct 24, 2018 8:45

Hello dodicat!

Very interesting, thank you. For me, I use 32 bit compilers. What do I need to change in your example?
marcov
Posts: 2778
Joined: Jun 16, 2005 9:45
Location: Eindhoven, NL
Contact:

Re: [offtopic] FreePascal

Postby marcov » Oct 24, 2018 10:18

dodicat wrote:freepascal 64 bits optimized for speed, ~~ 750 ms.
freebasic 64 bits -O3 ~~ 550 ms.


Your FB code doesn't time filling mod/div array, and your freepascal code does?
dodicat
Posts: 5943
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: [offtopic] FreePascal

Postby dodicat » Oct 24, 2018 10:39

Hi Roland.
My fpc 32 bit is not working
(unable to open fp.cfg my text ide says)
Anyway it is very old (2.4.4 or something)
But I do know that the compiler should be set Delphi compatible.
So I have the 64 bit version (Free Pascal Compiler version 3.0.4 [2018/02/25] for x86_64), a zip kindly sent to me by srvaldez.
I could of course download the 32 bit version, but it is a .exe installer, which I don't want to use here on Win 10.
Hi marcov
I have the lookup arrays shared in FB, but for the first run they are filled., and this is timed.
But anyway, I know that the pchar pointers are much faster than raw ansistring index, and the pointers are 0 based of course, which makes the translation from fb to fp easier.
Here is fibonacci converted to pchar.

Code: Select all

 
program fibonacci;

uses
SysUtils,DateUtils;
   var
     z:integer;

Function fib(n :longint): ansistring;
var
 n_,x:longint;
 addup,addcarry,diff,LL:longint;
 sl,l,term:ansistring;
 slp,lp,termp:pchar;
 label
 skip;

 Type 
  TA = Array[0..19] of longint;

  var
  addqmod,addbool:TA;

  begin  // set look up arrays
  term:='';
   for x:=0 to 9 do
   begin
   AddQmod[x]:=x+48;
   addqmod[x+10]:=x+48;
   addbool[x]:=0;
   addbool[x+10]:=1;
   end;

    if (n=1) then
    begin
      fib:='0';
      exit;
     // goto fin
      end;

    if (n=2) or (n=3) then
    begin
    fib:='1';
    exit;
   // goto fin;
    end;

    if (n=4) then
        fib:= '2'
        else
        begin
        sl:='1';
         l:='2' ;
    For x := 1 To n-4  do
    begin
    LL:=Length(l);
    diff:=0;
    if LL <> length(sl) then  diff:=1 ;
       addcarry:=0;
        term:='0'+l ;
         slp:=@sl[1];   // set pointers //
          lp:=@l[1];
       termp:=@term[1];

      For n_ :=LL-1 downTo diff do
      begin
            addup:=ord(slp[n_-diff])+ord(lp[n_])-96 ;
            ord(termp[n_+1]):=ADDQmod[addup+addcarry] ;
            addcarry:=ADDbool[addup+addcarry];
        end;//next n_

           If addcarry=0 Then
             begin
           if termp[0]='0' then term:=copy(term,2,length(term)-1) ;
           goto skip;
             end;

        If n_= 0      Then
          begin
          ord(termp[0]):=addcarry+48  ;
          goto skip;
          end;
           addup:=ord(lp[0])-48;
           ord(termp[1]):=ADDQmod[addup+addcarry];
           addcarry:=ADDbool[addup+addcarry];
        ord(termp[0]):=addcarry+48  ;
       if (addcarry=0) then
       begin
         if termp[0]='0' then  term:=copy(term,2,length(term)-1)
       end;
   skip:
        sl:=l ;
        l:=term;
        end;// next x

    fib:=term;

    end;{end if}

    //fin:
    end;  {function}

   //   test function fib //
   var
    D1,D2: TDateTime;
     ans:ansistring;
    begin
    writeln('Hang on...');
     d1:=Now ;
     ans:= fib(100000);
     d2:=Now;
      writeln(ans);
      Writeln( MilliSecondsBetween(D1, D2), ' milliseconds');

      for z:=1 to 20 do
      begin
      writeln(fib(z));
      end;
    readln(z);
    end.

 
dodicat
Posts: 5943
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: [offtopic] FreePascal

Postby dodicat » Oct 24, 2018 19:55

roland.
I have it running in 32 bits on 2.4.4

one.bas

Code: Select all

 
'one.bas --- a dll for 32 bit pascal
'compile with -dll
Extern "c"
Sub screen1 (Byval X As Integer, Byval Y As Integer,xres As Long,yres As Long,b As Long) Export
    Screenres xres,yres,b,,64
    Screencontrol(100, X, Y)
End Sub

Function createimage(w As Long,h As Long,clr As Ulong=Rgb(255,0,255)) As Any Ptr Export
    Return Imagecreate(w,h,clr)
End Function

Sub destroyimage(Byref i As Any Ptr) Export
    If i Then Imagedestroy i
End Sub

Sub putimage(i As Any Ptr,x As Long,y As Long,alph As Long=255) Export
    Put(x,y),i,Alpha, alph
End Sub

Sub font16 Export
    Dim As Integer x,y
    Screeninfo x,y
    Width x\8,y\16
End Sub

Sub clearcolor(c As Ulong) Export
    Color ,c
    Cls
End Sub

Function inkey1 As zstring Ptr Export
    static as string i:i=Inkey
    Function= @i[0]
End Function

Function rgbcolor(r As Long,g As Long,b As Long,a As Long=64) As Ulong Export
    Return Rgba(r,g,b,a)
End Function

Sub drawstring (x As Long,y As Long, text As zstring Ptr,c As Ulong,i As Any Ptr=0) Export
    Draw String i,(x,y),*text,c
End Sub

Sub printdbl(n As Double,flag As Long=0) Export
    Select Case As Const flag
    Case 0:Print n
    Case 1:Print n,
    Case 2:Print n;
    Case Else
        Print n
    End Select
End Sub

Sub line1(x1 As Single,y1 As Single,x2 As Single,y2 As Single,c As Ulong,i As Any Ptr=0) Export
    Line i,(x1,y1)-(x2,y2),c
End Sub

Sub boxfill1(x1 As Single,y1 As Single,x2 As Single,y2 As Single,c As Ulong,i As Any Ptr=0) Export
    Line i,(x1,y1)-(x2,y2),c,bf
End Sub

Sub box1(x1 As Single,y1 As Single,x2 As Single,y2 As Single,c As Ulong,i As Any Ptr=0) Export
    Line i,(x1,y1)-(x2,y2),c,b
End Sub

Sub sleep1(t As Long) Export
    Sleep t
End Sub

Sub waitkey() Export
    Sleep
End Sub

Function randoms(n As Long) As Double Export
    Return Rnd*n
End Function

Sub circlefill1(x1 As Single,_
    y1 As Single,_
    rad As Single,_
    c As Ulong, _
    i As Any Ptr=0) Export
   
    Circle i,(x1,y1),rad,c,,,,f
End Sub

Sub circle1(x1 As Single,_
    y1 As Single,_
    rad As Single,_
    c As Ulong,_
    i As Any Ptr=0) Export
   
    Circle i,(x1,y1),rad,c
End Sub

Sub pset1(x1 As Single,y1 As Single,c As Ulong,im As Any Pointer=0) Export
    Pset im,(x1,y1),c
End Sub

Sub clearscreen1 Export
    Cls
End Sub

Sub endkey1 Export
    If Inkey=Chr(27) Then End
End Sub

Sub screenlock1 Export
    Screenlock
End Sub

Sub screenunlock1 Export
    Screenunlock
End Sub

Sub getmouse1( mx As Long Ptr, my As Long Ptr, mw As Long Ptr, mb As Long Ptr) Export
    Getmouse(*mx,*my,*mw,*mb)
End Sub
Sub locate1(x As Long,y As Long) Export
    Locate x,y
End Sub

Function framecounter() As Long Export
    Dim As Double t2=Timer
    Static As Double t3,frames,answer
    frames=frames+1
    If (t2-t3)>=1 Then
        t3=t2
        answer=frames
        frames=0
    End If
    Return answer
End Function

Function regulate( MyFps As Long, fps As Long Ptr) As Long Export
    Static As Double timervalue,lastsleeptime,t3,frames
    frames+=1
    If (Timer-t3)>=1 Then t3=Timer:*fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

End Extern
   


and the pascal file using one.dll:

Code: Select all



 

program dll ;

uses
crt;   {only for beep}
 var
 e:integer;
 key:pchar;
 mx,my,mw,mb:integer;
 fps:integer;
 i:pointer;
 g,g2:ansistring;

  procedure screen1(x:integer;y:integer;xres:integer;yres:integer;b:integer); cdecl external 'one.DLL';
  function  rgbcolor(red:integer;green:integer;blue:integer;alpha:integer=255):longword ; cdecl external 'one.DLL';
  procedure screenlock1;cdecl external 'one.DLL';
  procedure screenunlock1;cdecl external 'one.DLL';
  procedure clearcolor(c:longword); cdecl external 'one.DLL';
  procedure drawstring (x:integer;y:integer; text :ansistring;colour:longword;im:pointer=nil); cdecl external 'one.DLL';
  procedure clearscreen1 ; cdecl external 'one.DLL';
  procedure printdbl(n:double;flag :integer=0)cdecl external 'one.DLL';   // 0=newline 1= small space 2= big space
  procedure pset1(x1:single;y1:single;clr:longword;im:pointer=nil);cdecl external 'one.DLL';
  procedure circlefill1(x:single;y:single;rad:single;colour:longword;im:pointer=nil);cdecl external 'one.DLL';
  procedure circle1(x:single;y:single;rad:single;colour:longword;im:pointer=nil);cdecl external 'one.DLL';
  procedure line1(x1:single;y1:single;x2:single;y2:single;colour:longword;im:pointer=nil); cdecl external 'one.DLL';
  procedure box1(x1:single;y1:single;x2:single;y2:single;colour:longword;im:pointer=nil); cdecl external 'one.DLL';
  procedure boxfill1(x1:single;y1:single;x2:single;y2:single;colour:longword;im:pointer=nil); cdecl external 'one.DLL';
  procedure font16 ;cdecl external 'one.DLL';
  procedure getmouse1(out mx:integer;out my:integer;out mw:integer;out mb:integer); cdecl external 'one.DLL';
  procedure locate1(y:integer;x:integer); cdecl external 'one.DLL';
  procedure endkey1 ; cdecl external 'one.DLL';
  function inkey1 :pchar ; cdecl external 'one.DLL';
  procedure sleep1(t:integer); cdecl external 'one.DLL';
  function framecounter():Integer ; cdecl external 'one.DLL';
  procedure waitkey(); cdecl external 'one.DLL';
  Function regulate(MyFps:integer;out fps :integer):integer; cdecl external 'one.DLL';
  function randoms(n:integer):double; cdecl external 'one.DLL';
  function createimage(x:integer;y:integer;clr:longword):pointer; cdecl external 'one.DLL';
  procedure destroyimage(out i:pointer); cdecl external 'one.DLL';
  procedure putimage(i:pointer;x:integer;y:integer;alph:longword=255); cdecl external 'one.DLL';

procedure beep(f :integer=820;d:integer=100);
begin
  sound(f);
  delay(d);
  nosound;
end;
// create a moving ball//
type
 ball =object
x,y:single;
dx,dy:single;
procedure edges;
procedure move;
procedure draw;
end;

procedure ball.edges ;
begin
if x>780 then dx:=-dx;
if x<20 then dx:=-dx;
if y>580 then dy:=-dy;
if y<20 then dy:=-dy;
end;



procedure ball.move ;
begin
x:=x+dx ;
y:=y+dy ;
end;

procedure ball.draw ;
begin
circlefill1(x,y,20,rgbcolor(200,0,0));
end;

var
bl:ball;
var
x,y:integer;

begin
bl.x:=400;
bl.y:=300;
bl.dx:=1.5;
bl.dy:=1.3;

screen1(150,150,800,600,32);     //  set screen at 150,150 800 wide 600 high
font16;                          // optional - dosfont height = 16
clearcolor(rgbcolor(0,0,50));    // optional -- background colour

// make an image//

  i:=createimage(100,100,rgbcolor(200,0,0));
  for x:=10 to 90 do
  begin
  for y:=10 to 90 do
  begin
  pset1(x,y,rgbcolor(x,x xor y,y),i);    // create a pattern on image
  end;
  end;

  drawstring(20,20,'Image',rgbcolor(255,255,255),i);


//=============    START GRAPHICS =================//
while 1=1 do                     //  graphics loop
begin
key:=(inkey1);                     // get a keypress
if key <>'' then g:=g+(key);         // keep key value  if significant
 if key=' ' then g:='';           //
screenlock1;                     // for smoothness lock the screen while drawing
clearscreen1;                    // clear at every frame
putimage(i,50,400);              // draw the image
// ball motion
bl.move;
bl.edges;
bl.draw;
drawstring(300,100,g,rgbcolor(200,200,200));                       // print string at location
drawstring(350,50,'hello, Press ecape to end.',rgbcolor(00,200,00)); //      ""
// basic shapes
circlefill1(400,300,100,rgbcolor(0,100,255));
circle1(400,300,110,rgbcolor(255,100,0));
boxfill1(450,350,550,450,rgbcolor(0,200,0,100));
box1(600,350,650,450,rgbcolor(0,200,0));
line1(20,550,400,590,rgbcolor(100,100,100));
for e:=1 to 5 do  // print some random numbers
begin
printdbl(randoms(1)); // print doubles
end;
getmouse1(mx,my,mw,mb); // retrieve mouse x,y and wheel and button
locate1(30,25);         // locate row,column
drawstring(200,450,'Mouse:',rgbcolor(0,100,100));
printdbl(mx,2);printdbl(my,2);printdbl(mw,2);printdbl(mb,2); // print the mouse returns
locate1(15,5);
str(fps,g2);
drawstring(45,210,'Framerate  =  '+ g2,rgbcolor(200,0,0));
//printdbl(fps);
 screenunlock1;              // unlock the screen
 sleep1(regulate(100,fps));  // sleep1(number of milliseconds), in this case sleep to get 100 frames per second
 if key=chr(27) then break
end;{while}


destroyimage(i); // delete the pointer
beep;


end.   


I hope it works for the newer 32 bit fpc.
Roland Chastain
Posts: 851
Joined: Nov 24, 2011 19:49
Location: Dakar, Senegal
Contact:

Re: [offtopic] FreePascal

Postby Roland Chastain » Oct 24, 2018 21:13

@dodicat

Thank you, it works fine here (FBC 1.05.0, FPC 3.0.4).

I also like your Fibonacci demo. :)

Return to “Community Discussion”

Who is online

Users browsing this forum: No registered users and 49 guests