## Squares

General FreeBASIC programming questions.
Posts: 2046
Joined: May 24, 2007 22:10
Location: The Netherlands

### Re: Squares

Sounds like a good way to destroy data.
albert
Posts: 5675
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Dodicat

I need to turn the output string digits , back into 2 bit sequences...

This one compresses 90% after 40 loops.

Code: Select all

`Declare Function      compress_loop( chrs as string ) as stringDeclare Function decompress_loop( chrs as string ) as stringscreen 19'====================================================================='====================================================================='start program'====================================================================='=====================================================================dim as double time1 , time2 , time3 , time4do        randomize       dim as string s = ""    For n As Long = 1 To 8        s+=chr(Int(Rnd*256))    Next       time1=timer    'begin compress        dim as string comp = s            'do            '    dim as longint chk = len(comp) - 1            '    comp = compress_loop(comp)            '    if len(comp) >= chk then exit do            'loop            for a as longint = 1 to 1 step 1                comp = compress_loop(comp)            next    'end compress    time2 = timer       time3=timer    'begin decompress        dim as string final_out = comp        for a as longint = 1 to 1 step 1            final_out = decompress_loop(final_out)        next    'end decompress    time4 = timer      'sleep       'cls    'draw string( 0,10) , left(s,100)    'draw string( 0,30) , left(final_out,100)    print string(99,"=")    'print "inp = " ; (s)    print string(99,"=")    'print "out = " ; (final_out)    print    print "compress time   = "; time2-time1    print "decompress time = "; time4-time3    print       if s = final_out then print "Decompressed OK" else print "Decompression failed."    print string(99,"=")       sleep   loop until inkey = chr(27)sleepend'==============================================================================='==============================================================================='compress'==============================================================================='===============================================================================Function compress_loop( chrs as string ) as string        'turn file into binary    dim as string bits=""    dim as string zeros = string(64,"0")    dim as string n1    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))    for a as longint = 1 to len(chrs) step 8        n1 = zeros + bin(*ulp) : ulp+=1        bits+=right(n1,64)    next        print "c inp = " ; len(bits) , bits        'step by 2's , create output string    dim as string outs=""    for a as longint = 1 to len(bits) step 2        n1 = mid(bits,a,2)        dim as string vals=""        for b as longint = 0 to 1            if n1[b] = 49 then vals+=bin(b)        next        if vals = "" then vals = "2"        outs+=vals    next        print "c out = " ; len(outs)  , outs        'make output string an even length of 4    dim as ubyte count=0    dim as string str1    dim as ubyte dec1    do        str1=str(len(outs)/4)        dec1=instr(1,str1,".")        if dec1<>0 then outs+="0" : count+=1    loop until dec1=0        'turn output string into characters    dim as string final=""    dim as string s , n    for a as longint = 1 to len(outs) step 4        s = mid(outs,a,4)        n=""        n+=right("00"+bin(val(mid(s,1,1))),2)        n+=right("00"+bin(val(mid(s,2,1))),2)        n+=right("00"+bin(val(mid(s,3,1))),2)        n+=right("00"+bin(val(mid(s,4,1))),2)        final+=chr(val("&B"+n))    next        final = chr(count) + final        print "c fin = "; len(final) ' final       return final   end function'==============================================================================='============================================================================Function decompress_loop( chrs as string ) as string        dim as ubyte count = asc(left(chrs,1))    chrs = mid(chrs,2)        dim as string bits=""    for a as longint = 1 to len(chrs) step 1        bits+=right("00000000"+bin( chrs[a-1] ),8)    next        'print "c inp = " ; len(bits) , bits        dim as string outs=""    for a as longint = 1 to len(bits) step 2        outs+=str(val("&B"+mid(bits,a,2)))    next        outs = left(outs,len(outs)-count)        print "c out = " ; len(outs)  , outs        'need to turn digits back into 2 bit sequences.            return chrsend function`
albert
Posts: 5675
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Dodicat

I got the de-compressor done... I ran into a problem , can't tell a 1 , 2 from a 12

It sometimes de-compresses okay , and sometimes not...

Code: Select all

