Squares

[albert]

@Dodicat

I hard wired the 28 "11110000" , and 28 "10111011" combos..

It's sometimes decompressing okay.. And sometimes not... Got to trouble shoot it some more..


Here's the "Test Bed" where i try 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

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    randomize
   
    dim as string s = ""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))
    Next
   
    time1=timer
    'begin compress
        dim as string comp = s
            'do
            '    dim as longint chk = len(comp) - 1
            '    comp = compress_loop(comp)
            '    if len(comp) >= chk then exit do
            'loop
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    print "inp = " ; (s)
    print string(99,"=")
    print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
    
    dim as ubyte in_count = 0
    dim as string str1
    dim as ubyte dec1
    do
        str1 = str( len( chrs ) / 8 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then chrs+= chr(0) : in_count+=1
    loop until dec1 = 0
    
    dim as string bits = ""
    dim as string zeros = string( 64 , "0" )
    dim as string n1
    dim as ulongint ptr usp = cptr( ulongint ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 8
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 64 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) , bits
    
    dim as ubyte bit_count = 0
    do
        str1 = str( len( bits ) / 6 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then bits+= "0" : bit_count+=1
    loop until dec1 = 0
   
    dim as string outs1 = ""
    dim as string * 8 vals
    dim as ubyte v1 , v2
    dim as ubyte ptr ubp 
    for a as longint = 1 to len( bits ) step 6
           
        n1 = mid( bits , a , 6 )
       
        v1 = val( "&B" + mid( n1 , 1 , 3 ) )
        v2 = val( "&B" + mid( n1 , 4 , 3 ) )
        
        'SET 2 BITS
        if v1 < v2 then
            vals = "11110000"
            ubp = cptr( ubyte ptr , strptr( vals ) )
            if *( ubp + v1 ) = 48 then *( ubp + v1 ) = 49 else *( ubp + v1 ) = 48
            if *( ubp + v2 ) = 48 then *( ubp + v2 ) = 49 else *( ubp + v2 ) = 48
        end if
        
        'SET 1 BIT
        if v1 = v2 then
            vals = "00000000"
            ubp = cptr( ubyte ptr , strptr( vals ) )
             *( ubp + v1 ) = 49
        end if
        
        'SET 2 BITS
        if v1 > v2 then
            vals = "10111011"
            ubp = cptr( ubyte ptr , strptr( vals ) )
            if *( ubp + v1 ) = 48 then *( ubp + v1 ) = 49 else *( ubp + v1 ) = 48
            if *( ubp + v2 ) = 48 then *( ubp + v2 ) = 49 else *( ubp + v2 ) = 48
        end if
       
        outs1+= vals
        
        'print n1 , v1 , v2 , vals
        'sleep
        'if inkey = " " then end
       
    next
   
    print "c out = " ; len(outs1) , outs1
    
    dim as ubyte out_count = 0
    do
        str1 = str( len( outs1 ) / 64 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then outs1+= "0" : out_count+=1
    loop until dec1 = 0
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 64
        final+= mklongint( valulng( "&B" + mid( outs1 , a , 64 ) ) )
    next
    
    final = chr( in_count ) + chr( bit_count) + chr( out_count ) + final
    
    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
    
    print "dc inp = " ; len(chrs)
    
    dim as ubyte in_count = asc( left( chrs , 1 ) ) : chrs = mid( chrs , 2 )
    dim as ubyte bit_count = asc( left( chrs , 1 ) ) : chrs = mid( chrs , 2 )
    dim as ubyte out_count = asc( left( chrs , 1 ) ) : chrs = mid( chrs , 2 )
   
    dim as string bits = ""
    dim as string zeros = string( 64 , "0" )
    dim as string n1
    dim as ulongint ptr usp = cptr( ulongint ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 8
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 64)
        bits+= n1
    next
    
    bits = left( bits , len( bits ) - out_count )
    
    print "d bin = " ; len(bits) , bits
    
    dim as string outs1 = ""
    dim as string * 8 vals
    dim as ubyte v1 , v2
    for a as longint = 1 to len( bits ) step 8
            
            vals = mid( bits , a , 8 )

            'FOR  "00000000" ( V1 = V2 )
            
            if vals = "00000001" then v1 =  7 : v2 = 7
            if vals = "00000010" then v1 =  6 : v2 = 6
            if vals = "00000100" then v1 =  5 : v2 = 5
            if vals = "00001000" then v1 =  4 : v2 = 4
            if vals = "00010000" then v1 =  3 : v2 = 3
            if vals = "00100000" then v1 =  2 : v2 = 2
            if vals = "01000000" then v1 =  1 : v2 = 1
            if vals = "10000000" then v1 =  0 : v2 = 0
            
            
            'FOR "11110000" ( V1 < V2 )
            
            if vals = "11110011" then v1 =  6 : v2 = 7
            
            if vals = "11110101" then v1 =  5 : v2 = 7
            if vals = "11110110" then v1 =  5 : v2 = 6
            
            if vals = "11111001" then v1 =  4 : v2 = 7
            if vals = "11111010" then v1 =  4 : v2 = 6
            if vals = "11111100" then v1 =  4 : v2 = 5
            
            if vals = "11100001" then v1 =  3 : v2 = 7
            if vals = "11100010" then v1 =  3 : v2 = 6
            if vals = "11100100" then v1 =  3 : v2 = 5
            if vals = "11101000" then v1 =  3 : v2 = 4
            
            if vals = "11010001" then v1 =  2 : v2 = 7
            if vals = "11010010" then v1 =  2 : v2 = 6
            if vals = "11010100" then v1 =  2 : v2 = 5
            if vals = "11011000" then v1 =  2 : v2 = 4
            if vals = "11000000" then v1 =  2 : v2 = 3
            
            if vals = "10110001" then v1 =  1 : v2 = 7
            if vals = "10110010" then v1 =  1 : v2 = 6
            if vals = "10110100" then v1 =  1 : v2 = 5
            if vals = "10111000" then v1 =  1 : v2 = 4
            if vals = "10100000" then v1 =  1 : v2 = 3
            if vals = "10010000" then v1 =  1 : v2 = 2
            
            if vals = "01110001" then v1 =  0 : v2 = 7
            if vals = "01110010" then v1 =  0 : v2 = 6
            if vals = "01110100" then v1 =  0 : v2 = 5
            if vals = "01111000" then v1 =  0 : v2 = 4
            if vals = "01100000" then v1 =  0 : v2 = 3
            if vals = "01010000" then v1 =  0 : v2 = 2
            if vals = "00110000" then v1 =  0 : v2 = 1
            
            'FOR "10111011" ( V1 < V2 )
            
            if vals = "10111000" then v1 =  7 : v2 = 6
            
            if vals = "10111110" then v1 =  7 : v2 = 5
            if vals = "10111101" then v1 =  6 : v2 = 5
            
            if vals = "10110010" then v1 =  7 : v2 = 4
            if vals = "10110001" then v1 =  6 : v2 = 4
            if vals = "10110111" then v1 =  5 : v2 = 4
            
            if vals = "10101010" then v1 =  7 : v2 = 3
            if vals = "10101001" then v1 =  6 : v2 = 3
            if vals = "10101111" then v1 =  5 : v2 = 3
            if vals = "10100011" then v1 =  4 : v2 = 3
            
            if vals = "10011010" then v1 =  7 : v2 = 2
            if vals = "10011001" then v1 =  6 : v2 = 2
            if vals = "10011111" then v1 =  5 : v2 = 2
            if vals = "10010011" then v1 =  4 : v2 = 2
            if vals = "10001011" then v1 =  3 : v2 = 2
            
            if vals = "11111010" then v1 =  7 : v2 = 1
            if vals = "11111001" then v1 =  6 : v2 = 1
            if vals = "11111111" then v1 =  5 : v2 = 1
            if vals = "11110011" then v1 =  4 : v2 = 1
            if vals = "11101011" then v1 =  3 : v2 = 1
            if vals = "11011011" then v1 =  2 : v2 = 1
            
            if vals = "00111010" then v1 =  7 : v2 = 0
            if vals = "00111001" then v1 =  6 : v2 = 0
            if vals = "00111111" then v1 =  5 : v2 = 0
            if vals = "00110011" then v1 =  4 : v2 = 0
            if vals = "00101011" then v1 =  3 : v2 = 0
            if vals = "00011011" then v1 =  2 : v2 = 0
            if vals = "01111011" then v1 =  1 : v2 = 0
            
            outs1+= right("000" + bin( v1 ) , 3 ) + right( "000" + bin( v2 ) , 3 )
    
    next
    
    outs1 = left( outs1 , len( outs1 ) - bit_count )
    
    print "d out = " ; len(outs1) , outs1
    
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 64
        final+= mklongint( valulng( "&B" + mid( outs1 , a , 64 ) ) )
    next
    
    final = left( final , len( final ) - in_count )
    
    print "d fin = " ; len(final)
    
    return final
    
   
end function

[albert]

@Dodicat

It seems there are some duplicates....

I wrote a program to output the values and check for duplicates...

I'll have to play with Yah-Zip a little , to correct it..

Code: Select all

screen 19

dim as longint size = 8
dim as string bits( 0 to size )
dim as string bins

for a as longint = 0 to ( 2 ^ size ) - 1
    
    bins = right( string( size , "0" ) + bin( a ) , size )
    
    dim as ubyte count = 0
    for b as longint = 0 to ( size - 1 )
        if bins[ b ] = 49 then count+= 1
    next
    
    bits( count )+= right( string( 8 , "0" ) + bin( a ) , 8 )
    
next

for a as longint = lbound(bits) to ubound(bits)
    print "bits = " ; a , len( bits( a ) ) / 8 ' , bits(a)
next

dim as string two( 1 to 28 )
dim as longint ele = 1

print
print "Check for duplicates.."
print

dim as string check( 1 to 28 )
'open "v1_grtr.txt" for output as #1
'open "v1_less.txt" for output as #2
    dim as longint v1 , v2
    for a as longint = 1 to len( bits( 2 ) ) step 8
        
        two( ele ) = mid( bits( 2 ) , a , 8 ) : ele+= 1
        
        v1 = instr( 1 , two( ele - 1 ) , "1" )
        v2 = instr( v1+1 , two( ele - 1 ) , "1" )
        
        dim as string vals1 = "11110000"
        
        if mid( vals1 , v1 , 1 ) = "0" then mid( vals1 , v1 , 1 ) = "1" else mid( vals1 , v1 , 1 ) = "0"
        if mid( vals1 , v2 , 1 ) = "0" then mid( vals1 , v2 , 1 ) = "1" else mid( vals1 , v2 , 1 ) = "0"
        
        check( ele - 1 ) = vals1
        
        dim as string vals2 = "10111011"
        
        if mid( vals2 , v1 , 1 ) = "0" then mid( vals2 , v1 , 1 ) = "1" else mid( vals2 , v1 , 1 ) = "0"
        if mid( vals2 , v2 , 1 ) = "0" then mid( vals2 , v2 , 1 ) = "1" else mid( vals2 , v2 , 1 ) = "0"

'        print #1 , "if vals = `" ; str( vals2 ) ; "` then v1 =  " ; str( v2-1 ) ; " : v2 = " ; str( v1-1 )
'        print #2 , "if vals = `" ; str( vals1 ) ; "` then v1 =  " ; str( v1-1 ) ; " : v2 = " ; str( v2-1 )
        
        for b as longint = 1 to 28
            if vals2 = check( b ) then print "Error  , element "  ;  ele - 1 , vals2 , check( b ) , " input = " ; two( ele - 1 )
        next
        
    next
'close #1
'close #2

'print ( bits( 2 ) )  ' TWO BITS SET

print
print "done.. press key to exit"

sleep
end

[albert]

How many permutations are there for 1234 ?

And how do you do the permutations??

[Stonemonkey]

@Albert

Try changing the '4' in the main sub to a value from 1 to 4 and see what the output is too.

Code: Select all

function make_map(byval b as ulong)as ulong
    return (1 shl(b and 3))or(1 shl((b shr 2)and 3))or(1 shl((b shr 4)and 3))or(1 shl((b shr 6)and 3))
end function

function count_set_bits(byval b as ulong)as ulong
    dim as ulong result=0
    while b>0
        result+=b and 1
        b shr=1
    wend
    return result
end function

sub print_bit_pairs(byval b as ulong)
    for i as long=6 to 0 step-2
        print ((b shr i)and 3)+1;
    next
    print
end sub

        
sub main
    for i as ulong=0 to 255
        if count_set_bits(make_map(i))=4 then print_bit_pairs(i)
    next
end sub

main
sleep
end

or, for a bit of fun I decided to see how I could do it in assembly.

Code: Select all

function test(byval b as ulong)as ulong
    asm
        movzx eax,byte ptr[b]
        mov bx,&h400
        ror eax,6
map:        bts bx,ax
            xor al,al
            rol eax,2
            dec bh
        jnz map
count:      shr bl
            adc al,0
            test bl,bl
        jnz count
        mov [function],eax
    end asm
end function


sub print_bit_pairs(byval b as ulong)
    for i as long=6 to 0 step-2
        print ((b shr i)and 3)+1;
    next
    print
end sub

       
sub main
    for i as ulong=0 to 255
        if test(i)=4 then print_bit_pairs(i)
    next
end sub

main
sleep
end

[albert]

@Dodicat
@StoneMonkey

I got "YaH-Zip" , compressing... Now ; to write the decompression..

@StoneMonkey
I figured it out , for 4 digits , it's ( 4 * 4 * 4 * 4 ) = 256 permutations..
That takes 8 bits , so naturally it won't compress..

I found compression for 6 bits input, with two 3 bit values , setting bits 1 to 7 , if a value = 0 then it omits it..

[albert]

@Dodicat
@StoneMonkey

Here's "Yah-Zip" ... I'm still working on the decompression...

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

dim as double time1 , time2
time1 = timer
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        randomize
        For n As Long = 1 To 100000
            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 200."
    print
    print "press esc to exit."
    'sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 200

time2 = timer

print "Compress time = " ; time2 - time1

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
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) ' , bits
   
    dim as string outs1 = ""
    dim as string vals
    dim as string sorted
    dim as string v1 , v2
    dim as ubyte v3 , v4
    dim as string sort( 1 to 2 )
    for a as longint = 1 to len( bits ) step 6
           
        n1 = mid( bits , a , 6)
       
        v1 = mid( n1 , 01 , 3 )
        v2 = mid( n1 , 04 , 3 )
        
        sort( 1 ) = v1 + "0"
        sort( 2 ) = v2 + "1"
        
        for b as ubyte = 1 to 2
            for c as ubyte = b to 2
                if sort( b ) > sort( c ) then
                    swap sort( b ) , sort( c )
                end if
            next
        next

        v3 = val( "&B" + left( sort( 1 ) , 3 ) )
        v4 = val( "&B" + left( sort( 2 ) , 3 ) )
        
        if v1 = v2 then vals = "1111111" else vals = "0000000"
        
        if mid( vals , v3 , 1 ) = "0" then mid( vals , v3 , 1 ) = "1" else mid( vals , v3 , 1 ) = "0"
        if mid( vals , v4 , 1 ) = "0" then mid( vals , v4 , 1 ) = "1" else mid( vals , v4 , 1 ) = "0"
        
        
        sorted = right( sort( 1 ) , 1 ) + right( sort( 2 ) , 1 )
        
        if sorted = "01" then sorted = "0" : goto done
        if sorted = "10" then sorted = "1" : goto done
        
        done:
        
        vals+= sorted
        
        outs1+= vals
        
        'print n1 , v1 , v2 , vals
        'sleep 
        'if inkey = " " then end
       
    next
    
    print "c out = " ; len(outs1) ' , outs1
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next

    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "dc inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8)
        bits+= n1
    next
   
    print "d bin = " ; len(bits) ' , bits
   
    return chrs
   
end function

Here's the "Test-Bed" , where i try to write the decompression.

Each 8 bits of output = 6 bits of input.

Code: Select all

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

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    randomize
   
    dim as string s = ""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))
    Next
   
    time1=timer
    'begin compress
        dim as string comp = s
            'do
            '    dim as longint chk = len(comp) - 1
            '    comp = compress_loop(comp)
            '    if len(comp) >= chk then exit do
            'loop
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    print "inp = " ; (s)
    print string(99,"=")
    print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) , bits
   
    dim as string outs1 = ""
    dim as string vals
    dim as string sorted
    dim as string v1 , v2
    dim as ubyte v3 , v4
    dim as string sort( 1 to 2 )
    for a as longint = 1 to len( bits ) step 6
           
        n1 = mid( bits , a , 6)
       
        v1 = mid( n1 , 01 , 3 )
        v2 = mid( n1 , 04 , 3 )
        
        sort( 1 ) = v1 + "0"
        sort( 2 ) = v2 + "1"
        
        for b as ubyte = 1 to 2
            for c as ubyte = b to 2
                if sort( b ) > sort( c ) then
                    swap sort( b ) , sort( c )
                end if
            next
        next

        v3 = val( "&B" + left( sort( 1 ) , 3 ) )
        v4 = val( "&B" + left( sort( 2 ) , 3 ) )
        
        if v1 = v2 then vals = "1111111" else vals = "0000000"
        
        if mid( vals , v3 , 1 ) = "0" then mid( vals , v3 , 1 ) = "1" else mid( vals , v3 , 1 ) = "0"
        if mid( vals , v4 , 1 ) = "0" then mid( vals , v4 , 1 ) = "1" else mid( vals , v4 , 1 ) = "0"
        
        
        sorted = right( sort( 1 ) , 1 ) + right( sort( 2 ) , 1 )
        
        if sorted = "01" then sorted = "0" : goto done
        if sorted = "10" then sorted = "1" : goto done
        
        done:
        
        vals+= sorted
        
        outs1+= vals
        
        'print n1 , v1 , v2 , vals
        'sleep 
        'if inkey = " " then end
       
    next
    
    print "c out = " ; len(outs1) , outs1
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next

    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "dc inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8)
        bits+= n1
    next
   
    print "d bin = " ; len(bits) , bits
   
    return chrs
   
