No mouse effects or anything like that.
Code: Select all
Extern "c"
Declare Function Transfer Alias "memcpy" (As Byte Ptr,As Byte Ptr,As Integer) As long
End Extern
'make a crude terrain
Sub terrain(xstart As Long,xend As Long,im As Any Ptr)
Type _point
As Single x,y
As Ulong col
End Type
Dim As Long rotx,roty
#macro rotate(pivotx,pivoty,px,py,a,scale)
rotx=scale*(Cos(a*.0174533)*(px-pivotx)-Sin(a*.0174533)*(py-pivoty))+pivotx
roty=scale*(Sin(a*.0174533)*(px-pivotx)+Cos(a*.0174533)*(py-pivoty))+pivoty
#endmacro
#define rr(first,last) Rnd * (last - first) + first
#macro turnline(piv,p1,p2,ang,col,d)
Scope
rotate(piv.x,piv.y,p1.x,p1.y,ang,d)
Var rot1=Type<_point>(rotx,roty)
rotate(piv.x,piv.y,p2.x,p2.y,ang,d)
Var rot2=Type<_point>(rotx,roty)
Line im,(rot1.x,rot1.y)-(rot2.x,rot2.y),col
End Scope
#endmacro
Dim As _point v1,v2,piv
Dim As Ulong treecol
Dim As Double pivx,pivy,pivz,l,k,d
Dim As Long rd,g,b
Var diff=0.0,delta=0.0
Var yres=0.0
For m As Double=0 To 50 Step 2'5
Randomize m
For n As Double=xstart-(m+rr(2,20)) To xend+m Step rr(3,9)
Randomize n^2
l=rr(4,11)
k=rr(1,5)
diff=m*2
yres+=.02
piv=Type(n,yres+diff*(1-Sin(.002*(n-m*5-k+40-100)))) '20
Var cc=rr(1,40)
Var yfin=450
For a As Double=0 To yfin Step 7
Randomize a
Var shader=rr(1,6)
rd=20+shader+cc
g=150+shader:If g>40 Then g=g-40
b=20+shader:If b>20 Then b=b-20
treecol=Rgb(rd/2,g/2,b/2)
For a2 As Double=0 To l Step .3
If a>270 Then shader=-shader
treecol=Rgb(rd,(g-a2*shader)/2,b)
v1=Type(piv.x-a2,piv.y)
v2=Type(piv.x-l,piv.y)
turnline(piv,v1,v2,a,treecol,1)
Next a2
Next a
Next n
Next m
End Sub
'===== plotting ======
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
*pixel=(colour)
#endmacro
Dim As Integer Xres,Yres
Dim Shared As integer pitch
Dim Shared As any Pointer row
Dim Shared As Uinteger Pointer pixel
Screenres 900,600,32
Screeninfo Xres,Yres
'=================================
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
'colours for ripples
Const col1=Rgba(0,155,255,50)
Const col2=Rgba(0,100,255,50)
Const col3=Rgba(255,255,255,155)
'flow macro
#macro Flow(p)
For z As Integer= (size shr 2) to 0 step -1
Swap p[z],p[z+1]
Next z
#endmacro
Function water(iwidth As Long=0,iheight As Long=0) As Any Ptr
#define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))
Dim As Double N1=.1,N2=0
Static As Byte B1(),B2(),runflag
Static As Any Ptr im
Static As Long _iheight,_iwidth
'dim as long size
#macro Copy()
Transfer(@B1(0,0),@B2(0,0),(_iwidth+3)*(_iheight+3))
#endmacro
If runflag=0 Then
runflag=1
_iwidth=iwidth:_iheight=iheight
im=Imagecreate(iwidth,iheight)
Imageinfo im,,,,pitch,row
Redim B1(iwidth+2,iheight+2)
Redim B2(iwidth+2,iheight+2)
For n1 As Long=0 To iwidth+2
For n2 As Long=0 To iheight+2
b1(n1,n2)=IntRange(0,2)
b2(n1,n2)=IntRange(0,2)
Next
Next
End If
'Screenlock
For y As Integer= 1 To _iheight
For x As Integer= 1 To _iwidth
If B1(x,y)=0 And N1>Rnd Then B2(x,y)=1
If B1(x,y)=2 Then B2(x,y)=0
If B1(x,y)=1 Then
B2(x,y) = 1
If B1(x-1,y-1)=2 Or B1(x,y-1)=2 Or B1(x+1,y-1)=2 Then B2(x,y)=2
If B1(x-1,y)=2 Or B1(x+1,y)=2 Or N2>Rnd Then B2(x,y)=2
If B1(x-1,y+1)=2 Or B1(x,y+1)=2 Or B1(x+1,y+1)=2 Then B2(x,y)=2
End If
If B2(x,y)=0 Then:ppset((x-1),(y-1),col1):End If
If B2(x,y)=1 Then:ppset((x-1),(y-1),col2):End If
If B2(x,y)=2 Then:ppset((x-1),(y-1),col3):End If
Next x
Next y
water=im
'Screenunlock
Copy()
End Function
Dim As Long ctr,fps
locate 10,10
print "terraforming ... "
'setup water and image
water(xres,300)'water image size
Dim As Any Ptr Image=Imagecreate(xres,300,Rgb(255,255,255))'same as water image
dim as ulong ptr pi:dim as integer size
Imageinfo image,,,,,pi,size
'=============================
'setup a background
Dim As Any Ptr trn=Imagecreate(xres,yres)
terrain(0,xres,trn)'north
For n As Long=0 To xres
Var k=yres-200
var g=100*sin(n/(xres/2))+20
Line trn,(n,yres)-(n,k-120*Sin(n/xres+.0075*(cos(n/2)))),Rgb(g,g,g) 'south
Next
Do
ctr+=1
If ctr Mod 4=0 Then Put image,(0,0),water,Alpha:ctr=0
if ctr mod 2 =0 then :Flow(pi):end if
Screenlock
'Cls 'optional
Put(0,100),image,Pset 'water
Put(0,0),trn,trans 'background
Locate 1,1
Print fps
Screenunlock
Sleep regulate(50,fps),1
Loop Until Len(Inkey)
'Wend
Sleep
'Imagedestroy im 