`Declare Function      compress_loop( chrs as string ) as stringDeclare Function decompress_loop( chrs as string ) as stringscreen 19'====================================================================='====================================================================='start program'====================================================================='=====================================================================dim as double time1 , time2 , time3 , time4do        randomize       dim as string s = ""    For n As Long = 1 To 8        s+=chr(Int(Rnd*256))    Next       time1=timer    'begin compress        dim as string comp = s            'do            '    dim as longint chk = len(comp) - 1            '    comp = compress_loop(comp)            '    if len(comp) >= chk then exit do            'loop            for a as longint = 1 to 1 step 1                comp = compress_loop(comp)            next    'end compress    time2 = timer       time3=timer    'begin decompress        dim as string final_out = comp        for a as longint = 1 to 1 step 1            final_out = decompress_loop(final_out)        next    'end decompress    time4 = timer      'sleep       'cls    'draw string( 0,10) , left(s,100)    'draw string( 0,30) , left(final_out,100)    print string(99,"=")    print "inp = " ; (s)    print string(99,"=")    print "out = " ; (final_out)    print    print "compress time   = "; time2-time1    print "decompress time = "; time4-time3    print       if s = final_out then print "Decompressed OK" else print "Decompression failed."    print string(99,"=")       sleep   loop until inkey = chr(27)sleepend'==============================================================================='==============================================================================='compress'==============================================================================='===============================================================================Function compress_loop( chrs as string ) as string        'turn file into binary    dim as string bits=""    dim as string zeros = string(64,"0")    dim as string n1    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))    for a as longint = 1 to len(chrs) step 8        n1 = zeros + bin(*ulp) : ulp+=1        bits+=right(n1,64)    next        print "c inp = " ; len(bits) , bits        'step by 2's , create output string    dim as string outs=""    dim as string vals=""    for a as longint = 1 to len(bits) step 2        n1 = mid(bits,a,2)        if n1="00" then vals="0"        if n1="01" then vals="1"        if n1="10" then vals="2"        if n1="11" then vals="12"        outs+=vals    next        print "c out = " ; len(outs)  , outs        'make output string an even length of 4    dim as ubyte count=0    dim as string str1    dim as ubyte dec1    do        str1=str(len(outs)/4)        dec1=instr(1,str1,".")        if dec1<>0 then outs+="0" : count+=1    loop until dec1=0        'turn output string into characters    dim as string final=""    dim as string s , n    for a as longint = 1 to len(outs) step 4        s = mid(outs,a,4)        n=""        n+=right("00"+bin(val(mid(s,1,1))),2)        n+=right("00"+bin(val(mid(s,2,1))),2)        n+=right("00"+bin(val(mid(s,3,1))),2)        n+=right("00"+bin(val(mid(s,4,1))),2)        final+=chr(val("&B"+n))    next        final = chr(count) + final        print "c fin = "; len(final) ' final       return final   end function'==============================================================================='============================================================================Function decompress_loop( chrs as string ) as string        dim as ubyte count = asc(left(chrs,1))    chrs = mid(chrs,2)        dim as string bits=""    for a as longint = 1 to len(chrs) step 1        bits+=right("00000000"+bin( chrs[a-1] ),8)    next        'print "c inp = " ; len(bits) , bits        dim as string outs=""    for a as longint = 1 to len(bits) step 2        outs+=str(val("&B"+mid(bits,a,2)))    next        outs = left(outs,len(outs)-count)        print "d inp = " ; len(outs)  , outs        'need to turn digits back into 2 bit sequences.        dim as string outputs=""    dim as ubyte n1    for a as longint = 1 to len(outs) step 1                n1 = val( mid(outs,a,1) )                if n1 = 1 then             if val( mid(outs,a+1,1) ) = 2 then                 outputs+="11"                a+=1            else                outputs+= right("00"+bin(n1),2)            end if        else            outputs+= right("00"+bin(n1),2)        end if            next        print "d out = " ; len(outputs)  , outputs        dim as string final=""    for a as longint = 1 to len(outputs) step 64        final+=mklongint(valulng("&B"+mid(outputs,a,64)))    next        print "d fin = "; len(final) ' final        return finalend function`
albert
Posts: 5675
Joined: Sep 28, 2006 2:41
Location: California, USA

### Shine

I just got done with a new song.... called "Shine" about moonshine

( genre = Country Rock )

( title = Shine )

( entry music )