end function

[albert]

@Dodicat

I got the "Yah-Zip" , decompression done...

It's sometimes decompressing okay , and sometimes not?

Can't figure it out...
In the decompression , i hard wired all the possible values..

It should work , but it's not..

Here's the "Test-Bed"

Code: Select all

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

screen 19
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
do
   
    randomize
   
    dim as string s = ""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))
    Next
   
    time1=timer
    'begin compress
        dim as string comp = s
            'do
            '    dim as longint chk = len(comp) - 1
            '    comp = compress_loop(comp)
            '    if len(comp) >= chk then exit do
            'loop
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    print "inp = " ; (s)
    print string(99,"=")
    print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) , bits
    
    dim as ubyte count = 0
    dim as string str1
    dim as ubyte dec1
    do
        str1 = str( len( bits ) / 6 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then bits+= "0" : count+=1
    loop until dec1 = 0
    
    dim as string outs1 = ""
    dim as string vals
    dim as string sorted
    dim as string v1 , v2
    dim as ubyte v3 , v4
    dim as string sort( 1 to 2 )
    for a as longint = 1 to len( bits ) step 6
           
        n1 = mid( bits , a , 6)
       
        v1 = mid( n1 , 01 , 3 )
        v2 = mid( n1 , 04 , 3 )
        
        sort( 1 ) = v1 + "0"
        sort( 2 ) = v2 + "1"
        
        for b as ubyte = 1 to 2
            for c as ubyte = b to 2
                if sort( b ) > sort( c ) then
                    swap sort( b ) , sort( c )
                end if
            next
        next

        v3 = val( "&B" + left( sort( 1 ) , 3 ) )
        v4 = val( "&B" + left( sort( 2 ) , 3 ) )
        
        if v3 = v4 then vals = "1111111" else vals = "0000000"
        
        if mid( vals , v3 , 1 ) = "0" then mid( vals , v3 , 1 ) = "1" else mid( vals , v3 , 1 ) = "0"
        if mid( vals , v4 , 1 ) = "0" then mid( vals , v4 , 1 ) = "1" else mid( vals , v4 , 1 ) = "0"
        
        
        sorted = right( sort( 1 ) , 1 ) + right( sort( 2 ) , 1 )
        
        if sorted = "01" then sorted = "0" : goto done
        if sorted = "10" then sorted = "1" : goto done
        
        done:
        
        vals+= sorted
        
        outs1+= vals
        
        'print n1 , v1 , v2 , vals
        'sleep 
        'if inkey = " " then end
       
    next
    
    print "c out = " ; len(outs1) , outs1
   
    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)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print
    print "d inp = " ; len(chrs)
    
    dim as ubyte count = asc( left( chrs , 1 ) )
    chrs = mid( chrs , 2 )
    
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8)
        bits+= n1
    next
   
    print "d bin = " ; len(bits) , bits
    
    dim as string outs1 = ""
    dim as ubyte v1 , v2
    for a as longint = 1 to len( bits ) step 8
        
        n1 = mid( bits , a , 8 )
        
        ' FOR V1 < V2
        if n1 = "10000000" then v1 = 0 : v2 = 1
        if n1 = "01000000" then v1 = 0 : v2 = 2
        if n1 = "00100000" then v1 = 0 : v2 = 3
        if n1 = "00010000" then v1 = 0 : v2 = 4
        if n1 = "00001000" then v1 = 0 : v2 = 5
        if n1 = "00000100" then v1 = 0 : v2 = 6
        if n1 = "00000010" then v1 = 0 : v2 = 7
        
        if n1 = "11000000" then v1 = 1 : v2 = 2
        if n1 = "10100000" then v1 = 1 : v2 = 3
        if n1 = "10010000" then v1 = 1 : v2 = 4
        if n1 = "10001000" then v1 = 1 : v2 = 5
        if n1 = "10000100" then v1 = 1 : v2 = 6
        if n1 = "10000010" then v1 = 1 : v2 = 7
        
        if n1 = "01100000" then v1 = 2 : v2 = 3
        if n1 = "01010000" then v1 = 2 : v2 = 4
        if n1 = "01001000" then v1 = 2 : v2 = 5
        if n1 = "01000100" then v1 = 2 : v2 = 6
        if n1 = "01000010" then v1 = 2 : v2 = 7

        if n1 = "00110000" then v1 = 3 : v2 = 4
        if n1 = "00101000" then v1 = 3 : v2 = 5
        if n1 = "00100100" then v1 = 3 : v2 = 6
        if n1 = "00100010" then v1 = 3 : v2 = 7
        
        if n1 = "00011000" then v1 = 4 : v2 = 5
        if n1 = "00010100" then v1 = 4 : v2 = 6
        if n1 = "00010010" then v1 = 4 : v2 = 7        
        
        if n1 = "00001100" then v1 = 5 : v2 = 6
        if n1 = "00001010" then v1 = 5 : v2 = 7
        
        if n1 = "00000110" then v1 = 6 : v2 = 7
        
        ' FOR V1 > V2
        if n1 = "10000001" then v2 = 0 : v1 = 1
        if n1 = "01000001" then v2 = 0 : v1 = 2
        if n1 = "00100001" then v2 = 0 : v1 = 3
        if n1 = "00010001" then v2 = 0 : v1 = 4
        if n1 = "00001001" then v2 = 0 : v1 = 5
        if n1 = "00000101" then v2 = 0 : v1 = 6
        if n1 = "00000011" then v2 = 0 : v1 = 7
        
        if n1 = "11000001" then v2 = 1 : v1 = 2
        if n1 = "10100001" then v2 = 1 : v1 = 3
        if n1 = "10010001" then v2 = 1 : v1 = 4
        if n1 = "10001001" then v2 = 1 : v1 = 5
        if n1 = "10000101" then v2 = 1 : v1 = 6
        if n1 = "10000011" then v2 = 1 : v1 = 7
        
        if n1 = "01100001" then v2 = 2 : v1 = 3
        if n1 = "01010001" then v2 = 2 : v1 = 4
        if n1 = "01001001" then v2 = 2 : v1 = 5
        if n1 = "01000101" then v2 = 2 : v1 = 6
        if n1 = "01000011" then v2 = 2 : v1 = 7

        if n1 = "00110001" then v2 = 3 : v1 = 4
        if n1 = "00101001" then v2 = 3 : v1 = 5
        if n1 = "00100101" then v2 = 3 : v1 = 6
        if n1 = "00100011" then v2 = 3 : v1 = 7
        
        if n1 = "00011001" then v2 = 4 : v1 = 5
        if n1 = "00010101" then v2 = 4 : v1 = 6
        if n1 = "00010011" then v2 = 4 : v1 = 7        
        
        if n1 = "00001101" then v2 = 5 : v1 = 6
        if n1 = "00001011" then v2 = 5 : v1 = 7
        
        if n1 = "00000111" then v2 = 6 : v1 = 7
        
        ' FOR V1 = V2
        if n1 = "11111110" then v1 = 0 : v2 = 0
        if n1 = "01111110" then v1 = 1 : v2 = 1
        if n1 = "10111110" then v1 = 2 : v2 = 2
        if n1 = "11011110" then v1 = 3 : v2 = 3
        if n1 = "11101110" then v1 = 4 : v2 = 4
        if n1 = "11110110" then v1 = 5 : v2 = 5
        if n1 = "11111010" then v1 = 6 : v2 = 6
        if n1 = "11111100" then v1 = 7 : v2 = 7
        
        outs1+= right( "000" + bin( v1 ) , 3 ) + right( "000" + bin( v2 ) , 3 )
    
    next
    
    outs1 = left( outs1 , len( outs1 ) - count )
    
    print "d out = " ; len(outs1) , outs1

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

    return final
   
