Spring is in the air.

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

Spring is in the air.

Post by dodicat »

Some old routines amalgamated with some very old.
After reading some guff about compression algorithms, I decide to ignore all the gobbledegook and follow a true compressor (Robert Boyle), who simply called compression of air -- the natural spring of air--, and no doubt, If he was here now, he would call computer files and all their zip, rar, e.t.c. counterparts -- the natural spring of data.
Anyway, the weather here is improving each day as the seasons grind on, so, add some old harmony to the new Spring.

Code: Select all



Type _point
    As Single x,y,z
    As Ulong col
End Type

Dim Shared im As Any Pointer
Dim Shared As Integer xres,yres

Screen 19,32,,64
Locate 10,10
Print "Please wait . . ."
Screeninfo xres,yres
im=Imagecreate(xres,yres)

Function rotatepoint3d(Byval pivot As _point,_  
    Byval first As _point,_  
    Byval angle As _point,_ 
    Byval dilator As Single=1) As _point  
    #macro mv(m1,v,ans)
    For i As Long=1 To 3
        s=0
        For k As Long = 1 To 3
            s=s+m1(i,k)*v(k)
        Next k
        ans(i)=s
    Next i
    #endmacro
    Static Pi As Single = 4*Atn(1)  
    Dim angle_radians As _point
    Static pivot_vector(1 To 3) As Single
    Dim s As Single
    angle_radians.x=(Pi/180)*angle.x      
    angle_radians.y=(Pi/180)*angle.y
    angle_radians.z=(Pi/180)*angle.z
    pivot_vector(1)=(first.x-pivot.x)*dilator
    pivot_vector(2)=(first.y-pivot.y)*dilator
    pivot_vector(3)=(first.z-pivot.z)*dilator
    Static Rx(1 To 3,1 To 3) As Single
    Static Ry(1 To 3,1 To 3) As Single
    Static Rz(1 To 3,1 To 3) As Single
    'rotation matrices about the three axix
    Rx(1,1)=1:Rx(1,2)=0:Rx(1,3)=0
    Rx(2,1)=0:Rx(2,2)=Cos(angle_radians.x):Rx(2,3)=-Sin(angle_radians.x)
    Rx(3,1)=0:Rx(3,2)=Sin(angle_radians.x):Rx(3,3)=Cos(angle_radians.x)
    
    Ry(1,1)=Cos(angle_radians.y):Ry(1,2)=0:Ry(1,3)=Sin(angle_radians.y)
    Ry(2,1)=0:Ry(2,2)=1:Ry(2,3)=0
    Ry(3,1)=-Sin(angle_radians.y):Ry(3,2)=0:Ry(3,3)=Cos(angle_radians.y)
    
    Rz(1,1)=Cos(angle_radians.z):Rz(1,2)=-Sin(angle_radians.z):Rz(1,3)=0
    Rz(2,1)=Sin(angle_radians.z):Rz(2,2)=Cos(angle_radians.z):Rz(2,3)=0
    Rz(3,1)=0:Rz(3,2)=0:Rz(3,3)=1
    
    Static new_pos(1 To 3) As Single
    Static temp1(1 To 3) As Single
    Static temp2(1 To 3) As Single
    
    mv (Rx,pivot_vector,temp1)           
    mv (Ry,temp1,temp2)
    mv (Rz,temp2,new_pos)
    
    new_pos(1)+=pivot.x
    new_pos(2)+=pivot.y
    new_pos(3)+=pivot.z
    Dim As _point xyz=Type(first.x-new_pos(1),first.y-new_pos(2),first.z-new_pos(3))
    Return Type(first.x-xyz.x,first.y-xyz.y,first.z-xyz.z)' pt
    Dim As _point pt=Type(first.x-xyz.x,first.y-xyz.y,first.z-xyz.z)
    Return Type(first.x-xyz.x,first.y-xyz.y,first.z-xyz.z)' pt
End Function

Function apply_perspective(p As _point,eye As _point,w As Single) As _point
    Dim As _point rv
    rv.x=(p.x-eye.x)/w+eye.x:rv.y=(p.y-eye.y)/w+eye.y:rv.z=(p.z-eye.z)/w+eye.z
    Return rv
End Function