way out in the country back up in the woods
got a copper still putting out the goods

people round the county they all love the shine
sit around drinking after dinner time

grandpa on the porch he's a banjo man
picking out a tune like he's got a plan

narry a word 'bout where they get the shine
it's all a big secret and they waiting in line

[chorus]
sitting on the front porch in the full moon light
drinking
some
shine
tonight

[music]

gallon after gallon in the pickup truck
bring the shine to town and we're all in luck

people in the county they all waiting in line
paying good money for their gallon of shine

grandpa on the front porch drinking him some shine
picking on the banjo and we're having a time

narry a word 'bout where they get the shine
it's all a big secret and they waiting in line

[chorus]
sitting on the front porch in the full moon light
drinking
some
shine
tonight

[music]

way out in the country back up in the woods
got a copper still putting out the goods

not too many people know to make the shine
but they all love to drink it and they wait in line

draining off the high hat and the rest is shine
got many a customers waiting in line

narry a word 'bout where they get the shine
it's all a big secret and they waiting in line

[chorus]
sitting on the front porch in the full moon light
drinking
some
shine
tonight

[music]

just some good ole boys back in the woods they go
tending to the still even in the snow

got to make some money from the fresh moonshine
many a gallon people waiting in line

back up in the woods there sits a copper still
just puttin out the goods and paying off the bills

narry a word 'bout where they get the shine
it's all a big secret and they waiting in line

[chorus]
sitting on the front porch in the full moon light
drinking
some
shine
tonight

[music]

[chorus]
sitting on the front porch in the full moon light
drinking
some
shine
tonight

[music]

drinking some shine tonight

[music]

drinking some shine tonight

all right now

[exit music]

albert_redditt@yahoo.com

Albert Redditt
315 W. Carrillo St. #104
Santa Barbara, Ca. 93101 U.S.A
Knatterton
Posts: 165
Joined: Apr 19, 2019 19:03

### Re: Squares

Albert, you have deserved to hear my favourite country song as well:

Posts: 2046
Joined: May 24, 2007 22:10
Location: The Netherlands

### Re: Squares

Random square doodle, not worth its own topic:

Code: Select all

`const SW = 800, SH = 600Const As Single PI = 4 * Atn(1)Const As Single RAD_PER_DEG = (PI / 180)Const As Single DEG_PER_RAD = 180 / PI'-------------------------------------------------------------------------------type int2d   dim as integer x, y   Declare Constructor   Declare Constructor(x As Integer, y As Integer)   Declare Operator Cast () As Stringend typeConstructor int2dEnd ConstructorConstructor int2d(x As Integer, y As Integer)   This.x = x : This.y = yEnd Constructor' "x, y"Operator int2d.cast () As String  Return Str(x) & "," & Str(y)End Operator' a - bOperator - (a As int2d, b As int2d) As int2d   Return Type(a.x - b.x, a.y - b.y)End Operator'-------------------------------------------------------------------------------type sgl3d   dim as single x, y, z   Declare Constructor   Declare Constructor(x as single, y as single, z as single)   Declare Operator Cast () As Stringend typeConstructor sgl3dEnd ConstructorConstructor sgl3d(x as single, y as single, z as single)   This.x = x : This.y = y : This.z = zEnd Constructor' "x, y"Operator sgl3d.cast () As String  Return Str(x) & "," & Str(y) & "," & Str(z)End Operator'-------------------------------------------------------------------------------function to2d(p as sgl3d) as int2d   return int2d(SW \ 2 + p.y - p.x / 2, SH \ 2 + p.x / 2 - p.z)end functionsub pset3d(p1 as sgl3d, c as ulong)   dim as int2d p1Screen = to2d(p1)   pset(p1Screen.x, p1Screen.y), cend subsub line3d(p1 as sgl3d, p2 as sgl3d, c as ulong)   dim as int2d p1Screen = to2d(p1)   dim as int2d p2Screen = to2d(p2)   line(p1Screen.x, p1Screen.y)-(p2Screen.x, p2Screen.y), cend sub'-------------------------------------------------------------------------------sub rotate(byref p3d as sgl3d, xTheta as single, yTheta as single, zTheta as single)   'From tutorials Relsoft   dim as single x = p3d.x, y = p3d.y, z = p3d.z   dim as single xNew, yNew, zNew   '***Rotation on the Z-axis   yNew = y*cos(xTheta) - z*sin(xTheta)   zNew = z*cos(xTheta) + y*sin(xTheta)   y = yNew   z = zNew   '***Rotation on the Y-axis   zNew = z*cos(yTheta) - x*sin(yTheta)   xNew = x*cos(yTheta) + z*sin(yTheta)   x = xNew   '***Rotation on the Z-axis   xNew = x*cos(zTheta) - y*sin(zTheta)   yNew = y*cos(zTheta) + x*sin(zTheta)   p3d.x = xNew   p3d.y = yNew   p3d.z = zNewend subscreenres SW, SH, 32width SW \ 8, SH \ 16const NUM_POINTS = 4dim as sgl3d p(NUM_POINTS - 1) = {sgl3d(100, 100, 0), sgl3d(-100, 100, 0), sgl3d(-100, -100, 0), sgl3d(100, -100, 0)}dim as int2d mousePos, deltaPosdim as double tNow = timer, dt = 0while inkey <> chr(27)   if getmouse(mousePos.x, mousePos.y) = 0 then      deltaPos = mousePos - int2d(SW \ 2, SH \ 2)   end if      for i as integer = 0 to ubound(p)         rotate(p(i), 0, deltaPos.y * RAD_PER_DEG * dt, deltaPos.x * RAD_PER_DEG * dt) 'deltaPos * degrees / second      next   screenlock   line(0, 0)-(SW-1, SH-1), 0, bf   locate 1,1 : Print "Use mouse position for rotation of plane";   for i as integer = 0 to ubound(p)      dim as integer j = i + 1      if j > ubound(p) then j = 0      line3d(p(i), p(j), rgb(200, 200, 0))      line3d(p(i), sgl3d(0, 0, 0), rgb(200, 0, 200))      circle(SW \ 2, SH \ 2), 10, rgb(0, 200, 0)   next    screenunlock   sleep 1   dt = timer - tNow   tNow = timerwend `
albert
Posts: 5675
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