end function

[albert]

@Dodicat

I found the problem...

if v3 = v4 then vals = "1111111" else vals = "0000000"

if mid( vals , v3 , 1 ) = "0" then mid( vals , v3 , 1 ) = "1" else mid( vals , v3 , 1 ) = "0"
if mid( vals , v4 , 1 ) = "0" then mid( vals , v4 , 1 ) = "1" else mid( vals , v4 , 1 ) = "0"

( v4 is undoing v3 )

should be :

if v3 = v4 then
vals = "1111111"
if mid( vals , v3 , 1 ) = "0" then mid( vals , v3 , 1 ) = "1" else mid( vals , v3 , 1 ) = "0"
else
vals = "0000000"
if mid( vals , v3 , 1 ) = "0" then mid( vals , v3 , 1 ) = "1" else mid( vals , v3 , 1 ) = "0"
if mid( vals , v4 , 1 ) = "0" then mid( vals , v4 , 1 ) = "1" else mid( vals , v4 , 1 ) = "0"
end if

Changed it , and now it doesn't compress...

[albert]

@Dodicat

I found another compression technique... you mul the 2 inputs..

n1 = mid( bits , a , 6 )

v1 = val("&B" + mid( n1 , 01 , 3 ) ) + 1
v2 = val("&B" + mid( n1 , 04 , 3 ) ) + 1

