Ever box

[Roland Chastain]

@dodicat

It would be nice if the drawing adapted to the resolution of the window.

Code: Select all

'Screen 19,32
Screen 18,32

[dodicat]

Hi Roland
An easy way for windows users with the 32 bit fbc compiler.
Change the resolution at line 12
(move the screen by left mouse button and drag)

Code: Select all

 
 


Screen 19,32,,&h08
Dim Shared As Integer xres,yres
Screeninfo xres,yres
Dim As Integer I
Screencontrol(2,I)'getwindowhandle
Dim As Any Ptr Win = Cast(Any Ptr,I)
Declare Function MoveWindow Alias "MoveWindow"(As Any Ptr,As Integer,As Integer,As Integer,As Integer,As Integer) As Integer
            'screen 18  640,480
 MoveWindow(Win,200,200,640,480,1)
Declare Function main() As Long
End main

Type Pt
    As Single x,y
End Type

Sub arrayinsert(a() As pt,index As Long,insert As pt)
    If index>=Lbound(a) And index<=Ubound(a)+1 Then
        index=index-Lbound(a)
        Redim Preserve a(Lbound(a) To  Ubound(a)+1)
        Dim x As Long
        For x= Ubound(a) To Lbound(a)+index+1 Step -1
            Swap a(x),a(x-1)
        Next x
        a(Lbound(a)+index)=insert
    End If
End Sub

Sub arraydelete(a() As pt,index As Long)
    If index>=Lbound(a) And index<=Ubound(a) Then
        Dim x As Long
        For x=index To Ubound(a)-1
            a(x)=a(x+1)
        Next x
        Redim Preserve a(Lbound(a) To Ubound(a)-1)
    End If
End Sub

Function rotate(pivot As pt,p As pt,a As Single,d As Single=1) As pt
    Return Type<pt>(d*(Cos(a)*(p.x-pivot.x)-Sin(a)*(p.y-pivot.y)) +pivot.x,_
    d*(Sin(a)*(p.x-pivot.x)+Cos(a)*(p.y-pivot.y)) +pivot.y)
End Function

Function inpolygon(p1() As Pt,Byval p2 As Pt) As Long
    #macro Winder(L1,L2,p)
    ((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

Sub drawpolygon(p() As Pt,Byref col As Ulong,Byref c As pt=type(0,0)) 
    Dim k As Long=Ubound(p)+1
    Dim As Long index,nextindex
    Dim As Long cx,cy
    For n As Long=1 To Ubound(p)
        cx+=p(n).x:cy+=p(n).y
        index=n Mod k:nextindex=(n+1) Mod k
        If nextindex=0 Then nextindex=1
        Line (p(index).x,p(index).y)-(p(nextindex).x,p(nextindex).y),col
    Next
    cx/=Ubound(p):cy/=Ubound(p)
    c=type(cx,cy)
    'Paint (cx,cy),rgba(100,0,0,50),col
    for n as long=1 to ubound(p)
        line(cx,cy)-(p(n).x,p(n).y),rgb(100,50,0)
        circle(p(n).x,p(n).y),2,rgb(0,0,0),,,,f
        next
     circle(cx,cy),5,0,,,,f
     circle(cx,cy),6,rgb(255,0,0)
End Sub

Function cspline(p() As Pt,t As Single) As Pt'catmull rom
    #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<pt>(set(x),set(y))',set(z))'3D
End Function

Sub Getspline(v() As Pt,outarray() As Pt,arraysize As Long=1000)
    Dim As Pt p(1 To 4)
    Redim outarray(0)
    Dim As Single stepsize=(Ubound(v)-Lbound(v)+1)/(arraysize)
    If stepsize>1 Then stepsize=1
    For n As Long=Lbound(v)+1 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))=cspline(p(),t)
        Next t
    Next n
End Sub

Sub DrawSplinePoints(a() As Pt,col As Uinteger,ydisp As Integer=0)
    Pset(a(Lbound(a)).x,a(Lbound(a)).y+ydisp),col
    For z As Integer=Lbound(a)+1 To Ubound(a)
        Line-(a(z).x,a(z).y+ydisp),col
    Next z
    Paint(xres\2,yres-5),col,col
End Sub

Sub advance(p1() As Pt,a As Single,ypos As Long,range As Long)
    #define Intrange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
    For n As Long=Lbound(p1) To Ubound(p1)
        p1(n).x+=a
    Next n
    If p1(Ubound(p1)).x>xres+.25*xres Then
        arraydelete(p1(),Ubound(p1))
        Var p=Type<Pt>(-.25*xres,IntRange((ypos-range),(ypos+range)))
        arrayinsert(p1(),1,p)
    End If
End Sub

Sub SetUpPoints(p1() As Pt,ypos As Long,range As Long)
    #define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    #define Intrange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
    For n As Long=1 To Ubound(p1) 
        Var xpos=map(Lbound(p1),Ubound(p1),n,(-.2*xres),(xres+.2*xres))
        p1(n)=Type<pt>(xpos,Intrange((ypos-range),(ypos+range)))
    Next n
End Sub

Sub getcentre(b() As pt)
    dim as long cx,cy
    for n as long=1 to ubound(b)
        cx+=b(n).x
        cy+=b(n).y
    next
    cx=cx/ubound(b):cy=cy/ubound(b)
    b(0)=type(cx,cy)
End Sub

Sub SetUpWheel(b() As pt,sz As Long=100,x as long=400,y As Long=450,n as long=6)
    dim as single pi=4*atn(1),ctr
     #define Intrange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
    Redim b(1 To n)
    for z as single=0 to 2*pi+.5 step 2*pi/n
        ctr+=1
        if ctr>n then exit for
        b(ctr)=type(x+sz*cos(z),y+sz*sin(z))
    next