Function Filter(Byref tim As Ulong Pointer,_
    Byval rad As Single,_
    Byval destroy As Integer=1,_
    Byval fade As Integer=0) As Ulong Pointer
    #define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
    If fade<0 Then fade=0:If fade>100 Then fade=100
    Type p2
        As Integer x,y
        As Ulong col
    End Type
    #macro _ppoint(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*4
    (colour)=*pixel
    #endmacro
    #macro ppset(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*4
    *pixel=(colour)
    #endmacro
    #macro average()
    ar=0:ag=0:ab=0:inc=0
    xmin=x:If xmin>rad Then xmin=rad
    xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
    ymin=y:If ymin>rad Then ymin=rad
    ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
    For y1 As Integer=-ymin To ymax
        For x1 As Integer=-xmin To xmax
            inc=inc+1 
            ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
            ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
            ab=ab+(NewPoints(x+x1,y+y1).col And 255)
        Next x1
    Next y1
    If fade=0 Then
        averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
    Else
        averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
    End If
    #endmacro
    Dim As Single fd=map(0,100,fade,1,0)
    Dim As Integer _x,_y
    Imageinfo tim,_x,_y
    Dim  As Ulong Pointer im=Imagecreate(_x,_y)
    Dim As Integer pitch
    Dim  As Any Pointer row
    Dim As Ulong Pointer pixel
    Dim As Ulong col
    Imageinfo tim,,,,pitch,row
    Dim As p2 NewPoints(_x-1,_y-1)
    For y As Integer=0 To (_y)-1
        For x As Integer=0 To (_x)-1
            _ppoint(x,y,col)
            NewPoints(x,y)=Type<p2>(x,y,col)
        Next x
    Next y
    Dim As Ulong averagecolour
    Dim As Integer ar,ag,ab
    Dim As Integer xmin,xmax,ymin,ymax,inc
    Imageinfo im,,,,pitch,row
    For y As Integer=0 To _y-1
        For x As Integer=0 To _x-1  
            average()
            ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour) 
        Next x
    Next y
    If destroy Then Imagedestroy tim: tim = 0
    Function= im
End Function

Sub Magnify()    
    #define resetwheel(w,fl) fl=w
    #define wheel(w,f) w-f
    Dim As Long mx,my,mw,button:Getmouse mx,my,mw,button
    Static As Long flag,pmw
    mw=Abs(mw/2)
    Line(mx-40,my-40)-(mx+40,my+40),Rgb(0,0,0),B':exit sub
    If button=1 Then  resetwheel(mw,flag)
    Dim As Ulong array(1 To 6561),count
    pmw=wheel(mw,flag)
    If pmw<=1 Then Exit Sub
    For z As Long=1 To 2
        For x As Long=mx-40 To mx+40
            For y As Long=my-40 To my+40
                count+=1
                If z=1 Then 
                    Var c=Point(x,y) 'needed to magnify an alpha screen
                    Var r =Cast(Ubyte Ptr,@c)[2]
                    Var g =Cast(Ubyte Ptr,@c)[1]
                    Var b =Cast(Ubyte Ptr,@c)[0]
                    Var al=Cast(Ubyte Ptr,@c)[3]
                    array(count)=Rgba(r,g,b,255)
                End If
                If z=2 Then
                    Var NewX=pmw*(x-mx)+mx:Var NewY=pmw*(y-my)+my
                    Line(newx-pmw/2,newy-pmw/2)-(newx+pmw/2,newy+pmw/2),array(count),bf
                End If
            Next y
        Next x
        count=0
    Next z
    Line(mx-pmw*40,my-pmw*40)-(mx+pmw*40,my+pmw*40),5,B
End Sub

Sub cloud(x As Long, y As Long,length As Long=100,Alpha As Long=105, Zoom As Single = 0,im As Any Pointer=0)
    Dim As Long rr=255
    Dim As Long bb=255
    Dim As Long gg=255
    Static As Double pi=3.14159
    #define mp(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    If Length<=1 Or Alpha<=1 Then Exit Sub
    Dim As Single rnded = -pi+Rnd*1*pi/2
    Dim As Single rnded2 = -pi+Rnd*-3*pi
    If Alpha<25 Then
        For i As Long = 0 To 255-Alpha Step 100
            Var c=mp((0),(500),y,0,100)
            Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded*PI/3),y+Length/6+length*Sin(-pi/2+rnded*PI/3)),Rgba(Rr-c,Gg-c,Bb-c,Alpha)
            Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded2*PI/3),y+Length/6+length*Sin(pi/2+rnded2*PI/3)),Rgba(Rr-c,Gg-c,Bb-c,Alpha)
        Next
    End If
    cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded*PI/3),(Zoom/2)+y+length*Sin(-pi/2+rnded*PI/3),length/1.4,Alpha/1.2,Zoom,im)
    cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi/2+rnded2*PI/3),length/1.4,Alpha/1.2,Zoom,im)
    cloud(-(Zoom/2)+x+length*Cos(pi/3+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi+rnded2*PI/3),length/1.4,Alpha/2,Zoom,im)
