Squares

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

Re: Squares

Postby albert » May 13, 2019 23:26

@Richard

I figured out how to compress data to the maximum....You turn each byte into a number of zeros , or a number of ones.

A megabyte string , compresses down , to just a few bytes..
But you don't know where 1 byte ends and then next begins..If you put in a separator , it doesn't compress...
jj2007
Posts: 1215
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: Squares

Postby jj2007 » May 14, 2019 1:13

albert wrote:A megabyte string , compresses down , to just a few bytes..
That's a really good start! If you are stuck with the details of decompression, here is some reading for you.
albert
Posts: 4952
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » May 15, 2019 17:11

@Richard
@Dodicat

I came up with a "lossey Compression" it compresses down to 97%..

It turns the data into binary , and then replaces all the "00's" with "01's"

The input data needs to be several kilobytes for it to compress.. it doens't work on hundreds...


Code: Select all


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

Namespace Zlibrary

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

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


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

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

End Namespace


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

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        For n As Long = 1 To 10000
            s+=chr(Int(Rnd*256))'+48)
        Next
        compare =  s
        length = len(s)
    else
        'modify compression to make further compression possible
       
        s = compress_loop(s)
       
    end if
    check = s
    compression = (100 - ( 100 / ( length / len(check) ) ))
   
    Print "original string"
    Print Len(s)
    Print
   
    Dim As String compressed=Zlibrary.pack(s)
    s = compressed
   
    Print "packed string "
    Print Len(compressed)
    Print
   
    Dim As String uncompressed=Zlibrary.unpack(compressed)
   
    Print "Retrieve"
    Print Len(uncompressed)
    Print
    'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
    Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
    Print Iif(uncompressed=check,"OK","ERROR")
    Print "-------------------------------"
   
    'sleep 1000
   
    'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do
   
    print "press a key for next compression."
    print
    print "press esc to exit."
    sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 20

print "Press a key to decompress." 
sleep

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

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

comp = Zlibrary.unpack(comp)

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

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string zeros= string(8,"0")
    for a as longint = 1 to len(chrs) step 1
        binari+=right(zeros + bin(chrs[a-1]),8)
    next
   
    'print "inp = "; len(binari) , binari
   
    dim as string outputs = binari
    dim as string n1
    for a as longint = 1 to len(binari) step 2
        n1 = mid(binari,a,2)
        if n1 = "00" then mid(outputs,a,2) = "01"
    next
   
    'print "out = "; len(outputs) , outputs
   
    dim as string final_out= ""
    for a as longint = 1 to len(outputs) step 8
        final_out+= chr(val("&B"+mid(outputs,a,8)))
    next
   
    'print "out = " ; len(final_out) , final_out
   
    return final_out
   
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as string binari=""
    for a as longint = 0 to len(chrs)-1 step 1
        binari+=right("00000000"+bin(chrs[a]),8)
    next
   
    'print "len = " ; len(binari) , binari

    dim as string final_out = chrs
   
    return final_out
   
end function

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

Re: Squares

Postby albert » May 17, 2019 3:36

@Richard

I got lossless compression working...Compresses 10,000 bytes , down to under 100 bytes..
I can't post the code.. I need to copyright it or patent it..

After several days and hours and hours of playing with the zlib compressor , I finally figured out how to trick it , into compressing random data..
Richard
Posts: 2953
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Postby Richard » May 17, 2019 15:02

@albert.
I believe in the science of information theory which says that you cannot compress truly random data.
I think you have tricked yourself, not Zlib.
albert
Posts: 4952
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » May 18, 2019 1:07

@Richard

The compressor works. I just can't figure out how to decompress it.

I'll go ahead and post it.

you have , stepping by 2 bits
00
01
10
1

So it turns 8 bits into 7 , so it compresses , and 11 is the most prolific set... so 10,000 compresses to under 9,000 on the first run.

10-01 has 00
10-10 has 101
01-01 has 101

So i'm confused about decompression..
You can put "000" as the first set, but it doesn't compress as much , but solves the "00" issue.

I can't figure out the "101" issue...

Code: Select all


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

Namespace Zlibrary

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

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


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

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

