Squares

General FreeBASIC programming questions.
albert
Posts: 4951
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jul 06, 2019 0:54

( !!~~OFF TOPIC~~!! )

I got another song demo'd

That makes 4 songs so far...
Cost like $1,400 to get 4 songs demo'd ( $350 a piece )

I got like , 25 more songs to get demo'd ( like $9,000 dollars worth )
It will take several years to get them all done...unless i come into some money along the way..

Listen to my songs: https://soundcloud.com/user-704620747
badidea
Posts: 1457
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Squares

Postby badidea » Jul 06, 2019 12:53

FreeBASIC art:

Code: Select all

const SCREEN_W = 640, SCREEN_H = 480
const IMG_SIZE = 400
const IMG_XO = (SCREEN_W - IMG_SIZE) \ 2 '120
const IMG_YO = (SCREEN_H - IMG_SIZE) \ 2 '40

const as ulong WHITE = rgb(255, 255, 255)
const as ulong GREEN = rgb(0, 200, 0)
const as ulong RED = rgb(255, 0, 0)
const as ulong YELLOW = rgb(255, 255, 0)
const as ulong BLUE = rgb(0, 0, 255)
const as ulong BROWN = rgb(150, 75, 0)

const as single PI = atn(1) * 4

'-------------------------------------------------------------------------------

type int2d
   dim as integer x, y
end type

operator + (a as int2d, b as int2d) as int2d
   return type(a.x + b.x, a.y + b.y)
end operator

sub tline(pTarget as any ptr, p1 as int2d, p2 as int2d, c as ulong)
   line pTarget, (p1.x, p1.y)-(p2.x, p2.y), c
end sub

sub dline(pTarget as any ptr, p1 as int2d, p2 as int2d, c as ulong)
   line pTarget, (p1.x, p1.y)-step(p2.x, p2.y), c
end sub

sub thickline(pTarget as any ptr, p1 as int2d, p2 as int2d, c as ulong)
   for x as integer = -1 to +1
      for y as integer = -1 to +1
         line pTarget, (p1.x + x, p1.y + y)-step(p2.x, p2.y), c
      next
   next
end sub

sub pointyline(pTarget as any ptr, p1 as int2d, p2 as int2d, c as ulong)
   for x as integer = -1 to +1
      for y as integer = -1 to +1
         line pTarget, (p1.x + x, p1.y + y)-(p1.x + p2.x, p1.y + p2.y), c
      next
   next
end sub

sub drawLeaf(pTarget as any ptr, p0 as int2d, dp1 as int2d, dp2 as int2d, c as ulong)
   thickline(pTarget, p0, dp1, c)
   pointyline(pTarget, p0 + dp1, dp2, c)
end sub

sub tcircle(pTarget as any ptr, p as int2d, r as single, c as ulong)
   circle pTarget, (p.x, p.y), r, c, ,,,f
end sub

'-------------------------------------------------------------------------------

screenres SCREEN_W, SCREEN_H, 32
width SCREEN_W \ 8, SCREEN_H \ 16

dim as integer i, x, y, r
dim as ulong c, f
dim as int2d root, dp1, dp2, flower

const NUM_LEAVES = 6, NUM_STEMS = 5

root = type(IMG_SIZE \ 2, IMG_SIZE - 20)

dim as int2d leafNodes(NUM_LEAVES - 1, 0 to 1) = { _
   { type(80, -30), type(70, +20) }, _
   { type(60, -40), type(60, +40) }, _
   { type(20, -30), type(20, -10) }, _
   { type(-70, -40), type(-90, +30) }, _
   { type(-40, -30), type(-100, +30) }, _
   { type(-30, -10), type(-20, +10) }}

dim as int2d stemNodes(NUM_STEMS - 1, 0 to 1) = { _
   { type(-20, -70), type(-50, -140) }, _
   { type(-40, -80), type(-50, -70) }, _
   { type(-10, -150), type(-20, -120) }, _
   { type(+20, -140), type(+20, -90) }, _
   { type(+30, -80), type(+40, -50) } }

dim as any ptr pImg = imagecreate(IMG_SIZE, IMG_SIZE)

'blue sky
line pImg, (0, 0)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(70, 70, 255), bf
line pImg, (0, 80)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(50, 50, 255), bf
line pImg, (0, 110)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(0, 0, 255), bf
line pImg, (0, 200)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(40, 40, 255), bf

'mountains
for i = 0 to 2
   circle pImg, (IMG_SIZE \ 2 - 300 - i * 10, IMG_SIZE + 70 + i * 10), 500, rgb(180 - i * 10, 170 - i * 10, 180 - i * 20),,, 0.6 , f
