Slack halyard

[dodicat]

Flag(ish) for Summer.

Code: Select all

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)

#define rr(first,last) Rnd * (last - first) + first
#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

Sub trees
    Dim As Integer rotx,roty
    #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 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
    Dim As Integer 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(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 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
    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
            rotate((mx+2),(my+2),array(count).x,array(count).y,10000*inc,mag)
            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
Dim As Single inc
jack(.45*xres,.61*yres,1.5,im)
inspectimage
backdrop
Do
    count=count+.01
    mag=3+Cos(count)/2
    inc=.003*Sin(count)*Cos(count)+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  

[AGS]

That's the wrong flag, dodicat. This is what the routine 'jack' should look like:

Code: Select all

    Sub jack(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

It's much shorter and much better than the original version of the jack routine ;)

[TJF]

Dodicat, the software artist!

That's the wrong flag, dodicat.

I guess we need an I18N extension for this project. Here's my input

Code: Select all

Sub jack(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

and

Code: Select all

Sub jack(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

[AGS]

I wonder if someone from Saudi Arabia will try and make a flag. It's got text and a sword on it (on a green background). I guess you could turn a picture of an arabian flag (saw a nice SVG one online) into something freebasic understands (I don't see how you could draw the saudi flag with fb gfx instructions but you never know....).

Clearly that black-red-yellow coloured flag MUST be a mistake, TJF. You got the colors all wrong: it should have been red-white-blue :) (red-white-ligthblue is also an option).

Nice flag, that Austrian flag.

[ytwinky]

hi,
I only wanted to see, how to use my function fbsincos(), so I inserted my function and removed the macro because I was not sure how to insert the function(and the additional variables) into a macro..
Maybe it can be optimized, but that was not what I was interested in, it works..
If you want to try it too hal @ http://www.freebasic-portal.de/porticul ... -1522.html
regards
ytwinky

p.s.
no need to say which version I like the most: slack_halyard /tjf1

[dodicat]

Nice jacks AGS and TJF.
Thats an improvement on the rotator ytwinky, you can notice it when a jack is flying away from you.
Maybe a slight increase in speed, perhaps +.5 Beaufort.

Maybe I should have used the Euro jack?

I didn't realize Holland had mountains, I thought that the Euromast was the highest point in that land.
Then again, maybe some rich Dutch person has bought an estate in Scotland, so it's ok.

I think the Austrian Mountains are more jagged. You didn't have a mile thick of ice overhead 12,000 years ago!
This old land was ground down, Ice + Rocks = ~carborundum

[1000101]

This reminds me of the 3d flag snippets in the ABC packets.

[bfuller]

You know, I have been searching for years for that old (AI) program called ELIZA, I used to have it on a CP/M machine, a Kaypro II, I often wondered if it could be rewritten/updated/modernised----and there she is on that ABC site.

[dodicat]

Hi bfuller.
Here's some Eliza stuff:
http://codeanticode.wordpress.com/2007/ ... rocessing/

The source code is in Java.