End Sub

Sub trees()
    Type v2
        As Single x,y
    End Type
    
    Dim As Long rotx,roty
    #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
    #macro turnline(piv,p1,p2,ang,col,d)
    Scope
        rotate(piv.x,piv.y,p1.x,p1.y,ang,d)
        Var rot1=Type<v2>(rotx,roty)
        rotate(piv.x,piv.y,p2.x,p2.y,ang,d)
        Var rot2=Type<v2>(rotx,roty)
        Line im,(rot1.x,rot1.y)-(rot2.x,rot2.y),col
    End Scope
    #endmacro
    Dim As v2 v1,v2,piv
    Dim As Ulong treecol
    Dim As Double pivx,pivy,pivz,l,k,d
    Dim As Long 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 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
    Dim As Double lasty,gr
    paintsketch(.8*yres+20*Sin(.01*(x-200)),xres,0,yres,0,50,100,0,255)
    im=filter(im,1)
    trees()
End Sub

Sub background
    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    For y As Long=0 To yres
        Var rd=map(0,yres,y,0,200)
        Var bl= map(0,yres,y,250,200)
        Var gr=map(0,yres,y,0,200)
        Line im,(0,y)-(xres,y),Rgb(rd,gr,bl)
    Next y
    cloud(100,340,150/2,250,1,im)
    cloud(300,340,150/2,250,1,im)
    cloud(600,340,150/2,250,1,im)
    im=filter(im,2)
    backdrop
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
    Static As Double timervalue,_lastsleeptime,t3,frames
    frames+=1
    If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
    Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    _lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

Sub birds 
    Static As Single span=1,k=1,w
    Static As Single cx,cy,dslug
    Dim As Long dist=100,pix
    Static As Double pi=4*Atn(1)
    #macro dot(rad,slug)
    cx=150+xres/3+(5)*400/yres*rad*Cos(slug)
    cy=.17*yres+(50)*yres/400+rad*Sin(slug)
    #endmacro
    span=span+.15*k
    If span>5 Then k=-k
    If span<1 Then k=-k
    Do
        dist-=10
        pix=-10
        If (dslug)>2*pi Then dslug=0
        dot(yres/6,(dslug+.2*dist))
        w=cy/100
        Do
            dslug=dslug+.000002
            pix=pix+1
            Circle(cx,cy),w/2,Rgb(200,200,0),,,,f
            Line(cx,cy)-(cx+w*(span),cy+(span)-3),Rgb(180,180,180)
            Line(cx,cy)-(cx-w*(span),cy+(span)-3),Rgb(255,255,255)
        Loop Until pix>100 
    Loop Until dist<10
End Sub

#macro dot(rad,slug)
xdot=xres/2+2*rad*Cos(slug)
ydot=yres/10+rad*Sin(slug)
#endmacro
#define r(f,l) rnd*(l-f)+f
Dim As _point piv
piv.x=400:piv.y=00: piv.z=00
Dim As _point ang,np,eye,cp
eye.x=xres/2:eye.y=yres/2:eye.z=0
Dim As Single pi=4*Atn(1),rad,ep=1.5,flag,count,t,k=1,k2=1,dslug
Dim As String i
Dim As Long xdot,ydot
Dim As Long blades=8000
Dim Shared As _point gr(1 To blades)
'set array
For z As Long=1 To blades
    gr(z).x=r(-100,xres+100)
    gr(z).y=r(.9*yres,yres+50)
    gr(z).col=r(50,250)
Next z
Dim  As Single gl, fr
Dim As Long fps

background

