better on 32 bits.
Code: Select all
Screen 19,32
'GLOBALS
Dim Shared As long fps
Dim Shared As Integer pitch,pitchS
Dim Shared As Any Pointer row,rowS
Dim Shared As Ulong Pointer pixel,pixelS
Dim Shared As Any Ptr im
Dim Shared As Integer xres,yres
Screeninfo xres,yres,,,pitchS
im=Imagecreate(xres,yres,Rgb(200,0,0))
Imageinfo im,,,,pitch,row
rowS=Screenptr
Dim Shared As long Tot 'get Tot
For xp As long=0 To xres Step 2
For yp As long=0 To yres Step 2
Tot+=1
Next yp
Next xp
Dim Shared As Single px( TOT),py( TOT)
'=======================
Sub EUROjack(x As Long,y As Long,s As Single,im As Any Pointer=0)
#macro pentagon(starx,stary,size,col)
Scope
Var count=0,rad=0.0,_px=0.0,_py=0.0
For z As Single=0+.28 To 2*pi+.1+.28 Step 2*pi/10
count=count+1
If count Mod 2=0 Then rad=size Else rad=.4*size
_px=starx+rad*Cos(z)
_py=stary+rad*Sin(z)
If count=1 Then Pset im,(_px,_py)Else Line im,-(_px,_py),col
Next z
Paint im,(starx,stary),col,col
End Scope
#endmacro
Dim As Double pi=4*Atn(1)
Dim As Long lx=60*s,ly=1*lx
Line im,(x,y)-(x+lx,y+ly),Rgba(2,3,192,255),bf
Dim As Long cntx=(x+x+lx)/2,cnty=(y+Y+ly)/2
For z As Double=0 To 2*pi Step 2*pi/12
Var px=cntx+.7*(lx/2)*Cos(z)
Var py=cnty+.7*(lx/2)*Sin(z)
pentagon(px,py,3*s,Rgb(243,236,24))
Next z
Line im,(x,y)-(x+lx,y+ly),,b
End Sub
Function Regulate(Byval MyFps As long,Byref fps As long) As long
Static As Double timervalue,lastsleeptime,t3,frames
Var t=Timer
frames+=1
If (t-t3)>=1 Then t3=t:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=T
Return sleeptime
End Function
Sub line_to(x1 As Single,y1 As Single,x2 As Single,y2 As Single,Byref retx As Single,Byref rety As Single,flag As long=1)
Dim As Single diffx=x2-x1,diffy=y2-y1
Dim As Single L=Sqr(diffx*diffx+diffy*diffy):If L<1e-6 Then L=1e-6
retx=flag*diffx/L
rety=flag*diffy/L
End Sub
Sub update(cx As long,cy As long,flag As long=1,fx As Single,fy As Single)
#define ppset(_x,_y,colour) *Cptr(Ulong Ptr,rowS+ (_y)*pitchS+ (_x) Shl 2) =(colour)
#define ppoint(_x,_y) *Cptr(Ulong Ptr,row + (_y)*pitch + (_x) Shl 2)
Static As Ubyte r=75,g=190,b=240,kr=1,kg=1,kb=1
Dim As Single dx,dy
Dim As long i
Static As Ulong c
r+=kr: If r>=254 Or r<=0 Then kr=-kr
g+=kg: If g>=254 Or g<=0 Then kg=-kg
b+=kb: If b>=254 Or b<=0 Then kb=-kb
c=Rgb(r,g,b)
Screenlock
Color,c
Cls
Draw String(10,10),"Framerate = "&fps
Draw String(10,40),"R/L mouse buttons"
For x As long=0 To xres -1 Step 2
For y As long=0 To yres-1 Step 2
If px(i)<0 Or px(i)>xres Then px(i)=cx+Rnd*15-Rnd*15:py(i)=cy+Rnd*15-Rnd*15'rnd*640
If py(i)<0 Or py(i)>yres Then py(i)=cy+Rnd*15-Rnd*15:px(i)=cx+Rnd*15-Rnd*15
line_to(px(i),py(i),cx,cy,dx,dy,flag)
px(i)+=dx-fx
py(i)+=dy-fy
Var Cix=Cint(px(i)),Ciy=Cint(py(i))
If Cix<xres And Ciy <yres Then
If Cix>=0 And Ciy >=0 Then
ppset(Cix,Ciy,ppoint(Cix,Ciy))
End If
End If
i+=1
Next y
Next x
Screenunlock()
End Sub
Dim As long cx,cy,kx=1,ky=2
cx=319
cy=239
Dim As Single fx,fy
For y As Long=5 To 600 Step 200
For x As Long=5 To 800 Step 200
eurojack(x,y,3.1,im)
Next
Next
#macro set()
Dim As long c
For xp As long=0 To xres Step 2
For yp As long=0 To yres Step 2
px(c)=xp:py(c)=yp
c+=1
Next yp
Next xp
#endmacro
set()
Dim As long counter,btnflag
Dim As String i
Dim As Integer mx,my,mb
Do
Getmouse mx,my,,mb
i=Inkey
cx+=kx
cy+=ky
If mb=1 Then
Var d=Sqr((cx-mx)*(cx-mx) +(cy-my)*(cy-my))
fx=5*(cx-mx)/d
fy=5*(cy-my)/d
Else
fx=0:fy=0
End If
If cx<0 Orelse cx>xres Then kx=-kx
If cy<0 Orelse cy>yres Then ky=-ky
update(cx,cy,-2,fx,fy) '-2
Sleep regulate(50,fps),1
If mb=2 And btnflag=0 Then :set():btnflag=1:End If
btnflag=mb
Loop Until i=Chr(27)
Print "done"
Imagedestroy im
Sleep