Squares

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

Re: Squares

Postby albert » Mar 15, 2020 22:48

@Dodicat

I found the problem...

outs1+= hex( val( "&B " + n2 ) )

There's a space after the B ,

Now it doesn't compress.. I couldn't figure out why it was compressing 30% on loop 1
bfuller
Posts: 339
Joined: Jun 02, 2007 12:35
Location: Sydney, Australia

Re: Squares

Postby bfuller » Mar 17, 2020 9:59

Albert,

did you download the book on numbers? With your brilliant mind, I am sure you could write a program for each chapter. Would be fun for you and you might even stumble on a new way of compressing things.

http://www.plouffe.fr/simon/Phys%20et%2 ... umbers.pdf
dodicat
Posts: 6728
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Mar 17, 2020 10:55

Chapter 15 is dedicated to squares.
Richard had a nice link several years ago to mathematical enigmas.
I have completely lost the site.
Strange that when I was a book user I could go back years to so some topic with ease.
Just scan the book shelf to trigger a memory, and get the book down.
But now, even with bookmarking a site, things get lost.
Probably far too much information available or I am loosing some marbles.
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Yah-Zip ( Test Bed )

Postby albert » Mar 17, 2020 21:22

@Dodicat

I've got another formula that compresses... Compresses 100,000 bytes in by 98% after 100 loops..

I've got to figure out where to add and where to subtract... Got to solve the yellow values.

Here's the "Test Bed" where i write the decompression...

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
            '    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
   
    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) ' , chrs
   
    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
    for a as longint = 1 to len( bits ) step 4
        print mid( bits , a , 4 )  ; " " ;
    next
    print
   
    dim as string outs1 = ""
    dim as string outs2 = ""
    dim as longint v1 , v2
    for a as longint = 1 to len( bits ) step 8
       
        n1 = mid( bits , a , 8 )
       
        v1 = val( "&B" + mid( n1 , 1 , 4 ) )
        v2 = val( "&B" + mid( n1 , 5 , 4 ) )
       
        if v1 <= v2 then outs1+= hex( v1 ) + hex( v2 - v1 )
        if v1 >   v2 then outs1+= hex( v1 ) + hex( v1 - v2 )
       
        'print
        'print n1
        'print outs1
        'print outs2
        'sleep
        'if inkey = " " then end
       
    next
   
    print "d bin = " ; len( outs1 ) , ', outs1
    for a as longint = 1 to len( outs1 ) step 1
        n1 = right( "0000" + mid( outs1 , a , 1 ) , 4 )
        print n1 ; " " ;
    next
    print
   

    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 2
        final+= chr( val( "&H" + mid( outs1 , a , 2 ) ) )
    next
    'for a as longint = 1 to len( outs2 ) step 8
    '    final+= chr( val( "&B" + mid( outs2 , 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( 2 , "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 + hex( *ubp ) : ubp+= 1
        n1 = right( n1 , 2 )
        bits+=n1
    next
   
    print "d bin = " ; len( bits ) , ', bits
   
    for a as longint = 1 to len( bits ) step 1
        n1 = right( "0000" + mid( bits , a , 1 ) , 4 )
        if a mod 2 = 1 then color 11 else color 14
        print n1 ; " " ;
    next
    color 15
    print
   
   
    return chrs
   
end function

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

Yah-Zip ( Test Bed )

Postby albert » Mar 17, 2020 22:20

@Dodicat

I altered it some.....Now it only compresses 100,000 bytes in by 64% after 100 loops. : takes about 20 seconds


===================================================
n1 = mid( bits , a , 8 )

v1 = val( "&B" + mid( n1 , 1 , 4 ) )
v2 = val( "&B" + mid( n1 , 5 , 4 ) )

if v1 <= v2 then outs1+= hex( v1 ) + hex( v2 )
if v1 > v2 then outs1+= hex( v1 ) + hex( v1 - v2 )
===================================================

If v1 <= v2 then the output is normal v1 + v2
if v1 > v2 then the output is v1 + ( v1 - v2 )

Got to solve the yellow values...


Here's the "Test Bed" where i write the decompression..

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
            '    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
   
    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) ' , chrs
   
    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
    for a as longint = 1 to len( bits ) step 4
        print mid( bits , a , 4 )  ; " " ;
    next
    print
   
    dim as string outs1 = ""
    dim as string outs2 = ""
    dim as longint v1 , v2
    for a as longint = 1 to len( bits ) step 8
       
        n1 = mid( bits , a , 8 )
       
        v1 = val( "&B" + mid( n1 , 1 , 4 ) )
        v2 = val( "&B" + mid( n1 , 5 , 4 ) )
       
        if v1 <= v2 then outs1+= hex( v1 ) + hex( v2 )
        if v1 >   v2 then outs1+= hex( v1 ) + hex( v1 - v2 )
       
        'print
        'print n1
        'print outs1
        'print outs2
        'sleep
        'if inkey = " " then end
       
    next
   
    print "d bin = " ; len( outs1 ) , ', outs1
    for a as longint = 1 to len( outs1 ) step 1
        n1 = right( "0000" + mid( outs1 , a , 1 ) , 4 )
        print n1 ; " " ;
    next
    print
   

    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 2
        final+= chr( val( "&H" + mid( outs1 , a , 2 ) ) )
    next
    'for a as longint = 1 to len( outs2 ) step 8
    '    final+= chr( val( "&B" + mid( outs2 , 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( 2 , "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 + hex( *ubp ) : ubp+= 1
        n1 = right( n1 , 2 )
        bits+=n1
    next
   
    print "d bin = " ; len( bits ) , ', bits
   
    for a as longint = 1 to len( bits ) step 1
        n1 = right( "0000" + mid( bits , a , 1 ) , 4 )
        if a mod 2 = 1 then color 11 else color 14
        print n1 ; " " ;
    next
    color 15
    print
   
    return chrs
   