Do
    dslug=dslug+.01
    If dslug>2*pi Then dslug=0
    count=count+k*.01 
    If count>=.999 Then k=-k
    If count<=-.999 Then k=-k
    
    Screenlock
    Cls
    Put (0,0),im,Pset
   if ep<9 then  birds
    Draw String(20,20),"Framerate " &fps
    dot(200,dslug)
    For z As Long=1 To blades
        gl=(.1-.01)*(gr(z).y-.9*yres)/(yres+50-.9*yres)+.01
        Line (gr(z).x,gr(z).y)-(gr(z).x+gl*(xdot-gr(z).x),gr(z).y+gl*(ydot-gr(z).y)),Rgb(50,gr(z).col,0)
        If z Mod 20 =0 Then
            fr=(6-2)*(gr(z).y-.9*yres)/(yres+50-.9*yres)+2
            Circle (gr(z).x+gl*(xdot-gr(z).x),gr(z).y+gl*(ydot-gr(z).y)+1.1*fr),fr-2,Rgb(250,250,0),,,,f
            Circle (gr(z).x+gl*(xdot-gr(z).x),gr(z).y+gl*(ydot-gr(z).y)),fr,Rgb(200,0,r(50,200)),,,,f
        End If
    Next z
    i=Inkey
    ep=ep+k2*.01
    If ep>15 Then k2=-k2
    If ep<1.5 Then k2=-k2
    t=t+Asin(count)
    ang.z=t-60:ang.y=(t-60)*1.1:ang.x=(t+60)/50
    For z As Single=0 To 10*360 Step 1
        cp.x=xres/2+.1*z*Cos(z*pi/180)
        cp.y=yres/1.5+.1*z*Sin(z*pi/180)
        cp.z=-z/5
        np= rotatepoint3d(piv,cp,ang)
        np=apply_perspective(np,eye,ep)
        rad=((40-10)*(z)/3600 + 10)/ep
        Circle(np.x,np.y),rad,Rgb(z*250/3600,0,255-z*250/3600),,,,f
    Next z
    if ep>9 then birds
    magnify
    Screenunlock
    Sleep regulate(60,fps),1
Loop Until Inkey=Chr(27)
Imagedestroy im
Sleep

  
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Spring is in the air.

Post by UEZ »

Well done dodicat. I like the idea of procedural graphic animation.

I think some (Perlin) noise would give it a little more natural movements of the birds and gras. ^^

Btw, what about the black rectangle. I guess it should zoom but it doesn't.

Compression algorithms either graphic or audio is a very interesting chapter in computer science.
VANYA
Posts: 1834
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: Spring is in the air.

Post by VANYA »

Cool!
Tourist Trap
Posts: 2958
Joined: Jun 02, 2015 16:24

Re: Spring is in the air.

Post by Tourist Trap »

dodicat wrote: Anyway, the weather here is improving each day as the seasons grind on, so, add some old harmony to the new Spring.
Hi,

I changed it by hand in some fresher mood scene :)

Code: Select all


Type _point
    As Single x,y,z
    As Ulong col
End Type

Dim Shared im As Any Pointer
Dim Shared As Integer xres,yres

Screen 19,32,,64
Locate 10,10
Print "Please wait . . ."
Screeninfo xres,yres
im=Imagecreate(xres,yres)

Function rotatepoint3d(Byval pivot As _point,_ 
    Byval first As _point,_ 
    Byval angle As _point,_
    Byval dilator As Single=1) As _point 
    #macro mv(m1,v,ans)
    For i As Long=1 To 3
        s=0
        For k As Long = 1 To 3
            s=s+m1(i,k)*v(k)
        Next k
        ans(i)=s
    Next i
    #endmacro
    Static Pi As Single = 4*Atn(1) 
    Dim angle_radians As _point
    Static pivot_vector(1 To 3) As Single
    Dim s As Single
    angle_radians.x=(Pi/180)*angle.x     
    angle_radians.y=(Pi/180)*angle.y
    angle_radians.z=(Pi/180)*angle.z
    pivot_vector(1)=(first.x-pivot.x)*dilator
    pivot_vector(2)=(first.y-pivot.y)*dilator
    pivot_vector(3)=(first.z-pivot.z)*dilator
    Static Rx(1 To 3,1 To 3) As Single
    Static Ry(1 To 3,1 To 3) As Single
    Static Rz(1 To 3,1 To 3) As Single
    'rotation matrices about the three axix
    Rx(1,1)=1:Rx(1,2)=0:Rx(1,3)=0
    Rx(2,1)=0:Rx(2,2)=Cos(angle_radians.x):Rx(2,3)=-Sin(angle_radians.x)
    Rx(3,1)=0:Rx(3,2)=Sin(angle_radians.x):Rx(3,3)=Cos(angle_radians.x)
   
    Ry(1,1)=Cos(angle_radians.y):Ry(1,2)=0:Ry(1,3)=Sin(angle_radians.y)
    Ry(2,1)=0:Ry(2,2)=1:Ry(2,3)=0
    Ry(3,1)=-Sin(angle_radians.y):Ry(3,2)=0:Ry(3,3)=Cos(angle_radians.y)
   
    Rz(1,1)=Cos(angle_radians.z):Rz(1,2)=-Sin(angle_radians.z):Rz(1,3)=0
    Rz(2,1)=Sin(angle_radians.z):Rz(2,2)=Cos(angle_radians.z):Rz(2,3)=0
    Rz(3,1)=0:Rz(3,2)=0:Rz(3,3)=1
   
    Static new_pos(1 To 3) As Single
    Static temp1(1 To 3) As Single
    Static temp2(1 To 3) As Single
   
    mv (Rx,pivot_vector,temp1)           
    mv (Ry,temp1,temp2)
    mv (Rz,temp2,new_pos)
   
    new_pos(1)+=pivot.x
    new_pos(2)+=pivot.y
    new_pos(3)+=pivot.z
    Dim As _point xyz=Type(first.x-new_pos(1),first.y-new_pos(2),first.z-new_pos(3))
    Return Type(first.x-xyz.x,first.y-xyz.y,first.z-xyz.z)' pt
    Dim As _point pt=Type(first.x-xyz.x,first.y-xyz.y,first.z-xyz.z)
    Return Type(first.x-xyz.x,first.y-xyz.y,first.z-xyz.z)' pt