next
for i = 0 to 2
   circle pImg, (IMG_SIZE \ 2 + 350 + i * 30, IMG_SIZE + 100 + i * 20), 500, rgb(127 - i * 10, 127 - i * 20, 127 - i * 20),,, 0.7, f
next
for i = 0 to 2
   circle pImg, (IMG_SIZE \ 2 - 350 - i * 30, IMG_SIZE + 100 + i * 20), 500, rgb(127 - i * 10, 127 - i * 10, 80 - i * 20),,, 0.6 , f
next

'brown ground
for i = 0 to 2
   circle pImg, (root.x, root.y + i * 10), 400 - i * 40, rgb(150 - i * 20, 75 - i * 10, 0),,, 0.2 + i / 40, f
next

'ground leaves
for i = 0 to NUM_LEAVES - 1
   drawLeaf(pImg, root, leafNodes(i, 0), leafNodes(i, 1), GREEN)
next

'flower stems
for i = 0 to NUM_STEMS - 1
   drawLeaf(pImg, root, stemNodes(i, 0), stemNodes(i, 1), GREEN)
   flower = root + stemNodes(i, 0) + stemNodes(i, 1)
   for j as integer = 0 to 6
      x = cos((j / 7) * PI * 2) * 25
      y = sin((j / 7) * PI * 2) * 25
      pointyline(pImg, flower, type(x, y), rgb(255, 200, 0))
      tcircle(pImg, flower + type(x, y), 10, RED)
   next
   tcircle(pImg, flower, 10, YELLOW)
next

'clouds
randomize 123
for i = 0 to 19
   x = rnd * IMG_SIZE
   y = rnd * 20
   r = rnd * (40 - i) + 40
   f = rnd* 50 + 200
   c = rgb(f, f, f)
   circle pImg, (x, y), r, c, ,, rnd / 2 + 0.3, f
next

'show image
put (IMG_XO, IMG_YO), pImg

sleep
albert
Posts: 4951
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jul 06, 2019 17:35

@badidea

Nice Doodle!!
badidea
Posts: 1457
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Squares

Postby badidea » Jul 06, 2019 17:53

A doodle a day, keeps the insanity away :-)
albert
Posts: 4951
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jul 06, 2019 22:36

Time Rhyme!!

3:35 = bee dirty hive
dodicat
Posts: 5913
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Take a break

Postby dodicat » Jul 07, 2019 23:26

Summer is here.

Code: Select all


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

Function Regulate(Byval MyFps As Long,Byref fps As Long=0) 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 drawpolygon(p() As Point, col As Ulong,im As Any Ptr=0)
    Dim k As Long=Ubound(p)+1
    Dim As Long index,nextindex
    Dim As Single cx,cy,counter
    For n As Long=1 To Ubound(p)
        counter+=1
        index=n Mod k:nextindex=(n+1) Mod k
        If nextindex=0 Then nextindex=1
        cx+=p(index).x:cy+=p(index).y
        Line im,(p(index).x,p(index).y)-(p(nextindex).x,p(nextindex).y),col
    Next
    cx=cx/counter:cy=cy/counter
    p(0)=Type<Point>(cx,cy)
    Line im,(p(4).x,p(4).y)-(p(36).x,p(36).y),col
    Paint im,((p(1).x+p(4).x)\2,p(1).y),Rgb(0,0,0),col'prop
    Paint im,(cx,cy),col,col
    For n As Long=8 To 10
        Line im,(p(n).x,p(n).y)-(p(n+1).x,p(n+1).y),Rgb(200,0,0)
    Next n
    Line im,(p(11).x,p(11).y)-(p(8).x,p(8).y),Rgb(200,0,0)
    Paint im,((p(8).x+p(10).x)/2,(p(8).y+p(10).y)/2),Rgb(100,100,255),Rgb(200,0,0)
    for n as long=-1 to 1
    line(p(16).x,p(16).y+n)-(p(21).x,p(21).y+n),rgb(0,0,0)
    next
End Sub

Function RotatePoint(c As Point,p As Point,angle As Point,scale As Point=Type<Point>(1,1,1)) As Point
    Dim As Single sx=Sin(angle.x),sy=Sin(angle.y),sz=Sin(angle.z)
    Dim As Single cx=Cos(angle.x),cy=Cos(angle.y),cz=Cos(angle.z)
    Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
    Return Type<Point>((scale.x)*((cy*cz)*dx+(-cx*sz+sx*sy*cz)*dy+(sx*sz+cx*sy*cz)*dz)+c.x,_
    (scale.y)*((cy*sz)*dx+(cx*cz+sx*sy*sz)*dy+(-sx*cz+cx*sy*sz)*dz)+c.y,_
    (scale.z)*((-sy)*dx+(sx*cy)*dy+(cx*cy)*dz)+c.z,p.col)
