Moving on random spline loops with near const speed !

Game development specific discussions.
D.J.Peters
Posts: 8180
Joined: May 28, 2005 3:28
Contact:

Moving on random spline loops with near const speed !

Postby D.J.Peters » Feb 10, 2020 5:20

Code: Select all

#define CatmullRom(a,b,c,d,t) (b) + (t)*(-0.5*(a) + 0.5*(c) + (t)*((a) + -2.5*(b) +  2.0*(c) + -0.5*(d) + (t)*(-0.5*(a) + 1.5*(b) + -1.5*(c) + 0.5*(d))))

type tPoint
  as single x,y
end type
type tSegment
  as single x,y,l ' length
end type

type tSpline
  declare sub DeletePoints()
  declare function addPoint(byval x as single, byval y as single) as integer
  declare sub update(img as any ptr)
  declare sub show(img as any ptr)
  declare function animate(t as single) as single
  as integer      nSegments
  as tSegment ptr Segments
  as integer      nPoints
  as tPoint   ptr Points
  private:
  declare function addSegment(byval x as single, byval y as single) as integer 
end type
sub tSpline.DeletePoints
  if points then deallocate points:points=0
  nPoints=0
end sub
function tSpline.addPoint(byval x as single, byval y as single) as integer
  var index = nPoints : nPoints+=1
  Points=reallocate(Points,nPoints*sizeof(tPoint))
  Points[index].x=x
  Points[index].y=y
  return index
end function
function tSpline.addSegment(byval x as single, byval y as single) as integer
  var index = nSegments : nSegments+=1
  Segments=reallocate(Segments,nSegments*sizeof(tSegment))
  Segments[index].x=x
  Segments[index].y=y
  Segments[index].l=0
  return index
end function

' generate splinesegments from points
sub tSpline.update(img as any ptr)
  const SEG_LENGHT = 10
  dim as integer a,b,c,d,w,h
  dim as single t,tStep,l2,distance,length,x,y,dx,dy,ox,oy,nLength
  if nPoints<3 then exit sub
  if segments then deallocate segments:segments=0
  nSegments=0
   
  screeninfo w,h
  line img,(0,0)-(w-1,h-1),0,BF
 
  for i as integer=0 to 1
    ox=Points[1].x
    oy=Points[1].y
    if i=1 then addSegment(ox,oy): segments[nSegments-1].l=SEG_LENGHT 
    for j as integer = 0 to nPoints-1
      a=j mod nPoints
      b=(a+1) mod nPoints
      c=(b+1) mod nPoints
      d=(c+1) mod nPoints
      tStep=0.0001
      t=0
      while t<1+tStep
        x = CatmullRom(Points[a].x,Points[b].x,Points[c].x,Points[d].x,t)
        y = CatmullRom(Points[a].y,Points[b].y,Points[c].y,Points[d].y,t)
        if i=0 then pset img,(x,y),32+b
        dx=x-ox : dy=y-oy : l2=dx*dx + dy*dy : if l2 then length+=sqr(l2)
        ox=x : oy=y
        if i=1 and length>=nLength then
          addSegment(x,y)
          segments[nSegments-1].l=nLength+(length-nLength)
          length-=nLength
        end if 
        t+=tStep
      wend
    next
    if i=0 then nLength=length/(SEG_LENGHT*(nPoints+1)) : length=0
  next
  show(img)
end sub 
sub tSpline.show(img as any ptr)
  dim as integer a,b,c,d
  dim as single x,y,f
  if nSegments<1 then exit sub
 
  for t as single=0 to nSegments-1 step 0.01
    f=frac(t)
    a = t-f
    b = (a+1) mod nSegments
    c = (b+1) mod nSegments
    d = (c+1) mod nSegments
    x = CatmullRom(Segments[a].x,Segments[b].x,Segments[c].x,Segments[d].x,f)
    y = CatmullRom(Segments[a].y,Segments[b].y,Segments[c].y,Segments[d].y,f)
    pset (x,y),32+a mod 32
  next
  for i as integer=0 to nSegments-1
    circle img,(Segments[i].x,Segments[i].y),2,,,,,F
  next 
end sub
function tSpline.animate(byval AnimTime as single) as single
  dim as integer a,b,c,d 
  dim as single x,y,t
  if nSegments<3 then return 0
  t=frac(AnimTime)
  a = AnimTime-t
  b = (a+1) mod nSegments
  c = (b+1) mod nSegments
  d = (c+1) mod nSegments
  x = CatmullRom(Segments[a].x,Segments[b].x,Segments[c].x,Segments[d].x,t)
  y = CatmullRom(Segments[a].y,Segments[b].y,Segments[c].y,Segments[d].y,t)
  circle (x,y),7,15,,,,F
  return Segments[b].l
end function 


CONST PI=ATN(1)*4
randomize timer
dim as tSpline spline
dim as integer iWidth,iHeight,nPoints
dim as single t,length,w,w2,h2,x,y,speed
dim as boolean bNewSpline=true
screeninfo iWidth,iHeight
iWidth-=128:iHeight-=128
screenres iWidth,iHeight,8,2
screenset 1,0