End Function

Function apply_perspective(p As _point,eye As _point,w As Single) As _point
    Dim As _point rv
    rv.x=(p.x-eye.x)/w+eye.x:rv.y=(p.y-eye.y)/w+eye.y:rv.z=(p.z-eye.z)/w+eye.z
    Return rv
End Function

Function Filter(Byref tim As Ulong Pointer,_
    Byval rad As Single,_
    Byval destroy As Integer=1,_
    Byval fade As Integer=0) As Ulong Pointer
    #define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
    If fade<0 Then fade=0:If fade>100 Then fade=100
    Type p2
        As Integer x,y
        As Ulong col
    End Type
    #macro _ppoint(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*4
    (colour)=*pixel
    #endmacro
    #macro ppset(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*4
    *pixel=(colour)
    #endmacro
    #macro average()
    ar=0:ag=0:ab=0:inc=0
    xmin=x:If xmin>rad Then xmin=rad
    xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
    ymin=y:If ymin>rad Then ymin=rad
    ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
    For y1 As Integer=-ymin To ymax
        For x1 As Integer=-xmin To xmax
            inc=inc+1
            ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
            ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
            ab=ab+(NewPoints(x+x1,y+y1).col And 255)
        Next x1
    Next y1
    If fade=0 Then
        averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
    Else
        averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
    End If
    #endmacro
    Dim As Single fd=map(0,100,fade,1,0)
    Dim As Integer _x,_y
    Imageinfo tim,_x,_y
    Dim  As Ulong Pointer im=Imagecreate(_x,_y)
    Dim As Integer pitch
    Dim  As Any Pointer row
    Dim As Ulong Pointer pixel
    Dim As Ulong col
    Imageinfo tim,,,,pitch,row
    Dim As p2 NewPoints(_x-1,_y-1)
    For y As Integer=0 To (_y)-1
        For x As Integer=0 To (_x)-1
            _ppoint(x,y,col)
            NewPoints(x,y)=Type<p2>(x,y,col)
        Next x
    Next y
    Dim As Ulong averagecolour
    Dim As Integer ar,ag,ab
    Dim As Integer xmin,xmax,ymin,ymax,inc
    Imageinfo im,,,,pitch,row
    For y As Integer=0 To _y-1
        For x As Integer=0 To _x-1 
            average()
            ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
        Next x
    Next y
    If destroy Then Imagedestroy tim: tim = 0
    Function= im
End Function

Sub Magnify()   
    #define resetwheel(w,fl) fl=w
    #define wheel(w,f) w-f
    Dim As Long mx,my,mw,button:Getmouse mx,my,mw,button
    Static As Long flag,pmw
    mw=Abs(mw/2)
    Line(mx-40,my-40)-(mx+40,my+40),Rgb(0,0,0),B':exit sub
    If button=1 Then  resetwheel(mw,flag)
    Dim As Ulong array(1 To 6561),count
    pmw=wheel(mw,flag)
    If pmw<=1 Then Exit Sub
    For z As Long=1 To 2
        For x As Long=mx-40 To mx+40
            For y As Long=my-40 To my+40
                count+=1
                If z=1 Then
                    Var c=Point(x,y) 'needed to magnify an alpha screen
                    Var r =Cast(Ubyte Ptr,@c)[2]
                    Var g =Cast(Ubyte Ptr,@c)[1]
                    Var b =Cast(Ubyte Ptr,@c)[0]
                    Var al=Cast(Ubyte Ptr,@c)[3]
                    array(count)=Rgba(r,g,b,255)
                End If
                If z=2 Then
                    Var NewX=pmw*(x-mx)+mx:Var NewY=pmw*(y-my)+my
                    Line(newx-pmw/2,newy-pmw/2)-(newx+pmw/2,newy+pmw/2),array(count),bf
                End If
            Next y
        Next x
        count=0
    Next z
    Line(mx-pmw*40,my-pmw*40)-(mx+pmw*40,my+pmw*40),5,B