End Function

Sub rotateimage(Byref dest As Any Ptr=0,im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1,miss As Ulong=Rgb(255,0,255),fixedpivot As boolean=false)
    Static As Integer pitch,pitchs,xres,yres,runflag
    Static As Any Ptr row,rows
    Static As Integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row
    If dest=0 Then
    Screeninfo xres,yres,,,pitchS
    rowS=Screenptr
    Else
    If sc<>1 Then
        Dim As Integer x,y
        Imageinfo dest,x,y
    Imagedestroy dest:dest=0: dest=Imagecreate(x*sc,y*sc)
    End If
    Imageinfo dest, xres,yres,,pitchS,rows
    End If
    Dim As Long centreX=ddx\2,centreY=ddy\2
    Dim As Single sx=Sin(angle)
    Dim As Single cx=Cos(angle)
    Dim As Long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
    Var fx=sc*.7071067811865476,sc2=1/sc
    If fixedpivot=false Then
     shiftx+=centreX*sc-centrex
     shiftY+=centrey*sc-centrey
     End If
    For y As Long=centrey-fx*mx+1 To centrey+ fx*mx
        Dim As Single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
        shfty=y+shifty
        For x As Long=centrex-mx*fx To centrex+mx*fx
                 If x+shiftx >=0 Then 'on the screen
                    If x+shiftx <xres Then
                        If shfty >=0 Then
                            If shfty<yres Then
            resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
                If resultx >=0 Then 'on the image
                    If resultx<ddx Then
                        If resulty>=0 Then
                            If resulty<ddy Then
    Dim As Ulong u=*Cast(Ulong Ptr,row+pitch*((resultY))+((resultX)) Shl 2 ) 'point(image)
   If u<>miss Then *Cast(Ulong Ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= u 'pset (screen)
                End If:End If:End If:End If
                End If:End If:End If:End If
        Next x
    Next y
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 Ptr=0)
    Static As Long r=255,b=255,g=255
    Dim As Double pi=3.14159
    Static As Long cl,p
    cl=cl+1
    If cl Mod 100000=0 Then
        p=p+1
        Draw String(x/50+8*p,400),"_____",Rgb(255,255,255)
    End If
    If Length<=1 Or Alpha<=1 Then Exit Sub
    Dim As Single rnded  = -pi+Rnd*1*pi*3
    Dim As Single rnded2 = -pi+Rnd*-3*pi*3
    If Alpha<15 Then
        For i As long = 0 To 255-Alpha Step 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(R,G,B,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(R,G,B,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 Tree(i As Any Ptr=0,x1 As Single,y1 As Single,size As Single,angle As Single,depth As Single,colb As Ulong=0,colL As Ulong=0)
    Dim  As Single spread,scale,x2,y2
    spread=25
    scale=.76
    #define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
    x2=x1-.25*size*Cos(angle*.01745329)
    y2=y1-.25*size*Sin(angle*.01745329)
    Static As long count,fx,fy,sz,z
    If count=0 Then  fx=x1:fy=y1:sz=size:z=2^(depth+1)-1
    Line i,(x1,y1)-(x2,y2),colb
    If count=0 Then  fx=x2:fy=y2:sz=size
    count=count+1
    If count>z Then count=0
    If incircle(fx,fy,(.45*sz),x2,y2)=0 Then Circle i,(x2,y2),.01*sz,colL
    If depth>0 Then
        Tree(i,x2, y2, size * Scale, angle - Spread, depth - 1,colB,colL)
        Tree(i,x2, y2, size * Scale, angle + Spread, depth - 1,colB,colL)
    End If
End Sub

Function Filter(Byref tim As Ulong Pointer,_
    Byval rad As Single,_
    Byval destroy As long=1,_
    Byval fade As long=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 Long x,y
        As Ulong col
    End Type
    #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 long=-ymin To ymax
        For x1 As long=-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 Ulong col
    Dim As p2 NewPoints(_x-1,_y-1)
    For y As long=0 To (_y)-1
        For x As long=0 To (_x)-1
            col=Point(x,y,tim)
            NewPoints(x,y)=Type<p2>(x,y,col)
        Next x
    Next y
    Dim As Ulong averagecolour
    Dim As long ar,ag,ab
    Dim As long xmin,xmax,ymin,ymax,inc
    For y As long=0 To _y-1
        For x As long=0 To _x-1 
            average()
            Pset im,((NewPoints(x,y).x),(NewPoints(x,y).y)),averagecolour
        Next x
    Next y
    If destroy Then Imagedestroy tim: tim = 0
    Function= im
End Function

Function range(f As Long,l As Long) As Long
    Return  Int(Rnd*((l+1)-(f)))+f
    End Function

Function go As Long
    #macro backdrop()
    Scope
        #define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
        Dim As Single minx,maxx,miny,maxy,lasty,grad
        Dim As Long ctr
        #macro paintsketch(_function,r,g,b,im,sz,set)
        Randomize 1
        ctr=0
        For x As Double=minx To maxx Step (maxx-minx)/5000
            ctr+=1
            If ctr=4500 Then Randomize 1
            Dim As Double x1=(xres)*(x-minx)/(maxx-minx)
            Dim As Double y1=(yres)*(_function-maxy)/(miny-maxy)
            If ctr Mod set=0 Then
                Var xx=x1+Rnd*5-Rnd*5,yy=y1+Rnd*set/4
                tree(im,xx,yy,sz,90+(Rnd*10-Rnd*10),12,Rgb(100,10+Rnd*50,0),Rgb(Rnd*50,100+Rnd*100,0))
            End If
            grad=y1-lasty
            lasty=y1
            grad=grad*250
            Line im,(x1,yres)-(x1,y1),Rgb(r+grad,g+grad,b)
        Next x
        #endmacro
        #macro _window(topleftX,topleftY,bottomrightX,bottomrightY)
        minx=topleftX
        maxx=bottomrightX
        miny=bottomrightY
        maxy=topleftY
        #endmacro
        #macro sea
        For z As Long=0 To .7*yres
            Var r=map(0,(.7*yres),z,0,250)
            Var g=map(0,(.7*yres),z,0,250)
            Var b=map(0,(.7*yres),z,200,250)
            Line im2,(0,z)-(xres,z),Rgb(r,g,b)
        Next z
        #endmacro
        sea
        Dim As Single pi=4*Atn(1)
        _window(-4*pi,3,4*pi,-1.2)
        paintsketch(.05*Sin(x)+.05*Sin(2*x),50,100,50,imgs(1),15,100)
       
        _window(-3*pi,2,3*pi,-.8)
        paintsketch(.1*Sin(x),50,120,0,imgs(2),25,100)
       
        _window(-2*pi,2,2*pi,-.6)
        paintsketch(.1*Sin(x),50,150,0,imgs(3),30,150)
       
        _window(-pi,2,pi,-.5)
        paintsketch(.2*Sin(x),50,170,0,imgs(4),55,150)
        Var x=xres,y=yres
        Randomize 2
        For a As Long = 1 To 7
            If a<=5 Then
                cloud(x*1.5/a, y*1/a, Range(60,80)/2, Range(40,60),5,im2)
                cloud(x*1.4/a, y*2/a, range(60,80)/2, range(40,60),2,im2)
            End If
            If a=6 Then  cloud(x/2,y/4,150,250,1,im2)
            If a=7 Then  cloud(.8*x,.1*y,100,80,5,im2)
           
        Next
        im2=filter(im2,2)
        Line im2,(0,.7*yres)-(xres,.9*yres),Rgb(0,50,200),bf
    End Scope
    #endmacro
   
    #macro Sweep(p,_step,sz)
    For z As Long=0 To (sz)\4 -_step
        Swap p[z],p[z+_step]
    Next z
    #endmacro
   
    Dim As Integer xres,yres
    Screenres 1024,768,32,,64
    Screeninfo xres,yres
    Width xres\8,yres\16
    Dim As Any Ptr sim=Imagecreate(150,25)
    Draw String sim,(5,10),"D-CAT",Rgb(0,0,0)
    Draw String sim,(129,10),"|||",Rgb(0,0,0)
    Circle sim,(90,15),35,Rgb(0,10,0),,,.1,f
    Dim As Any Ptr im2=Imagecreate(xres,yres)
    Dim As Any Ptr imgs(1 To 4)={Imagecreate(xres,yres),Imagecreate(xres,yres),Imagecreate(xres,yres),Imagecreate(xres,yres)}
      Draw String(20,406),"[",Rgb(255,255,255)
      Draw String(690,406),"]",Rgb(255,255,255)
    backdrop()
    Dim As Ulong Ptr p(1 To 4),p2
    Dim As Integer size,size2
   
    For n As Long=1 To 4
        Imageinfo imgs(n),,,,,p(n),size
    Next n
    Imageinfo im2,,,,,p2,size2
   
    Dim As Point pt(0 To 38),rot(0 To 38)
    For n As Long=1 To 38: Read pt(n).x:pt(n).x+=410: Next
    For n As Long=1 To 38: Read pt(n).y:pt(n).y+=350: Next
    drawpolygon(pt(),Rgb(0,0,0))
    Dim As Point ctr=pt(0)
    Dim As Single pi=4*Atn(1)
    Dim As Single a
    Dim As Long k2=1.5
    Dim As String i
    Dim As String s="Going on holiday"
    Dim As Any Ptr im(1 To Len(s))
   
    Dim As Long sz=10,fps
    For n As Long=1 To Len(s)
        im(n)=Imagecreate(sz*3,sz*3)
        Draw String im(n),(10,5),Chr(s[n-1]),Rgb(255,Rnd*255,Rnd*255)
        Put(n*sz,400),im(n),trans
    Next
   
    Dim As Single angl,d=50
    Dim As Single x1,y1,x2,y2
    Dim As Single x3,y3,x4,y4,yy=100
    Do
        i=Inkey
        For n As Long=1 To 4
            sweep(p(n),k2*n,size) 'hills
        Next n
        sweep(p2,1,size2) 'sky
        angl+=.1
        a=.1*Sin(angl)
        Screenlock
        Cls
        Put(0,0),im2,Pset
        For n As Long=1 To 3
            Put(0,0),imgs(n),trans
        Next n
        For n As Long=1 To 38
            pt(n).y+=a*5
            rot(n)= rotatepoint(ctr,pt(n),Type<Point>(0,0,a),Type<Point>(.8,.8,.8))
        Next n
        drawpolygon(rot(),Rgb(88,73,00))
        Circle(rot(22).x,rot(22).y),3,0,,,,f
         rotateimage(,sim,-a,rot(0).x-75,rot(0).y-12.5,1,,true)
       
        For n As Long=1 To Ubound(im)
            Var k=n+2,k1=k+1
            If n=1 Then 
                x1=k*3*sz-d:y1=400+30*Sin(angl+n/2)-20
                x2=k*3*sz-d:y2=400+30*Sin(angl+n/2)+40
            End If
            If n=Ubound(im) Then 
                x3=k1*3*sz-d:y3=400+30*Sin(angl+(n+1)/2)-20
                x4=k1*3*sz-d:y4=400+30*Sin(angl+(n+1)/2)+40
            End If
            Pset(k*3*sz-d,400+30*Sin(angl+n/2)-20+yy),Rgb(200,0,1)
            Line -((k+1)*3*sz-d,400+30*Sin(angl+(n+1)/2)-20+yy),Rgb(200,0,1)
           
            Pset(k*3*sz-d,400+30*Sin(angl+n/2)+40+yy),Rgb(0,0,1)
            Line -((k+1)*3*sz-d,400+30*Sin(angl+(n+1)/2)+40+yy),Rgb(200,0,1)
        Next
        Line(x1,y1+yy)-(x2,y2+yy),Rgb(200,0,1)
        Line(x3,y3+yy)-(x4,y4+yy),Rgb(200,0,1)
        Paint(100,400+30*Sin(angl+(1)/2)+10+yy),Rgb(0,100,200),Rgb(200,0,1)
        For n As Long=1 To Ubound(im)
            Var k=n+2
            rotateimage(,im(n),(Sin((angl+n/2)))/4-0,k*3*sz-d-15,400+30*Sin(angl+n/2)+yy-20,2)
        Next n
     
        Line(x3,y3+yy)-(rot(22).x,rot(22).y),Rgb(0,0,0)
        Line(x4,y4+yy)-(rot(22).x,rot(22).y),Rgb(0,0,0)
        Put(0,0),imgs(4),trans
        Line(0,750)-(xres,768),Rgb(200,200,200),bf
        Draw String(400,755),"Framerate = "&fps,Rgb(200,0,0)
        Screenunlock
        Sleep regulate(30,fps),1
    Loop Until i=Chr(27)
    For n As Long=Lbound(im) To Ubound(im)
        Imagedestroy im(n)
    Next
    Imagedestroy im2
    Imagedestroy sim
    For n As Long=1 To 4
        Imagedestroy(imgs(n))
    Next n
    Sleep
    Return 0
End Function

Data _
498, 489, 487, 481, 454, 420, 399, 390, 381, 369, 359, 331, 297, 272, 255, 247, 237, 228, 217, 205, 202, 205, 219, 228, 251, 288, 319, 347, 359, 401, 418, 440, 440, 457, 471, 480, 486, 488

Data _
165, 158, 116, 157, 153, 152, 151, 151, 144, 143, 146, 145, 148, 151, 151, 149, 134, 124, 120, 133, 152, 167, 174, 174, 178, 184, 189, 191, 193, 196, 195, 200, 193, 190, 182, 174, 218, 177


End go
 
UEZ
Posts: 336
Joined: May 05, 2017 19:59
Location: Germany

Re: Take a break

Postby UEZ » Jul 08, 2019 6:49

dodicat wrote:Summer is here.
...


Very nice dodicat. Cool parallax scrolling.
badidea
Posts: 1457
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Take a break

Postby badidea » Jul 08, 2019 16:26

dodicat wrote:Summer is here.

Fractal trees?
albert
Posts: 4951
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jul 09, 2019 0:52

Dodicat , It's amazing how much action you get , out of so little code!!
Love the clouds!!
D.J.Peters
Posts: 7808
Joined: May 28, 2005 3:28

Re: Squares

Postby D.J.Peters » Jul 09, 2019 6:44

dodicat good job I like it :-)

The fractal tree's and the cloud stuff isn't new for me
but I played around with your rotateimage code and optimized the inner loop only for fun.
It's faster as before but slower than MultiPut may be your solution is more accurate as MultiPut.
How ever here are the result and it was fun for me.

Joshy

Code: Select all

'     !!! inner loop !!!
'     old           new       diff
'  9 times +     6 times +     +3
'  3 times -     2 times -     +1
'  6 times *     3 times *     +3
'  4 times >     2 times >     +2
'  4 times <     2 times <     +2
'  2 times shift 0 times shift +2
'  4 times if    2 times if    +2  (both plus 1 color compare)
' -----------------------------------
' 30            17             15
A short test compare

Code: Select all

Sub rotateimage_old(Byref dest As Any Ptr=0,im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1,miss As Ulong=Rgb(255,0,255),fixedpivot As boolean=false)
  Static As Integer pitch,pitchs,xres,yres,runflag
  Static As Any Ptr row,rows
  Static As Integer ddx,ddy,resultx,resulty
  Imageinfo im,ddx,ddy,,pitch,row
  If dest=0 Then
    Screeninfo xres,yres,,,pitchS
    rowS=Screenptr
  Else
    If sc<>1 Then
      Dim As Integer x,y
      Imageinfo dest,x,y
      Imagedestroy dest:dest=0: dest=Imagecreate(x*sc,y*sc)
    End If
    Imageinfo dest, xres,yres,,pitchS,rows
  End If
  Dim As Long centreX=ddx\2,centreY=ddy\2
  Dim As Single sx=Sin(angle)
  Dim As Single cx=Cos(angle)
  Dim As Long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
  Var fx=sc*.7071067811865476,sc2=1/sc
  If fixedpivot=false Then
    shiftx+=centreX*sc-centrex
    shiftY+=centrey*sc-centrey
  End If
  For y As Long=centrey-fx*mx+1 To centrey+ fx*mx
    Dim As Single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
    shfty=y+shifty
    For x As Long=centrex-mx*fx To centrex+mx*fx
      ' !!! inner loop !!!
      If x+shiftx >=0 andalso x+shiftx <xres Then
        If shfty >=0 andalso shfty<yres Then
          resultx=sc2*(Cx*(x-centrex)-Sxcy)+centrex
          resulty=sc2*(Sx*(x-centrex)+Cxcy)+centrey
          If resultx >=0 andalso resultx<ddx Then
            If resulty>=0 andalso resulty<ddy Then
              Dim As Ulong u=*Cast(Ulong Ptr,row+pitch*((resultY))+((resultX)) Shl 2 ) 'point(image)
              If u<>miss Then *Cast(Ulong Ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= u 'pset (screen)
            End If
          End If
        End If
      End If
    Next x
  Next y
End Sub

Sub rotateimage_new(byref dstImage    As Any Ptr =0   , _ ' 0 = screen
                    byval srcImage    As Any Ptr      , _
                    byval rotAngle    As single       , _
                    byval rotCenterX  As integer = 0  , _
                    byval rotCenterY  As integer = 0  , _
                    byval scaleFactor As single  = 1.0, _
                    byval maskColor   As Ulong   = Rgb(255,0,255), _
                    byval fixedPivot  As boolean = false)
  dim as Integer srcWidth=any,srcHeight=any,srcBytes=any,srcPitch=any
  dim as Integer dstWidth=any,dstHeight=any,dstBytes=any,dstPitch=any
  dim as integer dstX=any,dstY=any,srcX=any,srcY=any
  dim as single  dx=any,dy=any,sidy=any,cody=any
  dim as ulong   srcColor=any
  dim as ulong ptr srcPixels=any,dstP,dstPixels=Screenptr()
  ' no active screen
  if dstPixels=0 then exit sub
  ' no legal source image
  if Imageinfo(srcImage,srcWidth,srcHeight,srcBytes,srcPitch,srcPixels) then exit sub
 
  If dstImage=0 Then
    Screeninfo dstWidth,dstHeight,,dstBytes,dstPitch
  Else
    If scaleFactor<>1.0 Then
      if scaleFactor<0.01 then scaleFactor=0.01
      dim as integer oldWidth,oldHeight
      ' no legal destinantion image
      if Imageinfo(dstImage,dstWidth,dstHeight) then exit sub
      ' destroy destination and create new scaled image
      Imagedestroy(dstImage)
      dstWidth  = oldWidth *scaleFactor
      dstHeight = oldHeight*scaleFactor
      ' more safe
      while dstWidth<2 or dstHeight<2
        scaleFactor += 0.01
        dstWidth    *= oldWidth *scaleFactor
        dstHeight   *= oldHeight*scaleFactor
      wend 
      ' create scaled image   
      dstImage=Imagecreate(dstWidth,dstHeight)
    End If
    if Imageinfo(dstImage,dstWidth,dstHeight,dstBytes,dstPitch,dstPixels) then exit sub
  End If
  ' not the same color depth
  if srcBytes<>dstBytes then exit sub
  ' it's an RGB (ulong) rotater only
  if dstBytes<=2 then exit sub
 
  ' pitch in bytes to pitch in ulong
  srcPitch shr=2 : dstPitch shr=2
 
  Dim As integer srcCenterX=srcWidth \2
  dim as integer srcCenterY=srcHeight\2
  Dim As single si=Sin(rotAngle), co=cos(rotAngle)
  Dim As integer mx=Iif(srcWidth>=srcHeight,srcWidth,srcHeight)
  ' isn't as magic number it's sqr(0.5)
  dim as single fx=scaleFactor*.7071067811865476
  dim as single invScale=1.0/scaleFactor
  If fixedPivot=false Then
    rotCenterX+=srcCenterX*scaleFactor-srcCenterX
    rotCenterY+=srcCenterY*scaleFactor-srcCenterY
  End If
  dim as single  fxmx=fx*mx
  dim as integer yS=srcCenterY-fxmx ' Y start
  dim as integer yE=srcCenterY+fxmx ' Y end
  dim as integer xS=srcCenterX-fxmx ' X start
  dim as integer xE=srcCenterX+fxmx ' X end
  dim as integer Rows=any,xSize=any,Columns=any,dstRow=any
 
  dstY=rotCenterY+yS : if dstY>=dstHeight then exit sub
  if dstY<0 then yS=0-rotCenterY
  dstY=yE+rotCenterY : if dstY<1 then exit sub
  if dstY>=dstHeight then yE=dstHeight-rotCenterY-1
  Rows = yE-yS : if Rows<1 then exit sub
 
  dstX=xS+rotCenterX : if dstX>=dstWidth then exit sub
  if dstX<0 then xS=0-rotCenterX
  dstX=xE+rotCenterX : if dstX<1 then exit sub
  if dstX>=dstWidth then xE=dstWidth-rotCenterX-1
  xSize = xE-xS : if xSize<1 then exit sub
 
  dstY=yS+rotCenterY : dy =yS-srcCenterY
  dstX=xS+rotCenterX : dstRow=dstPitch*dstY+dstX
  while Rows
    sidy=si*dy : cody=co*dy
    dx=xS-srcCenterX : dstP=dstPixels+dstRow
    Columns=xSize
    while Columns
      ' !!! inner loop !!!
      srcX=srcCenterX + invScale*(co*dx-sidy) 
      ' is srcX inside source ?
      If srcX>-1 andalso srcX<srcWidth Then
        srcY=srcCenterY + invScale*(si*dx+cody)
        ' is srcY inside source
        If srcY>-1 andalso srcY<srcHeight Then
          srcColor = srcPixels[srcPitch*srcY+srcX]
          If srcColor<>maskColor Then *dstP = srcColor
        End If
      End If
      dx+=1 : dstP+=1 : Columns-=1
    wend
    dstRow+=dstPitch : dy+=1 : Rows-=1
  wend
End Sub


const as single PI=4*ATN(1)
const as single DEG2RAD = PI/180.0 '0.01745329

dim as integer scrW,scrH
screeninfo scrW,scrH
scrW*=0.7:scrH*=0.7

screenres scrW,scrH,32,2,64
screenset 1,0
var img = ImageCreate(512,512)

line img,(0,0)-step(511,511),rgb(128,128,128),BF
line img,(0,0)-step(511,511),rgb(255,255,255),B
for i as integer = 0 to 511 step 32
  line img,(0,i)-step(511,0),rgb(255,255,255)
  line img,(i,0)-step(0,511),rgb(255,255,255)
next 

windowtitle "old code please wait ..."
dim as single w
dim as double t1=timer()

for i as integer=0 to 360*2
  var x=scrW/2-256+cos(w*0.5)*256
  var y=scrH/2-256+sin(w)*scrH
  cls
  rotateimage_old(,img,w,x,y,2.1+sin(w*0.5)*2)
  flip
  w+=0.01
  'sleep 10
next
t1=timer()-t1

w=0
windowtitle "new code please wait ..."
dim as double t2=timer()
for i as integer=0 to 360*2
  var x=scrW/2-256+cos(w*0.5)*256
  var y=scrH/2-256+sin(w)*scrH
  cls
  rotateimage_new(,img,w,x,y,2.1+sin(w*0.5)*2)
  flip
  w+=0.01
  'sleep 10
next
t2=timer()-t2

print "old: " & t1 & " new: " & t2
flip
sleep
albert
Posts: 4951
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jul 10, 2019 3:09

@Dodicat
@Richard

I'm trying to get the right value , using only 1 or 2 decimal digits..

Can someone help?

Code: Select all


screen 19

dim as ulongint v1
dim as single v2
dim as string n , v
do
   
    dim as longint n1 = int( rnd * 65536 )
   
        v1 = n1
       
        v2 = v1 / 256
       
        v  = str(int(v2))
       
        n = str(frac(v2))
        n = mid(n,3)
        n = left(n,2)  ' trying to get right answer with only 1 or two decimal digits
               
        print n1 ,  int( (val( v  + "." + n )+.005) * 256)
       
        sleep
       
loop until inkey = chr(27)

sleep
end

Richard
Posts: 2953
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Postby Richard » Jul 10, 2019 3:56

What are you trying to do.

Code: Select all

 print " >>> "; Cint( 2.56 * Int( v1 / 2.56 )  )
fxm
Posts: 9123
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Squares

Postby fxm » Jul 10, 2019 7:19

Code: Select all

screen 19

do
   
  const as integer n = 2              '' 2: for displaying 2 decimal digits at most
  const as integer c = 10 ^ n
   
  dim as double d
  dim as string s
  dim as integer i
   
  d = int( rnd * 65536 ) / 256        '' decimal number to round to 'n' decimal digits at most
   
  s  = str( clngint( d * c ) / c )    '' to round the 'n'th decimal digit
  i = instr( 1, s, "." )
  if i > 0 then
    s = left( s, i + n )              '' to keep 'n' decimal digits at most
  end if
   
  print d,, s
   
loop until getkey = 27

sleep

Variant with procedure called::

Code: Select all

declare function roundToDecimalDigits (byval d as double, byval n as uinteger) as string

screen 19

do
   
  const as integer n = 2              '' 2: for displaying 2 decimal digits at most
  dim as double d
   
  d = int( rnd * 65536 ) / 256        '' decimal number to round to 'n' decimal digits at most
   
  print d,, roundToDecimalDigits(d, n)
   
loop until getkey = 27

sleep


Function roundToDecimalDigits (byval d as double, byval n as uinteger) as string
   
  dim as integer c = 1
  for k as integer = 1 to n
    c = c * 10
  next k
   
  dim as string s
  dim as integer i
   
  s  = str( clngint( d * c ) / c )    '' to round the 'n'th decimal digit
  i = instr( 1, s, "." )
  if i > 0 then
    s = left( s, i + n )              '' to keep 'n' decimal digits at most
  end if
   
  return s
   
end function
albert
Posts: 4951
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jul 10, 2019 17:12

You guys;

I'm trying to round the 16 bit input ( 0 to 65535) to 1 or 2 decimal digits , and then try to recreate the input with just those 2 digit places.

v = int( input / 256 )

n = str( frac( input / 256) )
n = mid(n,3)
n = left(n,2) ' truncate to 2 decimal places

now , try to recreate the input , using just v and n..
fxm
Posts: 9123
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Squares

Postby fxm » Jul 10, 2019 17:54

Code: Select all

screen 19

dim as longint v1 , v2 , v3 , v4
do
   
    dim as longint n1 = int( rnd * 65536 )
   
        v1 = n1 mod 256
        v2 = n1 \ 256
       
        print
        print n1 , v1 , v2
       
'        for b as longint = 0 to 65535 step 1
'            if b mod 256 = v1 and b \ 256 = v2  then print b : exit for
'        next
        print v2 * 256 + v1
       
        sleep
       
loop until inkey = chr(27)

sleep
end


Note: If the question is not very understandable or changing, we can hardly help.

Return to “General”

Who is online

Users browsing this forum: No registered users and 3 guests