Squares

General FreeBASIC programming questions.
dodicat
Posts: 5942
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Event Horizon

Jupiterish.

Code: Select all

type ball
x as single    'position x component
y as single    'position y component
dx as single   'velocity x component
dy as single   'velocity y component
col as uLong   'colour
as Long r,m    'radius, mass
end type

dim shared as any ptr row
dim shared as integer pitch
dim shared as integer xres,yres

#define incircle(cx,cy,r,mx,my,a) _
iif(a<=1,a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= r*r*a*a,a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= (r)*(r))
#define shade(c,n)  rgb(Cptr(Ubyte Ptr,@c)*n,Cptr(Ubyte Ptr,@c)*n,Cptr(Ubyte Ptr,@c)*n)

Function o(c As Ulong) As Ulong 'mono maker
Var v=.299*((c Shr 16)And 255)+.587*((c Shr 8)And 255)+.114*(c And 255)
Return Rgb(v,v,v)
End Function

function dist(b1 as ball,b2 as ball) as single
return sqr((b1.x-b2.x)^2 + (b1.y-b2.y)^2)
end function

function rainbow( x as single ) as ulong 'idea from bluatigro
static as double pi=4*atn(1)
dim as ulong r , g , b
r = sin( rad( x ) ) * 127 + 128
g = sin( rad( x - 120 ) ) * 127 + 128
b = sin( rad( x + 120 ) ) * 127 + 128
return rgb( r and 255 , g and 255 , b and 255 )
end function

sub _circle(b as ball) 'custom
#define onscreen x>=0 and x<xres and y>.0 and y<yres
#define putpixel(_x,_y,colour)    *cptr(ulong ptr,row+ (_y)*pitch+ (_x) shl 2)  =(colour)
dim as ulong tc
for x as long=b.x-b.r to b.x+b.r
for y as long=b.y-b.r to b.y+b.r
if incircle(b.x,b.y,b.r,x,y,1) andalso onscreen then
if incircle(512,768\2,400,x,y,.75)  then tc=b.col else tc=o(b.col)
putpixel(x,y,tc)
end if
next
next
end sub

sub MoveAndDraw( b() as ball,byref e as Long)'get energy also
for n as Long=lbound(b) to ubound(b)
b(n).x+=b(n).dx:b(n).y+=b(n).dy
_circle(b(n))
e+=.5*b(n).m*(b(n).dx*b(n).dx + b(n).dy*b(n).dy)
next n
end sub

sub edges(b() as ball,xres as Long,yres as Long,byref status as Long ) 'get status also
for n as Long=lbound(b) to ubound(b)
if(b(n).x<b(n).r) then b(n).x=b(n).r: b(n).dx=-b(n).dx
if(b(n).x>xres-b(n).r )then b(n).x=xres-b(n).r: b(n).dx=-b(n).dx
if(b(n).y<b(n).r)then b(n).y=b(n).r:b(n).dy=-b(n).dy
if(b(n).y>yres-b(n).r)then  b(n).y=yres-b(n).r:b(n).dy=-b(n).dy
if b(n).x<0 or b(n).x>xres then status=0
if b(n).y<0 or b(n).y>yres then status=0
next n
end sub

Function DetectBallCollisions( B1 As ball,B2 As ball) As single 'avoid using sqr if they are well seperated
Dim As Long xdiff = B2.x-B1.x
Dim As Long ydiff = B2.y-B1.y
If Abs(xdiff) > (B2.r+B1.r) Then Return 0
If Abs(ydiff) > (B2.r+B1.r) Then Return 0
var L=Sqr(xdiff*xdiff+ydiff*ydiff)
If L<=(B2.r+B1.r) Then Function=L else Function=0
End Function

sub BallCollisions(b() as ball)
for n1 as Long=lbound(b) to ubound(b)-1
for n2 as Long=n1+1 to ubound(b)
dim as single  L= DetectBallCollisions(b(n1),b(n2))
if L then
dim as single  impulsex=(b(n1).x-b(n2).x)/L
dim as single  impulsey=(b(n1).y-b(n2).y)/L
'set one ball to nearest non overlap position
b(n1).x=b(n2).x+(b(n2).r+b(n1).r)*impulsex
b(n1).y=b(n2).y+(b(n2).r+b(n1).r)*impulsey

dim as single  impactx=b(n1).dx-b(n2).dx
dim as single  impacty=b(n1).dy-b(n2).dy
dim as single  dot=impactx*impulsex+impacty*impulsey
dim as single  mn2=b(n1).m/(b(n1).m+b(n2).m),mn1=b(n2).m/(b(n1).m+b(n2).m)

b(n1).dx-=dot*impulsex*2*mn1
b(n1).dy-=dot*impulsey*2*mn1
b(n2).dx+=dot*impulsex*2*mn2
b(n2).dy+=dot*impulsey*2*mn2
end if
next n2
next n1
end sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Static As double timervalue,lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function

