Jeepers creepers.
Code: Select all
Dim Shared As Integer _w,_h
Type V3
As Single x,y,z
End Type
Type screendata
As Integer w,h,depth,bpp,pitch
As Any Pointer row
As Ulong Pointer pixel32
End Type
Type Wrm
As Single x,y
Dim As Single dx,dy
Dim As Long kx,ky
Declare Property length As Single
Declare Property unit As Wrm
End Type
Type Creeper
h As V3
t As V3
segs(1 To 12) As V3
Declare Constructor
Declare Constructor(As V3,As V3)
End Type
#define A_R( c ) ( ( c ) Shr 16 And 255 )
#define A_G( c ) ( ( c ) Shr 8 And 255 )
#define A_B( c ) ( ( c ) And 255 )
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
#define vct Type<V3>
#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define Floatrange(f,l) Rnd*((l)-(f))+(f)
Operator + (Byref v1 As Wrm,Byref v2 As Wrm) As Wrm
Return Type<Wrm>(v1.x+v2.x,v1.y+v2.y)
End Operator
Operator -(Byref v1 As Wrm,Byref v2 As Wrm) As Wrm
Return Type<Wrm>(v1.x-v2.x,v1.y-v2.y)
End Operator
Operator * (Byval f As Single,Byref v1 As Wrm) As Wrm
Return Type<Wrm>(f*v1.x,f*v1.y)
End Operator
Property Wrm.length As Single
Return Sqr(x*x+y*y)
End Property
Property Wrm.unit As Wrm
Dim n As Single=length
Return Type<Wrm>(x/n,y/n)
End Property
'Operators on the x,y,z of Type V3
Operator + (v1 As V3,v2 As V3) As V3
Return vct(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(v1 As V3,v2 As V3) As V3
Return vct(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (f As Single,v1 As V3) As V3 'scalar*V3
Return vct(f*v1.x,f*v1.y,f*v1.z)
End Operator
Operator * (v1 As V3,f As Single) As V3 'V3*scalar
Return f*v1
End Operator
Function length(v As V3) As Single
Return Sqr(v.x*v.x+v.y*v.y+v.z*v.z)
End Function
Function normalize(v As V3) As V3
Dim n As Single=length(v)
If n=0 Then n=1e-20
Return vct(v.x/n,v.y/n,v.z/n)
End Function
Constructor Creeper:End Constructor
Constructor Creeper(hd As V3,tl As V3)
this.segs(1)=hd
this.segs(12)=tl
For n As Long=2 To 11
this.segs(n)=this.segs(1)+(n-1)*(1/11)*(tl-hd)
Next n
End Constructor
Sub bline(sd As screendata,x1 As Long,y1 As Long,x2 As Long,y2 As Long,col As Ulong)
#define ppset32(_x,_y,colour) *Cptr(Ulong Ptr,sd.row+ (_y)*sd.pitch+ (_x) Shl 2) =(colour)
#define onscreen ((x1+x)>=0) And ((x1+x)<(sd.w-1)) And ((y1+y)>=0) And ((y1+y)<(sd.h-1))
Var dx=Abs(x2-x1),dy=Abs(y2-y1),sx=Sgn(x2-x1),sy=Sgn(y2-y1)
Dim As Long e
If dx<dy Then e=dx\2 Else e=dy\2
Do
For x As Long=0 To 1
For y As Long=0 To 1
If onscreen Then
ppset32((x1+x),(y1+y),col)
End If
Next y
Next x
If x1 = x2 Then If y1 = y2 Then Exit Do
If dx > dy Then
x1 += sx : e -= dy : If e < 0 Then e += dx : y1 += sy
Else
y1 += sy : e -= dx : If e < 0 Then e += dy : x1 += sx
End If
Loop
End Sub
'Bressenham line thickened
Sub thickline(sd As screendata,_
x1 As Double,_
y1 As Double,_
x2 As Double,_
y2 As Double,_
thickness As Double,_
colour As Ulong)
Var h=Sqr((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1))
Var s=(y1-y2)/h
Var c=(x2-x1)/h
For yp As Double=-thickness/2 To thickness/2
bline(sd,x1+(s*yp),y1+(c*yp),x2+(s*yp),y2+(c*yp),colour)
Next yp
End Sub
Function lineto(s As screendata,Byref a As Wrm,Byref b As Wrm,Byval L As Single=1,Byval flag As Long=0,Byval c As Long=0,th As Single=2) As Wrm
If flag Then thickLine(s,a.x,a.y,(a+L*(b-a)).x,(a+L*(b-a)).y,th,c)
Return a+L*(b-a)
End Function
Sub setup(s As screendata,w() As Wrm)
For z As Long=1 To Ubound(W,1)
Do
W(z,0).x=Intrange(50,_w-50):W(z,0).y=Intrange(50,_h-50)
Loop Until w(z,0).x<>0 And w(z,0).y<>0
Do
W(z,0).dx=floatrange(-1,1):W(z,0).dy=floatrange(-1,1)
Loop Until Type<wrm>(W(z,0).dx,W(z,0).dy).length>1
w(z,0).kx=1:w(z,0).ky=1
Dim As Wrm p=Type<Wrm>(Intrange(50,_w-50),Intrange(50,_h-50))
Var p2=160*((p-W(z,0)).unit)
p2=W(z,0)+p2
Dim As Single j
For z3 As Single=1 To Ubound(w,2)
j+=1/(Ubound(w,2))
Var I=lineto(s,W(z,0),p2,j)
w(z,z3)=Type<Wrm>(I.x,I.y)
Next z3
Next z
End Sub
'Spline functions
Function catmull(p() As V3,t As Single) As V3
Return 0.5 *( (2 * P(2)) +_
(-1*P(1) + P(3)) * t +_
(2*P(1) - 5*P(2) + 4*P(3) - P(4)) * t*t +_
(-1*P(1) + 3*P(2)- 3*P(3) + P(4)) * t*t*t)
End Function
Sub FetchCatmull(v() As V3,outarray() As V3,arraysize As Long=1000)
Dim As V3 p(1 To 4)
Redim outarray(0)
Dim As Single stepsize=(Ubound(v)-1)/(arraysize)
If stepsize>1 Then stepsize=1
For n As Long=2 To Ubound(v)-2
p(1)=v(n-1):p(2)=v(n):p(3)=v(n+1):p(4)=v(n+2)
For t As Single=0 To 1 Step stepsize
Var temp=catmull(p(),t)
Redim Preserve outarray(1 To Ubound(outarray)+1)
outarray(Ubound(outarray))=temp
Next t
Next n
End Sub
Sub drawpoints(s As screendata,a() As V3,col As Ulong,th As Single)
For z As Long=Lbound(a)+1 To Ubound(a)
thickline(s,a(z-1).x,a(z-1).y,a(z).x,a(z).y,th,col)
Next z
End Sub
'extrapolate line beyond end point
Function _line(p1 As v3,p2 As v3,l As Single) As V3
Return vct(p1.x+l*(p2.x-p1.x),p1.y+l*(p2.y-p1.y),p1.z+l*(p2.z-p1.z))
End Function
Sub bendyline(s As screendata,p1 As V3,p2 As V3,b As v3,col As Ulong,th As Single)
Var lngth=length(b-p1)+length(b-p2)
Dim As v3 a(1 To 5)
Var t=_line(b,p1,1.25):a(1)=vct(t.x,t.y,t.z)
a(2)=p1:a(3)=b: a(4)=p2
t=_line(b,p2,1.25):a(5)=vct(t.x,t.y,t.z)
Redim As v3 C(0)
FetchCatmull(a(),c(),2*lngth) '2*lngth=number of interpolating points
Drawpoints(s,c(),col,th) 'Join by Bressenham thick line
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
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
Sub drawCreepers(s As screendata,w As Creeper,col As Ulong, th As Single)
Dim As v3 norm=w.segs(1)-w.segs(12)
Swap norm.x,norm.y
norm.x=-norm.x
norm=normalize(norm)
Dim As Long k=1
Dim As Single t
Dim As Single Ln=length(w.segs(1)-w.segs(12))
ln=ln/50
norm=Ln*norm
For n As Long=1 To 11
If n<6 Then
t=map(1,5,n,1,th)
Else
t=map(6,11,n,th,1)
End If
k=-k
Var OffsetPoint=.5*(w.segs(n)+w.segs(n+1))+k*norm
bendyline(s,w.segs(n),w.segs(n+1),OffsetPoint,col,t)
Next n
End Sub
Sub Creepers(ThisScreen As screendata,w() As creeper,c() As Ulong,n As Long)
For z As Long=1 To n
drawCreepers(ThisScreen,w(z),c(z),5)
Next z
End Sub
Sub Worms(thisScreen As screendata,wms() As wrm)
Dim As Ulong col
For z As Long=1 To Ubound(wms,1)
If wms(z,0).x>5 And wms(z,0).x<_w-5 Then
If wms(z,0).y>5 And wms(z,0).y<_h-5 Then
If Rnd>.99 Then wms(z,0).kx=-wms(z,0).kx
If Rnd>.99 Then wms(z,0).ky=-wms(z,0).ky
End If
End If
If wms(z,0).x<0 Or wms(z,0).x>_w Then wms(z,0).kx=-wms(z,0).kx
If wms(z,0).y<0 Or wms(z,0).y>_h Then wms(z,0).ky=-wms(z,0).ky
wms(z,0).x+=wms(z,0).dx*wms(z,0).kx
wms(z,0).y+=wms(z,0).dy*wms(z,0).ky
Var cnt=0
For z2 As Long=1 To Ubound(wms,2)
cnt+=1
If cnt And 1 Then col=Rgb(200,200,0) Else col=Rgb(0,0,0)
Var d=wms(z,z2-1)-wms(z,z2)
wms(z,z2)+=.1*d
d=lineto(ThisScreen,wms(z,z2-1),wms(z,z2),1,1,col,cnt)
Next z2
Circle(wms(z,0).x,wms(z,0).y),3,Rgb(200,0,0),,,,f
Next z
End Sub
Sub Constructworms(ThisScreen As screendata,w() As creeper,hflag() As Long,tflag() As Long,max() As Long,min() As Long,head() As V3,tail() As V3,drn() As V3,size() As Long,n As Long)
For z As Long=1 To n
If hflag(z)=1 Then
head(z)=head(z)+drn(z)
End If
If tflag(z)=1 Then
Var v=(head(z)-tail(z))
tail(z)=tail(z)+drn(z)+5*normalize(v)
End If
size(z)=length(w(z).segs(1)-w(z).segs(12))
If size(z)>max(z) Then hflag(z)=0:tflag(z)=1
If size(z)<min(z) Then hflag(z)=1:tflag(z)=0
Var t=FloatRange(0,1)
If hflag(z) Then
If head(z).x>ThisScreen.w-10 Then drn(z)=normalize(vct(-t,Floatrange(-.9,.9)))
If head(z).x<10 Then drn(z)=normalize(vct(t,Floatrange(-.9,.9)))
If head(z).y>ThisScreen.h-10 Then drn(z)=normalize(vct(Floatrange(-.9,.9),-t))
If head(z).y<10 Then drn(z)=normalize(vct(Floatrange(-.9,.9),t))
End If
w(z)=Type<Creeper>(head(z),tail(z))
Next z
End Sub
Sub bird
Dim As Integer xres,yres
Screeninfo xres,yres
Dim As Double PLOT_grade=10000
Dim As Double temp1,temp2,x1,y1,x
#macro sketch(_function,minx,maxx,miny,maxy)
For x =minx To maxx Step (maxx-minx)/PLOT_GRADE
x1=(xres)*(x-minx)/(maxx-minx)
y1=(yres)*(_function-maxy)/(miny-maxy)
Pset(x1,y1),Rgb(0,0,10)'10
If Abs(x)<1e-3 Then
temp1=x1:temp2=y1
End If
Next x
Circle (temp1,temp2),50,Rgb(0,200,0),,,,f
Circle (temp1-20,temp2-20),10,Rgb(200,200,200),,,,f
Circle (temp1+20,temp2-20),10,Rgb(200,200,200),,,,f
Circle (temp1-20-5*z,temp2-20),3,Rgb(00,00,200),,,,f
Circle (temp1+20-5*z,temp2-20),3,Rgb(00,00,200),,,,f
Circle (temp1,temp2),30,Rgb(0,0,0),4,5.5
Circle (temp1,temp2-2),30,Rgb(0,0,0),4-k/3,5.5+k/3
Circle (temp1,temp2),51,Rgb(0,0,10)
#endmacro
Static k As long=1
Static z As Double
Dim pi As Double=4*Atn(1)
z=z+.02*k
sketch (-Sin(z*x+z),-(pi),pi,-2,2)
sketch (Sin(z*x-z),-(pi),pi,-2,2)
Paint (.25*xres,.5*yres),Rgba(100,100,120,190),Rgb(0,0,10)
Paint (.75*xres,.5*yres),Rgba(100,100,120,190),Rgb(0,0,10)
If z>1.1 Then k=-k
If z<-1.1 Then k=-k
If z>2*pi Then z=0
End Sub
Function begin As Long
Dim As Long xres=1024,yres=768
Screenres xres,yres,32
Color , Rgb(0,100,255)
Dim As screendata ThisScreen
With ThisScreen
Screeninfo .w,.h,.depth,.bpp,.pitch
_w=.w:_h=.h
.row=Screenptr
End With
Dim As Long fps
Dim As Long n=100
Dim As V3 drn(1 To n)
Dim As V3 head(1 To n),tail(1 To n)
Dim As Creeper w(1 To n)
Dim As Long max(1 To n),min(1 To n)
Dim As Ulong c(1 To n)
For z As Long=1 To n
drn(z)=vct(Intrange(-200,200),IntRange(-200,200),0)
If drn(z).y=0 Then drn(z).y=1
drn(z)=normalize(drn(z))
Var xpos=ThisScreen.w/2+IntRange(-400,400)
Var ypos=ThisScreen.h/2+IntRange(-300,300)
tail(z)=vct(xpos,ypos)
head(z)=tail(z)+IntRange(2,5)*drn(z)
max(z)=20*length(head(z)-tail(z))
min(z)=.5*max(z)
w(z)=Type<Creeper>(head(z),tail(z))
c(z)=Rgb(Rnd*255,Rnd*255,Rnd*255)
Next z
Dim As Long hflag(1 To n),tflag(1 To n),size(1 To n)
For z As Long=1 To n
hflag(z)=1
Next z
Dim As Wrm Wms(1 To n,20)
setup(thisscreen,wms())
Do
ConstructWorms(ThisScreen,w(),hflag(),tflag(),max(),min(),head(),tail(),drn(),size(),n)
Screenlock
Cls
bird
Draw String(20,20),"FPS= "& fps,Rgb(0,0,0)
Worms(ThisScreen,wms())
Creepers(ThisScreen,w(),c(),n)
Screenunlock
Sleep regulate(60,fps),1
Loop Until Inkey=Chr(27)
Return 0
End Function
End begin