End Namespace


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

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        For n As Long = 1 To 10000
            s+=chr(Int(Rnd*256))'+48)
        Next
        compare =  s
        length = len(s)
    else
        'modify compression to make further compression possible
       
        s = compress_loop(s)
       
    end if
    check = s
    compression = (100 - ( 100 / ( length / len(check) ) ))
   
    Print "original string"
    Print Len(s)
    Print
   
    Dim As String compressed=Zlibrary.pack(s)
    s = compressed
   
    Print "packed string "
    Print Len(compressed)
    Print
   
    Dim As String uncompressed=Zlibrary.unpack(compressed)
   
    Print "Retrieve"
    Print Len(uncompressed)
    Print
    'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
    Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
    Print Iif(uncompressed=check,"OK","ERROR")
    Print "-------------------------------"
   
    'sleep 1000
   
    'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do
   
    print "press a key for next compression."
    print
    print "press esc to exit."
    sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 20

print "Press a key to decompress." 
sleep

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

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

comp = Zlibrary.unpack(comp)

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

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string zeros= string(8,"0")
    for a as longint = 1 to len(chrs) step 1
        binari+=right(zeros + bin(chrs[a-1]),8)
    next
   
    'print "inp = "; len(binari) , binari
   
    dim as string outputs = ""
    dim as string n1
    for a as longint = 1 to len(binari) step 2
        n1 = mid(binari,a,2)
        if n1 = "00" then outputs+ = "00"
        if n1 = "01" then outputs+ = "01"
        if n1 = "10" then outputs+ = "10"
        if n1 = "11" then outputs+ = "1"
    next
   
    'print "out = "; len(outputs) , outputs
   
    dim as ubyte count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(outputs)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then outputs+= "0" : count+=1
    loop until dec1=0
   
    dim as string final_out= ""
    for a as longint = 1 to len(outputs) step 8
        final_out+= chr(val("&B"+mid(outputs,a,8)))
    next
   
    final_out = chr(count) + final_out
   
    'print "out = " ; len(final_out) , final_out
   
    return final_out
   
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as ubyte count = asc(left(chrs,1))
    chrs = mid(chrs,2)
   
    dim as string binari=""
    for a as longint = 0 to len(chrs)-1 step 1
        binari+=right("00000000"+bin(chrs[a]),8)
    next
   
    binari = left(binari,len(binari)-count)
   
    'print "len = " ; len(binari) , binari

    dim as string final_out = chrs
   
    return final_out
   
end function

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

Re: Squares

Postby Richard » May 18, 2019 1:46

Albert wrote:I got lossless compression working...
Albert wrote:The compressor works. I just can't figure out how to decompress it.
Then it is simply another a "hash function". It is not "lossless compression".
albert
Posts: 4952
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » May 18, 2019 2:20

@Richard

I was trying to use the instr() function to search for the sets..

10-10 has a 10 and 01
01-01 has a 01 and 10

01-10 solves out okay..

I've been racking my brain , how to solve it by stepping through the data..

Because it only uses a single 1 for the "11" set. you can't step through the data by 2's. so it's not systematic..

I'm sure there's a way to accomplish it. I'm just stupid and fumbling...

But you know that any numbers of 1's , that's not followed by a 0 , solve out to "11's"
I think you didn't run the code and look into it , before you called it a hash function..

if you step through it by 1's when you run into a 0 you need to read ahead to see if its a 1001 or a 1010 or a 0110 or a 0101..
I just can't seem to wrap my head around the concept to solve it...

if n1 = "00" then outputs+ = "000"
if n1 = "01" then outputs+ = "010"
if n1 = "10" then outputs+ = "10"
if n1 = "11" then outputs+ = "1"

compresses but requires 40+ loops
dodicat
Posts: 5913
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » May 18, 2019 22:52

Not 100% sure of your requirements Albert.
Here is a string tally function.

Code: Select all

 
Function TALLY(SomeString As String,PartString As String,a() As Integer) As Long
    Dim As Long LenP=Len(PartString),count
    Dim As Long position=Instr(SomeString,PartString)
    If position=0 Then Return 0
    While position>0
        count+=1
        position=Instr(position+LenP,SomeString,PartString)
    Wend
    Redim a(1 To count)
    Var u=count
    position=Instr(SomeString,PartString)
    a(1)=position
    count=1
    While count < u
        count+=1
        position=Instr(position+LenP,SomeString,PartString)
        a(count)=position
    Wend
    Return u
End Function

screen 12

dim as ulongint u=-1
u=u\1000000
dim as string b=bin(u)

dim as long flag
for n as long=0 to len(b)-1
    if n<len(b) then
    if b[n]=asc("0") and b[n+1] = asc("1") then color 4 :flag=1
    end if
