Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
slack_halyard with fbsincos
| Uploader: |  ytwinky |
| Datum/Zeit: | 28.05.2012 14:57:39 |
'Slack halyard
'source from http://www.freebasic.net/forum/viewtopic.php?f=7&t=19911
'author: dodicat
'with extensions by AGS, TJF, ytwinky
Screen 20,32,1,64 Or 1
Dim Shared As Integer xres,yres
Screeninfo xres,yres
Type _point
As Single x,y
As Uinteger col
End Type
Dim Shared As Any Pointer im
im=imagecreate(xres,yres)
Dim Shared As _point array(1 To 6561)
Sub FBSinCos(Angle As Double, byRef fbSin As Double, byRef fbCos As Double)
'©2008 by ytwinky, optimized by volta ;-))
Asm
fld qword Ptr [Angle] 'Angle -> st(0)
fsincos 'compute sin AND cos
mov edx, [fbCos] 'Addr. of fbCos -> EDX
fstp qword Ptr [edx] 'St(0) = cos -> fbCos
mov edx, [fbSin] 'Addr. of fbSin -> EDX
fstp qword Ptr [edx] 'St(0) = sin -> fbSin
End Asm
End Sub
#define rr(first,last) Rnd * (last - first) + first
Sub trees
Var fsin=0.0, fcos=0.0
Dim As Integer rotx,roty
#macro turnline(piv,p1,p2,ang,col,d)
Scope
FBSinCos(ang*.0174533, fsin, fcos)
rotx=d*(fcos*(p1.x-piv.x)-fsin*(p1.y-piv.y))+piv.x
roty=d*(fSin*(p1.x-piv.x)+fcos*(p1.y-piv.y))+piv.y
var rot1=Type<_point>(rotx,roty)
rotx=d*(fcos*(p2.x-piv.x)-fsin*(p2.y-piv.y))+piv.x
roty=d*(fsin*(p2.x-piv.x)+fcos*(p2.y-piv.y))+piv.y
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 Uinteger treecol
Dim As Double pivx,pivy,pivz,l,k
Dim As Integer rd,g,b
For m As Double=0 To 50 Step 5
Randomize m
For n As Double=200-(m+rr(2,20)) To 990+m Step rr(3,9)
Randomize n^2
l=rr(2,11)
k=rr(1,5)
piv=Type(n,.8*yres+20*(1-Sin(.01*(n-m*5-k+40-200))))
Line im,(piv.x,piv.y)-(piv.x+rr(-2,5),piv.y+8),Rgb((100),(35),37)
var cc=rr(1,40)
For a As Double=90 To 450 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/2,(g-a2*shader)/2,b/2)
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
Sub inspectimage
Dim As Integer mx=550, my=552, count
Dim As Uinteger tempcol
For x As Integer=mx-80 To mx
For y As Integer=my-80 To my
count=count+1
tempcol=Point(x,y,im)
array(count)=Type(x,y,tempcol)
Next y
Next x
End Sub
Sub jack_AGS(x As Integer,y As Integer,s As Single,im As Any Pointer=0)
Dim As Integer lx=60*s,ly=1*lx
Line im,(x,y)-(x+lx,y+20*s),Rgb(255,0,0),bf
Line im,(x,y+20*s)-(x+lx,y+40*s),Rgb(255,255,255),bf
Line im,(x,y+40*s)-(x+lx,y+60*s),Rgb(0,0,227),bf
End Sub
Sub jack_dodicat(x As Integer, y As Integer, s As Single, im As Any Pointer=0)'union
Dim As Integer lx=60*s, ly=1*lx
Dim As Uinteger col
Dim As Single st=-4*s, fi=0
Line im,(x, y)-(x+lx, y+ly), RGB(0, 0, 200), bf
For n As Integer=1 To 2
For k As Single=st To fi
If k>-1*s Or k<-3*s Then col=Rgb(255, 255, 255) Else col=Rgb(200, 0, 0)
Line im,(x, y-k)-(x+lx, y+ly-k-4*s), col
Line im,(x,y+ly-4*s-k)-(x+lx, y-k), col
Line im,((x+lx/2)+k+2*s, y)-((x+lx/2)+k+2*s, y+ly), col
Line im,(x, y+ly/2+k+2*s)-(x+lx, y+ly/2+k+2*s), col
Next k
st=-3*s
fi=-1*s
Next n
End Sub
Sub jack_TJF1(x As Integer,y As Integer,s As Single,im As Any Pointer=0)
Dim As Integer lx=60*s,ly=1*lx
Line im,(x,y)-(x+lx,y+20*s),Rgb(0,0,0),bf
Line im,(x,y+20*s)-(x+lx,y+40*s),Rgb(255,0,0),bf
Line im,(x,y+40*s)-(x+lx,y+60*s),Rgb(227,227,0),bf
End Sub
Sub jack_TJF2(x As Integer,y As Integer,s As Single,im As Any Pointer=0)
Dim As Integer lx=60*s,ly=1*lx
Line im,(x,y)-(x+lx,y+20*s),Rgb(255,0,0),bf
Line im,(x,y+20*s)-(x+lx,y+40*s),Rgb(255,255,255),bf
Line im,(x,y+40*s)-(x+lx,y+60*s),Rgb(255,0,0),bf
End Sub
Sub jack_select()
Select Case UCase(Command(1))
Case "/AGS"
jack_AGS(.45*xres, .61*yres, 1.5, im)
Case "/TJF1"
jack_TJF1(.45*xres, .61*yres, 1.5, im)
Case "/TJF2"
jack_TJF2(.45*xres, .61*yres, 1.5, im)
Case Else
jack_dodicat(.45*xres, .61*yres, 1.5, im)
End Select
End Sub
Sub backdrop 'hills/trees
#macro paintsketch(_function,minx,maxx,miny,maxy,r,g,b,alp)
For x As Double=minx To maxx Step (maxx-minx)/10000
var x1=(xres)*(x-minx)/(maxx-minx)
var y1=(yres)*(_function-maxy)/(miny-maxy)
gr=(lasty-y1)*1000
lasty=y1
If gr>g Then gr=g
Line im,(x1,yres)-(x1,y1),Rgba(r,g-gr,b,alp)
Next x
#endmacro
imagedestroy(im)
im=imagecreate(xres,yres)
For y As Integer=0 To yres
Line im,(0,y)-(xres,y),Rgb(y*255/yres,y*255/yres,y*(255-200)/yres+200)
Next y
Dim As Double lasty,gr
paintsketch(.65*yres+90*(1-Sin(.15*x)/(.15*x)),100,-100,yres,0,50,100,0,10)
paintsketch(.82*yres+20*Sin(.01*(x-200)),xres,0,yres,0,50,100,0,255)
trees
paintsketch(.85*yres+60*Sin(.001*x)-15*Cos(.015*x),xres,0,yres,0,0,100,0,255)
End Sub
Sub flag(mag As Single=3,inc As Single=.001)
Static As Single x
Var fsin=0.0, fcos=0.0
x=x+.01
Dim As Integer mx=Any,my=Any,tx=Any,ty=Any,bx=Any,by=Any
Dim As Integer rotx,roty
mx=500+5*Sin(x):my=600+5*Sin(x)
Dim As Integer count
For x As Integer=mx-80 To mx
For y As Integer=my-80 To my
count=count+1
mag=mag+rr(-3*inc,+3*inc)+inc/10
FBSinCos(mag*.0174533, fsin, fcos)
rotx=mag*(fcos*(array(count).x-(mx+2))-fsin*(array(count).y-(my+2)))+(mx+2)
roty=mag*(fsin*(array(count).x-(mx+2))+fcos*(array(count).y-(my+2)))+(my+2)
If count=1 Then tx=rotx:ty=roty
If count=80 Then bx=rotx:by=roty
Line (rotx-mag,roty-mag)-(rotx+mag,roty+mag),array(count).col,BF
Next y
Line(tx,ty)-(250,50) 'halyard
Line(bx,by)-(250,yres+200)
For z As Integer=1 To 10
Line(250+z,50)-(250+z,yres),Rgb(z*20,z*20,z*20)'post
Next z
Next x
End Sub
'____________________________________________
Dim As Single count, mag, inc
Var fsin=0.0, fcos=0.0
jack_select()
inspectimage
backdrop
Do
count += .01
mag=3+Cos(count)/2
FBSinCos(count, fsin, fcos)
inc=.003*fsin*fCos+rr(-.0001,.0001)
If inc<.0001 And inc >-.0001 Then inc=rr(-.0001,.0001)
Screenlock
Cls
Put(0,0),im
flag mag,inc
Screenunlock
Sleep 10,1
Loop Until Len(Inkey)
imagedestroy im