sub Start()
dim  as ball b(0 to 10)
dim as Long fps,energy,status=1
screen 20,32
row=screenptr
screeninfo xres,yres,,,pitch
dim as any ptr i=imagecreate(xres,yres)
dim as ball p(15)
for n as long=0 to ubound(p)
p(n)=type(rnd*xres,rnd*yres)
next
for y as long=0 to yres
for x as long=0 to xres
if incircle(512,768\2,400,x,y,.75) then
pset i,(x,y),rainbow(x-y)
else
var clr=o(rainbow(x-y))
end if
next
next
randomize 3
for n as Long=lbound(b) to ubound(b)
with b(n)
.x=xres/2
.y=yres/2
.dx=rnd*3-rnd*3
.dy=rnd*3-rnd*3
select case n
case 0:.col=rgb(0,55,55)
case 1:.col=rgb(200,0,0)
case 2:.col=rgb(0,200,0)
case 3:.col=rgb(0,0,200)
case 4:.col=rgb(255,215,0)
case 5:.col=rgb(0,200,200)
case 6:.col=rgb(0,50,255)
case 7:.col=rgb(255,100,0)
case 8:.col=rgb(255,0,255)
case else:.col=rgb(rnd*255,rnd*255,rnd*255)
end select
.r=20+rnd*40
.m=.r^2
end with
next
while 1
energy=0
edges(b(),xres,yres,status)
BallCollisions(b())
screenlock
cls
put(0,0),i,pset

MoveAndDraw(b(),energy)
draw string(50, 10), " Press escape key to end",0
draw string(50, 55), "framerate " &fps ,0
draw string (50,100),"System energy " &energy,0
draw string (50,145),"System stauus " & iif(1,"OK","Leaks"),0
screenunlock

sleep regulate(65, fps)
if inkey=chr(27) then exit while
wend
imagedestroy i
end sub

Start
sleep

Richard
Posts: 2955
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Better energy conservation.

Code: Select all

Function DetectBallCollisions( B1 As ball, B2 As ball) As Single
Dim As Single xdiff2 = B2.x - B1.x : xdiff2 *= xdiff2
Dim As Single ydiff2 = B2.y - B1.y : ydiff2 *= ydiff2
Dim As Single sumR2  = B2.r + B1.r : sumR2  *= sumR2
If xdiff2 > sumR2 Then Return 0  ' fast exits
If ydiff2 > sumR2 Then Return 0  '  avoids call abs()
Dim As Single sos = xdiff2 + ydiff2 ' sum of squares
If sos <= sumR2 Then Return Sqr( sos ) Else Return 0
End Function            ' uses sqr() only if colliding
albert
Posts: 5040
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

@Dodicat

Got compression....Compresses 80+% after 40 loops... I'm working on the decompression...

It steps by 3 bits.

if len = 1 , then it sets both strings to s
if len = 2 , then it sets both strings to s
if len = 3 , then it sets outs1 to "1" and outs2 to mid(s,2)

So , the two strings don't equal each other if len = 3 , otherwise they equal each other.

Should be pretty easy , to write the de-compressor...

Code: Select all

Declare Function   compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

Namespace Zlibrary

#inclib "zlib"
Extern "C"
Declare Function compressBound(Byval sourceLen As Ulong) As Ulong
Declare Function uncompress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
Declare Function compress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
End Extern

Function getpassedinfo(text As String,Byref passed_length As Integer) As String
Dim As String var1,var2
Dim As Integer pst
#macro splice(stri,char,var1,var2)
pst=Instr(stri,char)
var1="":var2=""
If pst<>0 Then
var1=Mid(stri,1,pst-1)
var2=Mid(stri,pst+1)
Else
var1=stri
End If
#endmacro
splice(text,"|",var1,var2)
text=var2
passed_length=Valint(var1)
Return text
End Function

'=================   UNPACK ===============
Function unpack(file As String) As String
Dim As Integer passed_length
Dim As String text=getpassedinfo(file,passed_length)
Dim As Integer stringlength,destinationlength
stringlength=Len(text)
destinationlength =passed_length
Dim As Ubyte Ptr source
Dim As Ubyte Ptr  destination =Callocate(destinationlength,1)
source=@text
Var mistake=uncompress(destination,@destinationlength, source, stringlength)
If mistake<>0 Then Print "There was an error":Sleep:End
Dim As String uncompressed
uncompressed=String(destinationlength,0)
For i As Integer = 0 To destinationlength- 1
uncompressed[i]=(destination[i])
Next
Deallocate destination
Return uncompressed
End Function