end function

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

Re: Squares

Postby albert » Mar 18, 2020 1:06

@Dodicat

Never mind....

If v1 <= v2 then the output is normal v1 + v2
if v1 > v2 then the output is v1 + ( v1 - v2 )

if v2 = 0 then outputs = v1 , ( v1 - v2 ) It comes out to an equate.. like the first case.. no way to solve it..
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Mar 18, 2020 1:08

@angros47

Hutter with an udder.. I'd like to win that prize!!!

One thought..

If you bring in a byte , input = bin( str[ 0 ] ) , The input has to start with a 1 unless the byte is 0
So you can lose the first bit... But if that first bit is followed by 0's then you don't know how many zeros to add back in....
You just know you have to add a 1 to the front...
D.J.Peters
Posts: 8190
Joined: May 28, 2005 3:28
Contact:

Re: Squares

Postby D.J.Peters » Mar 18, 2020 10:34

@angros47 i donloaded the one GB xml/text file.
On a older PC with WIN 10 4GB VisualCode, Geany, FBIDE, MS Editor, FireFox all creasched while opening the file exept an Hex-Editor I'm in love with :-)

Than I reboot in Linux the simple editor gEdit does the job perfect including syntax highlighting.

I'm suree VisualCode and Geany crashed while highlighting the GB at once.

By the way I hate you, I try to compress the beast again and again, without your post my life would be much more lovely :-)

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

Yah-Zip ( Alter Bin )

Postby albert » Mar 18, 2020 23:37

@Richard
@Dodicat

I think I've finally done it... Compresses 100,000 bytes in by 80+% after 100 loops : Takes about 4 to 10 seconds...

( I need some help with the decompression... )

===================================
bits = character string converted to binary.

n1 = mid( bits , a , 6 )

s1 = 0
if n1[ 0 ] = 49 then s1+= 28
if n1[ 1 ] = 49 then s1+= 14
if n1[ 2 ] = 49 then s1+= 7
if n1[ 3 ] = 49 then s1+= 5
if n1[ 4 ] = 49 then s1+= 3
if n1[ 5 ] = 49 then s1+= 1

outs1+= chr( s1 )
===================================

I think I've checked all the possible values , so there's no duplicates..

Here it is doing 100,000 bytes in , in Dodicat's Zlib code...

Code: Select all


' YAH-ZIP ( Alter Bin )
'
' Writen in FreeBasic for Windows
'
'Zlibrary code by Dodicat , From Scottland
'
' compress_loop() , decompress_loop by Albert Redditt


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 esc to exit."
    print
    print "press a key for next compression." ; " loops = " ; loops ; " out of 100."
    'sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 100

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) ' , chrs
   
    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
   
    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 longint s1
    for a as longint = 1 to len( bits ) step 6
       
        n1 = mid( bits , a , 6 )
       
        s1 = 0
        if n1[ 0 ] = 49 then s1+=  28
        if n1[ 1 ] = 49 then s1+=  14
        if n1[ 2 ] = 49 then s1+=    7
        if n1[ 3 ] = 49 then s1+=    5
        if n1[ 4 ] = 49 then s1+=    3
        if n1[ 5 ] = 49 then s1+=    1
       
        outs1+= chr( s1 )
       
        'print n1 , s1
        'sleep
        'if inkey = " " then end
       
    next
   
    print "c out = " ; len( outs1 ) ' , outs1

    dim as string final = outs1
   
    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 longint v1
    for a as longint = 1 to len( chrs ) step 1
       
        v1 = chrs[ a - 1 ]
       
        'NEED TO SOLVE VALUES...
       
       
    next
   
   
    return chrs
   
end function

badidea
Posts: 2154
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Yah-Zip ( Alter Bin )

Postby badidea » Mar 18, 2020 23:54

albert wrote:I think I've checked all the possible values , so there's no duplicates..

"001110" and "010001" both result in 15

And there are more:

Code: Select all

dim as integer bits, s1
dim as string n1

for bits = 0 to &b111111
   n1 = bin(bits, 6)
   s1 = 0
   if n1[ 0 ] = 49 then s1+= 28
   if n1[ 1 ] = 49 then s1+= 14
   if n1[ 2 ] = 49 then s1+= 7
   if n1[ 3 ] = 49 then s1+= 5
   if n1[ 4 ] = 49 then s1+= 3
   if n1[ 5 ] = 49 then s1+= 1
   print n1, s1
