No liquor for me this Christmas, I am driving later on.
Just an old an old Crookes bottle I found.
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 )
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
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
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,_
colour As Ulong)
If thickness<2 Then
Line(x1,y1)-(x2,y2),colour
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=colour
Next n
End If
End Sub
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,25,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,30,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)
Line i,(0,500)-(1024,768),Rgb(0,50,0),bf
Color ,Rgb(0,20,155)
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 colour
aa.y=-.248
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
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)
colour=Rgb(rd,rd,rd)
Else
colour=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),colour,,,,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
Screenunlock
Sleep regulate(40,fps),1
Loop Until key=Chr(27)
Sleep
imagedestroy i