screeninfo iWidth,iHeight
var background = ImageCreate(iWidth,iHeight)
w2=iWidth/2 : h2=iHeight/2

while inkey()=""
  if bNewSpline then
    cls : flip
    spline.DeletePoints
    nPoints=3+rnd*20
    for i as integer = 0 to nPoints-1
      w=i/nPoints*PI*2
    #if 1
      x=w2+cos(w)*(100+rnd*(w2-120))
      y=h2+sin(w)*(100+rnd*(h2-120))
    #else     
      x=50+rnd*(iWidth -100)
      y=50+rnd*(iHeight-100)
    #endif 
      spline.addPoint(x,y)
    next 
    spline.update(background)
    speed=10'+rnd*9
    bNewSpline=false
  end if   
  put (0,0),background,PSET
  length = spline.animate(t)
  t+=1/length*speed
  if t>=spline.nSegments then t-=spline.nSegments : bNewSpline=true
  flip
  sleep 10
wend
BasicCoder2
Posts: 3586
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Moving on random spline loops with near const speed !

Postby BasicCoder2 » Feb 10, 2020 6:22

Compiler output:
Aborting due to runtime error 12 ("segmentation violation" signal)

Results:
Compilation failed
D.J.Peters
Posts: 8180
Joined: May 28, 2005 3:28
Contact:

Re: Moving on random spline loops with near const speed !

Postby D.J.Peters » Feb 10, 2020 7:29

It's simple BASIC no problems here I tested 32 and 64-bit !

What are wrong with your FreeBASIC setup ?

Joshy
jdebord
Posts: 529
Joined: May 27, 2005 6:20
Location: Limoges, France
Contact:

Re: Moving on random spline loops with near const speed !

Postby jdebord » Feb 10, 2020 7:47

Works well with Windows 10 + FB 32 bits

Thanks for this nice demo !
BasicCoder2
Posts: 3586
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Moving on random spline loops with near const speed !

Postby BasicCoder2 » Feb 10, 2020 8:27

D.J.Peters wrote:What are wrong with your FreeBASIC setup ?
Joshy

No idea what was wrong. Anyway I downloaded and reinstalled FreeBASIC and your program now compiles and runs.
D.J.Peters
Posts: 8180
Joined: May 28, 2005 3:28
Contact:

Re: Moving on random spline loops with near const speed !

Postby D.J.Peters » Feb 10, 2020 9:27

Code: Select all

#if 1 ' <-- change it to 0 to see really extreme random splines
  x=w2+cos(w)*(100+rnd*(w2-120))
  y=h2+sin(w)*(100+rnd*(h2-120))
#else     
  x=50+rnd*(iWidth -100)
  y=50+rnd*(iHeight-100)
#endif
dafhi
Posts: 1359
Joined: Jun 04, 2005 9:51

Re: Moving on random spline loops with near const speed !

Postby dafhi » Feb 10, 2020 16:24

nice work. the movement looks organic
D.J.Peters
Posts: 8180
Joined: May 28, 2005 3:28
Contact:

Re: Moving on random spline loops with near const speed !

Postby D.J.Peters » Feb 10, 2020 18:42

Of course the speed can be made random as well.

speed = 5 + rnd*5

Joshy
dodicat
Posts: 6692
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Moving on random spline loops with near const speed !

Postby dodicat » Feb 10, 2020 21:40

Nice.
The two Catmull Rom end points are a nuisance when closing a loop.(I find anyway)
Here is my effort, West to East but draggable, not Catmull Rom, but a particle trajectory.

Code: Select all

 
Screen 20,32
Dim Shared As Integer xres,yres
Screeninfo xres,yres
Type Point
    As Single x,y,z
End Type
Type particle
    As Point position,velocity
End Type

#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#define vct Type<Point>
#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)

