Squares

General FreeBASIC programming questions.
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Rand-Zip

Postby albert » Dec 07, 2019 22:40

@Richard
@Dodicat
@StoneMonkey

I got another compression technique... It's kinda slow..

You generate , rand = mkshort( random ) , and check the file , to see if it exists in the file.

If rand > mkshort( 0 ) then you increment the counter.

The output is ; outs1 + = mkl( count ) , from observation , the count never goes above 1,000,000... But it's bigger than a mkshort()

See: compress_loop()

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 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 100."
    print
    print "press esc to exit."
    sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 100

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
   
    dim as ubyte cnt
    dim as string str1
    dim as ubyte dec1
    do
        str1 = str( len( chrs ) / 4 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then chrs+= chr(0) : cnt+=1
    loop until dec1 = 0
   
    print "c inp = " ; len(chrs)
   
    dim as string outs1= ""
    dim as string check =  string( len( chrs ) , chr( 0 ) )
    dim as string rand
    dim as longint place
    dim as longint count = 0
    dim as longint got_one = 0
    randomize 0
    do
       
        rand = chr( int( rnd * 256) ) + chr( int( rnd * 256 ) )
       
        if rand <> mkshort( 0 ) then
            count+=1
            place = 0
            do
                place = instr( place + 1 , chrs , rand )
                if place > 0 and place mod 2 = 1 then
                    mid( chrs , place , 2 ) = mkshort( 0 )
                    outs1+= mkl( count )
                    got_one+=2
                end if
            loop until place = 0
        end if
       
        if count mod 10000 = 0 then print "Got " ; got_one ; " so far out of " ; len( chrs ) , "count = " ; count
   
    loop until chrs = check
   
    print
    print "c out = " ; len( outs1 ) ' , outs1
   
    dim as string final = outs1
   
    print "c fin = "; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "d inp = "; len(chrs)
   
    return chrs
   
end function

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

Re: Squares

Postby albert » Dec 07, 2019 22:59

My mistake..

I had outs1 + = mkl( count )

i need to make outs1 the same size as the input data.
And then split the outs1 string , and insert mkl( count ) into outs1 where it's supposed to go..

I'll fix it , and see if it still compresses..

( !~ Edited ~! )

Fixed it and it doesn't compress..
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Dec 08, 2019 3:30

@Richard

How many permutations are there for "1234"

Is it 16 or 256 ??

1234
1243

1324
1342

etc... ??

Do you have a program , that can do the permutations for 4 chr()'s ??
Richard
Posts: 3030
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Postby Richard » Dec 08, 2019 5:44

How many permutations are there for "1234"
Is it 16 or 256 ??

Neither. It is the factorial of 4 = 4! = 1x2x3x4 = 24.
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Dec 08, 2019 9:22

Hi Albert.
I have been following your compressor, but have been messing with other stuff also.
To permute you can either write some code to cycle a string, but I had this old code to do it a different way.

Code: Select all


    Sub Permutate(Byval s2 As String,perm() As String,OptionalStop As String="")
        Dim As Long p,i,j,result
        Redim perm(0)
        Dim As Long LENS2M1=Len(S2)-1
        Dim As Long lens2=Len(s2)
        Dim As Double factorial
        Dim temp As Double=1
        If Len(s2) >1 Then
            For n As Integer =1 To Len(s2)
                temp =temp * n
            Next
            factorial =temp
        Else
            factorial =1
        End If
        Redim perm(1 To (factorial))
        For p1 As Integer =0 To Len(s2)-2
            For p2 As Integer =p1 + 1 To Len(s2)-1
                If s2[p1]>s2[p2] Then Swap s2[p1],s2[p2]
            Next p2
        Next p1
        Do
            p=p+1
            perm(p)=s2
            If s2=OptionalStop Then Goto skip
            Do
                For i=Lens2-2 To 0 Step -1
                    If s2[i] <s2[i+1] Then Exit For
                Next
                If i <0 Then Result=0:Exit Do
                j =LENS2M1
                While s2[j] <= s2[i]: j -=1 : Wend
                Swap s2[i], s2[j]
                i +=1
                j =LENS2M1
                While i <j
                    Swap s2[i], s2[j]
                    i +=1
                    j -=1
                Wend
                result=-1:Exit Do
            Loop
        Loop Until result=0
        skip:
        Redim Preserve perm(1 To p)
    End Sub
   
    Redim Shared As String p()
   
    permutate("1234",p())

   
    For z As Integer=Lbound(p) To Ubound(p)
        Print z,p(z)
        next
        Sleep
     
Stonemonkey
Posts: 646
Joined: Jun 09, 2005 0:08

Re: Squares

Postby Stonemonkey » Dec 08, 2019 11:08

@albert
I posted code to do that a page or two back.
Change the '4' in the main sub to value from 1 to 4 to get permutations containing 1 to 4 different digits.

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

Re: Squares

Postby albert » Dec 08, 2019 20:38

Thanks you guys..

How do you get the right answer??? cvl( str val ) is giving ( plus and minus )

I'm trying to get the positive 32 bit value..

Code: Select all


screen 19

dim as string zeros = string( 32 , "0" )
dim as string rand1
dim as string rand2
do
   
        rand1 = chr( int( rnd * 256 ) ) + chr( int ( rnd * 256 ) ) + chr( int( rnd * 256 ) ) + chr( int ( rnd * 256 ) )
       
        rand2 = zeros + bin( cvl( rand1 ) )
       
        rand2 = right( rand2 , 32 )
       
        'cvl( rand ) is returning wrong.
        print cvl( rand1 ) , val( "&B" + rand2 )
        sleep
        if inkey = " " then end

loop until inkey = chr( 27 )

sleep
end



( !~ Edited ~! )

I figured it out , you have to create a var , ( dim as ulong UL ) and assign the cvl( string ) to UL = cvl( 4 byte string )
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Dec 08, 2019 22:32

You just cast the long to ulong. (use culng)

Code: Select all



dim as string s=string(4,0)

for n as long=1 to 20
   
    s[0]=rnd*255:s[1]=rnd*255:s[2]=rnd*255:s[3]=rnd*255
   
print s, cvl(s),culng(cvl(s)),mkl(culng(cvl(s)))
print
next
sleep
 
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Hex Zip

Postby albert » Dec 11, 2019 0:17

@Richard
@Dodicat
@StoneMonkey

I got compression... Finally !! , it actually works..

The down side is ; it only compresses a small amount each loop. So it takes hours to compress 10,000,000 bytes..

The method is :

Turn the input string into hex , and then search for quadruples n1 = "0000" , "1111" , "2222" , "3333" to "FFFF"
Then you replace the quadruples with "A0" + left( n1 , 1 ) + "~" ( four bytes )
Then you go through the string and take out the "~" chrs..

It compresses a few hundred bytes each loop ,, Which means , it takes forever.. So it can't be used in it's present state..

Code: Select all


( !!~ HEX-ZIP ~~!! )

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 10000000
        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
                if inkey = chr( 27 ) then end
            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)
   
    ' convert input string into hex
    dim as string bits = ""
    dim as string zeros = string( 16 , "0" )
    dim as string n1
    dim as ulongint ptr ulp = cptr( ulongint ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 8
        n1 = zeros + hex( *ulp ) : ulp+= 1
        bits+= right( n1 , 16 )
    next
   
    'print "c bin = " ; len( bits ) ' , bits
   
    'search for 3 like hex digits
    dim as longint count = 0
    dim as longint place
    n1 = "0000"
    do
        place = 0
        do
            place = instr( place + 1 , bits , n1 )
            if place > 0 then mid( bits , place , 4 ) = "A0" + left( n1 , 1 ) + "~" : count+= 1
        loop until place = 0
       
        n1  = hex( val( "&H" + left( n1 , 1 ) ) + 1 ) + hex( val( "&H" + left( n1 , 1 ) ) + 1 ) + hex( val( "&H" + left( n1 , 1 ) ) + 1 ) + hex( val( "&H" + left( n1 , 1 ) ) + 1 )
       
    loop until len( n1 ) > 4
   
    'take the tildes out.
    dim as string outs1 = ""
    for a as longint = 1 to len( bits ) step 1
        n1 = mid( bits , a , 1 )
        if n1 <> "~" then outs1+= n1
    next
   
    'print "c cnt =  "; count
    'print "c out = " ; len( outs1 ) ' , outs1
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 2
        final+= chr( val( "&H" + mid( outs1 , a , 2 ) ) )
    next
   
     print "c fin = "; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print "d inp = "; len(chrs)
   
    return chrs
   
end function

angros47
Posts: 1673
Joined: Jun 21, 2005 19:04

Re: Squares

Postby angros47 » Dec 12, 2019 9:40

And what happens if you have to compress a quadruple that starts with "A0" and ends with "~"? When you try to restore it, the decompression algorithm can tell that it was part of the original data set, and not something to decompress?
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Dec 13, 2019 0:42

@angros47

There are no quads dups , that start with "A0" , but there are some data sets that do start with "A0"

Maybe making it "A" + left( quad 1 ) + "0~" ( "A 1 0 ~ ) then take out the "~" chrs.

Maybe A + ? + 0 , probably almost never happens.. ???

Anyways its to slow to use...
Stonemonkey
Posts: 646
Joined: Jun 09, 2005 0:08

Re: Squares

Postby Stonemonkey » Dec 13, 2019 20:45

@albert
An idea I just tried, taking say 7 bits at a time and counting the number of set bits, direct each 7 bits to one of 2 streams, one stream with mostly 0s and the other with mostly 1s, then compress each stream separately, so the stream with mostly 0s is compressed using 00=0, 1=1 and 01=2, storing as base 3 so each takes up 1.58 bits.
It sometimes compresses, sometimes not, the streams compress but the extra bit indicating which stream to take the next 7 bits from usually cancels out any gains.
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Yah-Zip

Postby albert » Dec 15, 2019 22:42

@StoneMonkey

You got me thinking about the counting of the bits....

You count the number of set bits , then record every other bit , and then add in the last decimal digit.. ( 16 bits in , 16 bits out. ) It compresses...

16 bits input
count = bit count
vals1 = every other bit
vals2 = right( decimal digit )
outs+= right( "0000" + bin( count ) , 4 ) + vals1 + right( "0000" + bin( val( vals2 ) ) , 4 )

Compresses 90+% after 50 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

dim as double time1 , time2

time1 = timer
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        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 50."
    print
    print "press esc to exit."
    'sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 50

time2 = timer

print
print  "Compress time = " ; time2 - time1
print
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
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'============================,===================================================
'begin functions
'===============================================================================
'================='==============================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    'CONVERT INPUT TO 64 BIT BINARY
    dim as string bits = ""
    dim as string zeros = string( 64 , "0" )
    dim as string n1 , n2
    dim as ulongint ptr ubp = cptr( ulongint ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 8
        n1 = zeros + bin( *ubp ) : ubp+= 1
        n1 = right( n1 , 64 )
        bits+=n1
    next
   
    print "c bin = " ; len( bits ) ' , bits
   
    'STEP THROUGH BINARY BY 16'S AND BUILD OUTPUT
    dim as string outs = ""
    dim as longint count
    dim as longint v1 , v2
    dim as string vals1 , vals2
    for a as longint = 1 to len( bits ) step 16
       
        n1 = mid( bits , a , 16 )
       
        'COUNT BITS
        count = 0
        for b as longint = 1 to len( n1 ) step 1
            if n1[ b - 1 ] = 49 then count+= 1
        next
       
        v1 = val( "&B" + n1 )
       
        'RECORD EVERY OTHER BIT
        vals1=""
        vals1+= mid( n1 , 01 , 1 )
        vals1+= mid( n1 , 03 , 1 )
        vals1+= mid( n1 , 05 , 1 )
        vals1+= mid( n1 , 07 , 1 )
        vals1+= mid( n1 , 09 , 1 )
        vals1+= mid( n1 , 11 , 1 )
        vals1+= mid( n1 , 13 , 1 )
        vals1+= mid( n1 , 15 , 1 )
       
        'TAKE RIGHT DIGIT
        vals2 = right( str( v1 ) , 1 )
       
        'ADD COUNT + EVERYOTHER BIT + LAST DIGIT
        outs+= right( "0000" + bin( count ) , 4 ) + vals1 + right( "0000" + bin( val( vals2 ) ) , 4 )
       
        'print n1 , count , v1 ,  v2 , vals2
        'sleep
        'if inkey = " " then end
       
    next
   
    print "c out = " ; len( outs ) ' , outs
       
   
    'CREATE OUTPUT
    dim as string final = ""
    for a as longint = 1 to len( outs ) step 8
        final+= chr( val( "&B" + mid( outs , 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)
   
    return chrs
   
end function

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

Yah-Zip

Postby albert » Dec 17, 2019 23:09

@StoneMonkey

Instead of counting bits , i decided to try summing bits..

you have:

sum0 to sum the zeros
sum1 to sum the ones

Then ; whichever is lower , you put that chr() into the output..

For some reason 6 bits per chr() , compresses more then 8 bits per chr()

I can't figure out how to tell which sum ( 0 or 1 ) you put into the output....Can you think of something??

Compresses 99% after 40 loops..

Here's the compressor in Dodicat's Zlib code.
See : compress_loop()

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
        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 40."
    print
    print "press esc to exit."
    'sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 40

time2 = timer

print
print  "Compress time = " ; time2 - time1
print
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
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'============================,===================================================
'begin functions
'===============================================================================
'================='==============================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    'CONVERT INPUT TO 8 BIT BINARY
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr ubp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *ubp ) : ubp+= 1
        n1 = right( n1 , 8 )
        bits+=n1
    next
   
    print "c bin = " ; len( bits ) ', bits
   
    'STEP THROUGH BINARY BY 6'S AND BUILD OUTPUT
    'FOR SOME REASON STEPPING BY 6'S , COMPRESSES MORE THAN STEPPING BY 8'S
    dim as string outs = ""
    dim as longint sum0
    dim as longint sum1
    dim as string s0
    dim as string s1
    for a as longint = 1 to len( bits ) step 6
       
        n1 = mid( bits , a , 6 )
       
        'SUM 1'S AND 0'S
        sum0 = 0
        sum1 = 0
        for b as longint = 1 to len( n1 ) step 1
            if n1[ b - 1 ] = 48 then sum0+= ( 1 shl ( len( n1 ) - b ) )
            if n1[ b - 1 ] = 49 then sum1+= ( 1 shl ( len( n1 ) - b ) )
        next
       
        'DECIDE WHICH SUM IS LOWER AND PUT THAT CHR() INTO THE OUTPUT
        if sum0 < sum1 then outs+= chr( sum0 )
        if sum1 < sum0 then outs+= chr( sum1 )
        if sum0 = sum1 then outs+= chr( sum0 )
       
        'UN COMMENT TO SEE IF VALUES EQUAL OKAY. 
        'print n1 , val( "&B" + n1 ) , sum0 , sum1
        'sleep
        'if inkey = " " then end
       
    next
   
    print "c out = " ; len( outs ) ', outs
       
   
    'CREATE OUTPUT
    dim as string final = outs
    'for a as longint = 1 to len( outs ) step 8
     '   final+= chr( val( "&B" + mid( outs , 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)
   
    return chrs
   
end function



( !~~ Edited ~~! )
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Yah-Zip

Postby albert » Dec 18, 2019 18:37

@StoneMonkey

I got it workin' like a Gerkin....

it steps by 2 bits and outputs a chr()

==========================================================================
'SUM 1'S AND 0'S
sum0 = 0
sum1 = 0
for b as longint = 1 to len( n1 ) step 1
if n1[ b - 1 ] = 48 then sum0+= ( 1 shl ( len( n1 ) - b ) )
if n1[ b - 1 ] = 49 then sum1+= ( 1 shl ( len( n1 ) - b ) )
next

sum1+=1

'DECIDE WHICH SUM IS LOWER AND PUT THAT CHR() INTO THE OUTPUT
if sum0 < sum1 then outs+= chr( sum0 )
if sum1 < sum0 then outs+= chr( 3 + sum1 )
==========================================================================

if it's less than or equal to 3 then you know the output is sum0
if it's greater than or equal to 4 then you know the output is sum1

For 50 loops : Compresses 99%

Here it is in Dodicat's Zlib code.

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
        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 50."
    print
    print "press esc to exit."
    'sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 50

time2 = timer

print
print  "Compress time = " ; time2 - time1
print
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
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'============================,===================================================
'begin functions
'===============================================================================
'================='==============================================================
Function compress_loop( chrs as string ) as string
   
    print "c inp = " ; len(chrs)
   
    'CONVERT INPUT TO 8 BIT BINARY
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    dim as ubyte ptr ubp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( *ubp ) : ubp+= 1
        n1 = right( n1 , 8 )
        bits+=n1
    next
   
    print "c bin = " ; len( bits ) ', bits
   
    'STEP THROUGH BINARY BY 6'S AND BUILD OUTPUT
    'FOR SOME REASON STEPPING BY 6'S , COMPRESSES MORE THAN STEPPING BY 8'S
    dim as string outs = ""
    dim as longint sum0
    dim as longint sum1
    for a as longint = 1 to len( bits ) step 2
       
        n1 = mid( bits , a , 2 )
       
        'SUM 1'S AND 0'S
        sum0 = 0
        sum1 = 0
        for b as longint = 1 to len( n1 ) step 1
            if n1[ b - 1 ] = 48 then sum0+= ( 1 shl ( len( n1 ) - b ) )
            if n1[ b - 1 ] = 49 then sum1+= ( 1 shl ( len( n1 ) - b ) )
        next
       
        sum1+=1
       
        'DECIDE WHICH SUM IS LOWER AND PUT THAT CHR() INTO THE OUTPUT
        if sum0 < sum1 then outs+= chr( sum0 )
        if sum1 < sum0 then outs+= chr( 3 + sum1 )
       
        'UN COMMENT TO SEE IF VALUES EQUAL OKAY. 
        'print n1 , val( "&B" + n1 ) , sum0 , sum1
        'sleep
        'if inkey = " " then end
       
    next
   
    print "c out = " ; len( outs ) ', outs
       
   
    'CREATE OUTPUT
    dim as string final = outs
    'for a as longint = 1 to len( outs ) step 8
     '   final+= chr( val( "&B" + mid( outs , 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)
   
    return chrs
   
end function



Now to write the decompression....

( !~~ Edited ~~! )

Return to “General”

Who is online

Users browsing this forum: No registered users and 9 guests