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)