End Sub

Sub cloud(x As Long, y As Long,length As Long=100,Alpha As Long=105, Zoom As Single = 0,im As Any Pointer=0)
    Dim As Long rr=255
    Dim As Long bb=255
    Dim As Long gg=255
    Static As Double pi=3.14159
    #define mp(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    If Length<=1 Or Alpha<=1 Then Exit Sub
    Dim As Single rnded = -pi+Rnd*1*pi/2
    Dim As Single rnded2 = -pi+Rnd*-3*pi
    If Alpha<25 Then
        For i As Long = 0 To 255-Alpha Step 100
            Var c=mp((0),(500),y,0,100)
            Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded*PI/3),y+Length/6+length*Sin(-pi/2+rnded*PI/3)),Rgba(Rr-c,Gg-c,Bb-c,Alpha)
            Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded2*PI/3),y+Length/6+length*Sin(pi/2+rnded2*PI/3)),Rgba(Rr-c,Gg-c,Bb-c,Alpha)
        Next
    End If
    cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded*PI/3),(Zoom/2)+y+length*Sin(-pi/2+rnded*PI/3),length/1.4,Alpha/1.2,Zoom,im)
    cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi/2+rnded2*PI/3),length/1.4,Alpha/1.2,Zoom,im)
    cloud(-(Zoom/2)+x+length*Cos(pi/3+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi+rnded2*PI/3),length/1.4,Alpha/2,Zoom,im)
End Sub

Sub trees()
    /'
    Type v2
        As Single x,y
    End Type
   
    Dim As Long rotx,roty
    #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
    #macro turnline(piv,p1,p2,ang,col,d)
    Scope
        rotate(piv.x,piv.y,p1.x,p1.y,ang,d)
        Var rot1=Type<v2>(rotx,roty)
        rotate(piv.x,piv.y,p2.x,p2.y,ang,d)
        Var rot2=Type<v2>(rotx,roty)
        Line im,(rot1.x,rot1.y)-(rot2.x,rot2.y),col
    End Scope
    #endmacro
    Dim As v2 v1,v2,piv
    Dim As Ulong treecol
    Dim As Double pivx,pivy,pivz,l,k,d
    Dim As Long 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 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
    Dim As Double lasty,gr
    paintsketch(.8*yres+20*Sin(.01*(x-200)),xres,0,yres,0,50,100,0,255)
    im=filter(im,1)
    trees()
End Sub

Sub background
    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    For y As Long=0 To yres
        Var rd=map(0,yres,y,0,200)
        Var bl= map(0,yres,y,250,200)
        Var gr=map(0,yres,y,0,200)
        Line im,(0,y)-(xres,y),Rgb(rd,gr,bl)
    Next y
    cloud(100,340,150/2,250,1,im)
    cloud(300,340,150/2,250,1,im)
    cloud(600,340,150/2,250,1,im)
    im=filter(im,2)
    backdrop
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
    Static As Double timervalue,_lastsleeptime,t3,frames
    frames+=1
    If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
    Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    _lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

Sub birds
    Static As Single span=1,k=1,w
    Static As Single cx,cy,dslug
    Dim As Long dist=100,pix
    Static As Double pi=4*Atn(1)
    #macro dot(rad,slug)
    cx=150+xres/3+(5)*400/yres*rad*Cos(slug)
    cy=.17*yres+(50)*yres/400+rad*Sin(slug)
    #endmacro
    span=span+.15*k
    If span>5 Then k=-k
    If span<1 Then k=-k
    Do
        dist-=10
        pix=-10
        If (dslug)>2*pi Then dslug=0
        dot(yres/6,(dslug+.2*dist))
        w=cy/100
        Do
            dslug=dslug+.000002
            pix=pix+1
            Circle(cx,cy),w/2,Rgb(200,200,0),,,,f
            Line(cx,cy)-(cx+w*(span),cy+(span)-3),Rgb(180,180,180)
            Line(cx,cy)-(cx-w*(span),cy+(span)-3),Rgb(255,255,255)
        Loop Until pix>100
    Loop Until dist<10