'===================  PACK ============
Function pack(file As String) As String
Dim As String text=file
Dim As Integer stringlength,destinationlength
stringlength=Len(text)
destinationlength = compressBound(stringlength)
Dim As Ubyte Ptr source
Dim As Ubyte Ptr destination =Callocate(destinationlength,1)
source=@text
Var mistake=compress(destination, @destinationlength, source, stringlength)
If mistake <>0 Then Print "There was an error"
Dim As String compressed
compressed=String(destinationlength,0)
For n As Integer=0 To destinationlength-1
compressed[n]=destination[n]
Next n
compressed=stringlength &"|"+compressed
Deallocate destination
Return compressed
End Function

End Namespace

'==================================================================
'==================================================================
'test zipper
'==================================================================
'==================================================================
screen 19

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
do

loops+=1

'one time run , create initial string
if loops = 1 then
For n As Long = 1 To 10000
s+=chr(Int(Rnd*256))'+48
Next
compare =  s
length = len(s)
else
'modify compression to make further compression possible

s = compress_loop(s)

end if
check = s
compression = (100 - ( 100 / ( length / len(check) ) ))

Print "original string"
Print Len(s)
Print

Dim As String compressed=Zlibrary.pack(s)
s = compressed

Print "packed string "
Print Len(compressed)
Print

Dim As String uncompressed=Zlibrary.unpack(compressed)

Print "Retrieve"
Print Len(uncompressed)
Print
'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
Print Iif(uncompressed=check,"OK","ERROR")
Print "-------------------------------"

'sleep 1000

'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do

print "press a key for next compression." ; " loops = " ; loops ; " out of 40."
print
print "press esc to exit."
'sleep

if inkey = chr(27) then exit do

loop until loops = 40

print "Press a key to decompress."
sleep

s = str(loops) + "_" + s ' save as an output file...

'==================================================================
'decompress
'==================================================================
dim as longint dec = instr(1,s,"_")
dim as longint count = val(left(s,dec-1))
dim as string comp = mid(s,dec+1)
dim as string val1
dim as string outs
for a as longint = count to 2 step -1
s = Zlibrary.unpack(comp)
outs = decompress_loop(s)
comp = outs
next

comp = Zlibrary.unpack(comp)

print
print "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
print
if comp = compare then print "Decompression successful." else print "ERROR"
print
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'================='==============================================================
Function compress_loop( chrs as string ) as string

dim as string bits=""
dim as string zeros = string(8,"0")
dim as ulongint n1
for a as longint = 0 to len(chrs)-1 step 1
n1 = chrs[a]
bits+=right(zeros+bin(n1),8)
next

print "c inp = " ; len(bits)

dim as string outs1=""
dim as string outs2=""
dim as string s
for a as longint = 1 to len(bits) step 3

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+= s : outs2+= s
if len(s) = 2 then outs1+= s : outs2+= s
if len(s) = 3 then outs1+= "1" : outs2+= mid(s,2)

'print s
'print outs1
'print outs2
'sleep
'if inkey=" " then end

next

print
print "c out 1 = " ; len(outs1)
print "c out 2 = " ; len(outs2)

dim as string final_out = ""
for a as longint = 1 to len(outs1) step 8
final_out+=chr(valulng("&B"+mid(outs1,a,8)))
next
final_out+="END"
for a as longint = 1 to len(outs2) step 8
final_out+=chr(valulng("&B"+mid(outs2,a,8)))
next

print "c fin =  "; len(final_out) ' , final

return final_out

end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string

return chrs

end function

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

Re: Squares

@Dodicat

I modified it so that both output strings , are the same length... It should make it easier to decompress..

Compresses 10,000 78+% after 50 loops...
Compresses 100,000 94+% after 50 loops...
Compresses 1,000,000 98+% after 50 loops...

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+= s : outs2+= s
if len(s) = 2 then outs1+= left(s,1) : outs2+= right(s,1)
if len(s) = 3 then outs1+= left(s,2) : outs2+= "0" + right(s,1)

Code: Select all

Declare Function   compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

Namespace Zlibrary

#inclib "zlib"
Extern "C"
Declare Function compressBound(Byval sourceLen As Ulong) As Ulong
Declare Function uncompress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
Declare Function compress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
End Extern

Function getpassedinfo(text As String,Byref passed_length As Integer) As String
Dim As String var1,var2
Dim As Integer pst
#macro splice(stri,char,var1,var2)
pst=Instr(stri,char)
var1="":var2=""
If pst<>0 Then
var1=Mid(stri,1,pst-1)
var2=Mid(stri,pst+1)
Else
var1=stri
End If
#endmacro
splice(text,"|",var1,var2)
text=var2
passed_length=Valint(var1)
Return text
End Function