print chr(b[n]);
flag+=1
if flag=3 then color 15:flag=0
next
print

redim as integer a()
var t=tally(bin(u),"01",a())

print "position of 01 in string"
for n as long=lbound(a) to ubound(a)
    print a(n)
next
print
print "number of occurrencies = ";t
print "Length of string ";len(b)
sleep
 
albert
Posts: 4952
Joined: Sep 28, 2006 2:41
Location: California, USA

Data Compression

Postby albert » May 19, 2019 19:05

@Dodicat

I need to find the stray "1's" that expand to "1111"

See compress_loop() , I need to write a decompressor

Code: Select all


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


screen 19

dim as double time1,time2,time3,time4
do
   
    randomize
   
    dim as string s=""
    For n As Long = 1 To 10
        s+=chr(Int(Rnd*256))'+48)
    Next
   
    time1=timer
    'begin compress
        dim as string comp = compress_loop(s)
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = decompress_loop(comp)
    'end decompress
    time4 = timer
   
    print
    print string(99,"=")
    print s
    print string(99,"=")
    print 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."
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string zeros= string(8,"0")
    for a as longint = 1 to len(chrs) step 1
        binari+=right(zeros + bin(chrs[a-1]),8)
    next
   
    print "comp in  = " ; len(binari) ; "    " ; binari
   
    dim as string outputs = ""
    dim as string n1
    for a as longint = 1 to len(binari) step 4
        n1 = mid(binari,a,4)
        if n1="1111" then outputs+= "1" else outputs+=n1
    next
   
    print "comp out = "; len(outputs) ; "    " ; outputs
   
    dim as ubyte count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(outputs)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then outputs+= "0" : count+=1
    loop until dec1=0
   
    dim as string final_out= ""
    for a as longint = 1 to len(outputs) step 8
        final_out+= chr(val("&B"+mid(outputs,a,8)))
    next
   
    final_out = chr(count) + final_out
   
    'print "out = " ; len(final_out) , final_out
   
    return final_out
   
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as ubyte count = asc(left(chrs,1))
   
    chrs=mid(chrs,2)
   
    dim as string binari=""
    dim as string zeros= string(8,"0")
    for a as longint = 1 to len(chrs) step 1
        binari+=right(zeros + bin(chrs[a-1]),8)
    next
   
    binari = left(binari,len(binari)-count)
   
    print "decomp   = " ; len(binari) ; "    " ; binari
   
   
    dim as string final_out = chrs
   
    'for a as longint = 1 to len(outs) step 8
    '    final_out+= chr(val("&B"+mid(outs,a,8)))
    'next
   
    return final_out
   
end function

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

Re: Squares

Postby albert » May 24, 2019 17:04

I figured out a formula....

But it takes like 200 loops to compress 90%
I'm working on the de-compressor...

Code: Select all


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

Namespace Zlibrary

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

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


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

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

End Namespace


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

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        For n As Long = 1 To 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."
    print
    print "press esc to exit."
    'sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 200

print "Press a key to decompress." 
sleep

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

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

