Cassini's box

General FreeBASIC programming questions.
dodicat
Posts: 4336
Joined: Jan 10, 2006 20:30
Location: Scotland

Cassini's box

Postby dodicat » Sep 22, 2017 23:01

Windows, 32 bit.
Like Cassini, ancient code, but not Win 95.

Code: Select all



type tmp as axis
Type v3
    As Single x,y,z
    Declare Property length As Single
    Declare Property unit As v3
    Declare Function AxialRotate(As v3,As Single,As tmp) As v3
    Declare Function PointRotate(As v3,As v3,As v3=Type<v3>(1,1,1)) As v3
    Declare Function perspective(eyepoint As v3) As v3
    #define vct Type<v3>
    #define dot *
    #define cross ^
End Type
#define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define rd  .01745329
type axis extends v3
   declare constructor
   declare constructor(as v3)
end type

constructor axis
end constructor

constructor axis(v as v3)
var temp=v.unit
this.x=temp.x:this.y=temp.y:this.z=temp.z
end constructor
dim shared as integer xres,yres
Type rainbow
    As Integer min,max,z
    As Integer ba
    As Integer xp,yp
    Declare Function colours(As String,As Any Pointer=0) As Uinteger
End Type
Dim Shared As rainbow rb
Dim Shared As Integer cntx,cnty,number=1000
With rb
    .min=50
    .max=350
    .ba=255
End With