'=================   UNPACK ===============
Function unpack(file As String) As String
Dim As Integer passed_length
Dim As String text=getpassedinfo(file,passed_length)
Dim As Integer stringlength,destinationlength
stringlength=Len(text)
destinationlength =passed_length
Dim As Ubyte Ptr source
Dim As Ubyte Ptr  destination =Callocate(destinationlength,1)
source=@text
Var mistake=uncompress(destination,@destinationlength, source, stringlength)
If mistake<>0 Then Print "There was an error":Sleep:End
Dim As String uncompressed
uncompressed=String(destinationlength,0)
For i As Integer = 0 To destinationlength- 1
uncompressed[i]=(destination[i])
Next
Deallocate destination
Return uncompressed
End Function

'===================  PACK ============
Function pack(file As String) As String
Dim As String text=file
Dim As Integer stringlength,destinationlength
stringlength=Len(text)
destinationlength = compressBound(stringlength)
Dim As Ubyte Ptr source
Dim As Ubyte Ptr destination =Callocate(destinationlength,1)
source=@text
Var mistake=compress(destination, @destinationlength, source, stringlength)
If mistake <>0 Then Print "There was an error"
Dim As String compressed
compressed=String(destinationlength,0)
For n As Integer=0 To destinationlength-1
compressed[n]=destination[n]
Next n
compressed=stringlength &"|"+compressed
Deallocate destination
Return compressed
End Function

End Namespace

'==================================================================
'==================================================================
'test zipper
'==================================================================
'==================================================================
screen 19

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
do

loops+=1

'one time run , create initial string
if loops = 1 then
For n As Long = 1 To 10000
s+=chr(Int(Rnd*256))'+48
Next
compare =  s
length = len(s)
else
'modify compression to make further compression possible

s = compress_loop(s)

end if
check = s
compression = (100 - ( 100 / ( length / len(check) ) ))

Print "original string"
Print Len(s)
Print

Dim As String compressed=Zlibrary.pack(s)
s = compressed

Print "packed string "
Print Len(compressed)
Print

Dim As String uncompressed=Zlibrary.unpack(compressed)

Print "Retrieve"
Print Len(uncompressed)
Print
'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
Print Iif(uncompressed=check,"OK","ERROR")
Print "-------------------------------"

'sleep 1000

'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do

print "press a key for next compression." ; " loops = " ; loops ; " out of 50."
print
print "press esc to exit."
'sleep

if inkey = chr(27) then exit do

loop until loops = 50

print "Press a key to decompress."
sleep

s = str(loops) + "_" + s ' save as an output file...

'==================================================================
'decompress
'==================================================================
dim as longint dec = instr(1,s,"_")
dim as longint count = val(left(s,dec-1))
dim as string comp = mid(s,dec+1)
dim as string val1
dim as string outs
for a as longint = count to 2 step -1
s = Zlibrary.unpack(comp)
outs = decompress_loop(s)
comp = outs
next

comp = Zlibrary.unpack(comp)

print
print "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
print
if comp = compare then print "Decompression successful." else print "ERROR"
print
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'================='==============================================================
Function compress_loop( chrs as string ) as string

dim as string bits=""
dim as string zeros = string(8,"0")
dim as ulongint n1
for a as longint = 0 to len(chrs)-1 step 1
n1 = chrs[a]
bits+=right(zeros+bin(n1),8)
next

print "c inp = " ; len(bits)

dim as string outs1=""
dim as string outs2=""
dim as string s
for a as longint = 1 to len(bits) step 3

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+= s    : outs2+= s
if len(s) = 2 then outs1+= left(s,1) : outs2+= right(s,1)
if len(s) = 3 then outs1+= left(s,2) : outs2+= "0" + right(s,1)

'print s
'print outs1
'print outs2
'sleep
'if inkey=" " then end

next

print
print "c out 1 = " ; len(outs1)
print "c out 2 = " ; len(outs2)

dim as string final_out = ""
for a as longint = 1 to len(outs1) step 8
final_out+=chr(valulng("&B"+mid(outs1,a,8)))
next
final_out+="END"
for a as longint = 1 to len(outs2) step 8
final_out+=chr(valulng("&B"+mid(outs2,a,8)))
next

print "c fin =  "; len(final_out) ' , final

return final_out

end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string

return chrs

end function

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

Re: Squares

@Dodicat

While writing the de-compressor i ran into a snafu , you can't tell one from the other...So i modified it again..

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+= s : outs2+= "0"
if len(s) = 2 then outs1+= right(s,1) : outs2+= "1"
if len(s) = 3 then outs1+= right(s,2) : outs2+= "00"

Now you can search for the "1"'s , and then you have to figure the "0" verses the "00".

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

Namespace Zlibrary

#inclib "zlib"
Extern "C"
Declare Function compressBound(Byval sourceLen As Ulong) As Ulong
Declare Function uncompress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
Declare Function compress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
End Extern