comp = Zlibrary.unpack(comp)

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

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string zeros="00000000"
    dim as string n1
    for a as longint = 1 to len(chrs) step 1
        n1 = bin(chrs[a-1])
        binari+= right( zeros + n1,8)
    next
   
    'print "bin   = " ; len(binari) , binari
   
    dim as ubyte count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(binari)/64)
        dec1=instr(1,str1,".")
        if dec1<>0 then binari = "0" + binari : count+=1
    loop until dec1=0
   
    dim as string outs1=""
    dim as string map =""
    dim as ulongint v1
    for a as longint = 1 to len(binari) step 64
        v1 = valulng("&B"+mid(binari,a,64))
        if v1<= (2^63) then
            outs1+=right(string(63,"0")+bin(v1),63)
            map+="1"
        else
            map+="0"
            outs1+=right(string(63,"0")+bin(v1-((2^63)+1)),63)
        end if
    next
   
    'print "outs1 = " ; len(outs1) , outs1
    'print "map   = " ;  len(map) , map
   
    dim as ubyte count1=0
    do
        str1=str(len(map)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then map+="0":count1+=1
    loop until dec1=0
   
    dim as ubyte count2=0
    do
        str1=str(len(outs1)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then outs1+="0":count2+=1
    loop until dec1=0
   
   
    dim as string out1=""
    for a as longint = 1 to len(map) step 8
        out1+=chr(val("&B"+mid(map,a,8)))
    next
   
    dim as string out2=""
    for a as longint = 1 to len(outs1) step 8
        out2+=chr(val("&B"+mid(outs1,a,8)))
    next
   
    dim as string final_out = chr(count) + chr(count1) + chr(count2) + out1 + "END" + out2
   
    'print "fin   = " ; len(final_out) ', final_out
   
    return final_out
       
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as ubyte count = asc(left(chrs,1))
    chrs=mid(chrs,2)
    dim as ubyte count1 = asc(left(chrs,1))
    chrs=mid(chrs,2)
    dim as ubyte count2 = asc(left(chrs,1))
    chrs=mid(chrs,2)
   
    dim as string outs1 = left(chrs,instr(1,chrs,"END")-1)
    dim as string outs2 = mid(chrs,instr(1,chrs,"END")+3)
   
    dim as string out1=""
    for a as longint = 1 to len(outs1) step 1
        out1+=right("00000000" + bin(outs1[a-1]),8)
    next
    out1=left(out1,len(out1)-count1)
   
    dim as string out2=""
    for a as longint = 1 to len(outs2) step 1
        out2+=right("00000000" + bin(outs2[a-1]),8)
    next
    out2=left(out2,len(out2)-count2)
   
    'print "out1 = " ; len(out1) , out1
    'print "out2 = " ; len(out2)  , out2
   
   
    dim as string final_out = chrs
   
    return final_out
   
end function

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

Re: Squares

Postby albert » May 24, 2019 18:55

@Dodicat

I can't seem to get the de-compressor working.. Can you help??

Code: Select all


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


screen 19

dim as double time1,time2,time3,time4
do
   
    randomize
   
    dim as string s=""
    For n As Long = 1 To 10
        s+=chr(Int(Rnd*256))'+8)
    Next
   
    time1=timer
    'begin compress
        dim as string comp = compress_loop(s)
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = decompress_loop(comp)
    'end decompress
    time4 = timer
   
    print
    print string(99,"=")
    'print s
    print string(99,"=")
    'print 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."
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string zeros="00000000"
    dim as string n1
    for a as longint = 1 to len(chrs) step 1
        n1 = bin(chrs[a-1])
        binari+= right( zeros + n1,8)
    next
   
    print "bin   = " ; len(binari) , binari
   
    dim as ubyte count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(binari)/64)
        dec1=instr(1,str1,".")
        if dec1<>0 then binari+= "0" : count+=1
    loop until dec1=0
   
    dim as string outs1=""
    dim as string map =""
    dim as ulongint v1
    for a as longint = 1 to len(binari) step 64
        v1 = valulng("&B"+mid(binari,a,64))
        if v1> (2^63) then
            v1-=((2^63)+1)
            map+="1"
        else
            map+="0"
        end if
        outs1+=right(string(63,"0")+bin(v1),63)
    next
   
    print "outs1 = " ; len(outs1) , outs1
    print "map  = " ;  len(map) , map
   
    dim as ubyte count1=0
    do
        str1=str(len(map)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then map = "0"+ map : count1+=1
    loop until dec1=0
   
    dim as ubyte count2=0
    do
        str1=str(len(outs1)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then outs1 ="0" + outs1 : count2+=1
    loop until dec1=0
   
   
    dim as string out1=""
    for a as longint = 1 to len(map) step 8
        out1+=chr(val("&B"+mid(map,a,8)))
    next
   
    dim as string out2=""
    for a as longint = 1 to len(outs1) step 8
        out2+=chr(val("&B"+mid(outs1,a,8)))
    next
   
    dim as string final_out = chr(count) + chr(count1) + chr(count2) + out1 + "END" + out2
   
    print "fin   = " ; len(final_out) , final_out
   
    return final_out
       
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as ubyte count = asc(left(chrs,1))
    chrs=mid(chrs,2)
    dim as ubyte count1 = asc(left(chrs,1))
    chrs=mid(chrs,2)
    dim as ubyte count2 = asc(left(chrs,1))
    chrs=mid(chrs,2)
   
    dim as string outs1 = left(chrs,instr(1,chrs,"END")-1)
    dim as string outs2 = mid(chrs,instr(1,chrs,"END")+3)
   
    dim as string out1=""
    for a as longint = 1 to len(outs1) step 1
        out1+=right("00000000" + bin(outs1[a-1]),8)
    next
    out1=mid(out1,count1+1)
   
    dim as string out2=""
    for a as longint = 1 to len(outs2) step 1
        out2+=right("00000000" + bin(outs2[a-1]),8)
    next
    out2=mid(out2,count2+1)
   
    dim as string map = out1
   
    print "map  = " ; len(map) , map
    print "out2 = " ; len(out2)  , out2
   
    dim as longint map_loc = 1
    dim as ulongint v1
    dim as string binari=""
    for a as longint = 1 to len(out2) step 63
       
        v1 = valulng("&B"+mid(out2,a,63))
       
        if mid(map,map_loc,1) = "1" then v1+=((2^63)+1)
        map_loc+=1
       
        binari+=right(string(64,"0")+bin(v1),64)
    next
   
    binari = left(binari,len(binari)-count)
   
    print "bin   = " ; len(binari) , binari
   
    dim as string final_out = ""
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(val("&B"+mid(binari,a,8)))
    next
   
    final_out=trim(final_out,chr(0))
   
    return final_out
   
end function

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

Re: Squares

Postby albert » May 24, 2019 20:37

@Dodicat

I got the de-compressor working, but now it doesn't compress...

if v1 > (2^63) then v1-= (2^63)+1 , was returning a e+18 value , so it was writing 0's into the string, which allowed it to compress.

Code: Select all


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


screen 19

dim as double time1,time2,time3,time4
do
   
    randomize
   
    dim as string s=""
    For n As Long = 1 To 10
        s+=chr(Int(Rnd*256))'+8)
    Next
   
    time1=timer
    'begin compress
        dim as string comp = compress_loop(s)
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = decompress_loop(comp)
    'end decompress
    time4 = timer
   
    print
    print string(99,"=")
    'print s
    print string(99,"=")
    'print 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."
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string zeros="00000000"
    dim as string n1
    for a as longint = 1 to len(chrs) step 1
        n1 = bin(chrs[a-1])
        binari+= right( zeros + n1,8)
    next
   
    print "bin   = " ; len(binari) , binari
   
    dim as ubyte count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(binari)/64)
        dec1=instr(1,str1,".")
        if dec1<>0 then binari+= "0" : count+=1
    loop until dec1=0
   
    dim as string outs1=""
    dim as string map =""
    dim as ulongint v1
    dim as ulongint v2 = (2^63) + 1
    for a as longint = 1 to len(binari) step 64
        v1 = valulng("&B"+mid(binari,a,64))
        if v1 > (2^63) then
            v1-=v2
            map+="1"
        else
            map+="0"
        end if
        outs1+=right(string(63,"0")+bin(v1),63)
    next
   
    print "outs1 = " ; len(outs1) , outs1
    print "map  = " ;  len(map) , map
   
    dim as ubyte count1=0
    do
        str1=str(len(map)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then map+= "0" : count1+=1
    loop until dec1=0
   
    dim as ubyte count2=0
    do
        str1=str(len(outs1)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then outs1+="0" : count2+=1
    loop until dec1=0
   
   
    dim as string out1=""
    for a as longint = 1 to len(map) step 8
        out1+=chr(val("&B"+mid(map,a,8)))
    next
   
    dim as string out2=""
    for a as longint = 1 to len(outs1) step 8
        out2+=chr(val("&B"+mid(outs1,a,8)))
    next
   
    dim as string final_out = chr(count) + chr(count1) + chr(count2) + out1 + "END" + out2
   
    print "fin   = " ; len(final_out) , final_out
   
    return final_out
       
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as ubyte count = asc(left(chrs,1))
    chrs=mid(chrs,2)
    dim as ubyte count1 = asc(left(chrs,1))
    chrs=mid(chrs,2)
    dim as ubyte count2 = asc(left(chrs,1))
    chrs=mid(chrs,2)
   
    dim as string outs1 = left(chrs,instr(1,chrs,"END")-1)
    dim as string outs2 = mid(chrs,instr(1,chrs,"END")+3)
   
    dim as string out1=""
    for a as longint = 1 to len(outs1) step 1
        out1+=right("00000000" + bin(outs1[a-1]),8)
    next
    out1 = left(out1,len(out1)-count1)
   
    dim as string out2=""
    for a as longint = 1 to len(outs2) step 1
        out2+=right("00000000" + bin(outs2[a-1]),8)
    next
    out2 = left(out2,len(out2)-count2)

    dim as string map = out1
   
    print "map  = " ; len(map) , map
    print "out2 = " ; len(out2)  , out2
   
    dim as longint map_loc = 1
    dim as ulongint v1
    dim as ulongint v2 = (2^63) + 1
    dim as string binari=""
    for a as longint = 1 to len(out2) step 63
       
        v1 = valulng("&B"+mid(out2,a,63))
       
        if mid(map,map_loc,1) = "1" then v1+=v2
        map_loc+=1
       
        binari+=right(string(64,"0")+bin(v1),64)
    next
   
    binari = left(binari,len(binari)-count)
   
    print "bin   = " ; len(binari) , binari
   
    dim as string final_out = ""
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(val("&B"+mid(binari,a,8)))
    next
   
    return final_out
   
end function

coderJeff
Site Admin
Posts: 3020
Joined: Nov 04, 2005 14:23
Location: Ontario, Canada
Contact:

Re: Squares

Postby coderJeff » May 25, 2019 14:54

Hi albert, this is in reference to an earlier post, but I think the issue is relevant for your most recent incarnation as well. Sorry, I didn't analyze your newest.

When compressing, if you replace some pattern, word, sequence (what ever you want to call it), and it duplicates a pattern that can already exist, the information about it is lost forever.

For example, in a previous version of your compressor, translating the sequence:
"11110001" => "10001"
"10001111" => "10001"
From the output, you can never know which was the original sequence.

In a lot of the questions and bug reports from users about fbc, users are only looking at the end-points; from written code to program output. They don't really understand the in between parts. And why should they? Maybe the documentation was poor, maybe there is a bug in the compiler, etc. But if one is writing the algorithm, then it would be worthwhile to understand the in between parts. What's happening at each step? If there is no understanding there, then it's just a trial-and-error approach, which I think is what you are experiencing, when compressor/decompressor works/doesn't work, but don't know why.
albert
Posts: 4952
Joined: Sep 28, 2006 2:41
Location: California, USA

DATA COMPRESSION

Postby albert » May 25, 2019 18:47

@Richard
@Dodicat
@CoderJeff

I finally got "real-life" , lossless data compression.....But , I'm a little confused about writing the de-compression..
It turns out to be a simple Simon formula..

It only works on data sizes , less than 65,535 bytes. It uses ushort location pointers..

Richard or Dodicat or someone else , can you write the de-compressor??

You can do data up to 100,000 bytes if you do : outs(v1)+=mkshort( a \ 2 ) instead of mkshort( a )

[ i edited it with mkl( a ) and it still compresses..] So now it can do files up to MKL length.

Code: Select all


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

Namespace Zlibrary

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

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


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

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

End Namespace


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

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
do
   
    loops+=1
   
    'one time run , create initial string
    if loops = 1 then
        For n As Long = 1 To 10000
            s+=chr(Int(Rnd*256))'+48)
        Next
        compare =  s
        length = len(s)
    else
        'modify compression to make further compression possible
       
        s = compress_loop(s)
       
    end if
    check = s
    compression = (100 - ( 100 / ( length / len(check) ) ))
   
    Print "original string"
    Print Len(s)
    Print
   
    Dim As String compressed=Zlibrary.pack(s)
    s = compressed
   
    Print "packed string "
    Print Len(compressed)
    Print
   
    Dim As String uncompressed=Zlibrary.unpack(compressed)
   
    Print "Retrieve"
    Print Len(uncompressed)
    Print
    'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
    Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
    Print Iif(uncompressed=check,"OK","ERROR")
    Print "-------------------------------"
   
    'sleep 1000
   
    'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do
   
    print "press a key for next compression."
    print
    print "press esc to exit."
    sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 20

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
   
    'works for files up to 65535 bytes
   
    redim as string outs(0 to 65535)
    dim as ulongint v1
    for a as longint = 1 to len(chrs) step 2
        v1 = cvs(mid(chrs,a,2))
        outs(v1)+=mkl(a)
    next
   
    dim as string final_out=""
    for a as longint = 0 to 65535
        final_out+=outs(a) + "_"
    next
   
    print "fin = "; len(final_out)
   
   
    return final_out
       
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as string final_out = chrs
   
    return final_out
   
end function



[ edited ]

I might be jumping the gun , here , But i emailed the compressor to DARPA , they might think it's useful ?? Might get a job??

Return to “General”

Who is online

Users browsing this forum: No registered users and 47 guests