Operator + (v1 As v3,v2 As v3) As v3
Return Type<v3>(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(v1 As v3,v2 As v3) As v3
Return Type<v3>(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (f As Single,v1 As v3) As v3
Return vct(f*v1.x,f*v1.y,f*v1.z)
End Operator
Operator *(v1 As v3,f As Single) As v3
Return f*v1
End Operator
Operator * (v1 As v3,v2 As v3) As Single 'dot product
Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z
End Operator
Operator ^ (v1 As v3,v2 As v3) As v3     'cross product
Return Type<v3>(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 /(v1 As v3,n as single) As v3
return type<v3>(v1.x/n,v1.y/n,v1.z/n)
end operator

Property v3.length As Single
Return Sqr(this.x*this.x+this.y*this.y+this.z*this.z)
End Property

Property v3.unit As v3
Dim n As Single=this.length
If n=0 Then n=1e-20
Return this/n
End Property


Function v3.AxialRotate(centre As v3,Angle As Single,norm As axis) As v3
    Dim As v3 V=This-centre
    Return (V*Cos(Angle)+(Norm cross V)*Sin(Angle)+Norm*(Norm dot V)*(1-Cos(Angle)))+centre
End Function

Function v3.perspective(eyepoint As v3) As v3
    Dim As Single   w=1+(this.z/eyepoint.z)
    If w=0 Then w=1e-20
    return eyepoint+(this-eyepoint)/w
End Function
 
#macro Nan()

#ifdef __FB_WIN32__
Declare Function ScaleWindow Alias "MoveWindow"(As Any Ptr,As Integer=0,As Integer=0,As Integer,As Integer,As Integer=1) As Integer

scope
    dim as string s,t
    #macro r_d(a)
    s=string(ubound(a)," ")
    for n as integer=1 to ubound(a)
        s[n-1]=a(n)
    next n
    t+=s
    #endmacro
    screen 0
dim as integer desktopW,desktopH,xres,yres
screeninfo desktopW,desktopH
screenres DesktopW/1.8,DesktopH/1.8,32,,64 or 8
color rgb(200,200,200),rgb(0,0,200)
cls
screeninfo xres,yres
width xres\8,yres\16
Dim As Integer I
Screencontrol(2,I)
ScaleWindow(Cast(Any Ptr,I),0,0,desktopW,desktopH)
dim as ubyte a1(1 to 68)={65,32,102,97,116,97,108,32,101,120,99,101,112,116,105,111,110,32,79,69,32,104,97,_
115,32,111,99,99,117,114,114,101,100,32,97,116,32,48,48,50,56,58,67,48,48,49,49,_
69,51,54,32,105,110,32,86,88,68,32,86,77,77,40,48,49,41,32,43,10}
dim as ubyte a2(1 to 58) ={32,32,32,32,48,48,48,49,48,69,51,54,46,32,84,104,101,32,99,117,114,114,101,110,116,32,97,112,_
112,108,105,99,97,116,105,111,110,32,119,105,108,108,32,98,101,32,116,101,114,109,_
105,110,97,116,101,100,46,10}
dim as ubyte a3(1 to 2)= {10,10}
dim as ubyte a4(1 to 57)= {32,32,32,32,42,32,80,114,101,115,115,32,97,110,121,32,107,101,121,32,116,111,32,_
116,101,114,109,105,110,97,116,101,32,116,104,101,32,99,117,114,114,101,110,116,_
32,97,112,112,108,105,99,97,116,105,111,110,10}
dim as ubyte a5(1 to 69)= {32,32,32,32,42,32,80,114,101,115,115,32,67,84,82,76,32,43,32,65,76,84,32,43,32,68,_
69,76,32,97,103,97,105,110,32,116,111,32,114,101,115,116,97,114,116,32,121,111,_
117,114,32,99,111,109,112,117,116,101,114,46,89,111,117,32,119,105,108,108,10}
dim as ubyte a6(1 to 56)= { 32,32,32,32,32,32,108,111,111,115,101,32,97,110,121,32,117,110,115,97,118,101,100,_
32,105,110,102,111,114,109,97,116,105,111,110,32,105,110,32,97,108,108,32,97,112,_
112,108,105,99,97,116,105,111,110,115,46}
dim as ubyte a7(1 to 2)= {10,10}
dim as ubyte a8(1 to 56)= { 32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,_
80,114,101,115,115,32,97,110,121,32,107,101,121,32,116,111,32,99,111,110,116,105,_
110,117,101,32,95}
r_d(a1):r_d(a2):r_d(a3):r_d(a4):r_d(a5):r_d(a6):r_d(a7):r_d(a8)
locate 10,5
print t
sleep
end scope
#endif
 #endmacro   



Sub rotate(im As Any Ptr,angle As single,shiftx As Integer=0,shifty As Integer=0,sc As Single=1)
    #define InRange() resultx>=0 And resultx<ddx And resulty>=0 And resulty<ddy And _
    x+shiftx>=0 And x+shiftx<xres And y+shifty>=0 And y+shifty<yres
    Dim As Integer pitch,pitchs,xres,yres
    Dim As Any Ptr row
    Dim As Ulong Ptr pixel,pixels
    Dim As Integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row
    Screeninfo xres,yres,,,pitchS
    Dim As Any Ptr rowS=Screenptr
    Dim As long centreX=ddx\2,centreY=ddy\2
    Dim As Single sx=Sin(angle*.0174533)
    Dim As Single cx=Cos(angle*.0174533)
    Dim As long mx=Iif(ddx>=ddy,ddx,ddy)
    Var fx=sc*Sqr(2)/2,sc2=1/sc
    dim as ulong empty = rgb(0,0,0)
    dim as long starty=iif(centrey-fx*mx<0,0,centrey-fx*mx)
     dim as long endy=iif(centrey+fx*mx>yres,yres,centrey+fx*mx)
     dim as long startx=iif(centrex-mx*fx<0,0,centrex-mx*fx)
      dim as long endx=iif(centrex+mx*fx>xres,xres,centrex+mx*fx)
    For y As long=starty To endy Step 1
        var sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
    For x As long=startx To endx Step 1
    resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
            If InRange() Then
                 pixel=row+pitch*((resultY))+((resultX)) Shl 2
                  if *pixel <> empty then
                pixels=rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2
                *pixels=*pixel
                end if
            End If
        Next x
    Next y
End Sub
Sub _circle(cx As Integer,cy As Integer,radius As Integer,im As Uinteger Pointer=0)
    #define incircle(cx,cy,radius,x,y) ((cx)-(x))*((cx)-(x)) +((cy)-y)*((cy)-y)<= (radius)*(radius)
    #define distance(cx,cy,px,py) Sqr((cx-px)*(cx-px)+(cy-py)*(cy-py))
    For y As Integer=cy-radius To cy+radius
        For x As Integer=cx-radius To cx+radius
            If incircle(cx,cy,radius,x,y) Then
                rb.xp=x
                rb.yp=y
                rb.z=distance(cntx,cnty,x,y)
                'circle im,(x,y),1,(rb.colours("outer",im)),,,,f
                 pset im,(x,y),(rb.colours("outer",im))
            End If
        Next x
    Next y
End Sub
Function rainbow.colours(part As String="inner",im As Any Pointer=0) As Uinteger
    Dim As Uinteger col
    Dim As Integer diff=this.z-this.min
    Dim As Integer gap=(this.max-this.min)/6
    If part="outer" Then
        If this.z>=this.min-2*gap And this.z<this.min Then
            col=Point(this.xp,this.yp,im)
            Return Rgba((255-(col Shr 16 And 255))*(diff+2*gap)/(2*gap)+(col Shr 16 And 255),_
            -(diff+2*gap)*(col Shr  8 And 255)/(2*gap)+(col Shr  8 And 255),_
            -(diff+2*gap)*(col  And 255 )/(2*gap)+(col  And 255 ),this.ba)
        End If
        If this.z>=this.min And this.z<this.min+gap Then _ 
        Return Rgba(255,165*(diff)/(gap),0,this.ba)
        If this.z>=this.min+gap And this.z<this.min+2*gap Then _
        Return Rgba(255,90*(diff-gap)/gap+165,0,this.ba)
        If this.z>=this.min+2*gap And this.z<this.min+3*gap Then _
        Return Rgba(-255*(diff-2*gap)/gap+255,-127*(diff-2*gap)/gap+255,0,this.ba)
        If this.z>=this.min+3*gap And this.z<this.min+4*gap Then _
        Return Rgba(0,-128*(diff-3*gap)/gap+128,255*(diff-3*gap)/gap,this.ba)
        If this.z>=this.min+4*gap And this.z<this.min+5*gap Then _
        Return Rgba(75*(diff-4*gap)/gap,0,-125*(diff-4*gap)/gap+255,this.ba)
        If this.z>=this.min+5*gap And this.z<this.min+6*gap Then _
        Return Rgba(163*(diff-5*gap)/gap+75,130*(diff-5*gap)/gap,108*(diff-5*gap)/gap+130,this.ba)
        If this.z>=this.min+6*gap And this.z<this.min+8*gap Then
            col=Point(this.xp,this.yp,im)
            Return Rgba((-238+(col Shr 16 And 255))*(diff-6*gap)/(2*gap)+238,_
            (-130+(col Shr  8 And 255))*(diff-6*gap)/(2*gap)+130,_
            (-238+(col  And 255 ))*(diff-6*gap)/(2*gap)+238,this.ba)
        End If
    End If
End Function

Function Blur(Byref tim As Uinteger Pointer,rad As Single=2) As Uinteger Pointer
    Type p2
        As Integer x,y
        As Uinteger 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 Integer=-ymin To ymax
        For x1 As Integer=-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
    averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
    #endmacro
    Dim As Integer _x,_y
    Imageinfo tim,_x,_y
    Dim  As Uinteger Pointer im=Imagecreate(_x,_y)
    Dim As Integer pitch
    Dim  As Any Pointer row
    Dim As Uinteger Pointer pixel
    Dim As Uinteger col
    Imageinfo tim,,,,pitch,row
    Dim As p2 NewPoints(_x,_y)
    For y As Integer=0 To (_y)-1
        For x As Integer=0 To (_x)-1
            ppoint(x,y,col)
            NewPoints(x,y)=Type<p2>(x,y,col)
        Next x
    Next y
    Dim As Uinteger averagecolour
    Dim As Integer ar,ag,ab
    Dim As Integer xmin,xmax,ymin,ymax,inc
    For y As Integer=0 To _y-1
        For x As Integer=0 To _x-1 
            average()
            NewPoints(x,y).col=averagecolour
        Next x
    Next y
    Imageinfo im,,,,pitch,row
    For y As Integer=0 To _y
        For x As Integer=0 To _x
            ppset((NewPoints(x,y).x),(NewPoints(x,y).y),NewPoints(x,y).col)
        Next x
    Next y
    Function= im
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

'=================================================================================
#macro pentagon(starx,stary,size,col)
Scope
    Var pi=4*Atn(1)
    Var count=0,rad=0.0,_px=0.0,_py=0.0
    For z As Single=0+.28 To 2*pi+.1+.28 Step 2*pi/10
        count=count+1
        If count Mod 2=0 Then rad=size Else rad=.4*size
        _px=starx+rad*Cos(z)
        _py=stary+rad*Sin(z)
        If count=1 Then Pset im,(_px,_py)Else Line im,-(_px,_py),col
    Next z
    Paint im,(starx,stary),col,col
End Scope
#endmacro

#macro display()
static as single a,k=.5,sc=1
k+=.001
a+=k
if a>5*sc or a<-5*sc then k=-k
sc+=.005
Screenlock
Cls
rotate(im,sc*2*sin(a),0,0,sc)
Put(0,0),im2,trans

Draw String(10,10),"FPS " &fps
if sc>5 then goto fin
Screenunlock
Sleep snooze,1
#endmacro

#macro MakeImage()
#define incircle(cx,cy,radius,x,y) ((cx)-(x))*((cx)-(x)) +((cy)-y)*((cy)-y)<= (radius)*(radius)
For n As Integer=1 To 40
    Var x=IntRange(0,xres),y=IntRange(0,yres)
    If incircle(595,484,250,x,y)=0 Then
        If y<.8*yres Then
            Var sz=IntRange(2,7)
            Var c=Rgb(IntRange(200,255),IntRange(200,255),IntRange(200,255))
            pentagon(x,y,sz,c)
        End If
    End If
Next n
Dim As v3 t(1 To 501)
For a As Single=1 To 360 Step .25
    For n As Integer=1 To 501
        t(n).x=IntRange(153,253)
        t(n).y=IntRange(500,520)   
        Var trace=t(n).AxialRotate(centre,a*rd,normal_line)
        trace=trace.perspective(vct(xres/2,yres/2,600))
        Pset im,(trace.x,trace.y),Rgb(IntRange(200,255),IntRange(200,255),IntRange(200,255))
    Next n
Next a
_circle(595,(484),250,im)
dim as long clr

for n as single=xres/2-50 to xres/2+50 step .5
    var xp=map((xres/2-50),(xres/2+50),n,(xres/2-10),(xres/2+10))
    clr=map((xres/2-50),(xres/2+50),n,255,0)
    var tp=map((xres/2-10),(xres/2+10),xp,0,6)
    line im2,(n,yres)-(xp,yres/2+100-abs(10*cos(tp))),rgb(clr,clr/2,clr)
next

#endmacro

Screen 20,32,2,64
Screeninfo xres,yres
Dim As Any Pointer im=Imagecreate(xres,yres,Rgb(0,0,0)),im2=imagecreate(xres,yres)
cntx=xres/2-100:cnty=.25*yres
Dim As v3 centre=Type<v3>(595,434,0),pt(1 To number)
Dim As axis normal_line =vct(.5,1,.5)


MakeImage()
im=blur(im,2)
Dim As Integer fps,snooze
display()
locate 10,10
print "Press a key"
sleep
Do
     snooze=regulate(60,fps)
    display()
Loop Until Inkey=Chr(27)
FIN:
nan()
Imagedestroy im
imagedestroy im2
 
srvaldez
Posts: 1354
Joined: Sep 25, 2005 21:54

Re: Cassini's box

Postby srvaldez » Sep 24, 2017 23:49

hello dodicat
I had to change Integer to long in line 374 Dim As Integer fps,snooze, it compiled and runs ok except that if I let it continue to zoom-in it gets to a point where it stops and freezes, had to issue a control-c to exit.
running on my Mac.
h4tt3n
Posts: 638
Joined: Oct 22, 2005 21:12
Location: Denmark

Re: Cassini's box

Postby h4tt3n » Sep 26, 2017 16:49

Dodicat, you make some exceptionally, amazingly trippy stuff :-) I seriously am speechless when looking at the weird stuff happening on my screen whenever I accidentally compile one of your code snippets. Also, on exit it throws a blue screen fatal exception error.

Cheers, Mike
grindstone
Posts: 322
Joined: May 05, 2015 5:35
Location: Germany

Re: Cassini's box

Postby grindstone » Sep 26, 2017 20:33

@dodicat:
You're a wisecracker! :-D
deltarho[1859]
Posts: 530
Joined: Jan 02, 2017 0:34
Location: UK

Re: Cassini's box

Postby deltarho[1859] » Sep 27, 2017 20:27

h4tt3n wrote:Also, on exit it throws a blue screen fatal exception error.

and on pressing Esc before sc>5.

The first line following FIN: is nan().

Nan() is a macro but used only once, after FIN: I could not fathom out it's purpose so I removed it. No fatal exception now when sc>5 or if Esc is pressed beforehand.

The wobble/buffeting makes the graphics for me. I nearly spilled my scotch. <smile>

Needs a final screen: RIP Cassini.

Well done, dodicat.
dodicat
Posts: 4336
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Cassini's box

Postby dodicat » Sep 27, 2017 22:02

Thank you all for the comments.
What the final fatal error in Cassini's computer was, we can only guess.
But I am sure it did complain about something in that plunge.

NASA were very keen in not crashing Cassini on one of the moons.
They say that contamination could occur (bacteria)
They didn't want contamination because either:

1) It would affect future probes from reporting a true picture of the moon.
2) They didn't want the poor sods living there to get sick.

