Vector fields

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Vector fields

Post by dodicat »

Springtime
For fb 1.09.0 (at least)

Code: Select all

#cmdline "-gen gcc -O 2"
Const lim As long = 50
Dim Shared As long w, h
Screeninfo w,h
Screenres .9*w,.9*h,32
Screeninfo w,h

Type Vector
    As Double  x,y
    As Ulong col
    As Long mark
End Type

Dim Shared As Any Ptr row
Dim Shared As long pitch
row=Screenptr
Screeninfo ,,,,pitch

#define irange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
#define putpixel(_x,_y,colour)    *cptr(ulong ptr,row+ (_y)*pitch+ (_x) shl 2)  =(colour)
#define getpixel(_x,_y)           *cptr(ulong ptr,row + (_y)*pitch + (_x) shl 2)

Function ShortSpline(p() As Vector,t As Single) As Vector
    #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
    Dim As Vector G
    G.x=set(x):G.y=set(y)':G.z=set(z)
    Return g
End Function

Sub GetSpline(v() As Vector,outarray() As Vector,arraysize As long=1000)
    Dim As Vector p(1 To 4)
    Redim outarray(0)
    Dim As Single stepsize=(Ubound(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))=ShortSpline(p(),t)
        Next t
    Next n
End Sub

Sub DrawCurve(a() As Vector,col As Ulong,flag As Long=0)
    If flag=1 Then Pset(a(Lbound(a)).x,a(Lbound(a)).y),Rgb(1,0,1)
    For z As long=Lbound(a)+1 To Ubound(a)
        If flag=0 Then Circle (a(z).x,a(z).y),10,col,,,,f
        If flag=1 Then Line-(a(z).x,a(z).y),Rgb(1,0,1)
    Next z
End Sub

Sub Tree(i As Any Ptr=0,x1 As Single,y1 As Single,size As Single,angle As Single,depth As Single,colb As Ulong=0,colL As Ulong=0)
    Dim  As Single spread,scale,x2,y2
    spread=25
    scale=.76
    #define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
    x2=x1-.25*size*Cos(angle*.01745329)
    y2=y1-.25*size*Sin(angle*.01745329)
    Static As Long count,fx,fy,sz,z
    If count=0 Then  fx=x1:fy=y1:sz=size:z=2^(depth+1)-1
    Line i,(x1,y1)-(x2,y2),colb
    If count=0 Then  fx=x2:fy=y2:sz=size
    count=count+1
    If count>z Then count=0
    If incircle(fx,fy,(.45*sz),x2,y2)=0 Then Circle i,(x2,y2),.01*sz,colL 
    If depth>0 Then
        Tree(i,x2, y2, size * Scale, angle - Spread, depth - 1,colB,colL)
        Tree(i,x2, y2, size * Scale, angle + Spread, depth - 1,colB,colL)
    End If
End Sub

Sub drawtree(x As Long,y As Long,size As Long)
    tree(,x,y,size,0,7,Rgb(0,200,0),Rgb(0,100,0))
    tree(,x-.9*size,y,size,180,7,Rgb(0,200,0),Rgb(0,100+Rnd*100,0))
End Sub

Sub set(points() As Vector)
    Randomize
    For i As Long = 1 To lim
        points(i).x   = Rnd * w
        points(i).y   = Rnd * h
        points(i).col = Rgb(0,irange(100,255),0)
        If i*5<30 Then  points(i).col = Rgb(128-irange(1,50),164,4)
    Next i
    points(0).col=Rgb(0,100,0)
End Sub

Sub fields(points() As Vector)
    Dim As Long n,index
    For y As Long = 0 To h-1
        For x As Long = 0 To w-1
            n = 1e8
            For i As Long = 1 To lim
                Var distance = Sqr((x-points(i).x)*(x-points(i).x)+(y-points(i).y)*(y-points(i).y))
                If distance < n Then 
                    n = distance
                    index = i
                End If
            Next i
            If getpixel(x,y)=Rgb(100,0,0) Then 
                putpixel(x,y,points(index).col)
            Else
                putpixel(x,y,points(index-1).col)
            End If
        Next x
    Next y
End Sub

Sub hedges(z() As Vector)
    Dim As Long count
    Redim As Vector z(1000000)
    For x As Long=0 To w-2
        For y As Long=0 To h-2
            If getpixel(x,y)<>getpixel((x+1),(y+1)) Then
                count+=1
                z(count)=Type(x,y)
                If getpixel(x,y)=Rgb(100,100,100) or getpixel(x+1,y+1)=Rgb(100,100,100) Then z(count).mark=1
                If count Mod 100=0 Then z(count).mark=1
            End If
        Next
    Next
    Redim Preserve z(count)
    For i As Long = 1 To Ubound(z) 
        Pset(z(i).x,z(i).y),Rgb(100,50,0)
        If i Mod 3=0 Then  Circle (z(i).x,z(i).y), 2, Rgb(20,100+irange(0,50),0),,,,f
    Next i
    For i As Long = 1 To Ubound(z)
        If z(i).mark And i Mod 50=0 Then drawtree(z(i).x,z(i).y,irange(8,12))
    Next i
End Sub

Sub road(catmul() As Vector)
    Redim As Vector c(1 To irange(4+4+2,6+4+2))
    For n As Long=1 To 3
        c(n)=Type(irange(-100,-200),irange(0,(h)))
        c(Ubound(c)-n)=Type(irange((w+100),(w+200)),irange(0,(h)))
    Next n
    Var u=Ubound(c),gap=w/(u-6),k=0
    For n As Long=4 To Ubound(c)-4
        k+=gap
        c(n).x=k+irange(-5,5)
        c(n).y=irange(200,(h-200))
    Next
    GetSpline(c(),catmul())
End Sub

Sub split(catmul() As Vector)
    drawcurve(catmul(),0,1)
    Paint(w\2,2),Rgb(100,0,0),Rgb(1,0,1)
    Paint(w\2,h-2),Rgb(0,100,0),Rgb(1,0,1)
End Sub

Sub roadmarks(catmul() As Vector)
    For z As long=Lbound(catmul)+0 To Ubound(catmul)
        If z Mod 4=0 Then Pset(catmul(z).x,catmul(z).y),Rgb(255,255,255)
    Next z
End Sub

Redim As Vector z()
Dim As Vector points(0 To lim)
Redim As Vector catmul()
windowtitle "any key or <esc>"
Do
    set(points())
    road(catmul())
    Screenlock
    Cls
    split(catmul())
    fields(points())
    drawcurve(catmul(),Rgb(100,100,100))
    hedges(z())
    roadmarks(catmul())
    
    Screenunlock
    'Print "any key or <esc>"
    Sleep
Loop until inkey=chr(27)


 
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Vector fields

Post by srvaldez »

nice :D
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Vector fields

Post by UEZ »

Looks very nice - UK from top. :)

The fields look like a Voronoi diagram...

Thx for sharing.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Vector fields

Post by dodicat »

Thanks srvaldez/UEZ.
Yes, a Voronoi type diagram.
The closest points in the x/y plane (screen pixels) to a position in an array of points all share the position's colour.
Post Reply