Squares

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

Re: Event Horizon

Post by dodicat »

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)[2]*n,Cptr(Ubyte Ptr,@c)[1]*n,Cptr(Ubyte Ptr,@c)[0]*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)
    #define rad(n) (pi/180)*(n)
  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
'steady framerate
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))
             pset i,(x,y),shade(clr,.75)
             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: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Post by Richard »

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

Re: Squares

Post by albert »

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

Re: Squares

Post by albert »

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

Re: Squares

Post by albert »

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

Re: Squares

Post by albert »

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

Re: Squares

Post by albert »

@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[0]
    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[0]
    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: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Post by Richard »

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

Re: Squares

Post by albert »

@Richard

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

Re: Squares

Post by dodicat »

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

Re: Squares

Post by albert »

@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: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Post by Richard »

Albert wrote:How would you reverse it???
You have lost information so you cannot always reverse it.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

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

Re: Squares

Post by albert »

Time Rhyme!!

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

Re: Squares

Post by albert »

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

Locked