Operator + (v1 As Point,v2 As Point) As Point
Return vct(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(v1 As Point,v2 As Point) As Point
Return vct(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (f As Single,v1 As Point) As Point 'scalar*point
Return vct(f*v1.x,f*v1.y,f*v1.z)
End Operator

Function length(v As Point) As Single
    Return Sqr(v.x*v.x+v.y*v.y+v.z*v.z)
End Function

Function normalize(v As Point) As Point
    Dim n As Single=length(v)
    If n=0 Then n=1e-20
    Return vct(v.x/n,v.y/n,v.z/n)
End Function

Sub trace(In() As Point,Outarray() As Point,roundedness As Single=60)
    Redim Outarray(0)
    Dim As particle p:roundedness=roundedness/10
    If roundedness<1 Then roundedness=1
    If roundedness>100 Then roundedness=10
    p.position=In(Lbound(In))
    p.velocity=normalize(Type<Point>(In(Lbound(In)+1)-In(Lbound(In))))
    Redim Preserve Outarray(1 To Ubound(Outarray)+1)
    Outarray(Ubound(Outarray))=Type<Point>(In(Lbound(In)).x,In(Lbound(In)).y)
    Dim As Point f
    For n As long=Lbound(In) To Ubound(In)-1
        Do
            Var dist=length(p.position-In(n+1))
            f=(1/(Ubound(In)))*f+normalize(In(n+1)-p.position)
            p.velocity= roundedness*normalize(p.velocity+f)
            p.position=p.position+p.velocity
            Redim Preserve Outarray(1 To Ubound(Outarray)+1)
            Outarray(Ubound(Outarray))=Type<Point>(p.position.x,p.position.y,p.position.z)
            If dist<5*roundedness Then Exit Do
        Loop
    Next n
    Redim Preserve Outarray(1 To Ubound(Outarray)+1)
    Outarray(Ubound(Outarray))=Type<Point>(In(Ubound(In)).x,In(Ubound(In)).y,In(Ubound(In)).z)
End Sub

Sub drawpoints(p() As Point,col As Ulong)
    For n As Long=Lbound(p) To Ubound(p)
        Circle (p(n).x,p(n).y),5,col
        Draw String(p(n).x-4,p(n).y),Str(n),Rgb(0,200,0)
    Next n
End Sub

Sub DrawCurve(a() As Point,col As Ulong)
    Pset(a(Lbound(a)).x,a(Lbound(a)).y)
    For z As long=Lbound(a)+1 To Ubound(a)
        Line -(a(z).x,a(z).y),col
    Next z
End Sub

Sub SetUpPoints(p1() As Point,ypos As Long,range As Long)
    Dim As Integer xres,yres
    Screeninfo xres,yres
    For n As Long=1 To Ubound(p1)
        Var xpos=map(Lbound(p1),Ubound(p1),n,(-.2*xres*0),(xres+.2*xres*0))
        p1(n)=Type<Point>(xpos,Intrange((ypos-range),(ypos+range)),xpos)
    Next n
End Sub

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

Sub show(p() As Point,t() As Point,c As Point,r As Long=60)
    trace(p(),t(),r)
    static as single n=1
    static as long fps
    var k=(.01*ubound(t))/5
    n+=k
    if n>=ubound(t) then n=lbound(t)
    Screenlock
    Cls
    draw string(20,30),"Options:",rgb(200,200,200)
    draw string(20,50),"Drag points, slide the red ball, right click the screen",rgb(200,200,200)
    draw string(20,80),"F.P.S. "&fps'str(ubound(t))+"  "+str(k)
    drawcurve(t(),Rgb(0,0,255))
    drawpoints(p(),Rgb(200,0,0))
    Line(.25*xres,.95*yres)-(.75*xres,.95*yres+20),,b
    Circle(c.x,c.y),8,Rgb(200,0,0),,,,f
    circle(t(n).x,t(n).y),5,rgb(0,200,0),,,,f
    Screenunlock
    var q=map(5,75,r,60,30)
    Sleep regulate(q,fps)
End Sub

Sub handleradius(c As Point,mx As long,my As long,b As long,Byref r As long)
    Dim As long lowerx=.25*xres+10,upperx=.75*xres-10
    Dim As long lowery=.95*yres,uppery=.95*yres+20
    #define inbox mx>lowerx And my<upperx And my>lowery And my<uppery
    If b=1 Then
        If inbox Then
            c.x=mx
            If c.x<=lowerx Then c.x=lowerx
            If c.x>=upperx Then c.x=upperx
            r=map(lowerx,upperx,c.x,15,65) '75
        End If
    End If
End Sub

#macro mouse(m)
#define onscreen (mx>10) and (mx<xres-10) and (my>10) and (my<yres-10)
Dim As Long x=mx,y=my,dx,dy
While mb = 1
    show(p(),tracer(),c,r):Sleep 1,1
    Getmouse mx,my,,mb
    If onscreen Then
        If mx<>x Or my<>y  Then
            dx = mx - x
            dy = my - y
            x = mx
            y = my
            p(m).x=x+dx
            p(m).y=y+dy
        End If
    End If
Wend
#endmacro

#macro refresh
Redim As Point p(1 To intrange(10,20))
dim as single x=map(15,65,r,(.25*xres),(.75*xres))
Dim As Point c=Type(x,.95*yres+10)
Redim As Point tracer()
setuppoints(p(),300,intrange(50,300))
trace(p(),tracer())
#endmacro

Dim As long mx,my,mb,r=40,flag
refresh
Do
    Getmouse mx,my,,mb
    show(p(),tracer(),c,r)
    For n As Long=Lbound(p) To Ubound(p)
        If incircle(p(n).x,p(n).y,10,mx,my) And mb=1 Then
            mouse(n)
        End If
    Next
    handleradius(c,mx,my,mb,r)
    if mb=2 and flag=0 then
        flag=1
        refresh
    end if
    flag=mb
Loop Until Len(Inkey)

Sleep

 

Return to “Game Dev”

Who is online

Users browsing this forum: No registered users and 1 guest