End Sub

#macro dot(rad,slug)
xdot=xres/2+2*rad*Cos(slug)
ydot=yres/10+rad*Sin(slug)
#endmacro
#define r(f,l) rnd*(l-f)+f
Dim As _point piv
piv.x=400:piv.y=00: piv.z=00
Dim As _point ang,np,eye,cp
eye.x=xres/2:eye.y=yres/2:eye.z=0
Dim As Single pi=4*Atn(1),rad,ep=1.5,flag,count,t,k=1,k2=1,dslug
Dim As String i
Dim As Long xdot,ydot
Dim As Long blades=8000
Dim Shared As _point gr(1 To blades)
'set array
For z As Long=1 To blades
    gr(z).x=r(-100,xres+100)
    gr(z).y=r(.9*yres,yres+50)
    gr(z).col=r(50,250)
Next z
Dim  As Single gl, fr
Dim As Long fps

background

Do
    dslug=dslug+.01
    If dslug>2*pi Then dslug=0
    count=count+k*.01
    If count>=.999 Then k=-k
    If count<=-.999 Then k=-k
   
    Screenlock
    Cls
    Put (0,0),im,Pset
   if ep<100 then  birds
    Draw String(20,20),"Framerate " &fps
    dot(200,dslug)
    For z As Long=1 To blades
        gl=(.1-.01)*(gr(z).y-.9*yres)/(yres+500-.9*yres)+.01
        Line (0 + gl*(xdot-gr(z).x),gr(z).y+gl*(ydot-gr(z).y)  - 100 + rnd())-(10000,gr(z).y - 100 * rnd()),Rgba(50,gr(z).col,200, 2)
        'If z Mod 20 =0 Then
        '    fr=(6-2)*(gr(z).y-.9*yres)/(yres+50-.9*yres)+2
        '    Circle (gr(z).x+gl*(xdot-gr(z).x),gr(z).y+gl*(ydot-gr(z).y)+1.1*fr),fr-2,Rgba(250,250,0, 100),,,,f
        '    Circle (gr(z).x+gl*(xdot-gr(z).x),gr(z).y+gl*(ydot-gr(z).y)),fr,Rgb(200,0,r(50,200)),,,,f
        'End If
    Next z
    line (0,0)-step(100,800), rgba(100,10,200, 250), bf
    line (700,0)-step(100,800), rgba(100,10,200, 250), bf
    i=Inkey
    ep=ep+k2*.01
    If ep>15 Then k2=-k2
    If ep<1.5 Then k2=-k2
    t=t+Asin(count)
    ang.z=t-10:ang.y=(t-60)*1.1:ang.x=(t+600*rnd())/50
    
    For z As Single=0 To 10*360 Step 8
        cp.x=xres/2+.1*z*Cos(z*pi/180)/100 - 100*rnd()
        cp.y=yres/1.5+.1*z*Sin(z*pi/180) - 100*rnd()
        cp.z=-z/20 - 100*rnd()
        np= rotatepoint3d(piv,cp,ang)
        np=apply_perspective(np,eye,ep)
        rad=((40-10)*(z)/3600 + 10)/ep * rnd()
        Circle(np.x + rnd()*100,np.y * rnd()  + 550 + rnd()*100),rad + 100*rnd(),Rgba(z*250/3600,250,100, 100) xor TIMER/100,,20,,f
        Circle(np.x + rnd()*100 + 150,np.y * rnd()  + 550 + rnd()*100),rad + 100*rnd(),Rgba(z*250/3600,250,100, 100) xor TIMER/100,,20,,f
        Circle(np.x - rnd()*100,np.y * rnd()  + 550 + rnd()*100),rad + 100*rnd(),Rgba(z*250/3600,250,100, 100) xor TIMER/100,,20,,f
        Circle(np.x - 100 - rnd()*300,np.y * rnd()  + 550 + rnd()*100),rad + 100*rnd(),Rgba(z*250/3600,250,100, 100) xor TIMER/100,,20,,f
        Circle(np.x + 100 + rnd()*300,np.y * rnd()  + 550 + rnd()*100),rad + 100*rnd(),Rgba(z*250/3600,250,100, 100) xor TIMER/100,,20,,f
        
    Next z
    
    Put (0,0),im,or
    
    'line (0,0)-step(100,200), rgba(100,100,200, 200), bf
    'line (0,0)-step(100,200), rgba(100,100,200, 200), bf
    'line (0,0)-step(100,200), rgba(100,100,200, 200), bf
    if ep>9 then birds
    magnify
    Screenunlock
    Sleep regulate(60,fps),1