Just play around with all the functions..

sin
cos
tan
log
atn

Just experiment with the functions... sin * sin * cos * tan * deg^2 * sin * log .... etc...

Just silly strings of functions....never know what it will create...
albert
Posts: 5675
Joined: Sep 28, 2006 2:41
Location: California, USA

### Galactic_Chicken

Here's my "Galactic Chicken"

Just play around with the functions...

Code: Select all

`'Galactic-Chicken.basdim as single c1,c2dim as single s1,s2dim as single x1,x2dim as single y1,y2dim as single deg1,deg2dim as single rad1dim as single rad2dim as integer xctr, yctr, radius, divisions, fullcircle, toggledim as integer xres,yres'screen 19screeninfo xres,yresscreenres xres,yres,8,1,8xctr = xres/2yctr = yres/2radius = (xres*yres)/((xres+yres)*4)divisions = 45rad1 = atn(1) / divisionsrad2 = atn(1) / (divisions/2)fullcircle = atn(1)*8 / rad1toggle = 0do           for deg1 = 0 to fullcircle step 1               c1=cos(deg1*rad1)            s1=sin(deg1*rad1)               x1=radius*c1            y1=radius*s1           for deg2 = 0 to fullcircle step 1                       c2=cos(deg2*rad2)            s2=sin(deg2*rad2)                   x2=radius*s2*log(deg2*rad1*s2)*atn(deg2*rad2*s2/s1)*atn(deg2*rad2*c1*s1*c2)*sin(deg2/(s1*c1*s1*c1)*rad1*rad1)            y2=radius*c2*log(deg2*rad1*c2)*atn(deg2*rad2*c2/c1)*atn(deg2*rad2*c1*s1*c2)*sin(deg2/(s1*c1*s1*c1)*rad1*rad1)                         pset(xctr+x1+x2,yctr+y1+y2),9            'pset(xctr+x1+x2,yctr+y1+y2),deg2 ' cool rainbow color                   next       nextloop until inkey <>""`
albert
Posts: 5675
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Richard

How do you bring up the old "Circles" forum? I need to search it for one of my programs..