Function getpassedinfo(text As String,Byref passed_length As Integer) As String
Dim As String var1,var2
Dim As Integer pst
#macro splice(stri,char,var1,var2)
pst=Instr(stri,char)
var1="":var2=""
If pst<>0 Then
var1=Mid(stri,1,pst-1)
var2=Mid(stri,pst+1)
Else
var1=stri
End If
#endmacro
splice(text,"|",var1,var2)
text=var2
passed_length=Valint(var1)
Return text
End Function

'=================   UNPACK ===============
Function unpack(file As String) As String
Dim As Integer passed_length
Dim As String text=getpassedinfo(file,passed_length)
Dim As Integer stringlength,destinationlength
stringlength=Len(text)
destinationlength =passed_length
Dim As Ubyte Ptr source
Dim As Ubyte Ptr  destination =Callocate(destinationlength,1)
source=@text
Var mistake=uncompress(destination,@destinationlength, source, stringlength)
If mistake<>0 Then Print "There was an error":Sleep:End
Dim As String uncompressed
uncompressed=String(destinationlength,0)
For i As Integer = 0 To destinationlength- 1
uncompressed[i]=(destination[i])
Next
Deallocate destination
Return uncompressed
End Function

'===================  PACK ============
Function pack(file As String) As String
Dim As String text=file
Dim As Integer stringlength,destinationlength
stringlength=Len(text)
destinationlength = compressBound(stringlength)
Dim As Ubyte Ptr source
Dim As Ubyte Ptr destination =Callocate(destinationlength,1)
source=@text
Var mistake=compress(destination, @destinationlength, source, stringlength)
If mistake <>0 Then Print "There was an error"
Dim As String compressed
compressed=String(destinationlength,0)
For n As Integer=0 To destinationlength-1
compressed[n]=destination[n]
Next n
compressed=stringlength &"|"+compressed
Deallocate destination
Return compressed
End Function

End Namespace

'==================================================================
'==================================================================
'test zipper
'==================================================================
'==================================================================
screen 19

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
do

loops+=1

'one time run , create initial string
if loops = 1 then
For n As Long = 1 To 10000
s+=chr(Int(Rnd*256))'+48
Next
compare =  s
length = len(s)
else
'modify compression to make further compression possible

s = compress_loop(s)

end if
check = s
compression = (100 - ( 100 / ( length / len(check) ) ))

Print "original string"
Print Len(s)
Print

Dim As String compressed=Zlibrary.pack(s)
s = compressed

Print "packed string "
Print Len(compressed)
Print

Dim As String uncompressed=Zlibrary.unpack(compressed)

Print "Retrieve"
Print Len(uncompressed)
Print
'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
Print Iif(uncompressed=check,"OK","ERROR")
Print "-------------------------------"

'sleep 1000

'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do

print "press a key for next compression." ; " loops = " ; loops ; " out of 40."
print
print "press esc to exit."
'sleep

if inkey = chr(27) then exit do

loop until loops = 40

print "Press a key to decompress."
sleep

s = str(loops) + "_" + s ' save as an output file...

'==================================================================
'decompress
'==================================================================
dim as longint dec = instr(1,s,"_")
dim as longint count = val(left(s,dec-1))
dim as string comp = mid(s,dec+1)
dim as string val1
dim as string outs
for a as longint = count to 2 step -1
s = Zlibrary.unpack(comp)
outs = decompress_loop(s)
comp = outs
next

comp = Zlibrary.unpack(comp)

print
print "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
print
if comp = compare then print "Decompression successful." else print "ERROR"
print
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'================='==============================================================
Function compress_loop( chrs as string ) as string

dim as string bits=""
dim as string zeros = string(8,"0")
dim as ulongint n1
for a as longint = 0 to len(chrs)-1 step 1
n1 = chrs[a]
bits+=right(zeros+bin(n1),8)
next

print "c inp = " ; len(bits)

dim as string outs1=""
dim as string outs2=""
dim as string s
for a as longint = 1 to len(bits) step 3

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+= s : outs2+= "0"
if len(s) = 2 then outs1+= right(s,1) : outs2+= "1"
if len(s) = 3 then outs1+= right(s,2) : outs2+= "00"

'print
'print mid(bits,a,3)
'print outs1
'print outs2
'sleep
'if inkey=" " then end

next

print
print "c out 1 = " ; len(outs1)
print "c out 2 = " ; len(outs2)

dim as string final_out = ""
for a as longint = 1 to len(outs1) step 8
final_out+=chr(valulng("&B"+mid(outs1,a,8)))
next
final_out+="END"
for a as longint = 1 to len(outs2) step 8
final_out+=chr(valulng("&B"+mid(outs2,a,8)))
next

print "c fin =  "; len(final_out) ' , final

return final_out

end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string

return chrs

end function

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

Re: Squares

@Dodicat

I came up with an idea for corporate board members...
Companies have between 7 and 31 board members..

