Squares

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

Re: Squares

Postby badidea » Sep 05, 2019 20:48

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

Re: Squares

Postby albert » Sep 08, 2019 17:19

@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 string
Declare Function decompress_loop( chrs as string ) as string

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    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)

sleep
end
'===============================================================================
'===============================================================================
'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 chrs

end function

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

Re: Squares

Postby albert » Sep 08, 2019 21:27

@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 string
Declare Function decompress_loop( chrs as string ) as string

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    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)

sleep
end
'===============================================================================
'===============================================================================
'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 final

end function

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

Shine

Postby albert » Sep 09, 2019 1:36

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: 157
Joined: Apr 19, 2019 19:03

Re: Squares

Postby Knatterton » Sep 09, 2019 2:19

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

https://www.youtube.com/watch?v=c9CyMJXg6PA
badidea
Posts: 1545
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Squares

Postby badidea » Sep 09, 2019 20:24

Random square doodle, not worth its own topic:

Code: Select all

const SW = 800, SH = 600
Const 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 String
end type

Constructor int2d
End Constructor

Constructor int2d(x As Integer, y As Integer)
   This.x = x : This.y = y
End Constructor

' "x, y"
Operator int2d.cast () As String
  Return Str(x) & "," & Str(y)
End Operator

' a - b
Operator - (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 String
end type

Constructor sgl3d
End Constructor

Constructor sgl3d(x as single, y as single, z as single)
   This.x = x : This.y = y : This.z = z
End 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 function

sub pset3d(p1 as sgl3d, c as ulong)
   dim as int2d p1Screen = to2d(p1)
   pset(p1Screen.x, p1Screen.y), c
end sub

sub 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), c
end 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 = zNew
end sub

screenres SW, SH, 32
width SW \ 8, SH \ 16

const NUM_POINTS = 4
dim 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, deltaPos
dim as double tNow = timer, dt = 0

while 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 = timer
wend
albert
Posts: 5016
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Sep 09, 2019 22:27

@badidea

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: 5016
Joined: Sep 28, 2006 2:41
Location: California, USA

Galactic_Chicken

Postby albert » Sep 09, 2019 22:57

@badidea

Here's my "Galactic Chicken"

Just play around with the functions...


Code: Select all

'Galactic-Chicken.bas

dim as single c1,c2
dim as single s1,s2
dim as single x1,x2
dim as single y1,y2
dim as single deg1,deg2
dim as single rad1
dim as single rad2


dim as integer xctr, yctr, radius, divisions, fullcircle, toggle

dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8

xctr = xres/2
yctr = yres/2

radius = (xres*yres)/((xres+yres)*4)

divisions = 45

rad1 = atn(1) / divisions
rad2 = atn(1) / (divisions/2)
fullcircle = atn(1)*8 / rad1

toggle = 0
do
   
        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
   
    next

loop until inkey <>""

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

Re: Squares

Postby albert » Sep 10, 2019 0:34

@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: 5016
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Sep 10, 2019 0:40

@badidea

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

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

Code: Select all


'The Temple

dim as integer xres,yres
screen 19
screeninfo xres,yres

dim as double xctr,yctr,radius=175
dim as double deg1,deg2
dim as double c1,c2,s1,s2
dim as double x1,y1
dim as double rad=atn(1)/45  '2 degrees worth of radians

dim as string ink

xctr=xres/2
yctr=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
       
    next

SLEEP
END



Here's the animated version 3D

Code: Select all


'Animated doodle "The Temple"
 
Type V3
    As Single x,y,z
    colour as uinteger
End 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 Function

Function 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 speed
Function 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 answer
End Function

Function 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 sleeptime
End Function

'setup screen
dim as integer xres,yres
screeninfo xres,yres
screenres xres,yres,8,1,8

'trig variables setup
dim as single c1,c2
dim as single s1,s2
dim as single x1,x2
dim as single y1,y2
dim as single z1
dim as single deg1,deg2
dim as single rad = atn(1) / 22.5 / 2

dim as integer xctr
dim as integer yctr
dim as integer radius
dim as integer count

xctr   = xres/2
yctr   = yres/2
radius = 200
count  = 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 setup
dim as V3 centre   = vct(xctr,yctr,0500)
dim as V3 eyepoint = vct(xctr,yctr,1000)
dim as V3 angle

'run program loop
dim as integer fps
dim as string ink
dim as single rot_x=.02 'radians
dim as single rot_y=.02
dim as single rot_z=.02
do
   
    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
   
loop

SLEEP
END

Last edited by albert on Sep 10, 2019 1:24, edited 1 time in total.
Richard
Posts: 2955
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Postby Richard » Sep 10, 2019 1:15

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: 5016
Joined: Sep 28, 2006 2:41
Location: California, USA

Circles

Postby albert » Sep 10, 2019 1:22

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

Re: Squares

Postby dodicat » Sep 10, 2019 11:17

Circles became squares.

Code: Select all

Type Point
    As Short x,y
    Declare Constructor(As Short=0,As Short=0)
End Type

Constructor Point(xx As Short=0,yy As Short=0)
x=xx
y=yy
End Constructor

Type 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 Type

Constructor 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)
#endmacro
v(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)
Next
pflag=pf
clr=col
End Constructor

Type 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 Type

Constructor 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 Constructor

Function 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 Function

Sub roundedrectangle.draw()
    Dim As Ubyte r=Cast(Ubyte Ptr,@clr)[2],g=Cast(Ubyte Ptr,@clr)[1]
    Dim As Ubyte b=Cast(Ubyte Ptr,@clr)[0],a=Cast(Ubyte Ptr,@clr)[3]
    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,c1
End Sub

Sub 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 n
End Sub

function start() as long
Screen 20,32,,64
Dim As roundedrectangle ra(1 To 16)

construct(ra())
var z=ra(1).rad
Dim As Long k=1
Do
    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,1
Loop Until Len(Inkey)
Sleep
return 0
end function

end start

 
Knatterton
Posts: 157
Joined: Apr 19, 2019 19:03

Re: Squares

Postby Knatterton » Sep 10, 2019 11:28

And then it becomes colorful:

Code: Select all

' colorwheel.bas ' 96 colors

#include "fbgfx.bi"

dim shared as single degree,angel
dim shared as integer x,y,turn,x1,y1,x2,y2,z,t,swidth,sheight

screencontrol fb.get_desktop_size, swidth, sheight ' get resolution
screenres(swidth,sheight,32,,fb.gfx_no_frame or fb.gfx_alpha_primitives)

' create color array
dim colorcircle(11) as integer
colorcircle(0)  = rgb(227,35,34)   ' red
colorcircle(1)  = rgb(237,89,30)   ' redorange
colorcircle(2)  = rgb(241,142,28)  ' orange
colorcircle(3)  = rgb(249,194,12)  ' yelloworange
colorcircle(4)  = rgb(244,229,0)   ' yellow
colorcircle(5)  = rgb(145,221,46)  ' yellowgreen
colorcircle(6)  = rgb(0,188,37)    ' green
colorcircle(7)  = rgb(26,168,114)  ' bluegreen
colorcircle(8)  = rgb(42,113,176)  ' blue
colorcircle(9)  = rgb(88,106,196)  ' blueviolet
colorcircle(10) = rgb(146,80,191)  ' violet
colorcircle(11) = rgb(219,4,147)   ' redviolet

function gsin (angel as single) as single
  return -sin((angel+90)*0.0174)
end function

function 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 ' border

sleep


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

Re: Squares

Postby albert » Sep 11, 2019 18:00

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 ??

Return to “General”

Who is online

Users browsing this forum: No registered users and 22 guests