v3 = ( v1 * v2 ) - 1

vals = right( "000000" + bin( v3 ) , 6 )

if instr( 1 , dict , str( v3 ) ) = 0 then dict+= str( v3 ) + " "

outs1+= vals

There's only 28 possible combinations.. 5 bits. so there's room to add a bit if v1 < or > v2

Do you think it'll work???

[Stonemonkey]

28 combinations is 4.8 bits.

[albert]

@Dodicat
@StoneMonkey

6 bit input ( v1 = 3 bits , v2 = 3 bits ) = ( ( v1 + 1 ) * ( v2 + 1 ) ) - 1 = 26 values...5 bits.

26 values : 0 3 5 6 7 9 11 13 14 15 17 19 20 23 24 27 29 31 34 35 39 41 47 48 55 63

To reverse it:
You would add 1 , and then search for 2 values that muled together equals that value..
Then with those 2 values you subtract 1 from each value.

I'll see if i can get it working....

[albert]

@Dodicat
@StoneMonkey

Here's "Yah-Zip" with the above formula... it's just outputting 6 bits 0 to 63...

I keep getting different values on the dictionary length...
100,000 in gives 25 and sometimes 26 values
1,000,000 in gives 27 and sometimes 28 values..

But either way it's still less than 32 , so it's 5 bits out. so you can use an extra bit to define < >