Someone hacked my computer and deleted all my abstract # ?? files from my "Patterns" folder.
But all the ones that were good , i posted in "Circles"
Last edited by albert on Sep 10, 2019 0:52, edited 1 time in total.
albert
Posts: 5675
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

Here's my trig doodle "The Temple"....

Just play with the functions, never know what you'll create...

Code: Select all

`'The Templedim as integer xres,yresscreen 19screeninfo xres,yresdim as double xctr,yctr,radius=175dim as double deg1,deg2dim as double c1,c2,s1,s2dim as double x1,y1dim as double rad=atn(1)/45  '2 degrees worth of radiansdim as string inkxctr=xres/2yctr=yres/2    for deg1 = 0 to 360 step 1               c1=cos(deg1*rad)        s1=sin(deg1*rad)               for deg2 = 0 to 360 step 1                       c2 = cos(deg2*rad)            s2 = sin(deg2*rad)                       x1=radius* (atan2( tan(c2+c2) , tan(c1+c1) ) /2 )            y1=radius* (atan2( tan(s2+s2) , tan(s1+s1) ) /2 )                       pset(xctr+x1,yctr+y1),deg1   ' deg1 here causes multi-color set to static value for mono            pset(xctr+x1,yctr-y1),deg1   ' deg1 here causes multi-color set to static value for mono            pset(xctr-x1,yctr+y1),deg1   ' deg1 here causes multi-color set to static value for mono            pset(xctr-x1,yctr-y1),deg1   ' deg1 here causes multi-color set to static value for mono                   next           nextSLEEPEND`

Here's the animated version 3D

Code: Select all

`'Animated doodle "The Temple" Type V3    As Single x,y,z    colour as uintegerEnd Type#define vct Type<V3>Function Rotate3D(Fulcrum as V3,pt As v3,Angle As v3,scale As v3=Type<v3>(1,1,1)) As v3    Dim As v3 p=vct(pt.x-Fulcrum.x,pt.y-Fulcrum.y,pt.z-Fulcrum.z)    Dim As v3 rot,temp    Dim As Single s=Sin(angle.x),c=Cos(angle.x)    temp=vct((p.y)*C+(-p.z)*S,(p.z)*C+(p.y)*S)    rot.y=temp.x    s=Sin(angle.y):c=Cos(angle.y)    temp=vct((temp.y)*C+(-p.x)*S,(p.x)*C+(temp.y)*S)    rot.z=temp.x    s=Sin(angle.z):c=Cos(angle.z)    temp=vct((temp.y)*C+(-rot.y)*S,(rot.y)*C+(temp.y)*S)    rot.x=temp.x:rot.y=temp.y    Return vct((scale.x*rot.x+Fulcrum.x),(scale.y*rot.y+Fulcrum.y),(scale.z*rot.z+Fulcrum.z),pt.colour)End FunctionFunction apply_perspective(p As V3,eyepoint As V3) As V3    Dim As Single   w=1+(p.z/eyepoint.z)    If w=0 Then w=1e-20    Return Type<V3>((p.x-eyepoint.x)/w+eyepoint.x,(p.y-eyepoint.y)/w+eyepoint.y,(p.z-eyepoint.z)/w+eyepoint.z,p.colour)End Function'====================== End of rotator and perspective getter ======================================'extra subs to regulate speedFunction framecounter() As Integer    Var t1=Timer,t2=t1    Static As Double t3,frames,answer    frames=frames+1    If (t2-t3)>=1 Then        t3=t2        answer=frames        frames=0    End If    Return answerEnd FunctionFunction regulate(MyFps As Integer,Byref fps As Integer) As Integer    fps=framecounter    Static As Double timervalue    Static As Double delta,lastsleeptime,sleeptime    Var k=1/myfps    If Abs(fps-myfps)>1 Then        If fps<Myfps Then delta=delta-k Else delta=delta+k    End If    sleeptime=lastsleeptime+((1/myfps)-(Timer-timervalue))*(2000)+delta    If sleeptime<1 Then sleeptime=1    lastsleeptime=sleeptime    timervalue=Timer    Return sleeptimeEnd Function'setup screendim as integer xres,yresscreeninfo xres,yresscreenres xres,yres,8,1,8'trig variables setupdim as single c1,c2dim as single s1,s2dim as single x1,x2dim as single y1,y2dim as single z1dim as single deg1,deg2dim as single rad = atn(1) / 22.5 / 2dim as integer xctrdim as integer yctrdim as integer radiusdim as integer countxctr   = xres/2yctr   = yres/2radius = 200count  = 1       'dim array to hold all the points    redim as V3 array(0)    for deg1 = 0 to 360 step 2               c1=cos(deg1*rad)        s1=sin(deg1*rad)               for deg2 = 0 to 360 step 2                       c2 = cos(deg2*rad)            s2 = sin(deg2*rad)                       x1=radius* (atan2( tan(c2+c2) , tan(c1+c1) ) /2 ) * atan2(deg2,tan(c2)) / 1.5            y1=radius* (atan2( tan(s2+s2) , tan(s1+s1) ) /2 ) * atan2(deg2,tan(s2)) / 1.5                       z1=radius * cos(c1+s1) * 1.5                           redim preserve array(count)            array(count)=vct(xctr+x1+x2, yctr+y1+y2 , yctr+z1, 9+count mod 2)            count+=1                   next           next      'rotate variables setupdim as V3 centre   = vct(xctr,yctr,0500)dim as V3 eyepoint = vct(xctr,yctr,1000)dim as V3 angle'run program loopdim as integer fpsdim as string inkdim as single rot_x=.02 'radiansdim as single rot_y=.02dim as single rot_z=.02do       var sleepover=regulate(60,fps)       ink=inkey       if ink=chr(255)+"H" then rot_x-=.02    if ink=chr(255)+"P" then rot_x+=.02    if ink=chr(255)+"M" then rot_y-=.02    if ink=chr(255)+"K" then rot_y+=.02    if ink=chr(255)+"R" then rot_z-=.02    if ink=chr(255)+"S" then rot_z+=.02    if ink=chr(32) then        rot_x=0 : angle.x=0        rot_y=0 : angle.y=0        rot_z=0 : angle.z=0    end if       if ink=chr(13) then        rot_x=.02        rot_y=.02        rot_z=.02    end if       angle.x+=rot_x    angle.y+=rot_y    angle.z+=rot_z       screenlock    cls       for n1 as integer = 1 to ubound(array)        var temp=rotate3d(centre,array(n1),angle,vct(1,1,1))        temp=apply_perspective(temp,eyepoint)        pset(temp.x,temp.y), temp.colour    next n1       draw string(20,20),"Frames per second = " & fps    screenunlock       sleep sleepover,1           if ink=chr(27) then exit do   loopSLEEPEND`
Last edited by albert on Sep 10, 2019 1:24, edited 1 time in total.
Richard
Posts: 3013
Joined: Jan 15, 2007 20:44
Location: Australia

