It would be nice if the drawing adapted to the resolution of the window.
Code: Select all
'Screen 19,32
Screen 18,32
Code: Select all
'Screen 19,32
Screen 18,32
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
Yes, that is what I had in mind. But your MoveWindow() demo is perfect. :)dodicat wrote:I could re-write, scaling all the positions and sizes of things I suppose.