6 bits in and 6 bits out , might not compress???

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

dim as double time1 , time2
time1 = timer
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        randomize
        For n As Long = 1 To 1000000
            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 200."
    print
    print "press esc to exit."
    'sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 200

time2 = timer

print "Compress time = " ; time2 - time1

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
    
    static as longint high
    static as string dict
    
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) ' , bits
   
    dim as string outs1 = ""
    dim as string vals
    dim as ubyte v1 , v2 , v3
    for a as longint = 1 to len( bits ) step 6
           
        n1 = mid( bits , a , 6 )
       
        v1 = val("&B" + mid( n1 , 01 , 3 ) ) + 1
        v2 = val("&B" + mid( n1 , 04 , 3 ) ) + 1
        
        v3 = ( v1 * v2 ) - 1
        
        vals = right( "000000" + bin( v3 ) , 6 )
        
        if instr( 1 , dict , str( v3 ) ) = 0 then dict+= str( v3 ) + " " : high+= 1
        
        outs1+= vals
        
        'print n1 , v1 , v2 , vals
        'sleep 
        'if inkey = " " then end
       
    next
    
    print "c dic = " ; high , dict
    
    print "c out = " ; len(outs1) ' , outs1
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next

    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "d inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8)
        bits+= n1
    next
   
    print "d bin = " ; len(bits) ' , bits
   
    return chrs
   
