Squares

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

Re: Squares

Sounds like a good way to destroy data.
albert
Posts: 5016
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 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

@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

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

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

Posts: 1545
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 = 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

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

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

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

for deg2 = 0 to fullcircle step 1

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

@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

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

for deg2 = 0 to 360 step 1

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
frames=0
End If
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
count  = 1

'dim array to hold all the points
redim as V3 array(0)
for deg1 = 0 to 360 step 2

for deg2 = 0 to 360 step 2

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

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

dodicat
Posts: 5938
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 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
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)
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),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)
Line(t(1).x,t(1).y)-(t(2).x,t(2).y),c1

Line(t(3).x,t(3).y)-(t(4).x,t(4).y),c1

Line(t(5).x,t(5).y)-(t(6).x,t(6).y),c1

Line(t(7).x,t(7).y)-(t(8).x,t(8).y),c1

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)

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)

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)

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)
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
End With
Next n
End Sub

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

construct(ra())
Dim As Long k=1
Do
Screenlock
Cls
For n As Long=1 To Ubound(ra)
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

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

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