Confederation snake

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

Confederation snake

Postby dodicat » Dec 29, 2018 0:22

Jumpy graphics on 64 bits.
better on 32 bits.

Code: Select all


Screen 19,32

'GLOBALS

Dim Shared As long fps
Dim Shared As Integer pitch,pitchS
Dim Shared As Any Pointer row,rowS
Dim Shared As Ulong Pointer pixel,pixelS

Dim Shared As Any Ptr im
Dim Shared As Integer xres,yres
Screeninfo xres,yres,,,pitchS

im=Imagecreate(xres,yres,Rgb(200,0,0))
Imageinfo im,,,,pitch,row

rowS=Screenptr
Dim Shared As long Tot 'get Tot
For xp As long=0 To xres Step 2
    For yp As long=0 To yres Step 2
        Tot+=1
    Next yp
Next xp
Dim Shared As Single px( TOT),py( TOT)
'=======================
Sub EUROjack(x As Long,y As Long,s As Single,im As Any Pointer=0)
    #macro pentagon(starx,stary,size,col)
    Scope
        Var count=0,rad=0.0,_px=0.0,_py=0.0
        For z As Single=0+.28 To 2*pi+.1+.28 Step 2*pi/10
            count=count+1
            If count Mod 2=0 Then rad=size Else rad=.4*size
            _px=starx+rad*Cos(z)
            _py=stary+rad*Sin(z)
            If count=1 Then Pset im,(_px,_py)Else Line im,-(_px,_py),col
        Next z
        Paint im,(starx,stary),col,col
    End Scope
    #endmacro
    Dim As Double pi=4*Atn(1)
    Dim As Long lx=60*s,ly=1*lx
    Line im,(x,y)-(x+lx,y+ly),Rgba(2,3,192,255),bf
    Dim As Long cntx=(x+x+lx)/2,cnty=(y+Y+ly)/2
    For z As Double=0 To 2*pi Step 2*pi/12
        Var px=cntx+.7*(lx/2)*Cos(z)
        Var py=cnty+.7*(lx/2)*Sin(z)
        pentagon(px,py,3*s,Rgb(243,236,24))
    Next z
    Line im,(x,y)-(x+lx,y+ly),,b
End Sub

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

Sub line_to(x1 As Single,y1 As Single,x2 As Single,y2 As Single,Byref retx As Single,Byref rety As Single,flag As long=1)
    Dim As Single diffx=x2-x1,diffy=y2-y1
    Dim As Single L=Sqr(diffx*diffx+diffy*diffy):If L<1e-6 Then L=1e-6
    retx=flag*diffx/L
    rety=flag*diffy/L
End Sub

Sub update(cx As long,cy As long,flag As long=1,fx As Single,fy As Single)
    #define ppset(_x,_y,colour)    *Cptr(Ulong Ptr,rowS+ (_y)*pitchS+ (_x) Shl 2)  =(colour)
    #define ppoint(_x,_y)           *Cptr(Ulong Ptr,row + (_y)*pitch + (_x) Shl 2)
    Static As Ubyte r=75,g=190,b=240,kr=1,kg=1,kb=1
    Dim As Single dx,dy
    Dim As long i
    Static As Ulong c
    r+=kr: If r>=254 Or r<=0 Then kr=-kr
    g+=kg: If g>=254 Or g<=0 Then kg=-kg
    b+=kb: If b>=254 Or b<=0 Then kb=-kb
    c=Rgb(r,g,b)
    Screenlock
    Color,c
    Cls
    Draw String(10,10),"Framerate = "&fps
    Draw String(10,40),"R/L mouse buttons"
    For x As long=0 To xres -1 Step 2
        For y As long=0 To yres-1 Step 2
            If px(i)<0 Or px(i)>xres Then px(i)=cx+Rnd*15-Rnd*15:py(i)=cy+Rnd*15-Rnd*15'rnd*640
            If py(i)<0 Or py(i)>yres Then py(i)=cy+Rnd*15-Rnd*15:px(i)=cx+Rnd*15-Rnd*15
            line_to(px(i),py(i),cx,cy,dx,dy,flag)
            px(i)+=dx-fx
            py(i)+=dy-fy
            Var Cix=Cint(px(i)),Ciy=Cint(py(i))
            If Cix<xres And Ciy <yres Then
                If Cix>=0 And Ciy >=0 Then
                   
                    ppset(Cix,Ciy,ppoint(Cix,Ciy))
                End If
            End If
            i+=1
        Next y
    Next x
    Screenunlock()
End Sub

Dim As long cx,cy,kx=1,ky=2
cx=319
cy=239
Dim As Single fx,fy
For y As Long=5 To 600 Step 200
    For x As Long=5 To 800 Step 200
        eurojack(x,y,3.1,im)
    Next
Next
#macro set()
Dim As long c
For xp As long=0 To xres Step 2
    For yp As long=0 To yres Step 2
        px(c)=xp:py(c)=yp
        c+=1
    Next yp
Next xp
#endmacro
set()

Dim As long counter,btnflag
Dim As String i
Dim As Integer mx,my,mb
Do
    Getmouse mx,my,,mb
    i=Inkey
    cx+=kx
    cy+=ky
    If mb=1 Then
        Var d=Sqr((cx-mx)*(cx-mx) +(cy-my)*(cy-my))
        fx=5*(cx-mx)/d
        fy=5*(cy-my)/d
    Else
        fx=0:fy=0
    End If
    If cx<0 Orelse cx>xres Then kx=-kx
    If cy<0 Orelse cy>yres Then ky=-ky
    update(cx,cy,-2,fx,fy) '-2
    Sleep regulate(50,fps),1
    If mb=2 And btnflag=0  Then :set():btnflag=1:End If
    btnflag=mb
Loop Until i=Chr(27)
Print "done"
Imagedestroy im
Sleep 
D.J.Peters
Posts: 7700
Joined: May 28, 2005 3:28

Re: Confederation snake

Postby D.J.Peters » Dec 29, 2018 1:23

Why do you calculate cx-mx and cy-my 3 times = 6 subtractions and SQR(0) is a bad idea.
By the way GetMouse() returns a value if <> 0 you have to ignore mx,my,mb

Hove ever looks nice.

Joshy

Code: Select all

    #if 0
    ' old
    Getmouse mx,my,,mb
    If mb=1 Then
        Var d=Sqr((cx-mx)*(cx-mx) +(cy-my)*(cy-my))
        fx=5*(cx-mx)/d
        fy=5*(cy-my)/d
    Else
        fx=0:fy=0
    End If
    #else
    ' new
    if GetMouse(mx,my,,mb)=0 andalso mb=1 Then
        var dx= cx-mx,dy=cy-my
        Var d = dx*dx + dy*dy
        if d then d=sqr(d) : fx=5*dx/d : fy=5*dy/d
    Else
        fx=0:fy=0
    End If
    #endif
lizard
Posts: 440
Joined: Oct 17, 2017 11:35
Location: Germany

Re: Confederation snake

Postby lizard » Dec 29, 2018 6:14

Great to have eu symbol as FB routine. Fascinating to see how short code it is in your program. You both are better programmers than me. :-)
grindstone
Posts: 640
Joined: May 05, 2015 5:35
Location: Germany

Re: Confederation snake

Postby grindstone » Dec 29, 2018 9:55

Watching that snake is real relaxing. <smile>

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 3 guests