end function

Just in case , I wrote a small program to calculate all the possible values of 6 bits.. There's 30 total possibilities. not 26 or 28
I guess some of the values never come up in random data..

Code: Select all

screen 19

dim as string n1
dim as string dict = ""
dim as longint high = 0
dim as ubyte v1 , v2 , v3
for a as longint = 0 to 63 step 1
    
    n1 = right( "000000" + bin( a ) , 6 )
    
    v1 = val( "&B" + mid( n1 , 1 , 3 ) ) + 1
    v2 = val( "&B" + mid( n1 , 4 , 3 ) ) + 1
    
    v3 = ( v1 * v2 ) - 1
    
    if instr( 1 , dict , str( v3 ) ) = 0 then dict+= str( v3 ) + " " : high+= 1
    
next

print "dict = " ; high , dict

sleep
end
 

Here's the output:
dict = 30 , 0 1 2 3 4 5 6 7 9 11 13 15 8 14 17 20 23 19 27 31 24 29 34 39 35 41 47 48 55 63

[albert]

@Dodicat
@StoneMonkey

Here's "Yah-Zip" , i plugged in the 30 values...

for 10,000 bytes input , it expands
for 100,000 bytes input , it compresses 65% after 400 loops.. ( 500 loops compresses 70+% , takes 170 seconds )
I didn't try 1,000,000 bytes input , it would take forever...

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