End Sub

Sub TurnWheel(b() As pt,rot() As pt,a As Single,f As pt)
    For n As Long=lbound(b) To ubound(b)
        rot(n)= rotate(f,b(n),a)
    Next n
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

sub update(c() as pt,rot() as pt)
    For m As Long =Lbound(c) To Ubound(c) 'update wheel position
            If inpolygon(rot(),c(m)) Then 
                Do
                    For n As Long=1 To ubound(rot)
                        rot(n).y-=.5
                    Next n
                Loop Until inpolygon(rot(),c(m))=0
            End If
        Next
    end sub
  'thick line  
sub tline(x as long,y as long,x2 as long,y2 as long,thickness as single,col as ulong)
dim as single h=Sqr((x2-x)^2+(y2-y)^2)  'hypotenuse
dim as single s=(y-y2)/h                 'sine
dim as single c=(x2-x)/h                 'cosine
Line (x+s*thickness/2,y+c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),col
Line (x-s*thickness/2,y-c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),col
Line (x+s*thickness/2,y+c*thickness/2)-(x-s*thickness/2,y-c*thickness/2),col
Line (x2+s*thickness/2,y2+c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),col
paint((x+x2)/2,(y+y2)/2), col, col 
end sub

function  lineto(x1 As long,y1 As long,x2 As long,y2 As long,L As single) as pt
    Dim As long diffx=x2-x1,diffy=y2-y1
    
    return type(x1+l*diffx,y1+l*diffy)
End function

 Sub MoveScreen(mx As Long=0,my As Long=0,mb As Long=0)
        Getmouse mx,my,,mb
        Static As Long lastmx,lastmy,lastx,lasty
        If lastx=mx Andalso lasty=my Then Exit Sub Else lastx=Mx:lasty=my
        Dim As Integer x,y: Screencontrol 0, x, y
        If mb=1 Then Screencontrol 100, x-(lastmx-mx),y-(lastmy-my):Exit Sub
        lastmx=mx:lastmy=my
    End Sub


Function main() As Long
     #define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    const numsides=30
    Redim As Pt p1(1 To 15)                 'given points for splines
    Redim As Pt p2(1 To 15)
    Redim As Pt c1(0)                      'interpolating endless splines
    Redim As Pt c2(0)
    Redim As pt b(),b2()                        'wheels
    Dim As pt rot(0 To numsides),rot2(0 to numsides)                   'working polygons (wheels)
    'set initial values
    Const midscreen=500
    Const range=25
    Const speed=3.0
   
    Dim As Single da,dx,dy                 'da is angle
    'tweaked for two wheels.
    Dim As pt pivot,centre1,pivot2,centre2,mp,z
    SetUpWheel(b(),100,600,450,numsides)
    SetUpWheel(b2(),50,300,500,numsides)
    SetUpPoints(p1(),midscreen,range)
    SetUpPoints(p2(),midscreen-100,range)
    Dim As Long fps
    Dim As String i,msg
    dim as any ptr im=imagecreate(xres,yres)   'sky
    for y as long=0 to yres
        dim as ubyte rd=map(0,yres,y,0,255)
        dim as ubyte gr=map(0,yres,y,100,255)
        line im,(0,y)-(xres,y),rgb(rd,gr,255)
        next
    Do
        movescreen
        i=Inkey
        da-=.008*3                                'rotate angle
        TurnWheel(b(),rot(),da,pivot)               
        TurnWheel(b2(),rot2(),da*2,pivot2)
        advance(p1(),speed,midscreen,range)        'fore bumps
        advance(p2(),speed/4,midscreen-100,range\2)'far away hills
        Getspline(p1(),c1(),300)
        Getspline(p2(),c2(),100)
        getcentre(rot())
        getcentre(rot2())
        pivot=rot(0)
        pivot2=rot2(0)
        update c1(),rot()'motion
        update c1(),rot2()
       
        Screenlock
        Cls
        put(0,0),im,pset
        Draw String(10,10),"FrameRate = "&fps,Rgb(0,0,0)
      
        DrawSplinePoints(c2(),Rgb(0,100,200)) 'far away
        DrawSplinePoints(c1(),Rgb(50,180,0))   'closer
        centre2=lineto(centre1.x,centre1.y,centre2.x,centre2.y,1.05)
        centre1=lineto(centre2.x,centre2.y,centre1.x,centre1.y,1.05)
        dx=centre1.x-centre2.x:dy=centre1.y-centre2.y
        swap dx,dy   'get normal to chassis
        dx=-dx
        mp=type((centre1.x+centre2.x)/2,(centre1.y+centre2.y)/2)'mid point of chassis
        dx=mp.x-dx:dy=mp.y-dy
        z=lineto(mp.x,mp.y,dx,dy,.5)
        tline(mp.x,mp.y,z.x,z.y,150,rgb(201,0,0))                      'the box
        tline(centre1.x,centre1.y,centre2.x,centre2.y,20,rgb(50,50,50))' the chassis
        drawpolygon(rot(),Rgb(0,0,0),centre1)      'wheels
        drawpolygon(rot2(),Rgb(0,0,0),centre2)     'smaller
         
        Screenunlock
        Sleep regulate(60,fps),1
    Loop Until i=Chr(27)
    Sleep
    imagedestroy im
    Return 1
End Function


  

I could re-write, scaling all the positions and sizes of things I suppose.

[Roland Chastain]

Hi dodicat. Thank you for Ever Box v3. :)

I could re-write, scaling all the positions and sizes of things I suppose.

Yes, that is what I had in mind. But your MoveWindow() demo is perfect. :)