## Squares

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

### Re: Squares

( !!~~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
Posts: 1782
Joined: May 24, 2007 22:10
Location: The Netherlands

### Re: Squares

FreeBASIC art:

Code: Select all

`const SCREEN_W = 640, SCREEN_H = 480const IMG_SIZE = 400const IMG_XO = (SCREEN_W - IMG_SIZE) \ 2 '120const IMG_YO = (SCREEN_H - IMG_SIZE) \ 2 '40const 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, yend typeoperator + (a as int2d, b as int2d) as int2d   return type(a.x + b.x, a.y + b.y)end operatorsub tline(pTarget as any ptr, p1 as int2d, p2 as int2d, c as ulong)   line pTarget, (p1.x, p1.y)-(p2.x, p2.y), cend subsub 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), cend subsub 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   nextend subsub 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   nextend subsub 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 subsub tcircle(pTarget as any ptr, p as int2d, r as single, c as ulong)   circle pTarget, (p.x, p.y), r, c, ,,,fend sub'-------------------------------------------------------------------------------screenres SCREEN_W, SCREEN_H, 32width SCREEN_W \ 8, SCREEN_H \ 16dim as integer i, x, y, rdim as ulong c, fdim as int2d root, dp1, dp2, flowerconst NUM_LEAVES = 6, NUM_STEMS = 5root = 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 skyline pImg, (0, 0)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(70, 70, 255), bfline pImg, (0, 80)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(50, 50, 255), bfline pImg, (0, 110)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(0, 0, 255), bfline pImg, (0, 200)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(40, 40, 255), bf'mountainsfor 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 , fnextfor 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, fnextfor 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 , fnext'brown groundfor 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, fnext'ground leavesfor i = 0 to NUM_LEAVES - 1   drawLeaf(pImg, root, leafNodes(i, 0), leafNodes(i, 1), GREEN)next'flower stemsfor 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'cloudsrandomize 123for 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, fnext'show imageput (IMG_XO, IMG_YO), pImgsleep`
albert
Posts: 5492
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

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

### Re: Squares

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

### Re: Squares

Time Rhyme!!

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

### Re: Take a break

Summer is here.

Code: Select all

`Type Point    As Single x,y,z    As Ulong colEnd TypeFunction 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 sleeptimeEnd FunctionSub 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)    nextEnd SubFunction 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 FunctionSub 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 yEnd SubSub 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 SubSub 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 IfEnd SubFunction 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= imEnd FunctionFunction range(f As Long,l As Long) As Long    Return  Int(Rnd*((l+1)-(f)))+f    End FunctionFunction 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 0End FunctionData _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: 374
Joined: May 05, 2017 19:59
Location: Germany

### Re: Take a break

dodicat wrote:Summer is here.
...

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

### Re: Take a break

dodicat wrote:Summer is here.

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

### Re: Squares

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

### Re: Squares

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 yEnd SubSub 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  wendEnd Subconst as single PI=4*ATN(1)const as single DEG2RAD = PI/180.0 '0.01745329dim as integer scrW,scrHscreeninfo scrW,scrHscrW*=0.7:scrH*=0.7screenres scrW,scrH,32,2,64screenset 1,0var img = ImageCreate(512,512)line img,(0,0)-step(511,511),rgb(128,128,128),BFline img,(0,0)-step(511,511),rgb(255,255,255),Bfor 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 wdim 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 10nextt1=timer()-t1w=0windowtitle "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 10nextt2=timer()-t2print "old: " & t1 & " new: " & t2flipsleep`
albert
Posts: 5492
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Dodicat
@Richard

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

Can someone help?

Code: Select all

`screen 19dim as ulongint v1dim as single v2dim as string n , vdo         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)sleepend`
Richard
Posts: 2984
Joined: Jan 15, 2007 20:44
Location: Australia

### Re: Squares

What are you trying to do.

Code: Select all

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

### Re: Squares

Code: Select all

`screen 19do     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 = 27sleep`

Variant with procedure called::

Code: Select all

`declare function roundToDecimalDigits (byval d as double, byval n as uinteger) as stringscreen 19do     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 = 27sleepFunction 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: 5492
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

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: 9472
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

### Re: Squares

Code: Select all

`screen 19dim as longint v1 , v2 , v3 , v4do       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)sleepend`

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