So you split the screen into 4 , 8, 16 ,32 video squares.

Kinda like Skype...But each member has their own square on the screen..
Then they can have board meetings without gathering together around a table..

The chairman of the board would have the biggest square , in the center of the screen..
Then the board members would each have a given square around the chairman square, with their name on the bottom of their square.
Each members square , would be assigned to a given DNS : IP

If they're not online then the square would be dark...
albert
Posts: 5040
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

@Dodicat

I modified the compressor again...Ran into another snafu , can't tell one form the next...

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+= "0" + s
if len(s) = 2 then outs1+= "0" + s
if len(s) = 3 then outs1+= s

I tried to make all outputs 3 bits.... But if len(s) = 1 then outs1+= "00" + s , doesn't compress..So i had to make it "0" + s

So if you run into a "00" or a "01" then you have to put a "0" in front of it....

Code: Select all

Declare Function   compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

Namespace Zlibrary

#inclib "zlib"
Extern "C"
Declare Function compressBound(Byval sourceLen As Ulong) As Ulong
Declare Function uncompress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
Declare Function compress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
End Extern

Function getpassedinfo(text As String,Byref passed_length As Integer) As String
Dim As String var1,var2
Dim As Integer pst
#macro splice(stri,char,var1,var2)
pst=Instr(stri,char)
var1="":var2=""
If pst<>0 Then
var1=Mid(stri,1,pst-1)
var2=Mid(stri,pst+1)
Else
var1=stri
End If
#endmacro
splice(text,"|",var1,var2)
text=var2
passed_length=Valint(var1)
Return text
End Function

'=================   UNPACK ===============
Function unpack(file As String) As String
Dim As Integer passed_length
Dim As String text=getpassedinfo(file,passed_length)
Dim As Integer stringlength,destinationlength
stringlength=Len(text)
destinationlength =passed_length
Dim As Ubyte Ptr source
Dim As Ubyte Ptr  destination =Callocate(destinationlength,1)
source=@text
Var mistake=uncompress(destination,@destinationlength, source, stringlength)
If mistake<>0 Then Print "There was an error":Sleep:End
Dim As String uncompressed
uncompressed=String(destinationlength,0)
For i As Integer = 0 To destinationlength- 1
uncompressed[i]=(destination[i])
Next
Deallocate destination
Return uncompressed
End Function

'===================  PACK ============
Function pack(file As String) As String
Dim As String text=file
Dim As Integer stringlength,destinationlength
stringlength=Len(text)
destinationlength = compressBound(stringlength)
Dim As Ubyte Ptr source
Dim As Ubyte Ptr destination =Callocate(destinationlength,1)
source=@text
Var mistake=compress(destination, @destinationlength, source, stringlength)
If mistake <>0 Then Print "There was an error"
Dim As String compressed
compressed=String(destinationlength,0)
For n As Integer=0 To destinationlength-1
compressed[n]=destination[n]
Next n
compressed=stringlength &"|"+compressed
Deallocate destination
Return compressed
End Function

End Namespace

'==================================================================
'==================================================================
'test zipper
'==================================================================
'==================================================================
screen 19

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
do

loops+=1

'one time run , create initial string
if loops = 1 then
For n As Long = 1 To 10000
s+=chr(Int(Rnd*256))'+48
Next
compare =  s
length = len(s)
else
'modify compression to make further compression possible

s = compress_loop(s)

end if
check = s
compression = (100 - ( 100 / ( length / len(check) ) ))

Print "original string"
Print Len(s)
Print

Dim As String compressed=Zlibrary.pack(s)
s = compressed

Print "packed string "
Print Len(compressed)
Print

Dim As String uncompressed=Zlibrary.unpack(compressed)

Print "Retrieve"
Print Len(uncompressed)
Print
'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
Print Iif(uncompressed=check,"OK","ERROR")
Print "-------------------------------"

'sleep 1000

'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do

print "press a key for next compression." ; " loops = " ; loops ; " out of 40."
print
print "press esc to exit."
'sleep

if inkey = chr(27) then exit do

loop until loops = 40

print "Press a key to decompress."
sleep

s = str(loops) + "_" + s ' save as an output file...

'==================================================================
'decompress
'==================================================================
dim as longint dec = instr(1,s,"_")
dim as longint count = val(left(s,dec-1))
dim as string comp = mid(s,dec+1)
dim as string val1
dim as string outs
for a as longint = count to 2 step -1
s = Zlibrary.unpack(comp)
outs = decompress_loop(s)
comp = outs
next

comp = Zlibrary.unpack(comp)

print
print "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
print
if comp = compare then print "Decompression successful." else print "ERROR"
print
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'================='==============================================================
Function compress_loop( chrs as string ) as string

