[offtopic] FreePascal
Re: [offtopic] FreePascal
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.
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.
-
- Posts: 82
- Joined: Nov 28, 2011 13:29
- Location: Dictatorship
Re: [offtopic] FreePascal
Speed is one factor, another is accuracy. Please consider the following programmarcov wrote:...The the 32-bit compiler also uses SSE, and the results are in the same magnitude as 64-bit.
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.
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...
Re: [offtopic] FreePascal
Probably a 64-bit or -Cfsse2 variant then, since stock 3.0.4 (32-bit) givesCarlos Herrera wrote: Free Pascal (3.0.4) results are:
53, 2.2204460...E-16.
64 1.0842021724855044E-019
Re: [offtopic] FreePascal
my first pascal code since virtual pascal.
observation; The freepascal .chm files are grim. i had to google for help.
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.
Re: [offtopic] FreePascal
Unclear observation. Navigating, or content? For me they work fine.dodicat wrote: observation; The freepascal .chm files are grim. i had to google for help.
Re: [offtopic] FreePascal
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.
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.
Re: [offtopic] FreePascal
True, it is in the units chmdodicat wrote:Marcov.
I had forgotten how to use VAL, it isn't in the ref.chm.
In RTL too, most procedure (real or internal) are.I use ORD instead, but couldn't find it in the ref.chm either.
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.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.
Note that the textmode IDE integrates all topics from registered helpfiles.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.
There are certainly issues, but mostly it works and is there.
Re: [offtopic] FreePascal
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.
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.
Re: [offtopic] FreePascal
freepascal 64 bits optimized for speed, ~~ 750 ms.
freebasic 64 bits -O3 ~~ 550 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 }
Re: [offtopic] FreePascal
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
pop this 64 bit freepascal code into the same folder and compile/run.
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
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.
-
- Posts: 1002
- Joined: Nov 24, 2011 19:49
- Location: France
- Contact:
Re: [offtopic] FreePascal
Hello dodicat!
Very interesting, thank you. For me, I use 32 bit compilers. What do I need to change in your example?
Very interesting, thank you. For me, I use 32 bit compilers. What do I need to change in your example?
Re: [offtopic] FreePascal
Your FB code doesn't time filling mod/div array, and your freepascal code does?dodicat wrote:freepascal 64 bits optimized for speed, ~~ 750 ms.
freebasic 64 bits -O3 ~~ 550 ms.
Re: [offtopic] FreePascal
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.
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.
Re: [offtopic] FreePascal
roland.
I have it running in 32 bits on 2.4.4
one.bas
and the pascal file using one.dll:
I hope it works for the newer 32 bit fpc.
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
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.
-
- Posts: 1002
- Joined: Nov 24, 2011 19:49
- Location: France
- Contact:
Re: [offtopic] FreePascal
@dodicat
Thank you, it works fine here (FBC 1.05.0, FPC 3.0.4).
I also like your Fibonacci demo. :)
Thank you, it works fine here (FBC 1.05.0, FPC 3.0.4).
I also like your Fibonacci demo. :)