Loop Until Inkey=Chr(27)
Imagedestroy im
Sleep

  
The birds are now seaguls so.
Makoto WATANABE
Posts: 231
Joined: Apr 10, 2010 11:41
Location: Japan
Contact:

Re: Spring is in the air.

Post by Makoto WATANABE »

This fairy tale video is fantastic and pretty.
I can watch it on my Windows 8.1 machine.
However, this "exe" file is not displayed on my Windows10 machines.

ASUS T100TA Atom Z3740 1.3GHz Win 10 32bit
ASUS AiO ET2232IUK Celeron J1800 2.4GHz Win 10 64bit
ThinkPad E570 i7-7500U 2.7GHz Win 10 64bit

The phenomenon that the "exe" file can not be displayed on my Windows10 machines is the same as the following program.
"A view of five sorts in action"
viewtopic.php?t=17702

Please let me know if you know how to solve this phenomenon.
Tourist Trap
Posts: 2958
Joined: Jun 02, 2015 16:24

Re: Spring is in the air.

Post by Tourist Trap »

Makoto WATANABE wrote:This fairy tale video is fantastic and pretty.
I can watch it on my Windows 8.1 machine.
However, this "exe" file is not displayed on my Windows10 machines.

ASUS T100TA Atom Z3740 1.3GHz Win 10 32bit
ASUS AiO ET2232IUK Celeron J1800 2.4GHz Win 10 64bit
ThinkPad E570 i7-7500U 2.7GHz Win 10 64bit

The phenomenon that the "exe" file can not be displayed on my Windows10 machines is the same as the following program.
"A view of five sorts in action"
viewtopic.php?t=17702

Please let me know if you know how to solve this phenomenon.
Hi Makoto,

I play the dodicat's code, and mine also, on win10. I simply compile it from source on FBIDE. Do you compile on Win8.1 and use the resulting executable on Win10, or do you try to compile on Win10 from source?
I don't see what can your problem be.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Spring is in the air.

Post by dodicat »

Hi Makoto WATANABE.

I normally use quick run on fbide.
Win 10 may take up to 30 seconds to run an unknown .exe, depending on your antivirus settings.
After the first run it should behave normally.
Makoto WATANABE
Posts: 231
Joined: Apr 10, 2010 11:41
Location: Japan
Contact:

Re: Spring is in the air.

Post by Makoto WATANABE »

Dear all;
Thanks for your reply.

>After the first run it should behave normally.

I executed the "exe" file many times.
Then, certainly, the screen was displayed in rare cases.
The situation was the same for "A view of five sorts in action".
The screen appeared occasionally and the program ran .
I expect that exe will run every time.

P.S.
My "exe"s ware compiled under the following environment.
Win 8.1 + FBC 0.09.1
Win 10 + FBC 1.05
Win 10 + FBC 1.06
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Spring is in the air.

Post by dodicat »

I see that someboby was having trouble with the screen command.
viewtopic.php?f=6&t=27522&p=259628&hili ... es#p259628
Different circumstances, but maybe you could try Screenres 800,600,32,,64 in the Spring and screenres in the sorts.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Spring is in the air.

Post by badidea »

Last week, Windows 10 was installed on my work-laptop. Uses Symantec virus-scanner. DPI stuff forced to 100% (they really made a mess of that).
I just installed the new freebasic compiler version as well (c:\tools\...)
Tested Dodicat's original demo. Compile and run (as normal user):
Win10, FBC 1.04.0 32-bit: OK
Win10, FBC 1.06.0 32-bit: OK
Win10, FBC 1.06.0 64-bit: OK
Also instant start of demo (application screen opening). So, no problems here.
(but of course quickly back to Linux now)
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Spring is in the air.

Post by UEZ »

On my Win10 v1803 build 17134.648 and FB 1.06 compiled as x86 / x64 it looks like this:

Image
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Spring is in the air.

Post by badidea »

UEZ wrote:On my Win10 v1803 build 17134.648 and FB 1.06 compiled as x86 / x64 it looks like this ...
I think that Tourist Trap's version is supposed to look that way:
Image
Post Reply