dim as double time1 , time2
time1 = timer
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        randomize
        For n As Long = 1 To 100000
            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 200."
    print
    print "press esc to exit."
    'sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 400

time2 = timer

print "Compress time = " ; time2 - time1

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
    
    static as longint high
    static as string dict
    
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) ' , bits
   
    dim as string outs1 = ""
    dim as string vals
    dim as ubyte v1 , v2 , v3
    for a as longint = 1 to len( bits ) step 6
           
        n1 = mid( bits , a , 6 )
       
        v1 = val("&B" + mid( n1 , 01 , 3 ) ) + 1
        v2 = val("&B" + mid( n1 , 04 , 3 ) ) + 1
        
        v3 = ( v1 * v2 ) - 1
        
        if v3 = 00 then vals = "00000"
        if v3 = 01 then vals = "00001"
        if v3 = 02 then vals = "00010"
        if v3 = 03 then vals = "00011"
        if v3 = 04 then vals = "00100"
        if v3 = 05 then vals = "00101"
        if v3 = 06 then vals = "00110"
        if v3 = 07 then vals = "00111"
        if v3 = 09 then vals = "01000"
        if v3 = 11 then vals = "01001"
        if v3 = 13 then vals = "01010"
        if v3 = 15 then vals = "01011"
        if v3 = 08 then vals = "01100"
        if v3 = 14 then vals = "01101"
        if v3 = 17 then vals = "01110"
        if v3 = 20 then vals = "01111"
        if v3 = 23 then vals = "10000"
        if v3 = 19 then vals = "10001"
        if v3 = 27 then vals = "10010"
        if v3 = 31 then vals = "10011"
        if v3 = 24 then vals = "10100"
        if v3 = 29 then vals = "10101"
        if v3 = 34 then vals = "10110"
        if v3 = 39 then vals = "10111"
        if v3 = 35 then vals = "11000"
        if v3 = 41 then vals = "11001"
        if v3 = 47 then vals = "11010"
        if v3 = 48 then vals = "11011"
        if v3 = 55 then vals = "11100"
        if v3 = 63 then vals = "11101"
        
        if v1 < v2 then vals+= "0" else vals+="1"
        
        'vals = right( "000000" + bin( v3 ) , 6 )
        
        'if instr( 1 , dict , str( v3 ) ) = 0 then dict+= str( v3 ) + " " : high+= 1
        
        outs1+= vals
        
        'print n1 , v1 , v2 , vals
        'sleep 
        'if inkey = " " then end
       
    next
    
    print "c dic = " ; high , dict
    
    print "c out = " ; len(outs1) ' , outs1
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next

    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "dc inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8)
        bits+= n1
    next
   
    print "d bin = " ; len(bits) ' , bits
   
    return chrs
   
