Squares

[badidea]

Sounds like a good way to destroy data.

[albert]

@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]

@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]

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]

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

https://www.youtube.com/watch?v=c9CyMJXg6PA

[badidea]

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]

@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]

@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]

@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"

[albert]

@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

[Richard]

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...
https://freebasic.net/forum/viewtopic.p ... es#p125920

[albert]

Thanks Richard

https://freebasic.net/forum/viewtopic.p ... es#p125920

[dodicat]

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]

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]

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