### Re: Squares

Albert wrote:How do you bring up the old "Circles" forum? I need to search it for one of my programs..

Use the search function on the FB forum, and you will get...
viewtopic.php?f=3&t=14570&hilit=circles#p125920
albert
Posts: 5675
Joined: Sep 28, 2006 2:41
Location: California, USA

### Circles

dodicat
Posts: 6485
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Squares

Circles became squares.

Code: Select all

`Type Point     As Short x,y    Declare Constructor(As Short=0,As Short=0)End TypeConstructor Point(xx As Short=0,yy As Short=0)x=xxy=yyEnd ConstructorType Rectangle Extends Point    As Ushort wide    As Ushort high    As Single aspect    As Byte pflag    As Ulong clr    Declare  Constructor(As Point=Point(0,0),As Ushort=0,As Ushort=0,As Single =0,As Ulong=0,As Byte=0)    As Point v(1 To 4)End TypeConstructor rectangle(c As Point,w As Ushort,h As Ushort,a As Single,col As Ulong,pf As Byte)#macro rotate(pivot,p,a,d)Point(d*(Cos(a*.0174533)*(p.x-pivot.x)-Sin(a*.0174533)*(p.y-pivot.y)) +pivot.x,_d*(Sin(a*.0174533)*(p.x-pivot.x)+Cos(a*.0174533)*(p.y-pivot.y)) +pivot.y)#endmacrov(1)=Type(c.x-w/2,c.y-h/2)v(2)=Type(c.x-w/2,c.y+h/2)v(3)=Type(c.x+w/2,c.y+h/2)v(4)=Type(c.x+w/2,c.y-h/2)For n As Long=1 To 4    v(n)=rotate(c,v(n),a,1)Nextpflag=pfclr=colEnd ConstructorType RoundedRectangle Extends Rectangle    As Ushort rad    Declare Sub Draw()     Declare Constructor( As Point=Type(0,0), As Ushort=0, As Ushort=0, As Single=0,As Ushort=0,As Ulong=0,As Byte=0)End TypeConstructor roundedrectangle(c As Point,w As Ushort,h As Ushort,a As Single,r As Ushort,col As Ulong,pf As Byte)This=*Cast(roundedrectangle Ptr,@rectangle(c,w,h,a,col,pf))#define mn iif(w>h,h/2,w/2)rad=Iif (r>mn,mn,r)End ConstructorFunction shortline(fp As Point,p As Point,length As Long) As Point    Dim As Long diffx=p.x-fp.x,diffy=p.y-fp.y    Dim As Single L=Sqr(diffx*diffx+diffy*diffy)    Return Type(fp.x+length*diffx/L,fp.y+length*diffy/L)End FunctionSub roundedrectangle.draw()    Dim As Ubyte r=Cast(Ubyte Ptr,@clr),g=Cast(Ubyte Ptr,@clr)    Dim As Ubyte b=Cast(Ubyte Ptr,@clr),a=Cast(Ubyte Ptr,@clr)    Dim As Ulong c1=Rgba(r,g,b,255)    Dim As Long q    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)        #macro set(dx,dy,z)    z=Atan2(dy,dx)    If dx<=0 And dy<=0 Then q=3    If dx>=0 And dy<=0 Then q=4    Select Case As Const q    Case 3,4:z=map(-pi,0,z,pi,2*pi)    End Select    #endmacro        Const pi=4*Atn(1)    Dim As Single s,e,dx,dy    Dim As Point t(1 To 8),c(1 To 4)    t(1)=shortline(v(1),v(2),rad)    t(2)=shortline(v(2),v(1),rad)    Line(t(1).x,t(1).y)-(t(2).x,t(2).y),c1        t(3)=shortline(v(2),v(3),rad)    t(4)=shortline(v(3),v(2),rad)    Line(t(3).x,t(3).y)-(t(4).x,t(4).y),c1        t(5)=shortline(v(3),v(4),rad)    t(6)=shortline(v(4),v(3),rad)    Line(t(5).x,t(5).y)-(t(6).x,t(6).y),c1        t(7)=shortline(v(4),v(1),rad)    t(8)=shortline(v(1),v(4),rad)    Line(t(7).x,t(7).y)-(t(8).x,t(8).y),c1        c(1)=shortline(t(1),t(6),rad)    dy=t(8).y-c(1).y:dx=t(8).x-c(1).x    set(dx,-dy,s)    dy=t(1).y-c(1).y:dx=t(1).x-c(1).x    set(dx,-dy,e)    Circle(c(1).x,c(1).y),rad,c1,s,e        c(2)=shortline(t(2),t(5),rad)    dx=t(2).x-c(2).x:dy=t(2).y-c(2).y    set(dx,-dy,s)    dx=t(3).x-c(2).x:dy=t(3).y-c(2).y    set(dx,-dy,e)    Circle(c(2).x,c(2).y),rad,c1,s,e        c(3)=shortline(t(4),t(7),rad)    dx=t(4).x-c(3).x:dy=t(4).y-c(3).y    set(dx,-dy,s)    dx=t(5).x-c(3).x:dy=t(5).y-c(3).y    set(dx,-dy,e)    Circle(c(3).x,c(3).y),rad,c1,s,e        c(4)=shortline(t(6),t(1),rad)    dx=t(6).x-c(4).x:dy=t(6).y-c(4).y    set(dx,-dy,s)    dx=t(7).x-c(4).x:dy=t(7).y-c(4).y    set(dx,-dy,e)    Circle(c(4).x,c(4).y),rad,c1,s,e    If pflag Then Paint((c(1).x+c(3).x)\2,(c(1).y+c(3).y)\2),clr,c1End SubSub construct(ra() As roundedrectangle)    #define map(a,b,x,c,d)  ((d)-(c))*((x)-(a))/((b)-(a))+(c)    Randomize 2    Dim As Long k,yy=120    Static As Long da    da+=10    For n As Long=1 To Ubound(ra)        k+=1        If k>4 Then k=1        With ra(n)            .x=map(1,4,k,150,(1024-150))            .y=yy            If n Mod 4=0 Then yy+=175            .high=165            .wide=.high            .clr=Rgba(Rnd*255,Rnd*255,Rnd*255,100+Rnd*155)            .aspect=n*2+da            .pflag=1            .rad=.high/2            ra(n)=roundedrectangle(Point(.x,.y),.wide,.high,.aspect,.rad,.clr,.pflag)        End With    Next nEnd Subfunction start() as longScreen 20,32,,64Dim As roundedrectangle ra(1 To 16)construct(ra())var z=ra(1).radDim As Long k=1Do    Screenlock    Cls    For n As Long=1 To Ubound(ra)        ra(n).rad-=k        ra(n).draw    Next    If ra(1).rad<=0 Then k=-k    If ra(1).rad > z Then k=-k: construct(ra())    Screenunlock    Sleep 1,1Loop Until Len(Inkey)Sleepreturn 0end functionend start `
Knatterton
Posts: 165
Joined: Apr 19, 2019 19:03