end function

[albert]

@Dodicat
@StoneMonkey

Here's "Yah-Zip" , again...

I tried adding 3 bits to the end of vals , and it compresses in every case now.. Don't know how??

if v3 = ? value , then vals = "00000" , 5 bit bin value ( 0 to 29 )
if v1 < v2 then vals+="000" else vals+="111"

It works and it compresses with 8 bits out. Where 6 bits out was hardly compressing.. ( required 400 to 500 loops. )

Here's 100,000 bytes input with 200 loops.. ( takes 16 to 18 seconds on my computer. )
1,000,000 bytes in , compresses to 98+% ( < 2,200 ) after 200 loops and takes ~170 seconds.

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

dim as double time1 , time2
time1 = timer
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        randomize
        For n As Long = 1 To 1000000
            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 200."
    print
    print "press esc to exit."
    'sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 200

time2 = timer

print "Compress time = " ; time2 - time1

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
    
    static as longint high
    static as string dict
    
    print "c inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8 )
        bits+= n1
    next
   
    print "c bin = " ; len(bits) ' , bits
   
    dim as string outs1 = ""
    dim as string vals
    dim as ubyte v1 , v2 , v3
    for a as longint = 1 to len( bits ) step 6
           
        n1 = mid( bits , a , 6 )
       
        v1 = val("&B" + mid( n1 , 01 , 3 ) ) + 1
        v2 = val("&B" + mid( n1 , 04 , 3 ) ) + 1
        
        v3 = ( v1 * v2 ) - 1
        
        if v3 = 00 then vals = "00000" : goto done
        if v3 = 01 then vals = "00001" : goto done
        if v3 = 02 then vals = "00010" : goto done
        if v3 = 03 then vals = "00011" : goto done
        if v3 = 04 then vals = "00100" : goto done
        if v3 = 05 then vals = "00101" : goto done
        if v3 = 06 then vals = "00110" : goto done
        if v3 = 07 then vals = "00111" : goto done
        if v3 = 09 then vals = "01000" : goto done
        if v3 = 11 then vals = "01001" : goto done
        if v3 = 13 then vals = "01010" : goto done
        if v3 = 15 then vals = "01011" : goto done
        if v3 = 08 then vals = "01100" : goto done
        if v3 = 14 then vals = "01101" : goto done
        if v3 = 17 then vals = "01110" : goto done
        if v3 = 20 then vals = "01111" : goto done
        if v3 = 23 then vals = "10000" : goto done
        if v3 = 19 then vals = "10001" : goto done
        if v3 = 27 then vals = "10010" : goto done
        if v3 = 31 then vals = "10011" : goto done
        if v3 = 24 then vals = "10100" : goto done
        if v3 = 29 then vals = "10101" : goto done
        if v3 = 34 then vals = "10110" : goto done
        if v3 = 39 then vals = "10111" : goto done
        if v3 = 35 then vals = "11000" : goto done
        if v3 = 41 then vals = "11001" : goto done
        if v3 = 47 then vals = "11010" : goto done
        if v3 = 48 then vals = "11011" : goto done
        if v3 = 55 then vals = "11100" : goto done
        if v3 = 63 then vals = "11101" : goto done
        
        done: 
        
        if v1 < v2 then vals+= "000" else vals+= "111"
        
        'vals = right( "000000" + bin( v3 ) , 6 )
        
        'if instr( 1 , dict , str( v3 ) ) = 0 then dict+= str( v3 ) + " " : high+= 1
        
        outs1+= vals
        
        'print n1 , v1 , v2 , vals
        'sleep 
        'if inkey = " " then end
       
    next
    
    print "c dic = " ; high , dict
    
    print "c out = " ; len(outs1) ' , outs1
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 8
        final+= chr( val( "&B" + mid( outs1 , a , 8 ) ) )
    next

    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "dc inp = " ; len(chrs)
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr usp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *usp ) : usp+= 1
        n1 = right( n1 , 8)
        bits+= n1
    next
   
    print "d bin = " ; len(bits) ' , bits
   
    return chrs
   
end function

Now ; to write the decompression...

[Stonemonkey]

@albert
Sorry, I thought you meant permutations of the sequence containing the digits 1,2,3 and 4