Declare Function settimer Lib "winmm" Alias "timeBeginPeriod"(As Ulong=1) As Long
settimer
...
...
...
Sleep 1 ' Choose 1 to 15
7 looks good on my machine.
3D Demo's
-
deltarho[1859]
- Posts: 4308
- Joined: Jan 02, 2017 0:34
- Location: UK
- Contact:
Re: 3D Demo's
Last edited by deltarho[1859] on May 18, 2023 9:34, edited 1 time in total.
Re: 3D Demo's
Here it is with dodicat's speed regulator.
Code: Select all
function map(a as double,b as double,x as double,c as double,d as double) as double
return (d-c)*(x-a)/(b-a)+c
end function
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
Dim As long i, r, x, y, Red, Green, Blue,fps
Color 15,0
Cls
ScreenRes 800, 600, 32
var w = 0
var h = 0
screeninfo w,h
var wh = w/2
var hh = h/2
var general_scale = 5
for z as single = 50 to .1 step -.1
var zs = general_scale / z
x = 380: y = 160:r = 170
Screenlock
Cls
FOR i = 1 TO r
red=map(1,r,i,255,25)
green=map(1,r,i,255,25)
blue=map(1,r,i,255,25)
CIRCLE (x*zs + wh, y*zs + hh),i*zs, RGB(Red, Green, Blue)
CIRCLE (x*zs + wh + 1,y*zs + hh),i*zs, RGB(Red, Green, Blue)
next
Screenunlock
''sleep 1
Sleep regulate(200,fps),1
next z
Locate 10,40: Print "DEMO HAS FINISHED"
sleepRe: 3D Demo's
Yes, but 'regulate(200,fps)' is always reset to value '1' (target value <1 internally of 'regular()').
-
deltarho[1859]
- Posts: 4308
- Joined: Jan 02, 2017 0:34
- Location: UK
- Contact:
Re: 3D Demo's
and Sleep is restricted by being linked to the 64Hz timer. Regulate works best when linked to a 1000Hz timer.
Re: 3D Demo's
For fun
"Shine the light!"
"Shine the light!"
Code: Select all
Const pi=4*Atn(1)
Type V3
As Single x,y,z
As Ulong col
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
End Type
Type d2
As Single mx,my
As Single mw,dy
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 )
'============= FONTS SET UP ==========================
Function Filter(Byref tim As Ulong Pointer,_
rad As Single,_
destroy As Long=1,_
fade As Long=0) As Ulong Pointer
#define fmap(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
If fade<0 Then fade=0:If fade>100 Then fade=100
Type p2
As Long x,y
As Ulong col
End Type
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
*pixel=(colour)
#endmacro
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As Long=-ymin To ymax
For x1 As Long=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
If fade=0 Then
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
Else
averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
End If
#endmacro
Dim As Single fd=fmap(0,100,fade,1,0)
Dim As Long _x,_y
Imageinfo tim,_x,_y
Dim As Ulong Pointer im=Imagecreate(_x,_y)
Dim As Long pitch
Dim As Any Pointer row
Dim As Ulong Pointer pixel
Dim As Ulong col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x-1,_y-1)
For y As Long=0 To (_y)-1
For x As Long=0 To (_x)-1
ppoint(x,y,col)
NewPoints(x,y)=Type<p2>(x,y,col)
Next x
Next y
Dim As Ulong averagecolour
Dim As Long ar,ag,ab
Dim As Long xmin,xmax,ymin,ymax,inc
Imageinfo im,,,,pitch,row
For y As Long=0 To _y-1
For x As Long=0 To _x-1
average()
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
Next x
Next y
If destroy Then Imagedestroy tim: tim = 0
Function= im
End Function
'basic dos fonts
Type _D2
As Double x,y
As Ulong col
End Type
Sub drawstring(xpos As Long,ypos As Long,text As String,colour As Ulong,size As Single,im As Any Pointer=0)
Static As _D2 cpt(),XY()
Static As Long runflag
If runflag=0 Then
Redim XY(128,127)
Redim cpt(1 To 64*2)
Screen 12 '8
'width 640\8,200\16
Dim As Ulong Pointer img
Dim count As Long
For ch As Long=1 To 127
img=Imagecreate(640,200)
Draw String img,(1,1),Chr(ch)
For x As Long=1 To 8
For y As Long=1 To 16
If Point(x,y,img)<>0 Then
count=count+1
XY(count,ch)=Type<_D2>(x,y)
End If
Next y
Next x
count=0
Imagedestroy img
Next ch
runflag=1
End If
If size=0 Then Exit Sub
Dim As _D2 np,t
#macro Scale(p1,p2,d)
np.col=p2.col
np.x=d*(p2.x-p1.x)+p1.x
np.y=d*(p2.y-p1.y)+p1.y
#endmacro
Dim As _D2 c=Type<_D2>(xpos,ypos)
Dim As Long dx=xpos,dy=ypos
For z6 As Long=1 To Len(text)
Var asci=text[z6-1]
For _x1 As Long=1 To 64*2
t=Type<_D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy,colour)
Scale(c,t,size)
cpt(_x1)=np
If XY(_x1,asci).x<>0 Then
If Abs(size)>1 Then
Line im,(cpt(_x1).x-size/2,cpt(_x1).y-size/2)-(cpt(_x1).x+size/2,cpt(_x1).y+size/2),cpt(_x1).col,bf
Else
Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
End If
End If
Next _x1
dx=dx+8
Next z6
End Sub
Sub initfont Constructor 'automatic loader
#define fontsinit
drawstring(0,0,"",0,0)
Screen 0, , , &h80000000
End Sub
Function Colour(im As Any Pointer,newcol As Ulong,tweak As Long,fontsize As Long) As Any Pointer
#macro ppset2(_x,_y,colour)
pixel2=row2+pitch2*(_y)+(_x)*dpp2
*pixel2=(colour)
#endmacro
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*dpp
(colour)=*pixel
#endmacro
Dim As Long grade
Select Case As Const fontsize
Case 1:grade=200
Case 2:grade=225
Case 3:grade=200
Case 4:grade=190
Case 5:grade=165
Case Else: grade=160
End Select
Dim As Long w,h
Dim As Long pitch,pitch2
Dim As Any Pointer row,row2
Dim As Ulong Pointer pixel,pixel2
Dim As Ulong col
Dim As Long dpp,dpp2
Imageinfo im,w,h,dpp,pitch,row
Dim As Any Pointer temp
temp=Imagecreate(w,h)
Imageinfo temp,,,dpp2,pitch2,row2
For y As Long=0 To h-1
For x As Long=0 To w-1
ppoint(x,y,col)
Var v=.299*((col Shr 16)And 255)+.587*((col Shr 8)And 255)+.114*(col And 255)
If v>(grade+tweak) Then
ppset2(x,y,newcol)
Else
ppset2(x,y,Rgb(255,0,255))
End If
Next x
Next y
Return temp
End Function
Sub CreateFont(Byref myfont As Any Pointer,fontsize As Long,col As Ulong,tweak As Long=0)
Const FIRSTCHAR =32,LASTCHAR=127
Const NUMCHARS=(LASTCHAR-FIRSTCHAR)+1
Dim As Ubyte Ptr p
Dim As Any Pointer temp
Dim As Long i
temp = Imagecreate(NUMCHARS*8*FontSize,16*FontSize,Rgb(255,0,255))
myfont=Imagecreate(NUMCHARS*8*FontSize,16*FontSize,Rgb(255,0,255))
For i = FIRSTCHAR To LASTCHAR
drawstring ((i - FIRSTCHAR) * 8*FontSize, 1,Chr(i),Rgb(255,255,255),FontSize,temp)
Next i
If fontsize<=0 Then fontsize=1
If fontsize>1 Then
For n As Long=0 To fontsize-2
temp=filter(temp,1,1,0)
Next n
End If
temp=Colour(temp,col,tweak,fontsize)
Put myfont,(0,0),temp,trans
Imageinfo( myfont,,,,, p )
p[0]=0
p[1]=FIRSTCHAR
p[2]=LASTCHAR
For i = FIRSTCHAR To LASTCHAR
p[3+i-FIRSTCHAR]=8*FontSize
Next i
Imagedestroy(temp)
End Sub
'=================== END FONT SETUP ========================================
'======================================================================
Sub throughview(b As d2,a As Single=2.9)
Static As Ulong _colour(81,81),clr
Static As Long result
#macro rotate(pivotx,pivoty,px,py,a,scale)
Var Newx=scale*((px-pivotx))+pivotx
Var Newy=scale*((py-pivoty))+pivoty
#endmacro
#macro incircle(cx,cy,r,mx,my,a)
If a<=1 Then
result=a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= r*r*a*a
Else
result=a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= (r)*(r)
End If
#endmacro
If b.mw=0 Then b.mw=1
b.mw=Abs(b.mw)
For x As Long=b.mx-40 To b.mx+40
For y As Long=b.my-40 To b.my+40
incircle(b.mx,b.my,40,x,y,a)
If result Then
clr=Point(x,y)
_colour(x-b.mx+40,y-b.my+40)=Rgb(A_R(clr)*.98,A_G(clr)*.98,A_B(clr)*.98)
End If
Next y
Next x
Static As Single dil
For x As Long=b.mx-40 To b.mx+40
For y As Long=b.my-40 To b.my+40
incircle(b.mx,b.my,40,x,y,a)
If result Then
rotate(b.mx,b.my,x,y,0,dil)
Var dist=Sqr((b.mx-newx)*(b.mx-newx)+(b.my-newy)*(b.my-newy))
dil=(b.mw+(.5-b.mw)*dist/(40*b.mw))
Line(NewX-dil/2,NewY-dil/2)-(NewX+dil/2,NewY+dil/2),_colour(x-b.mx+40,y-b.my+40),BF
End If
Next y
Next x
End Sub
Dim As d2 b(1 To 10),b2(1 To 5)
#define Intrange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
Randomize 2
For n As Long=1 To Ubound(b)
If n<6 Then
b2(n)=Type(intrange(350,660),intrange(480,510),1.5,0)
End If
b(n)=Type(intrange(350,670),intrange(250,600),1.5,0)
Next
Type float As V3
Type angle3D 'FLOATS for angles
As Single sx,sy,sz
As Single cx,cy,cz
Declare Static Function construct(As Single,As Single,As Single) As Angle3D
End Type
Function Angle3D.construct(x As Single,y As Single,z As Single) As Angle3D
Return Type (Sin(x),Sin(y),Sin(z), _
Cos(x),Cos(y),Cos(z))
End Function
Function dot(v1 As v3,v2 As v3) Byref As Const Single
Static As Single res
Dim As Single d1=Sqr(v1.x*v1.x + v1.y*v1.y+ v1.z*v1.z),d2=Sqr(v2.x*v2.x + v2.y*v2.y + v2.z*v2.z)
Dim As Single v1x=v1.x/d1,v1y=v1.y/d1,v1z=v1.z/d1 'normalize
Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
Res= (v1x*v2x+v1y*v2y+v1z*v2z)
Return res
End Function
Function Rotate(c As V3,p As V3,a As Angle3D,scale As float=Type(1,1,1)) As V3
Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
Return Type<V3>((scale.x)*((a.cy*a.cz)*dx+(-a.cx*a.sz+a.sx*a.sy*a.cz)*dy+(a.sx*a.sz+a.cx*a.sy*a.cz)*dz)+c.x,_
(scale.y)*((a.cy*a.sz)*dx+(a.cx*a.cz+a.sx*a.sy*a.sz)*dy+(-a.sx*a.cz+a.cx*a.sy*a.sz)*dz)+c.y,_
(scale.z)*((-a.sy)*dx+(a.sx*a.cy)*dy+(a.cx*a.cy)*dz)+c.z,p.col)
End Function
Function perspective(p As V3,eyepoint As V3) As V3
Dim As Single w=1+(p.z/eyepoint.z)
Return Type<V3>((p.x-eyepoint.x)/w+eyepoint.x,_
(p.y-eyepoint.y)/w+eyepoint.y,_
(p.z-eyepoint.z)/w+eyepoint.z,p.col)
End Function
Sub Qsort(array() As V3,begin As Long,Finish As Ulong)
Dim As Long i=begin,j=finish
Dim As V3 x =array(((I+J)\2))
While I <= J
While array(I).z > X .z:I+=1:Wend
While array(J).z < X .z:J-=1:Wend
If I<=J Then Swap array(I),array(J): I+=1:J-=1
Wend
If J >begin Then Qsort(array(),begin,J)
If I <Finish Then Qsort(array(),I,Finish)
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
Function inpolygon(p1() As v3,Byval p2 As v3) As Integer
#macro Winder(L1,L2,p)
-Sgn((L1.x-L2.x)*(p.y-L2.y)-(p.x-L2.x)*(L1.y-L2.y))
#endmacro
Dim As Integer index,nextindex,k=Ubound(p1)+1,wn
For n As Integer=1 To Ubound(p1)
index=n Mod k:nextindex=(n+1) Mod k
If nextindex=0 Then nextindex=1
If p1(index).y<=p2.y Then
If p1(nextindex).y>p2.y Andalso Winder(p1(index),p1(nextindex),p2)>0 Then wn+=1
Else
If p1(nextindex).y<=p2.y Andalso Winder(p1(index),p1(nextindex),p2)<0 Then wn-=1
End If
Next n
Return wn
End Function
Function onbox(ctr As V3,l As Integer,h As Integer,d As Integer,p As V3) As Integer
Dim As Integer a,b,c=1
Dim As Integer ax,ay,az,at
ax=(p.x>ctr.x-l And p.x<ctr.x+l)
ay=(p.y>ctr.y-h And p.y<ctr.y+h)
az=(p.z>ctr.z-d And p.z<ctr.z+d)
at=(ax And ay And az)=0
Return at
End Function
Sub AddABox(a() As V3,bx As V3,l As Integer,h As Integer,d As Integer,col As Ulong)
Dim As Integer counter=Ubound(a),c=0'-1
For x As Integer=bx.x-l-c To bx.x +l +c Step 1
For y As Integer=bx.y-h-c To bx.y +h +c Step 1
For z As Integer=bx.z-d-c To bx.z +d +c Step 1
If onbox(bx,l,h,d,Type<V3>(x,y,z)) Then
counter+=1
Redim Preserve a(Lbound(a) To counter)
a(counter)=Type<V3>(x,y,z,col)
End If
Next z
Next y
Next x
End Sub
Sub addavane(a() As V3,pt As V3,col As Ulong=0,p() As v3)
Dim As Long xx=Pt.x,yy=Pt.y,zz=Pt.z,r=Abs(pt.x-p(2).x),counter=Ubound(a)-1
For x As Long= xx-r-1 To xx+r+1 Step 2
For y As Long=yy-r-1 To yy+r+1 Step 2
If inpolygon(p(),Type(x,y)) Then
counter+=1
Redim Preserve a(Lbound(a) To counter)
a(counter)=Type<V3>(x,y,zz,col)
End If
Next y
Next x
End Sub
Sub createPolygon(p() As v3,x As Long,y As Long,w As Long,Byref cx As Single,Byref cy As Single)
Dim As angle3d ang=angle3d.construct(0,0,pi/4)
Redim p(1 To 4)
p(1)=Type(x,y)
p(2)=Type(x+w,y)
p(3)=Type(x+w,y+w)
p(4)=Type(x,y+w)
For n As Long=1 To 4
Dim As v3 tmp=rotate(Type(x+w/2,y+w/2,0),p(n),ang)
p(n)=tmp
Next n
cx=x+w/2
cy=y+w/2
End Sub
Sub thickline(x1 As Single,_
y1 As Single,_
x2 As Single,_
y2 As Single,_
thickness As Single,_
col As Ulong)
If thickness<2 Then
Line(x1,y1)-(x2,y2),col
Else
Var h=Sqr((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1)) 'hypotenuse
Var s=(y1-y2)/h 'sine
Var c=(x2-x1)/h 'cosine
Dim As Ulong prime=Rgb(253,254,255)
For n As Integer=1 To 2
Line (x1+s*thickness/2,y1+c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),prime
Line (x1-s*thickness/2,y1-c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),prime
Line (x1+s*thickness/2,y1+c*thickness/2)-(x1-s*thickness/2,y1-c*thickness/2),prime
Line (x2+s*thickness/2,y2+c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),prime
Paint((x1+x2)/2,(y1+y2)/2),prime,prime
prime=col
Next n
End If
End Sub
Function Ellipse(x As Long,y As Long,rx As Long,ry As Long,angle As Long,col As Ulong,paintflag As Long=1) As String
Const pi2=8*Atn(1)
Dim As Long lx,ly,xpos,ypos
Dim As String s="Ta" & angle & "Bm" & x & "," & y:s+="Bm+" & rx &"," & 0:s+="C" & col
For z As Single=0 To pi2*1.1 Step pi2/60
If z>pi2 Then Exit For
xpos=rx*Cos(z)
ypos=ry*Sin(z)
If z<>0 Then s+="M+" & (xpos-lx) & "," &(ypos-ly)
lx=xpos:ly=ypos
Next z
If paintflag Then s+="BM" & x & "," & y & "P" &col & "," &col
Return s
End Function
Sub bottle
Var edge=Rgba(0,20*.5,155*.5,255)
Circle(512,585),168,Rgba(0,20*.3,155*.3,100),,,.1,f
Circle(512,585),168,edge,,,.1
Line(680,587)-(680,300-8),edge
Line(345,587)-(345,300-3),edge
Circle(1024\2,768\2),190,edge,.46,1.2
Circle(1024\2,768\2),190,edge,.46+1.46,1.2+1.46
Line(447,204)-(447,100),edge
Line(581,206)-(581,100),edge
Line(447,100)-(581,100),edge
Paint(1024\2,768\2),Rgba(0,20*.5,155*.5,100),edge
Circle(447,100),10,edge,,,,f
Circle(581,100),10,edge,,,,f
thickline(516,190,512,80+20,120,Rgb(50+10,25+10,0))
thickline(512,80+20,512,80,120,Rgb(100,50,0))
thickline(440,85,584,80,12,Rgb(0,0,0))
thickline(447+5,100,581-8,100,10,Rgb(40,10,00))
thickline(544,188,540,103,64,Rgb(46,20,00))
thickline(542,94,542,93,64,Rgb(90,40,0))
Line(512,567)-(500,580),edge
Line(512,567)-(524,580),edge
Line(500,580)-(524,580),edge
Paint(512,570),Rgb(50,25,0),edge
Line(512,601)-(1024,620),edge
Line(679,565)-(1024,560),edge
Paint(860,580),Rgb(0,50,0),edge
Circle(1024\2,768\2),190,Rgb(50,50,50),.46+1.66,1.2+1.46
Line(345,587)-(345,300-3),Rgb(50,50,50)
Line(447,204)-(447,110),Rgb(50,50,50)
End Sub
Redim As v3 a(0)
Dim As v3 p()
Dim As Single cx,cy
createpolygon(p(),280,250,100,cx,cy)
addavane(a(),Type(cx,cy,1),Rgb(200,200,200),p()) 'vane 1
addavane(a(),Type(cx,cy,-1),Rgb(10,10,10),p())
createpolygon(p(),420,250,100,cx,cy)
addavane(a(),Type(cx,cy,1),Rgb(10,10,10),p())
addavane(a(),Type(cx,cy,-1),Rgb(200,200,200),p()) 'vane 2
addabox(a(),Type(400,300,0),10,5,5,Rgb(90,0,0))'the red joint
Dim As angle3D ang= angle3D.construct(0,pi/2,0)
For n As Long=Lbound(a) To Ubound(a)
Dim As v3 tmp=rotate(Type(400,300,0),a(n),ang)'roatate vane 1 and vane 2
a(n)=tmp
Next
createpolygon(p(),280,250,100,cx,cy)
addavane(a(),Type(cx,cy,1),Rgb(200,200,200),p()) 'vane 3
addavane(a(),Type(cx,cy,-1),Rgb(10,10,10),p())
createpolygon(p(),420,250,100,cx,cy)
addavane(a(),Type(cx,cy,1),Rgb(10,10,10),p()) 'vane 4
addavane(a(),Type(cx,cy,-1),Rgb(200,200,200),p())
addabox(a(),Type(400,300,0),10,5,5,Rgb(90,0,0))'the red joint
addabox(a(),Type(400,300,0),0,245,0,Rgb(140,140,140))'the vertical spindle
Redim As V3 rot(Lbound(a) To Ubound(a)) 'working array
ang=angle3D.construct(pi/2,pi/2,0) 'flip all points by pi/2 on y axis
For n As Long=Lbound(a) To Ubound(a)
rot(n)=rotate(Type(400,300,0),a(n),ang)
a(n)=rot(n)
Next n
'=============================
Screen 20,32,,64
Dim As Any Ptr i=Imagecreate(1024,768)
For n As Long=0 To 1024
Var r=map(0,1024,n,200,0)
Var g=map(0,1024,n,200,0)
Var b=map(0,1024,n,200,100)
Line i,(n,0)-(n,500),Rgb(r,g,b)
Swap g,b
Line i,(n,500)-(n,768),Rgb(r,g,b)
Next n
Dim As v3 aa
aa.z=pi/2 'initial angles
aa.y=-pi/7
Dim As Long mx,my,fps,rd
Dim As Single dt
Dim As String key
Dim As Ulong col
aa.y=-.248
Var s=ellipse(512,585,165,16,0,Rgb(5,100,5))
Dim As Any Pointer font
CreateFont font,4,Rgb(100,0,0),0
For n As Long=190 To 820
Var r=map(190,820,n,100,100)
Var g=map(190,820,n,100,50)
Var b=map(190,820,n,100,50)
Line i,(n,466)-(n,550),Rgb(r+20*Sin(n/7),g,b)
Next
Do
key=Inkey
aa.x+=.06 'the orbiting speed
ang=Angle3D.construct(aa.x,aa.y,aa.z)'get the six rotate components (sines, coses ...)
Screenlock
Cls
Put(0,0),i,trans
Draw String (200,470),"Crookes' radiometer",,font
Draw s
For n As Long=Lbound(a) To Ubound(a)
rot(n)=rotate(Type(400,300,0),a(n),ang,Type(1,1,1))
rot(n)=perspective(rot(n),Type(400,300,1000))
Next
qsort(rot(),Lbound(rot),Ubound(rot))
For n As Long=Lbound(rot) To Ubound(rot)
'dot products
dt= -dot(Type(rot(n).x-400,rot(n).y-300,rot(n).z),Type(400,0,-500))
If rot(n).col=Rgb(200,200,200) Then
rd=map(-1,1,dt,255,100)
col=Rgb(rd,rd,rd)
Else
col=rot(n).col
End If
Circle(rot(n).x+(1024\2-400),rot(n).y+(768\2-300-40)),map(-500,500,rot(n).z,2,1),col,,,,f
Next
For n As Long=1 To Ubound(b)
If n<6 Then
throughview b2(n) ,.5
End If
throughview b(n)
Next
bottle
'draw s
Screenunlock
Sleep regulate(40,fps),1
Loop Until key=Chr(27)
Sleep
Imagedestroy i
Re: 3D Demo's
@dodicat
Very nice and it's a solar powered 3D demo.
Very nice and it's a solar powered 3D demo.
Re: 3D Demo's
Thank you.
Here's another oldie.
White Dwarf on the move with hangers on.
Here's another oldie.
White Dwarf on the move with hangers on.
Code: Select all
''#cmdline "-exx"
'====== globals ====
type temp as point ptr 'advance notice
'dim shared lightsource as temp
Const pi=4*Atn(1)
Dim Shared As long xres,yres
screeninfo xres,yres
screenres .9*xres,.9*yres,32,,64
width .9*xres/8,.9*yres/16
Color Rgb(0,200,0),Rgb(0,0,55)
Screeninfo xres,yres
#define farpoint type<point>(xres\2,yres\2,1400) 'eyepoint 1500
Randomize 10
'======================
Enum
cube
tetra
' square
dodec
End Enum
'============= FONTS SET UP ==========================
Function Filter(Byref tim As Ulong Pointer,_
rad As Single,_
destroy As Long=1,_
fade As Long=0) As Ulong Pointer
#define fmap(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
If fade<0 Then fade=0:If fade>100 Then fade=100
Type p2
As Long x,y
As Ulong col
End Type
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
*pixel=(colour)
#endmacro
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As Long=-ymin To ymax
For x1 As Long=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
If fade=0 Then
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
Else
averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
End If
#endmacro
Dim As Single fd=fmap(0,100,fade,1,0)
Dim As Long _x,_y
Imageinfo tim,_x,_y
Dim As Ulong Pointer im=Imagecreate(_x,_y)
Dim As Long pitch
Dim As Any Pointer row
Dim As Ulong Pointer pixel
Dim As Ulong col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x-1,_y-1)
For y As Long=0 To (_y)-1
For x As Long=0 To (_x)-1
ppoint(x,y,col)
NewPoints(x,y)=Type<p2>(x,y,col)
Next x
Next y
Dim As Ulong averagecolour
Dim As Long ar,ag,ab
Dim As Long xmin,xmax,ymin,ymax,inc
Imageinfo im,,,,pitch,row
For y As Long=0 To _y-1
For x As Long=0 To _x-1
average()
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
Next x
Next y
If destroy Then Imagedestroy tim: tim = 0
Function= im
End Function
'basic dos fonts
Type _D2
As Double x,y
As Ulong col
End Type
Sub drawstring(xpos As Long,ypos As Long,text As String,colour As Ulong,size As Single,im As Any Pointer=0)
Static As _D2 cpt(),XY()
Static As Long runflag
If runflag=0 Then
Redim XY(128,127)
Redim cpt(1 To 64*2)
Screen 12 '8
'width 640\8,200\16
Dim As Ulong Pointer img
Dim count As Long
For ch As Long=1 To 127
img=Imagecreate(640,200)
Draw String img,(1,1),Chr(ch)
For x As Long=1 To 8
For y As Long=1 To 16
If Point(x,y,img)<>0 Then
count=count+1
XY(count,ch)=Type<_D2>(x,y)
End If
Next y
Next x
count=0
Imagedestroy img
Next ch
runflag=1
End If
If size=0 Then Exit Sub
Dim As _D2 np,t
#macro Scale(p1,p2,d)
np.col=p2.col
np.x=d*(p2.x-p1.x)+p1.x
np.y=d*(p2.y-p1.y)+p1.y
#endmacro
Dim As _D2 c=Type<_D2>(xpos,ypos)
Dim As Long dx=xpos,dy=ypos
For z6 As Long=1 To Len(text)
Var asci=text[z6-1]
For _x1 As Long=1 To 64*2
t=Type<_D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy,colour)
Scale(c,t,size)
cpt(_x1)=np
If XY(_x1,asci).x<>0 Then
If Abs(size)>1 Then
Line im,(cpt(_x1).x-size/2,cpt(_x1).y-size/2)-(cpt(_x1).x+size/2,cpt(_x1).y+size/2),cpt(_x1).col,bf
Else
Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
End If
End If
Next _x1
dx=dx+8
Next z6
End Sub
Sub initfont Constructor 'automatic loader
#define fontsinit
drawstring(0,0,"",0,0)
Screen 0, , , &h80000000
End Sub
Function Colour(im As Any Pointer,newcol As Ulong,tweak As Long,fontsize As Long) As Any Pointer
#macro ppset2(_x,_y,colour)
pixel2=row2+pitch2*(_y)+(_x)*dpp2
*pixel2=(colour)
#endmacro
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*dpp
(colour)=*pixel
#endmacro
Dim As Long grade
Select Case As Const fontsize
Case 1:grade=200
Case 2:grade=225
Case 3:grade=200
Case 4:grade=190
Case 5:grade=165
Case Else: grade=160
End Select
Dim As Long w,h
Dim As Long pitch,pitch2
Dim As Any Pointer row,row2
Dim As Ulong Pointer pixel,pixel2
Dim As Ulong col
Dim As Long dpp,dpp2
Imageinfo im,w,h,dpp,pitch,row
Dim As Any Pointer temp
temp=Imagecreate(w,h)
Imageinfo temp,,,dpp2,pitch2,row2
For y As Long=0 To h-1
For x As Long=0 To w-1
ppoint(x,y,col)
Var v=.299*((col Shr 16)And 255)+.587*((col Shr 8)And 255)+.114*(col And 255)
If v>(grade+tweak) Then
ppset2(x,y,newcol)
Else
ppset2(x,y,Rgb(255,0,255))
End If
Next x
Next y
Return temp
End Function
Sub CreateFont(Byref myfont As Any Pointer,fontsize As Long,col As Ulong,tweak As Long=0)
Const FIRSTCHAR =32,LASTCHAR=127
Const NUMCHARS=(LASTCHAR-FIRSTCHAR)+1
Dim As Ubyte Ptr p
Dim As Any Pointer temp
Dim As Long i
temp = Imagecreate(NUMCHARS*8*FontSize,16*FontSize,Rgb(255,0,255))
myfont=Imagecreate(NUMCHARS*8*FontSize,16*FontSize,Rgb(255,0,255))
For i = FIRSTCHAR To LASTCHAR
drawstring ((i - FIRSTCHAR) * 8*FontSize, 1,Chr(i),Rgb(255,255,255),FontSize,temp)
Next i
If fontsize<=0 Then fontsize=1
If fontsize>1 Then
For n As Long=0 To fontsize-2
temp=filter(temp,1,1,0)
Next n
End If
temp=Colour(temp,col,tweak,fontsize)
Put myfont,(0,0),temp,trans
Imageinfo( myfont,,,,, p )
p[0]=0
p[1]=FIRSTCHAR
p[2]=LASTCHAR
For i = FIRSTCHAR To LASTCHAR
p[3+i-FIRSTCHAR]=8*FontSize
Next i
Imagedestroy(temp)
End Sub
'=================== END FONT SETUP ========================================
'======================================================================
Type Point
As Single x,y,z
Declare Function rotate(As Point,As Point,As Point=Type<Point>(1,1,1)) As Point
Declare Function perspective(As Point=farpoint) As Point
Declare Function dot(As Point) As Single
End Type
dim shared lightsource as point
dim shared light as point
'a.y=-pi/9
'a.z=pi/2
lightsource=type(0,1,0)
Dim As point tp(0 To 19)={ _
(0.000000, -0.607062, 0.794654), _
(0.577350, -0.187592, 0.794654), _
(0.356822, 0.491123, 0.794654), _
(-0.356822, 0.491123, 0.794654), _
(-0.577350, -0.187592, 0.794654), _
(0.000000, -0.982247, 0.187592), _
(0.934172, -0.303531, 0.187592), _
(0.577350, 0.794654, 0.187592), _
(-0.577350, 0.794654, 0.187592), _
(-0.934172, -0.303531, 0.187592), _
(0.577350, -0.794654, -0.187592), _
(0.934172, 0.303531, -0.187592), _
(0.000000, 0.982247, -0.187592), _
(-0.934172, 0.303531, -0.187592), _
(-0.577350, -0.794654, -0.187592), _
(0.356822, -0.491123, -0.794654), _
(0.577350, 0.187592, -0.794654), _
(0.000000, 0.607062, -0.794654), _
(-0.577350, 0.187592, -0.794654), _
(-0.356822, -0.491123, -0.794654)}
dim shared as point d2(0 to 19)
for n as long=0 to 19
d2(n)=tp(n)
next
Type plane
As Point p(Any)
Declare Sub Draw(As Ulong)
Declare Static Sub fill(() As Point,As Ulong,As any ptr=0)
End Type
Type shape
As plane f(Any) 'faces
As Point centre
As Point norm(Any) 'normals
As Ulong clr(Any) 'colours
As Point aspect 'orientation in space
As Point d 'increment speed
As point p(0 To 4)
As point ctr
As Ulong col
As point pnorm
as long id
Declare Sub Construct(As Long)
Declare Sub translate(v As Point,s As Double) 'shift and blow
Declare Sub turn(As Point) 'turn about it's centroid
Declare Function rotate(As Point,As Point) As shape 'roatate about a chosen point
Declare Static Sub bsort(() As shape)'bubblesort (fast enough for a small number of things)
Declare Sub Draw
End Type
Dim shared As shape pp(1 To 12),rot(1 To 12)
'====================== methods point ====================
'dodec
Sub fill(p() As Point,c As Ulong,im As Any Ptr=0)
#define ub Ubound
Dim As Long Sy=1e6,By=-1e6,i,j,y,k
Dim As Single a(Ub(p)+1,1),dx,dy
For i =0 To Ub(p)
a(i,0)=p(i).x
a(i,1)=p(i).y
If Sy>p(i).y Then Sy=p(i).y
If By<p(i).y Then By=p(i).y
Next i
Dim As Single xi(Ub(a,1)),S(Ub(a,1))
a(Ub(a,1),0) = a(0,0)
a(Ub(a,1),1) = a(0,1)
For i=0 To Ub(a,1)-1
dy=a(i+1,1)-a(i,1)
dx=a(i+1,0)-a(i,0)
If dy=0 Then S(i)=1
If dx=0 Then S(i)=0
If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
Next i
For y=Sy-1 To By+1
k=0
For i=0 To Ub(a,1)-1
If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
(a(i,1)>y Andalso a(i+1,1)<=y) Then
xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
k+=1
End If
Next i
For j=0 To k-2
For i=0 To k-2
If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
Next i
Next j
For i = 0 To k - 2 Step 2
Line im,(xi(i)+0,y)-(xi(i+1)+1-0,y),c
Next i
Next y
End Sub
Function dot(p As point,v2 As Point) As Single 'dot product |v1| * |v2| *cos(angle between v1 and v2)
Dim As Single d1=Sqr(p.x*p.x + p.y*p.y+ p.z*p.z),d2=Sqr(v2.x*v2.x + v2.y*v2.y +v2.z*v2.z)
Dim As Single v1x=p.x/d1,v1y=p.y/d1,v1z=p.z/d1 'normalize
Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
Return (v1x*v2x+v1y*v2y+v1z*v2z)
End Function
Sub blow(d() As point,t As point,m As Double)
For n As Long=0 To 19
d(n).x=(d(n).x)*m+t.x
d(n).y=(d(n).y)*m+t.y
d(n).z=(d(n).z)*m+t.z
Next
End Sub
Sub setup(p() As shape,d() As point)',colours() As Ulong)
Dim As Long i
Dim As Double cx,cy,cz
Dim As point centre=Type(xres/2,yres/2,0)
For n As Long=1 To 12
cx=0:cy=0:cz=0
For k As Long=0 To 4
Read i
p(n).p(k)=d(i)
cx+=d(i).x
cy+=d(i).y
cz+=d(i).z
Next k
p(n).ctr=Type(cx/5,cy/5,cz/5)
p(n).centre=p(n).ctr
p(n).pnorm=Type(p(n).ctr.x-centre.x,p(n).ctr.y-centre.y,p(n).ctr.z-centre.z)
p(n).col=rgb(255,255,255)'colours(n)
Next n
End Sub
Sub show(p() As shape)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
For n As Long=1 To 12
Var col=Cptr(Ubyte Ptr,@p(n).col)
Dim As Single dt=dot(p(n).pnorm,lightsource)
Var dtt=map(1,-1,dt,.3,1)
Dim As Ulong clr=Rgb(dtt*col[2],dtt*col[1],dtt*col[0])
fill(p(n).p(),clr)
Next n
End Sub
Type angle3D 'FLOATS for angles
As Single sx,sy,sz
As Single cx,cy,cz
Declare Static Function construct(As Single,As Single,As Single) As Angle3D
End Type
Function Angle3D.construct(x As Single,y As Single,z As Single) As Angle3D
Return Type (Sin(x),Sin(y),Sin(z), _
Cos(x),Cos(y),Cos(z))
End Function
Function Rotate(c As point,p As point,a As Angle3D,scale As point=Type(1,1,1)) As point
Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
Return Type<point>((scale.x)*((a.cy*a.cz)*dx+(-a.cx*a.sz+a.sx*a.sy*a.cz)*dy+(a.sx*a.sz+a.cx*a.sy*a.cz)*dz)+c.x,_
(scale.y)*((a.cy*a.sz)*dx+(a.cx*a.cz+a.sx*a.sy*a.sz)*dy+(-a.sx*a.cz+a.cx*a.sy*a.sz)*dz)+c.y,_
(scale.z)*((-a.sy)*dx+(a.sx*a.cy)*dy+(a.cx*a.cy)*dz)+c.z)
End Function
Function perspective(p As point,eyepoint As point) As point
Dim As Single w=1+(p.z/eyepoint.z)
Return Type<point>((p.x-eyepoint.x)/w+eyepoint.x,_
(p.y-eyepoint.y)/w+eyepoint.y,_
(p.z-eyepoint.z)/w+eyepoint.z)
End Function
Sub sort(p() As shape)
For n1 As Long =1 To 11
For n2 As Long=n1+1 To 12
If p(n1).ctr.z<p(n2).ctr.z Then Swap p(n1),p(n2)
Next n2
Next n1
End Sub
Function length(v As Point) As Single
Return Sqr(v.x*v.x+v.y*v.y+v.z*v.z)
End Function
Function normalize(v As Point) As Point
Dim n As Single=length(v)
If n=0 Then n=1e-20
Return type(v.x/n,v.y/n,v.z/n)
End Function
function cross(p as point,q as point) as point
return type (p.y * q.z - p.z * q.y, p.z * q.x - p.x * q.z, p.x * q.y - p.y * q.x)
end function
Function shortline(fp As point,p As point,lngth As double) As point
Dim As Single diffx=p.x-fp.x,diffy=p.y-fp.y,diffz=p.z-fp.z
Dim As Single L=1'Sqr(diffx*diffx+diffy*diffy)
Return Type(fp.x+lngth*diffx/L,fp.y+lngth*diffy/L,fp.z+lngth*diffz/L)
End Function
function linetoo(p1 as point,p2 as point,L as double) as point
Var dx=p2.x-p1.x,dy=p2.y-p1.y,dz=p2.z-p1.z
return type(p1.x+dx*L,p1.y+dy*L,p1.z+dz*L)
end function
Function point.dot(v2 As Point) As Single 'dot product |v1| * |v2| *cos(angle between v1 and v2)
Dim As Single d1=Sqr(x*x + y*y+ z*z),d2=Sqr(v2.x*v2.x + v2.y*v2.y +v2.z*v2.z)
Dim As Single v1x=x/d1,v1y=y/d1,v1z=z/d1 'normalize
Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
Return (v1x*v2x+v1y*v2y+v1z*v2z)
End Function
Function point.Rotate(c As Point,angle As Point,scale As Point) As Point
Dim As Single sx=Sin(angle.x),sy=Sin(angle.y),sz=Sin(angle.z)
Dim As Single cx=Cos(angle.x),cy=Cos(angle.y),cz=Cos(angle.z)
Dim As Single dx=this.x-c.x,dy=this.y-c.y,dz=this.z-c.z
Return Type<Point>((scale.x)*((cy*cz)*dx+(-cx*sz+sx*sy*cz)*dy+(sx*sz+cx*sy*cz)*dz)+c.x,_
(scale.y)*((cy*sz)*dx+(cx*cz+sx*sy*sz)*dy+(-sx*cz+cx*sy*sz)*dz)+c.y,_
(scale.z)*((-sy)*dx+(sx*cy)*dy+(cx*cy)*dz)+c.z)',p.col)
End Function
Function point.perspective(eyepoint As Point) As Point
Dim As Single w=1+(this.z/eyepoint.z)
Return Type<Point>((this.x-eyepoint.x)/w+eyepoint.x,_
(this.y-eyepoint.y)/w+eyepoint.y,_
(this.z-eyepoint.z)/w+eyepoint.z)
End Function
' ================ methods plane ===================
Sub plane.fill(p() As Point,c As Ulong,im As Any Ptr=0)
#define ub Ubound
Dim As Long Sy=1e6,By=-1e6,i,j,y,k
Dim As Single a(Ub(p)+1,1),dx,dy
For i =0 To Ub(p)
var t=p(i)'.perspective(farpoint)
a(i,0)=t.x
a(i,1)=t.y
If Sy>t.y Then Sy=t.y
If By<t.y Then By=t.y
Next i
Dim As Single xi(Ub(a,1)),S(Ub(a,1))
a(Ub(a,1),0) = a(0,0)
a(Ub(a,1),1) = a(0,1)
For i=0 To Ub(a,1)-1
dy=a(i+1,1)-a(i,1)
dx=a(i+1,0)-a(i,0)
If dy=0 Then S(i)=1
If dx=0 Then S(i)=0
If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
Next i
For y=Sy-1 To By+1
k=0
For i=0 To Ub(a,1)-1
If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
(a(i,1)>y Andalso a(i+1,1)<=y) Then
xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
k+=1
End If
Next i
For j=0 To k-2
For i=0 To k-2
If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
Next i
Next j
For i = 0 To k - 2 Step 2
Line im,(xi(i)+0,y)-(xi(i+1)+1-0,y),c
Next i
Next y
End Sub
Sub plane.draw(clr As Ulong )
Redim As Point V1(1 To Ubound(p)+1)
Dim As Long n
For n =1 To Ubound(p)
V1(n)=p(n)
Next
v1(Ubound(v1))=p(Lbound(p))
redim preserve v1(0 to ubound(v1)-1)
plane.fill(v1(),clr)
End Sub
'===== methods shape =================
Sub shape.construct(flag As Long)
Static As Point g(1 To ...,1 To ...)= _ 'cube
{{(-1,-1,-1),(1,-1,-1),(1,1,-1),(-1,1,-1)},_'front
{(1,-1,-1),(1,-1,1),(1,1,1),(1,1,-1)},_ 'right
{(-1,-1,1),(1,-1,1),(1,1,1),(-1,1,1)},_'back
{(-1,-1,-1),(-1,-1,1),(-1,1,1),(-1,1,-1)},_'left
{(1,1,-1),(1,1,1),(-1,1,1),(-1,1,-1)},_ 'top
{(1,-1,-1),(1,-1,1),(-1,-1,1),(-1,-1,-1)}}'base
Static As Point t(1 To ...,1 To ...)= _ 'tetra
{{(-1,-1/Sqr(3),-1/Sqr(6)),(1,-1/Sqr(3),-1/Sqr(6)),(0,2/Sqr(3),-1/Sqr(6))}, _ 'b
{(-1,-1/Sqr(3),-1/Sqr(6)),(1,-1/Sqr(3),-1/Sqr(6)),(0,0,3/Sqr(6))},_ 'f
{(1,-1/Sqr(3),-1/Sqr(6)),(0,2/Sqr(3),-1/Sqr(6)),(0,0,3/Sqr(6))}, _ 'r
{(-1,-1/Sqr(3),-1/Sqr(6)),(0,2/Sqr(3),-1/Sqr(6)),(0,0,3/Sqr(6))}} 'l
'================== seperate the three shapes =============
If flag=cube Then
Redim f(1 To 6)
Redim norm(1 To 6)
Redim clr(1 To 6)
For n As Long=1 To 6
Redim (f(n).p)(1 To 4)'faces vertices
Next
norm(1)=Type(0,0,-1) 'face normals to cube
norm(2)=Type(1,0,0)
norm(3)=Type(0,0,1)
norm(4)=Type(-1,0,0)
norm(5)=Type(0,1,0)
norm(6)=Type(0,-1,0)
centre=Type(0,0,0)
End If
If flag=tetra Then
Redim f(1 To 4)
Redim norm(1 To 4)
Redim clr(1 To 4)
For n As Long=1 To 4
Redim (f(n).p)(1 To 3)'faces vertices
Next
norm(1)=Type(0, 0,-0.4082483) 'normals to tetra faces
norm(2)=Type(0,-0.3849002, 0.1360828)
norm(3)=Type(0.3333333, 0.1924501, 0.1360828)
norm(4)=Type(-0.3333333, 0.1924501, 0.1360828)
centre=Type(0,0,0)
End If
For n As Long=1 To Ubound(f)
clr(n)=Rgb(Rnd*255,Rnd*255,Rnd*255) 'set a default colour
For m As Long=1 To Ubound(f(n).p)
If flag=cube Then f(n).p(m)= g(n,m) 'set to g()
If flag=tetra Then f(n).p(m)= t(n,m) 'set to t()
Next m
Next n
'======================= each shape defined =========
'set some defaults starting aspects
aspect=Type(Rnd*2*pi,Rnd*2*pi,Rnd*2*pi)
For n As Long=1 To Ubound(f)
norm(n)=norm(n).rotate(centre,aspect)
For m As Long=1 To Ubound(f(n).p)
f(n).p(m)=f(n).p(m).rotate(centre,aspect)
Next
Next
'speeds
d.x=(Rnd-Rnd)/50
d.y=(Rnd-Rnd)/50
d.z=(Rnd-Rnd)/50
if flag=dodec then
this.id=dodec
blow(d2(),Type(xres/2,yres/2,0),150)
setup(pp(),d2())',colours())
end if
End Sub
Sub shape.turn(p As Point)
static as point eye,mdl
mdl=type(xres/2,yres/2,0)
Dim As shape tmp=This
For n As Long=1 To Ubound(f)
For m As Long=1 To Ubound(f(n).p)
tmp.f(n).p(m)=this.f(n).p(m).rotate(centre,p)
eye.x=tmp.centre.x
eye.y=tmp.centre.y
eye=linetoo(eye,mdl,.3)
eye.z=800
tmp.f(n).p(m)=tmp.f(n).p(m).perspective(eye)
Next
tmp.norm(n)=tmp.norm(n).rotate(centre,p)'normals turn also
Next
if this.id=dodec then
show(rot())
else
tmp.draw
end if
End Sub
Function shape.rotate(c As Point,ang As Point) As shape
Dim As shape tmp=This
For n As Long=1 To Ubound(f)
For m As Long=1 To Ubound(f(n).p)
tmp.f(n).p(m)=this.f(n).p(m).rotate(c,ang)
Next
tmp.norm(n)=this.norm(n).rotate(c,ang)
Next
For n As Long=1 To Ubound(f)
'tmp.norm(n)=this.norm(n).rotate(c,ang)
Next
tmp.centre=this.centre.rotate(c,ang)
Return tmp
End Function
Sub shape.translate(v As Point,s As Double)
' s=.8*s
For n As Long=1 To Ubound(f)
norm(n).x*=s
norm(n).y*=s
norm(n).z*=s
For m As Long=1 To Ubound(f(n).p)
f(n).p(m).x*=s
f(n).p(m).y*=s
f(n).p(m).z*=s
Next m
Next n
For n As Long=1 To Ubound(f)
norm(n).x=norm(n).x+v.x
norm(n).y=norm(n).y+v.y
norm(n).z=norm(n).z+v.z
For m As Long=1 To Ubound(f(n).p)
f(n).p(m).x= f(n).p(m).x+v.x
f(n).p(m).y= f(n).p(m).y+v.y
f(n).p(m).z= f(n).p(m).z+v.z
Next m
Next n
centre.x+=v.x
centre.y+=v.y
centre.z+=v.z
End Sub
Sub shape.draw
Static As Ubyte Ptr col
For n As Long=1 To Ubound(f)-1
For m As Long=n+1 To Ubound(f)
If norm(n).z<norm(m).z Then
Swap f(n),f(m)
Swap norm(n),norm(m)
Swap clr(n),clr(m)
End If
Next m
Next n
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
'var light=lightsource
For n As Long=1 To Ubound(f)
col=Cptr(Ubyte Ptr,@clr(n))
Dim As Single cx=norm(n).x-centre.x,cy=norm(n).y-centre.y,cz=norm(n).z-centre.z
Dim As Point k=Type<Point>(cx,cy,cz)
Dim As Single dt=k.dot(lightsource)
dt=map(1,-1,dt,.3,1)
f(n).draw(Rgba(dt*col[2],dt*col[1],dt*col[0],col[3]))
Next n
End Sub
Sub shape.bsort(c() As shape)
For n As Long=Lbound(c) To Ubound(c)-1
For m As Long=n+1 To Ubound(c)
If c(n).centre.z<c(m).centre.z Then Swap c(n),c(m)
Next
Next
End Sub
'================ end methods ======================
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
Type pt
As Single x,y,z
As Ulong col
End Type
Function pps(p As pt,ep As pt) As pt
Dim As Single w=1+(p.z/ep.z)
Return Type((p.x-ep.x)/w+ep.x, (p.y-ep.y)/w+ep.y,(p.z-ep.z)/w+ep.z,p.col)
End Function
Sub starfield(p() As pt,eyepoint As pt,lngth As Double=.005,rate As Long=5)
#define Sline(x1,x2,d) Type<pt>((x1.x+(x2.x-x1.x)*d),(x1.y+(x2.y-x1.y)*d),(x1.z+(x2.z-x1.z)*d))
#define onscreen(x,y) (x>0 And x<xres And y>0 And y<yres)
#define range(f,l) Int(Rnd*(((l)+1)-(f))+(f))
For n As Long=Lbound(p) To Ubound(p)
p(n).z-=rate
Var z=pps(p(n),eyepoint)
Var delta=Sqr((z.x-eyepoint.x)*(z.x-eyepoint.x) + (z.y-eyepoint.y)*(z.y-eyepoint.y)+(z.z)*(z.z))*lngth*lngth
Var z2=Sline(z,eyepoint,(lngth-delta))
If onscreen(z.x,z.y) Then Line(z.x,z.y)-(z2.x,z2.y),z.col
If p(n).z<-eyepoint.z Then p(n).z=range(eyepoint.z/4,eyepoint.z)
Next n
End Sub
Function farZ(p() As pt) As Single
Dim As Single d
For n As Long=Lbound(p) To Ubound(p)
If d<p(n).z Then d=p(n).z
Next
Return d
End Function
'==================== main ==============
function fbmain() as long
Dim As Any Pointer font,strike
CreateFont font,2,Rgb(200,100,0),0
CreateFont strike,3,Rgb(255,255,255),0
Dim As shape c(1 To 7)
c(1).construct(cube)
c(2).construct(cube)
c(3).construct(cube)
c(4).construct(cube)
c(5).construct(dodec)
c(6).construct(tetra)
c(7).construct(tetra)
dim as single cx=xres\2,cy=yres\2
c(1).translate(Type(cx-.5*cx,cy-.6*cy,0),cx/20) 'cube .5
c(2).translate(Type(cx+.5*cx,cy-.6*cy,0),cx/20) 'cube
c(3).translate(Type(cx+.5*cx,cy+.6*cy,0),cx/20) 'cube
c(4).translate(Type(cx-.5*cx,cy+.6*cy,0),cx/20) 'cube
c(5).translate(Type(cx,cy,0),cx/5) 'cube
c(6).translate(Type(cx,cy-.65*cy,0),cx/15) 'tetra
c(7).translate(Type(cx,cy+.65*cy,0),cx/15) 'tetra
Dim As Double pi2=2*pi
For n As Long=Lbound(c) To Ubound(c)
c(n)=c(n).rotate(Type(xres\2,yres\2,0),Type(0,pi/2,0)) 'flip 90
Next
Dim As shape tmp(Lbound(c) To Ubound(c))
Dim As Point a,la
'fix y and z
a.y=-pi/9
a.z=pi/2
la=a
#define irange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
Dim As pt p(1 To 5000)
For n As Long=lbound(p) To Ubound(p)
p(n)=Type(irange(-300,xres+300),irange(-300,yres+300),irange(-800,800),Rgb(Rnd*255,Rnd*255,Rnd*255))
Next
var f=farZ(p())
Dim As Long fps
#define fmod(x,y) y*frac(x/y)
Dim As String key
Dim As Angle3D A3d,lght
Dim As point ang
Dim As point sc=Type(xres/2,yres/2,0)
Do
ang.x+=.03/2 'the orbiting speed
ang.y+=.02/2
ang.z+=.01/2
A3D=Angle3D.construct(-2*a.x,a.y,a.z)
For n As Long=1 To 12
For m As Long=0 To 4
rot(n).p(m)=Rotate(sc,pp(n).p(m),A3D)
rot(n).p(m)=perspective(rot(n).p(m),Type(xres/2,yres/2,2000))
Next m
rot(n).ctr=Rotate(sc,pp(n).ctr,A3D)
rot(n).centre=rot(n).ctr
rot(n).pnorm=Type(rot(n).ctr.x-sc.x,rot(n).ctr.y-sc.y,rot(n).ctr.z)
rot(n).col=pp(n).col
Next n
sort(rot())
key=Inkey
If key=Chr(255)+"P" Then a.y-=.05:la.y-=.05 'down
If key=Chr(255)+"H" Then a.y+=.05:la.y+=.05 'up
If key=Chr(255)+"K" Then a.z-=.05:la.z-=.05 'right
If key=Chr(255)+"M" Then a.z+=.05:la.z+=.05 'left
If key=" " Then a.z=pi/2:a.y=-pi/9:la.x=0:la.y=0:la.z=0 'reset
lght=Angle3D.construct(la.x,la.y,la.z)
light=rotate(sc,lightsource,lght)
Screenlock
Cls
a.x+=.005:a.x=fmod(a.x,pi2)
Draw String (20,20),"Cubes, tetrahedrons and dodecahedron. use arrow and space keys",rgb(255,255,255)
Draw String (20,50),"FPS = " &fps
draw string (20,80),"SPACE ODDYSSEY",,font
draw string (20,70)," -----",, strike
draw string (14,70)," ----",, strike
draw string (250,80),"ODDITY",,font
starfield(p(),Type(xres\2,yres\2,f))
For n As Long=Lbound(c) To Ubound(c)
tmp(n)=c(n).rotate(Type(xres\2,yres\2,0),a)
Next
shape.bsort(tmp())
For n As Long=Lbound(tmp) To Ubound(tmp)
c(n).aspect.x+=c(n).d.x: c(n).aspect.x=fmod(c(n).aspect.x,pi2)'turning angles mod 2pi
c(n).aspect.y+=c(n).d.y: c(n).aspect.y=fmod(c(n).aspect.y,pi2)
c(n).aspect.z+=c(n).d.z: c(n).aspect.z=fmod(c(n).aspect.z,pi2)
tmp(n).turn(Type(tmp(n).aspect.x,tmp(n).aspect.y,tmp(n).aspect.z))
Next
Screenunlock
Sleep regulate(90,fps),1
Loop Until key=Chr(27)
Sleep
return 0
end function
fbmain
PENTAGONS:
Data _
0, 1, 2, 3, 4, _
0, 5, 10, 6, 1, _
1, 6, 11, 7, 2, _
2, 7, 12, 8, 3 , _
3, 8, 13, 9, 4, _
4, 9, 14, 5, 0, _
5, 14, 19, 15, 10, _
6, 10, 15, 16, 11, _
7, 11, 16, 17, 12, _
8, 12, 17, 18, 13, _
9, 13, 18, 19, 14, _
19, 18, 17, 16, 15
Re: 3D Demo's
@dodicat
The original Dodecahedron was in 3D.
I am not sure what you would call this.
Would this be called multidimensional 3D?
Anyway, this is very impressive.
The original Dodecahedron was in 3D.
I am not sure what you would call this.
Would this be called multidimensional 3D?
Anyway, this is very impressive.
Re: 3D Demo's
@dodicat
You seem to be into science.
Have you seen this homemade solar motor made using solar thermal strips?
I was surprised when I found out the thermal strips were made from a dark plastic rubbish bag.
https://www.youtube.com/watch?v=VQqpnAKf9cM
You seem to be into science.
Have you seen this homemade solar motor made using solar thermal strips?
I was surprised when I found out the thermal strips were made from a dark plastic rubbish bag.
https://www.youtube.com/watch?v=VQqpnAKf9cM
Re: 3D Demo's
Here a demo I overlooked by Gunslinger.
Starfield with planets orbiting.
Starfield with planets orbiting.
Code: Select all
const as double pi = 3.14159265359
const as double piDiv2 = pi/2
'dim as double posx,posy,posz
const scr_x = 1920 'screenres
const scr_y = 1080
const scr_z = 1000
const scr_xh = scr_x\2
const scr_yh = scr_y\2
const scr_zh = scr_z\2
const star_count = 999
const star_size_max = 3
const star_gravity_max = 50
const star_gravity_max_range_strengt = (star_size_max^2 + star_size_max^2) / (star_gravity_max^2)
const star_grid_x = scr_xh \ star_gravity_max + 3
const star_grid_y = scr_yh \ star_gravity_max + 3
const star_grid_z = scr_z \ star_gravity_max + 3
const star_grid_size = 50 ' 0 to xx = max planet in 1 grid space
type v3d
as double x, y, z
end type
declare sub grid_add_bol(posx as double, posy as double, size as single, strength as double, c as ubyte)
declare function to_perspective(byval p as v3d) as v3d
declare function vLength(v as v3d) as single
declare function vNormalised(v as v3d) as v3d
type v3d_short
as short x, y, z
end type
type grid_type
as double value
as boolean calculated = false
end type
type grid
redim as grid_type grid(star_grid_size)
as short grid_size_current = star_grid_size
as short grid_size_max = star_grid_size
declare constructor()
end type
constructor grid()
redim preserve as grid_type grid(grid_size_max)
end constructor
type stars_type
const count = star_count
as grid gridXYZ(-star_grid_x to star_grid_x, -star_grid_y to star_grid_y, -2 to star_grid_z)
as v3d p(star_count)
'as v3d_short grid_p(star_count)
as v3d v(star_count)
as double size(star_count)
as ubyte clr(star_count)
as boolean active(star_count)
declare function IndexByXYZgrid() as byte
declare function UpdateInGravityRange() as byte
declare constructor()
declare sub reset_pos(n as integer)
end type
constructor stars_type()
for i as long = 0 to star_count
active(i) = true
p(i).x = rnd * scr_x - scr_xh
p(i).y = rnd * scr_y - scr_yh
p(i).z = rnd * scr_z
size(i) = star_size_max ' * rnd
'v(i).x = (-rnd+.5) / 1
'v(i).y = (-rnd+.5) / 1
v(i).z = 2
clr(i) = &B111 'fix(rnd * 7) + 1
next
end constructor
sub stars_type.reset_pos(n as integer)
p(n).x = rnd * scr_x - scr_xh
p(n).y = rnd * scr_y - scr_yh
p(n).z = rnd * scr_z
v(n).x = (-rnd+.5) / 1
v(n).y = (-rnd+.5) / 1
'v(n).z = (-rnd+.5) / 1
v(n).z = 5
end sub
function stars_type.IndexByXYZgrid() as byte
' clear last time
dim as long x, y, z, i1
for x = -star_grid_x to star_grid_x
for y = -star_grid_y to star_grid_y
for z = -1 to star_grid_z
gridXYZ(x, y, z ).grid_size_current = 0
next
next
next
'end clear
'start count nummer of stars in a grid
dim as v3d_short grid_pos
'dim as grid_pos_x, grid_pos_y, grid_pos_z
for i1 = 0 to count
if active(i1) = true then
grid_pos.x = int((p(i1).x / star_gravity_max)+.5)
grid_pos.y = int((p(i1).y / star_gravity_max)+.5)
grid_pos.z = int((p(i1).z / star_gravity_max)+.5)
'grid_p(i) = grid_pos ' update to new no checks for now
with gridXYZ(grid_pos.x, grid_pos.y, grid_pos.z)
.grid( .grid_size_current).value = i1
.grid( .grid_size_current).calculated = false
.grid_size_current += 1
if .grid_size_current > .grid_size_max then
.grid_size_max += star_grid_size
.constructor() 'redim the arry preserve
end if
end with
end if
next
return 0
end function
function stars_type.UpdateInGravityRange() as byte
dim as long x, y, z, i
dim as long xx, yy, zz, ii
dim as v3d p1, p2, pp1,pp2
dim as double dist, bright, tmp
dim as short minx, maxx, miny, maxy, minz, maxz
dim as v3d po, ppo 'posities
dim as v3d pv 'vectors
for x = -star_grid_x to star_grid_x
for y = -star_grid_y to star_grid_y
for z = -1 to star_grid_z
if gridXYZ(x, y, z ).grid_size_current > 0 then
for i = 0 to gridXYZ(x, y, z ).grid_size_current - 1
if gridXYZ(x, y, z ).grid(i).calculated = false andalso active(i) = true then 'look for all neibors now
gridXYZ(x, y, z ).grid(i).calculated = true
pp1 = p(gridXYZ(x, y, z ).grid(i).value)
minx = x-1: maxx = x+1
miny = y-1: maxy = y+1
minz = z-1: maxz = z+1
for xx = minx to maxx
for yy = miny to maxy
for zz = minz to maxz
if gridXYZ(xx, yy, zz).grid_size_current > 0 then
for ii = 0 to gridXYZ(xx, yy, zz ).grid_size_current - 1
if gridXYZ(x, y, z).grid(i).value <> gridXYZ(xx, yy, zz).grid(ii).value andalso active(ii) = true then 'the same points are never connected
'gridXYZ(xx, yy, zz ).grid(ii).calculated = true
pp2 = p(gridXYZ(xx, yy, zz).grid(ii).value)
' calculate distens
dist = sqr((pp1.x - pp2.x)^2 + (pp1.y - pp2.y)^2 + (pp1.z - pp2.z)^2)
if dist < star_gravity_max then 'andalso clr(gridXYZ(xx, yy, zz).grid(ii).value) = clr(gridXYZ(x, y, z ).grid(i).value)
p1 = to_perspective(pp1)
p2 = to_perspective(pp2)
tmp = (p1.z + p2.z) /3
if tmp > 1 then tmp = 1
bright = (tmp*255) * (1-(dist / star_gravity_max))
'bright = (1-(dist / star_gravity_max))*255
line (p1.x + scr_xh, p1.y + scr_yh)-(p2.x + scr_xh, p2.y + scr_yh), rgba(bright, bright, bright, 127), ,&b1010101010101010
'*-------update star vectors
po.x = pp2.x - pp1.x
po.y = pp2.y - pp1.y
po.z = pp2.z - pp1.z
'pv = 'vReal(po, star_gravity_max)
pv = vNormalised(po)
po = pp1
po.x -= pv.x * (dist /5)
po.y -= pv.y * (dist /5)
po.z -= pv.z * (dist /5)
ppo = to_perspective(po)
line (ppo.x + scr_xh, ppo.y + scr_yh)-(p1.x + scr_xh, p1.y + scr_yh), rgba(0, bright, 0, 127) ', ,&b1010101010101010
v(gridXYZ(x, y, z ).grid(i).value).x += pv.x * (30 / (dist^2))
v(gridXYZ(x, y, z ).grid(i).value).y += pv.y * (30 / (dist^2))
v(gridXYZ(x, y, z ).grid(i).value).z += pv.z * (30 / (dist^2))
end if
end if
next ii
end if
next zz
next yy
next xx
end if
next i
end if
next z
next y
next x
return 0
end function
dim shared as stars_type star
dim as double cc
dim as long i
dim as double x, y, z, size
dim as v3d p1
screenres scr_x,scr_y,32, 2,0
screenset 1, 0
do
for i = 0 to star.count
if star.active(i) = true then
star.p(i).x += star.v(i).x
star.p(i).y += star.v(i).y
star.p(i).z += star.v(i).z
p1 = to_perspective(star.p(i))
size = p1.z / 2
if abs(p1.x)-size > scr_xh or abs(p1.y)-size > scr_yh then star.reset_pos(i): i -= 1:if i < 0 then i = 0
if star.p(i).x > scr_xh or star.p(i).x < -scr_xh or star.p(i).y > scr_yh or star.p(i).y < -scr_yh then star.reset_pos(i): i -= 1:if i < 0 then i = 0
if star.p(i).z >= scr_z or star.p(i).z <= 0 then star.reset_pos(i): i -= 1:if i < 0 then i = 0
end if
next i
'cls
star.IndexByXYZgrid()
star.UpdateInGravityRange()
for i = 0 to star.count
if star.active(i) = true then
size = star.p(i).z
p1 = to_perspective(star.p(i))
z = (p1.z - 1) /2
if z >= 1 then z = 1
grid_add_bol(p1.x + scr_xh, p1.y + scr_yh, (p1.z*star.size(i))+2, z/1.4+.1, star.clr(i))
end if
next
'locate 1,1
'print star_grid_x * 2, star_grid_y * 2, star_grid_z
'print star.gridXYZ(0, 0, star_grid_z/2 ).grid_size_current
flip
cls
screensync
loop while inkey <> chr(27)
sleep
sub grid_add_bol(posx as double, posy as double, size as single, strength as double, c as ubyte)
if size <= 1 then return
dim as integer posx_fix = int(posx)
dim as integer posy_fix = int(posy)
dim as single posx_frac = frac(posx)
dim as single posy_frac = frac(posy)
dim as double i
dim as short x,y
dim as single pre_x, pre_y, m = fix(size)
dim as single sqr_size = size * size
dim as ulong pointget
dim as byte stepsize_x = 1, stepsize_y = 1
if size > 25 then stepsize_y = (size \ 25) + 1: stepsize_x = (stepsize_y \2) +1
for y = -m to m + 1 step stepsize_y
for x = -m to m + 1 step stepsize_x
pre_x =(x-posx_frac)
pre_y =(y-posy_frac)
i = pre_x * pre_x + pre_y * pre_y
if i < sqr_size then
i = sqr(i) / size
i = sqr(1 - i*i)
i = ((i * 192)+63) * strength ' to color byte
pointget = point (x + posx_fix, y + posy_fix)
pset (x + posx_fix, y + posy_fix), pointget or rgb(i*(c and 4)\4, i*(c and 2)\2, i*(c and 1))
'pset (x + posx_fix, y + posy_fix), rgb(i*(c and 4)\4, i*(c and 2)\2, i*(c and 1))
'else
'pset (x+posx_fix,y+posy_fix), pointget or rgba(0,255,0,255)
end if
next
next
end sub
function to_perspective(byval p as v3d) as v3d
dim as v3d pr = any
pr.z = scr_z / (scr_z - p.z) 'output 1 or more
pr.x = (p.x * pr.z)
pr.y = (p.y * pr.z)
return pr
end function
'*----------------------------------- Vector code functions-------------
function vLength(v as v3d) as single
return sqr(v.x*v.x + v.y*v.y + v.z*v.z)
end function
function vNormalised(v as v3d) as v3d
dim as v3d temp
dim as single length3D = vLength(v)
temp.x = v.x / length3D
temp.y = v.y / length3D
temp.z = v.z / length3D
return temp
end function
Re: 3D Demo's
Thanks ptitjoz.
I am pleased it works OK in Linux.
I am pleased it works OK in Linux.
Re: 3D Demo's
Here's a Polygon. This was qbasic code that I modified to work in FreeBasic.
Code: Select all
SCREEN 21
'Type that holds the vertices of our polygon
TYPE coord
x AS INTEGER
y AS INTEGER
xdir AS INTEGER
ydir AS INTEGER
END TYPE
Dim As integer i
DIM coords(4) AS coord
'Set up the polygon
coords(1).x = RND(1) * 1024
coords(1).y = RND(1) * 768
coords(1).xdir = 1
coords(1).ydir = 1
coords(2).x = RND(1) * 1024
coords(2).y = RND(1) * 768
coords(2).xdir = -1
coords(2).ydir = 1
coords(3).x = RND(1) * 1024
coords(3).y = RND(1) * 768
coords(3).xdir = -1
coords(3).ydir = -1
coords(4).x = RND(1) * 1024
coords(4).y = RND(1) * 768
coords(4).xdir = 1
coords(4).ydir = -1
DO
'Clear the screen of Page 0
LINE (0, 0)-(1024, 768), 0, BF
'Update the polygon
FOR i = 1 TO 4
'Update x direction
IF coords(i).x <= 0 AND coords(i).xdir = -1 THEN
coords(i).xdir = 1
ELSEIF coords(i).x > 1023 AND coords(i).xdir = 1 THEN
coords(i).xdir = -1
END IF
'Update y direction
IF coords(i).y <= 0 AND coords(i).ydir = -1 THEN
coords(i).ydir = 1
ELSEIF coords(i).y > 767 AND coords(i).ydir = 1 THEN
coords(i).ydir = -1
END IF
coords(i).x = coords(i).x + coords(i).xdir
coords(i).y = coords(i).y + coords(i).ydir
IF i < 4 THEN
LINE (coords(i).x, coords(i).y)-(coords(i + 1).x, coords(i + 1).y), i + 8
ELSE
LINE (coords(i).x, coords(i).y)-(coords(1).x, coords(1).y), i + 8
END IF
NEXT
sleep 5
'Display Page 0 on Page 1
PCOPY 0, 1
LOOP UNTIL INKEY = chr(27)