Far memory.
Click run to start.
Code: Select all
Type Point
As Single x,y,z
As Ulong col
As Single dx,dy
As Single kx,ky
End Type
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
Function spline(p() As Point,t As Single) As Point
#macro set(n)
0.5 *( (2 * P(2).n) +_
(-1*P(1).n + P(3).n) * t +_
(2*P(1).n - 5*P(2).n + 4*P(3).n - P(4).n) * t*t +_
(-1*P(1).n + 3*P(2).n- 3*P(3).n + P(4).n) * t*t*t)
#endmacro
Return Type<Point>(set(x),set(y),set(z))
End Function
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 GetCatmull(v() As Point,outarray() As Point,colour As Ulong,arraysize As Long=1000)
Dim As Point 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
Redim Preserve outarray(1 To Ubound(outarray)+1)
outarray(Ubound(outarray))=spline(p(),t)
outarray(Ubound(outarray)).col=colour+Rnd*1000-Rnd*1000
Next t
Next n
End Sub
Sub DrawCurve(a() As Point,ydisp As Long=0)
Pset(a(Lbound(a)).x,a(Lbound(a)).y+ydisp),a(Lbound(a)).col
For z As Long=Lbound(a)+1 To Ubound(a)
Line-(a(z).x,a(z).y+ydisp),a(z).col
Next z
End Sub
Function lngth(a() As Point) As Long
Dim As Long acc
For n As Long=Lbound(a) To Ubound(a)-1
acc+=Abs(a(n).x-a(n+1).x) + Abs(a(n).y-a(n+1).y)
Next n
Return acc
End Function
Sub _line(x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer,l As Integer,col As Ulong,Byref xp As Integer=0,Byref yp As Integer=0)
Dim As Integer diffx=x2-x1,diffy=y2-y1,ln=Sqr(diffx*diffx+diffy*diffy)
If ln=0 Then ln=1e-6
Dim As Single nx=diffx/ln,ny=diffy/ln
xp=x1+l*nx:yp=y1+l*ny
Line(x1,y1)-(xp,yp),col
End Sub
Sub Bmouse(mx As Integer,my As Integer,sz As Integer)
Dim As Integer xp,yp
Dim As Ulong c=Rgb(255,255,250)
_line(mx,my,mx+sz,my+.8*sz,sz,c,xp,yp)
_line(xp,yp,mx+sz/2,yp+.03*sz,.4*sz,c,xp,yp)
Var tx=xp,ty=yp
_line(mx,my,mx,my+1.2*sz,sz,c,xp,yp)
_line(xp,yp,mx+sz/2,yp-sz/2,.4*sz,c,xp,yp)
_line(xp,yp,mx+sz/2,yp+sz/2,sz,c,xp,yp)
_line(xp,yp,xp+sz/2,yp-.4*sz,.2*sz,c,xp,yp)
_line(xp,yp,tx,ty,.95*sz,c,xp,yp)
Paint(mx+.1*sz,my+.2*sz),c,c
End Sub
Randomize 1
Screen 20,32,,64
Dim As Point v(1 To 10)
Redim As Point C()
For n As Long=1 To Ubound(v)-2
v(n)=Type(Rnd*800,500+Rnd*100,Rnd*200)
v(n).kx=.01:v(n).ky=.01
Next n
v(Ubound(v)-1)=Type(400,300,0)
v(Ubound(v))=Type(400,200,0)
Getcatmull(v(),C(),Rgb(0,100,255),900)
Dim As Long L= lngth(C())/2
Dim As Single kx=2,ky=-2
Dim As Single dd=.1
Dim As Long fps',dist
Dim As Single dist
Dim As Any Ptr i=Imagecreate(1024,768)
Line i,(0,0)-(1024,20),Rgb(168,168,168),bf
Draw String i,(30,5),"File",Rgb(0,0,0)
Draw String i,(30+70,5),"Edit",Rgb(0,0,0)
Draw String i,(30+140,5),"View",Rgb(0,0,0)
Draw String i,(30+210,5),"Search",Rgb(0,0,0)
Draw String i,(30+290,5),"Run",Rgb(0,0,0)
Draw String i,(30+350,5),"Debug",Rgb(0,0,0)
Draw String i,(30+430,5),"Calls",Rgb(0,0,0)
Draw String i,(30+500,5),"Options",Rgb(0,0,0)
Draw String i,(950,5),"Help",Rgb(0,0,0)
Line i,(0,20)-(1024,768),Rgb(0,0,168),bf
Line i,(10,25)-(1015,760),Rgb(255,255,255),b
Line i,(0,745)-(1025,768),Rgb(0,168,168),bf
Line i,(1015,35)-(1015,710-170),Rgb(0,0,168)
Draw String i,(20,750)," <Shift+F1=Help> <F6=Window> (F2=Subs> <F5=Run> <F8=Step> ",Rgb(0,0,0)
For n As Long = 35 To 700-170 Step 16
Draw String i,(1010,n),Chr(176),Rgb(168,168,168)
Next
Line i,(1010,33)-(1018,53),Rgb(168,168,168),bf
Draw String i,(1010,33),Chr( 24 ),Rgb(0,0,0)
Line i,(1010,700-170)-(1018,720-170),Rgb(168,168,168),bf'bx
Draw String i,(1010,700-170),Chr( 25 ),Rgb(0,0,0)
Line i,(1010,53)-(1018,73),Rgb(0,0,0),bf
Var g=String(124, Chr(176) )'219
Draw String i,(20,550),g
Line i,(10,580)-(512-55,580),Rgb(168,168,168)
Line i,(512+55,580)-(1024-10,580),Rgb(168,168,168)
Draw String i,(512-40,573),"Immediate"
Line i,(10,550)-(30,565),Rgb(168,168,168),bf
Line i,(30,550)-(50,565),Rgb(0,0,0),bf
Draw String i,(15,550),Chr(27),Rgb(0,0,0)
Line i,(1000-10,550)-(1020-10,565),Rgb(168,168,168),bf
Draw String i,(1000,550),Chr(26),Rgb(0,0,0)
Draw String i,(750,750-6),"|",Rgb(0,0,0)
Draw String i,(750,750+2),"|",Rgb(0,0,0)
Draw String i,(800,750),Time,Rgb(0,0,0)
Dim As Long mx,my,btn
Do
Screenlock
Cls
Getmouse mx,my,,btn
If (mx>320 And mx<340 And my>4 And my<20) And btn Then
Line i,(0,0)-(1024,768),Rgb(255,0,255),bf
Screenunlock
Exit Do
End If
Put(0,0),i,Pset
bmouse(330,15,18)
Screenunlock
Sleep 1
Loop
Dim As String key
Do
Screenlock
Line(0,0)-(1023,767),Rgba(0,0,0,2),bf
v(Ubound(v)-1).x+=kx
v(Ubound(v)-1).y+=ky
If v(Ubound(v)-1).x<-50 Or v(Ubound(v)-1).x>1075 Then kx=-kx
If v(Ubound(v)-1).y<-50 Or v(Ubound(v)-1).y>818 Then ky=-ky
For n As Long=1 To Ubound(v)-1
v(n).dx=(v(n+1).x-v(n).x)
v(n).dy=(v(n+1).y-v(n).y)
v(n).x+=v(n).kx*v(n).dx/(dd*(kx)):v(n).y+=v(n).ky*v(n).dy/(dd*(kx))
If v(n).x<0 Or v(n).x>1024 Then v(n).kx=-v(n).kx
If v(n).y<0 Or v(n).y>768 Then v(n).ky=-v(n).ky
Next n
Var clr=map(1000,5000,dist,50,200)
Getcatmull(v(),C(),Rgb(clr,100,255),900)
dist=lngth(c())/(1+Rnd)
If dist>l Then kx-=.001:ky-=.001
If dist<l Then kx+=.001:ky+=.001
drawcurve(C())
Put(0,0),i,trans
Screenunlock
key=Inkey
Sleep regulate(50,fps)
Loop Until key=Chr(27) Or key=Chr(255)+"k"
Imagedestroy i