They didn't say which.
grindstone
Posts: 322
Joined: May 05, 2015 5:35
Location: Germany

Re: Cassini's box

Postby grindstone » Sep 28, 2017 10:11

deltarho[1859] wrote:Nan() is a macro but used only once, after FIN: I could not fathom out it's purpose so I removed it.

*rofl* (I could tell you why, but I don't want to spoil dodicat's enjoyment.)
deltarho[1859]
Posts: 530
Joined: Jan 02, 2017 0:34
Location: UK

Re: Cassini's box

Postby deltarho[1859] » Oct 01, 2017 2:27

Oh, I see - as in Quiet NANs.

Since nan() causes a crash before the two imagedestroys are we then left with a memory leak?

Don't answer that - I don't particularly want to know. Oh, dear.
grindstone
Posts: 322
Joined: May 05, 2015 5:35
Location: Germany

Re: Cassini's box

Postby grindstone » Oct 01, 2017 11:51

deltarho[1859] wrote:Don't answer that - I don't particularly want to know.
Why not? Don't you want to become wiser? Not even a little bit? <grin>
deltarho[1859]
Posts: 530
Joined: Jan 02, 2017 0:34
Location: UK

Re: Cassini's box

Postby deltarho[1859] » Oct 01, 2017 12:28

I am running out of space so need to be selective. Graphics will not be getting a look in. Each to their own.

Return to “General”

Who is online

Users browsing this forum: No registered users and 2 guests