dim as string bits=""
dim as string zeros = string(8,"0")
dim as ulongint n1
for a as longint = 0 to len(chrs)-1 step 1
n1 = chrs[a]
bits+=right(zeros+bin(n1),8)
next

print "c inp = " ; len(bits) ', bits

dim as string outs1=""
dim as string s
for a as longint = 1 to len(bits) step 3

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+=  "0" + s
if len(s) = 2 then outs1+=  "0" + s
if len(s) = 3 then outs1+=  s

'print s
'print outs1
'print outs2
'sleep
'if inkey=" " then end

next

print "c out = " ; len(outs1) ', outs1

dim as longint count=0
dim as string str1
dim as longint dec1
do
str1=str(len(outs1)/8)
dec1=instr(1,str1,".")
if dec1<>0 then outs1+="0" : count+=1
loop until dec1=0

dim as string final_out = ""
for a as longint = 1 to len(outs1) step 8
final_out+=chr(valulng("&B"+mid(outs1,a,8)))
next

final_out = chr(count) + final_out

print "c fin = "; len(final_out) ' , final

return final_out

end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string

dim as longint count = asc(left(chrs,1))

chrs = mid(chrs,2)

dim as string bits=""
dim as string zeros = string(8,"0")
dim as ulongint n1
for a as longint = 0 to len(chrs)-1 step 1
n1 = chrs[a]
bits+=right(zeros+bin(n1),8)
next

bits = left(bits,len(bits)-count)

'print "d inp = " ; len(bits) , bits

return chrs

end function

Richard
Posts: 2955
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Albert wrote:I came up with an idea for corporate board members...
Companies have between 7 and 31 board members..

I believe "The Peter Principle", 1969, demonstrated that having more than 7 members on a board or committee makes it unmanageable and unproductive.
https://en.wikipedia.org/wiki/Peter_principle
albert
Posts: 5040
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

@Richard

I just googled "How many board members in a company".. It replied 7 to 31..
dodicat
Posts: 5942
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

The Peter Principle only mentions promotion.
It has completely missed the concept of demotion, and the fact that promotion in the demotion direction acts faster than the other way round, so there is no need to be incompetent for long.
albert
Posts: 5040
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

@Richard
@Dodicat

dim as single s1
for a as longint = 0 to len( chrs )-1 step 1
s1 = chrs[a] / 2
if frac(s1) = 0 then if s1 mod 2 = 0 then chrs[a] / = 2
next

How would you reverse it???
Richard
Posts: 2955
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Albert wrote:How would you reverse it???

You have lost information so you cannot always reverse it.
albert
Posts: 5040
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

I got compression without Zlib...

The problem is ; how to differentiate 3 bits values , from 4 bit values.

Code: Select all

Declare Function      compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19

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))'+8)
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
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string

dim as string bits = ""
dim as string zeros = string(64,"0")
dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
dim as string n1
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

dim as string outs1=""
dim as string s1
for a as longint = 1 to len(bits) step 4

s1 = mid(bits,a,4)

if s1 = "0000" then outs1+="001"
if s1 = "0001" then outs1+="010"
if s1 = "0010" then outs1+="011"
if s1 = "0011" then outs1+="100"
if s1 = "0100" then outs1+="101"
if s1 = "0101" then outs1+="110"
if s1 = "0110" then outs1+="111"

if s1 = "0111" then outs1+="0000"
if s1 = "1000" then outs1+="0001"
if s1 = "1001" then outs1+="0010"
if s1 = "1010" then outs1+="0011"
if s1 = "1011" then outs1+="0100"
if s1 = "1100" then outs1+="0101"
if s1 = "1101" then outs1+="0110"
if s1 = "1110" then outs1+="0111"

if s1 = "1111" then outs1+="1000"

next

print "c out = "; len(outs1) , outs1

dim as longint count=0
dim as string str1
dim as longint dec1
do
str1=str(len(outs1)/8)
dec1=instr(1,str1,".")
if dec1<>0 then outs1+="0" : count+=1
loop until dec1=0

dim as string final = ""
for a as longint = 1 to len(outs1) step 8
final+=chr(val("&B"+mid(outs1,a,8)))
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 longint count = asc(left(chrs,1))
chrs = mid(chrs,2)

dim as string bits = ""
dim as string zeros = string(8,"0")
dim as string n1
for a as longint = 1 to len(chrs) step 1
n1 = zeros + bin( chrs[a-1] )
bits+=right(n1,8)
next

bits = left(bits,len(bits)-count)

print "d inp = "; len(bits) , bits

return chrs

end function

Its worth working it out... figuring a way to tell 3 bit vals from 4 bit vals...
Here it is doing 1,000,000 bytes... it compresses down to 2 digits...

Code: Select all

Declare Function      compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19

dim as double time1 , time2 , time3 , time4
do

randomize

dim as string s=""
For n As Long = 1 To 1000000
s+=chr(Int(Rnd*256))'+8)
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
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string