next
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Mar 19, 2020 0:06

Sorry , it was a badidea!!
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Yah-Zip

Postby albert » Mar 19, 2020 3:22

@Dodicat
@badidea

I think i got it this time...

if mid( outs2 , a , 1 ) = "0" then you pull a value from outs1 ( 0 , 1 , 2 )
if mid( outs2 , a , 1 ) = "1" then you insert a "11" at that location

Here's Dodicat's Zlib code doing 100,000 bytes in over 50 loops.. ( compresses 99+% )

Code: Select all


' YAH-ZIP
'
' Writen in FreeBasic for Windows
'
'Zlibrary code by Dodicat , From Scottland
'
' compress_loop() , decompress_loop by Albert Redditt


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 esc to exit."
    print
    print "press a key for next compression." ; " loops = " ; loops ; " out of 50."
    '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) ' , chrs
   
    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
   
    dim as string outs1 = ""
    for a as longint = 1 to len( bits ) step 2
       
        n1 = mid( bits , a , 2 )
           
        if n1 = "00" then outs1+= "0" : mid( bits , a , 2 ) = "0~"
        if n1 = "01" then outs1+= "1" : mid( bits , a , 2 ) = "0~"
        if n1 = "10" then outs1+= "2" : mid( bits , a , 2 ) = "0~"
        if n1 = "11" then mid( bits , a , 2 ) = "1~"
       
    next

    dim as string outs2 = ""
    for a as longint = 1 to len( bits ) step 1
        n1 = mid( bits , a , 1 )
        if n1 <> "~" then outs2+= n1
    next

    print "c out = " ; len( outs1 ) ' , outs1
    print "c out = " ; len( outs2 ) ' , outs2
   
    dim as string final = ""
    for a as longint = 1 to len( outs1 ) step 3
        final+= chr( val( "&O" + mid( outs1 , a , 3 ) ) )
    next
    final+= "END"
    for a as longint = 1 to len( outs2 ) 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
    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 » Mar 20, 2020 1:13

I need someone to check this out for me...

For some reason it's compressing 70% on loop 1..

Can't figure it out... Did i finally get compression ????

Code: Select all


' YAH-ZIP
'
' Writen in FreeBasic for Windows
'
'Zlibrary code by Dodicat , From Scottland
'
' compress_loop() , decompress_loop by Albert Redditt


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 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 esc to exit."
    print
    print "press a key for next compression." ; " loops = " ; loops ; " out of 100."
    sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 100

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) ' , chrs
   
    dim as string outs1 = ""
    dim as string outs2 = ""
    dim as string n1
    dim as longint v1
    dim as ubyte ptr ubp = cptr( ubyte ptr , strptr( chrs ) )
    for a as longint = 1 to len( chrs ) step 1
       
        n1 = bin( *ubp ) : ubp+= 1
       
        v1 = instr( 1 , n1 , "0" )
       
        outs1+= mkshort( val( "1" + "&B" + mid( n1 , v1 ) ) )
        outs2+= str( v1 )
       
    next
   
    print "c out = " ; len( outs1 ) ' , outs1
    print "c out = " ; len( outs2 ) ' , outs2

    dim as string final = outs1
    'for a as longint = 1 to len( outs1 ) step 3
    '    final+= chr( val( "&O" + mid( outs1 , a , 3 ) ) )
    'next
    final+= "END"
    for a as longint = 1 to len( outs2 ) step 2
        final+= chr( val( mid( outs2 , a , 2 ) ) )
    next
   
    print "c fin = " ; len(final)
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    print
    print "d inp = " ; len( chrs )
   
    return chrs
   
end function

dodicat
Posts: 6728
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Mar 20, 2020 1:57

Albert.
A compressor but without a decompressor.
I could take a note of the swaps, write to a separate file and compress this.
Then use the two files to get back.
Maybe I'll try it out tomorrow.

Code: Select all


#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


Enum
    up
    down
End Enum

dim shared as long direction
direction=up

sub sort(s As string,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As ubyte x =S[(I+J)\2]
    While  I <= J
    if direction=down then
        While S[I] > X:I+=1:Wend
        While S[J] < X:J-=1:Wend
    else
        While S[I] < X:I+=1:Wend
        While S[J] > X:J-=1:Wend
    end if
    If I<=J Then   
    Swap S[I],S[J]'todo  save the swaps i and j
    I+=1:J-=1
    end if
    wend
    If J > begin Then sort(S,begin,J)
    If I < Finish Then sort(S,I,Finish)
End sub

#define range(f,l) int(Rnd*((l+1)-(f))+(f))

dim as string f=string(500000,0)
for n as long=0 to len(f)-1
    f[n]=range(65,122)
    next


dim as double t=timer,t2
sort(f,0,len(f)-1)

print f
print "Length ";len(f)
var c=pack(f)
print
print
print c
print "Compressed length  "; len(c)
print "compression  ";len(c)/len(f)

var orig=unpack(c)
print "Decompress length "; len(orig)
t2=timer
print "Total time  ";t2-t

print "Done"


sleep


 

Return to “General”

Who is online

Users browsing this forum: No registered users and 14 guests