### Re: Squares

And then it becomes colorful:

Code: Select all

`' colorwheel.bas ' 96 colors#include "fbgfx.bi"dim shared as single degree,angeldim shared as integer x,y,turn,x1,y1,x2,y2,z,t,swidth,sheightscreencontrol fb.get_desktop_size, swidth, sheight ' get resolutionscreenres(swidth,sheight,32,,fb.gfx_no_frame or fb.gfx_alpha_primitives) ' create color arraydim colorcircle(11) as integercolorcircle(0)  = rgb(227,35,34)   ' redcolorcircle(1)  = rgb(237,89,30)   ' redorangecolorcircle(2)  = rgb(241,142,28)  ' orangecolorcircle(3)  = rgb(249,194,12)  ' yelloworangecolorcircle(4)  = rgb(244,229,0)   ' yellowcolorcircle(5)  = rgb(145,221,46)  ' yellowgreencolorcircle(6)  = rgb(0,188,37)    ' greencolorcircle(7)  = rgb(26,168,114)  ' bluegreencolorcircle(8)  = rgb(42,113,176)  ' bluecolorcircle(9)  = rgb(88,106,196)  ' bluevioletcolorcircle(10) = rgb(146,80,191)  ' violetcolorcircle(11) = rgb(219,4,147)   ' redvioletfunction gsin (angel as single) as single  return -sin((angel+90)*0.0174)end functionfunction gcos (angel as single) as single  return -cos((angel+90)*0.0174)end function  color rgb(0, 0, 0), rgb(0, 1, 1)  cls  turn=170  x = swidth/2  y = sheight/2  circle(x,y),500   degree=turn    ' fields    for z = 0 to 5      x1=x+gsin(degree)*500      y1=y+gcos(degree)*500      x2=x+gsin(degree+180)*500      y2=y+gcos(degree+180)*500      line (x1,y1) - (x2,y2)      degree += 30    next    degree=15+turn     ' colors     for z = 0 to 11       x1=x+gsin(degree)*400       y1=y+gcos(degree)*400       paint(x1,y1),colorcircle(z),rgb(0,0,0)       degree += 30     next     for t = 500 to 20 step -60 ' circles almost black       circle(x,y),t,rgb(0,0,1)     next     for z = 0 to 3        ' light tones       paint(x,y+z*60),rgba(255,255,255,255-((z+1)*54)),rgb(0,0,1)     next     for z = 5 to 8       ' dark tones       paint(x,y+z*60),rgba(0,0,0,(z+1)*54),rgb(0,0,1)     next     ' middle circle white     circle(x,y),29,rgb(255,255,255),,,,f     circle(x,y),30 ' bordersleep`

Edit: now completely translated to english
albert
Posts: 5675
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

I need a video editor, for my songs...I need to be able to ; stick lyrics into the time line.
I've searched the internet and can't find any "Video Editors" ; that let you enter different fonts and text into the video box.

So you can play the song , and then pause it at a spot , and then enter text , pictures or movie clips into the video box..

How do you display an audio timeline , with tick marks ??