dim as string bits = ""
dim as string zeros = string(64,"0")
dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
dim as string n1
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

dim as string outs1=""
dim as string s1
for a as longint = 1 to len(bits) step 4

s1 = mid(bits,a,4)

if s1 = "0000" then outs1+="001"
if s1 = "0001" then outs1+="010"
if s1 = "0010" then outs1+="011"
if s1 = "0011" then outs1+="100"
if s1 = "0100" then outs1+="101"
if s1 = "0101" then outs1+="110"
if s1 = "0110" then outs1+="111"

if s1 = "0111" then outs1+="0000"
if s1 = "1000" then outs1+="0001"
if s1 = "1001" then outs1+="0010"
if s1 = "1010" then outs1+="0011"
if s1 = "1011" then outs1+="0100"
if s1 = "1100" then outs1+="0101"
if s1 = "1101" then outs1+="0110"
if s1 = "1110" then outs1+="0111"

if s1 = "1111" then outs1+="1000"

next

'print "c out = "; len(outs1) , outs1

dim as longint count=0
dim as string str1
dim as longint dec1
do
str1=str(len(outs1)/8)
dec1=instr(1,str1,".")
if dec1<>0 then outs1+="0" : count+=1
loop until dec1=0

dim as string final = ""
for a as longint = 1 to len(outs1) step 8
final+=chr(val("&B"+mid(outs1,a,8)))
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 longint count = asc(left(chrs,1))
chrs = mid(chrs,2)

dim as string bits = ""
dim as string zeros = string(8,"0")
dim as string n1
for a as longint = 1 to len(chrs) step 1
n1 = zeros + bin( chrs[a-1] )
bits+=right(n1,8)
next

bits = left(bits,len(bits)-count)

'print "d inp = "; len(bits) , bits

return chrs

end function

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

Re: Squares

Time Rhyme!!

5:03 hive yo bee
albert
Posts: 5040
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

I altered the compressor above....
Now it should be easier to identify the 3 bit vals form the 4 bit vals..

Compresses 1,000,000 bytes , down to ; between 120 bytes and 90 bytes..

s1 = mid(bits,a,4)

if s1 = "0000" then outs1+="100"
if s1 = "0001" then outs1+="101"
if s1 = "0010" then outs1+="110"
if s1 = "0011" then outs1+="111"
if s1 = "0100" then outs1+="1000"
if s1 = "0101" then outs1+="1001"
if s1 = "0110" then outs1+="1010"

if s1 = "0111" then outs1+="0000"
if s1 = "1000" then outs1+="0001"
if s1 = "1001" then outs1+="0010"
if s1 = "1010" then outs1+="0011"
if s1 = "1011" then outs1+="0100"
if s1 = "1100" then outs1+="0101"
if s1 = "1101" then outs1+="0110"
if s1 = "1110" then outs1+="0111"

if s1 = "1111" then outs1+="1100"

Code: Select all

Declare Function      compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19

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))'+8)
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
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string

dim as string bits = ""
dim as string zeros = string(64,"0")
dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
dim as string n1
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

dim as string outs1=""
dim as string s1
for a as longint = 1 to len(bits) step 4

s1 = mid(bits,a,4)

if s1 = "0000" then outs1+="100"
if s1 = "0001" then outs1+="101"
if s1 = "0010" then outs1+="110"
if s1 = "0011" then outs1+="111"
if s1 = "0100" then outs1+="1000"
if s1 = "0101" then outs1+="1001"
if s1 = "0110" then outs1+="1010"

if s1 = "0111" then outs1+="0000"
if s1 = "1000" then outs1+="0001"
if s1 = "1001" then outs1+="0010"
if s1 = "1010" then outs1+="0011"
if s1 = "1011" then outs1+="0100"
if s1 = "1100" then outs1+="0101"
if s1 = "1101" then outs1+="0110"
if s1 = "1110" then outs1+="0111"

if s1 = "1111" then outs1+="1100"

next

print "c out = "; len(outs1) , outs1

dim as longint count=0
dim as string str1
dim as longint dec1
do
str1=str(len(outs1)/8)
dec1=instr(1,str1,".")
if dec1<>0 then outs1+="0" : count+=1
loop until dec1=0

dim as string final = ""
for a as longint = 1 to len(outs1) step 8
final+=chr(val("&B"+mid(outs1,a,8)))
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 longint count = asc(left(chrs,1))
chrs = mid(chrs,2)

dim as string bits = ""
dim as string zeros = string(8,"0")
dim as string n1
for a as longint = 1 to len(chrs) step 1
n1 = zeros + bin( chrs[a-1] )
bits+=right(n1,8)
next

bits = left(bits,len(bits)-count)

print "d inp = "; len(bits) , bits

return chrs

end function