Code: Select all
Type v3
As Single x,y,z
As Ulong col
flag As Long
Declare Function length As Single
Declare Function unit As v3
End Type
Type Line
As v3 v1,v2
End Type
#define cross ^
#define dot *
Operator + (Byref v1 As v3,Byref v2 As v3) As v3
Return Type(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(Byref v1 As v3,Byref v2 As v3) As v3
Return Type(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (Byval f As Single,Byref v1 As v3) As v3
Return Type(f*v1.x,f*v1.y,f*v1.z)
End Operator
Operator * (Byref v1 As v3,Byref v2 As v3) As Single
Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z
End Operator
Operator ^ (Byref v1 As v3,Byref v2 As v3) As v3
Return Type(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)
End Operator
Operator <>(Byref v1 As V3,Byref v2 As V3) As Integer
Return (v1.x<>v2.x) Or (v1.y<>v2.y)
End Operator
Function v3.length As Single
Return Sqr(x*x+y*y+z*z)
End Function
Function v3.unit As v3
Dim n As Single=length
If n=0 Then n=1e-20
Return Type(x/n,y/n,z/n)
End Function
Type _float As V3
Dim Shared As Const v3 eyepoint=Type(512,768\2,600)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
'<><><><><><><><><><><> Quick SORT <><><><><><><><><><>
#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As Long,Finish As Ulong)
Dim As Long i=begin,j=finish
Dim As datatype x =array(((I+J)\2))
While I <= J
While array(I)dot b1 X dot:I+=1:Wend
While array(J)dot b2 X dot:J-=1:Wend
If I<=J Then Swap array(I),array(J): I+=1:J-=1
Wend
If J > begin Then fname(array(),begin,J)
If I < Finish Then fname(array(),I,Finish)
End Sub
#endmacro
Sub GetCircle(xm As Single, ym As Single,zm As Single, r As Integer,p() As v3)
#define CIRC(r) ( ( Int( (r)*(1 + Sqr(2)) ) - (r) ) Shl 2 )
Dim As Long x = -r, y = 0, e = 2 - r Shl 1,count
Redim p(1 To CIRC(r)+4 )
Do
count+=1:p(count)=Type<v3>(xm-x, ym+y,zm)
count+=1:p(count)=Type<v3>(xm-y, ym-x,zm)
count+=1:p(count)=Type<v3>(xm+x, ym-y,zm)
count+=1:p(count)=Type<v3>(xm+y, ym+x,zm)
r = e
If r<=y Then
y+=1
e+=y Shl 1+1
End If
If r>x Or e>y Then
x+=1
e+=x Shl 1+1
End If
Loop While x<0
Redim Preserve p(1 To count-1)
End Sub
Sub RotateArray(wa() As V3,result() As V3,angle As _float,centre As V3,flag As Long=0)
Dim As Single dx,dy,dz,w
Dim As Single SinAX=Sin(angle.x)
Dim As Single SinAY=Sin(angle.y)
Dim As Single SinAZ=Sin(angle.z)
Dim As Single CosAX=Cos(angle.x)
Dim As Single CosAY=Cos(angle.y)
Dim As Single CosAZ=Cos(angle.z)
Redim result(Lbound(wa) To Ubound(wa))
For z As Long=Lbound(wa) To Ubound(wa)
dx=wa(z).x-centre.x
dy=wa(z).y-centre.y
dz=wa(z).z-centre.z
Result(z).x=((Cosay*Cosaz)*dx+(-Cosax*Sinaz+Sinax*Sinay*Cosaz)*dy+(Sinax*Sinaz+Cosax*Sinay*Cosaz)*dz)+centre.x
result(z).y=((Cosay*Sinaz)*dx+(Cosax*Cosaz+Sinax*Sinay*Sinaz)*dy+(-Sinax*Cosaz+Cosax*Sinay*Sinaz)*dz)+centre.y
result(z).z=((-Sinay)*dx+(Sinax*Cosay)*dy+(Cosax*Cosay)*dz)+centre.z
#macro perspective()
w = 1 + (result(z).z/eyepoint.z)
result(z).x = (result(z).x-eyepoint.x)/w+eyepoint.x
result(z).y = (result(z).y-eyepoint.y)/w+eyepoint.y
result(z).z = (result(z).z-eyepoint.z)/w+eyepoint.z
#endmacro
If flag Then: perspective():End If
result(z).col=wa(z).col
result(z).flag=wa(z).flag
Next z
End Sub
Sub inc(a() As v3,b() As v3,clr As Ulong) 'increment an array
Var u=Ubound(a)
Redim Preserve a(1 To u+ Ubound(b))
For n As Long=1 To Ubound(b)
b(n).col=clr
a(u+n)= b(n)
Next n
End Sub
Sub createdisc(xc As Single,yc As Single,zc As Single,rad As Long,d() As v3)'ends
Redim d(1 To 4*rad^2)
Dim As Long ctr
For x As Long=xc-rad To xc+rad
For y As Long=yc-rad To yc+rad
If incircle(xc,yc,rad,x,y) Then
ctr+=1
d(ctr)=Type(x,y,zc,0,1)
End If
Next y
Next x
Redim Preserve d(1 To ctr)
End Sub
Function segment_distance( l As Line, p As v3, ip As v3=Type(0,0,0)) As Single
Var s=l.v1,f=l.v2
Dim As Single linelength=(s-f).length
Dim As Single dist= ((1/linelength)*((s-f) cross (p-s))).length
Dim As Single lpf=(p-f).length,lps=(p-s).length
If lps >= lpf Then
Var temp=Sqr(lps*lps-dist*dist)/linelength
If temp>=1 Then temp=1:dist=lpf
ip=s+(temp)*(f-s)
Return dist
Else
Var temp=Sqr(lpf*lpf-dist*dist)/linelength
If temp>=1 Then temp=1:dist=lps
ip=f+(temp)*(s-f)
Return dist
End If
Return dist
End Function
Function Regulate(Byval MyFps As Long,Byref fps As Long=0) 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
'======================== set up =============
Screen 20,32
Dim As Any Ptr i=Imagecreate(1024,768)
For n As Long=0 To 768
Var red=map(768,0,n,0,255)
Var green=map(768,0,n,0,255)
Var blue=map(768,0,n,100,255)
Line i,(0,n)-(1024,n),Rgb(red,green,blue)
Next
Redim As v3 e1(),e2() 'ends
Redim As v3 c(),a(0) 'cylinder
For z As Long=-200 To 200 'fill cylinder
getcircle(512,768\2,z,20,c())
inc(a(),c(),Rgb(0,200,0))
Next
createdisc(512,768\2,-201,18,e1()) 'ends
createdisc(512,768\2, 201,18,e2())
inc(a(),e1(),Rgb(155,50,0)) 'add them to the array
inc(a(),e2(),Rgb(0,50,155))
Dim As v3 L(1 To 2)={Type(512,768\2,-205),Type(512,768\2,205)}'ends of central axis
inc(a(),L(),0) 'add them to array
SetQsort(V3,QsortZ,down,.z)'initiate quicksort
Redim As v3 result()'working array
Dim As Single ang
Dim As Single r,g,b,rad,dt
Dim As v3 light=Type(512,-1000,0)
Dim As v3 ip
Dim As Line ln
Dim As Long fps
Do
ang+=.015
RotateArray(a(),result(),Type<_float>(1.2*ang,2*ang,ang),Type(512,768\2,0),1)
Qsortz(result(),Lbound(result),Ubound(result)-2)
Screenlock
Cls
put(0,0),i,pset
Draw String(20,20),"FPS " &fps,0
For n As Long=Lbound(result) To Ubound(result)-2
If result(n).flag=0 Then 'curved bit shader
Dim As v3 d=Type(result(n).x-light.x,result(n).y-light.y,result(n).z-light.z)'point to light
ln=Type<Line>(result(Ubound(result)-1),result(Ubound(result))) 'the central cylinder axis (line)
segment_distance(ln,result(n),ip) 'need ip (intercept of central axis)
Dim As v3 c=Type(result(n).x-ip.x,result(n).y-ip.y,result(n).z-ip.z) 'cylinder normals at point
Var q=c.unit dot d.unit 'shade by dot product
dt=map(-1,1,q,1,0) 'map dot product to [1,0]
r=Cast(Ubyte Ptr,@result(n).col)[2]*dt
g=Cast(Ubyte Ptr,@result(n).col)[1]*dt
b=Cast(Ubyte Ptr,@result(n).col)[0]*dt
Else 'ends
dt=map(600,200,result(n).y,.3,1) 'shade by .y
r=Cast(Ubyte Ptr,@result(n).col)[2]*dt
g=Cast(Ubyte Ptr,@result(n).col)[1]*dt
b=Cast(Ubyte Ptr,@result(n).col)[0]*dt
End If
rad=map(-200,200,result(n).z,2,1)
Circle(result(n).x,result(n).y),rad,Rgb(r,g,b),,,,f
Next n
Screenunlock
Sleep regulate(60,fps)
Loop Until Inkey=Chr(27)
imagedestroy i
Sleep
Win 10 64 bits.
