Squares

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

Re: Squares

Postby albert » Jun 03, 2019 18:31

I got it fixed...

Here it is again....
Somehow ; dropping the 64th bit , makes a big difference over multiple loops...

Here's 8000 bytes over 40 loops

Code: Select all


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

screen 19

dim as double time1,time2,time3,time4
do
   
    randomize
   
    dim as string s=""
    For n As Long = 1 To 8*1000
        s+=chr(Int(Rnd*256))'+8)
    Next
   
    time1=timer
    'begin compress
        dim as string comp=s
        for a as longint = 1 to 40 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 40 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
    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
    print
    print
    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
   
   
    if len(chrs) mod 8 > 0 then chrs+= string( ( 8 - len(chrs) mod 8 ) , chr(0))
   
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as string zeros = string(64,"0")
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = bin(*ubp) : ubp+=1
        n1 = right(zeros+n1,64)
        n1 = left(n1,63)
        binari+=n1
    next
   
    'print "c  in = "  ; len(chrs)
    'print "c bin = "  ; len(binari), binari
   
    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
    loop until dec1=0
   
    dim as string final_out =""
    for a as longint = 1 to len(binari) step 64
        final_out+=mklongint(valulng("&B"+mid(binari,a,64)))
    next
   
    print "c out = "; len(final_out)
       
    return final_out
       
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
   
    'print "d  in = "  ; len(chrs)
   
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as string zeros=string(64,"0")
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
       
        n1 = bin(*ubp) : ubp+=1
       
        n1=right(zeros+ n1,64)
       
        'print "n1 = "; n1
       
        binari+=n1
       
    next
   
    binari = mid(binari , (len(binari) mod 63) +1)
   
    'print "d bin = "  ; len(binari) , binari
   
    dim as string outputs=""
    for a as longint = 1 to len(binari) step 63
        n1=mid(binari,a,63) + "1"
        outputs+=n1
    next
   
    dim as string final_out = ""
    for a as longint = 1 to len(outputs) step 64
        final_out+=mklongint(valulng("&B"+mid(outputs,a,64)))
    next
   
    'print "d out = "; len(final_out)
   
   final_out = rtrim(final_out,chr(0))
   
    return final_out

end function

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

Re: Squares

Postby badidea » Jun 03, 2019 19:31

Try 400 'compression' loops, and your compressed data looks like this:

0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 103 97 111 0 0 0 0 0 201 242 10 231 153 61 48 116 0
albert
Posts: 5017
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jun 03, 2019 22:02

@badidea

You have to quit looping when the outputs is the same length as the input.

@Richard
I'm trying to reverse an "AND" formuia, any ideas??

when n2 < input output is correct when n2 = input output is 2 higher??

Code: Select all


screen 19

do
     
     dim as ulongint n1 = int(rnd*256)
     
     dim as ulongint n2 = n1 and not 2
     
     print
     print "n1" ,, "n1 and not 2" ,,  "1- (n2 xor not 2)"
     print  n1   ,,         n2             ,,  -1 - (n2 xor not 2)
     
     sleep
     
loop until inkey = chr(27)

sleep
end

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

Re: Squares

Postby Richard » Jun 03, 2019 22:46

@albert
Bitwise logic; z = ( x AND y ). Given input y and output z, solve for input x.

It is obvious that the AND function cannot be reversed when a bit position in both y and z are zero.
That should not stop you from trying to solve it, but I cannot help you to do the impossible.
albert
Posts: 5017
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jun 04, 2019 0:25

Here's ( val AND NOT 2 ) , it compresses down to 93.7% ( 10K to 600 bytes after 40 loops. )

I've been analyzing the formula, and it seems to be variable..
It's not consistently off by a value every so many numbers..
it sometimes skips 2 or 3 times and then equals..Sometimes it equals two times in a row and sometimes equals every 3 or 4 times ..
I've been analyzing the output and so far can't come up with a reversal formula.. ( i'll keep working on it. )

I tried comparing the output with mods and xor's and or's ,
Thinking that ; at some values it would be off and certain values it would be equal.. But it seems to be completely inconsistent.

Here's the 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
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 = 40

print "Press a key to decompress." 
sleep

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

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

comp = Zlibrary.unpack(comp)

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

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
       
        n1 = str(*ubp) : ubp+=1
       
        n1 = bin( val(n1) and not 2)
       
        n1 = right(string(8,"0") +n1,8)
       
        binari+=n1
   
    next
   
    print "inp = "  ; len(chrs)
    print "bin = "  ; len(binari) ', binari
   
    dim as string final_out =""
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(valulng("&B"+mid(binari,a,8)))
    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

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

Re: Squares

Postby albert » Jun 04, 2019 2:10

I redid the ( val AND NOT 2 ) code... to progress from 0 to 255...

The output follows a pattern... 0 1 0 1 , 4 5 4 5 , 8 9 8 9 , 12 13 12 13 etc... iterating by 2's.. Incrementing by 4 each set. 0 , 4 , 8 , 12 , 16 , 20

Is there a way to reverse it Richard??


Code: Select all


screen 19

do
     
     for n1 as longint = 0 to 255
         
     dim as ulongint n2 = n1 and not 2
     
     dim as ulongint n3 =  -1 - (n2 xor not 2)
     
     print
     print "n1" ,, "n1 and not 2" ,,  "1- (n2 xor not 2)"
     print  n1   ,,         n2             ,,   n3  , ,   (n2 mod 2) +n2
     
     sleep
    if inkey = chr(27) then end
    next
   
loop until inkey = chr(27)

end

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

Re: Squares

Postby dodicat » Jun 04, 2019 17:05

The values are paired.
Create a look up table and get both values.

Code: Select all


Dim As Long lookup(255)


For n1 As Long = 0 To 255 'create lloup
    lookup(n1)=n1 And Not 2
Next


For n As Long=Lbound(lookup) To Ubound(lookup) 'show lookup
    If n Mod 20=0 Then Print
    If n Mod 4=0 Then Color 5
    If n Mod 8=0 Then Color 15
    Print lookup(n);" ";
Next
 Color 15
Print
Print

Type pair
    As Long n1,n2
End Type

Function find(a() As Long,n As Long) As pair
    Redim As Long c(0)
    For i As Long=Lbound(a) To Ubound(a)
        If a(i)=n Then Redim Preserve c(1 To Ubound(c)+1):c(Ubound(c))=i
    Next i
    If Ubound(c)=2 Then
        Return Type<pair>(c(1),c(2))
    Else
        Return Type<pair>(-1,-1)  'failure
    End If
End Function


'Randomize   'test
Print " n1 (random)";Tab(20);"n1 values(returned)"
Print
For n As Long=1 To 100
    Var x1=Int(Rnd*255) 
    Var y=x1 And Not 2
    Dim As pair p=find(lookup(),y)
    Print x1;Tab(20);p.n1,p.n2
Next
Print ". . ."
Sleep

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

Re: Squares

Postby albert » Jun 04, 2019 18:51

@Richard
@Dodicat

Back to the drawing board!!
albert
Posts: 5017
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jun 04, 2019 23:43

The goal is to create a 1:1 or slightly less formula , that will compress further..
albert
Posts: 5017
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jun 05, 2019 1:09

@Richard
@Dodicat

I finally got a formula that works...

Except it varies , each loop.
Sometimes it compresses a loop and sometimes it expands a loop...
But mostly is compresses , but sometimes not...It's variable.

I haven't yet wrote the de-compressor...
For the de-compressor , it's just searching for the 0's and setting the bits that occur before the "0"...

it creates a string map = "12345678"
Then bubble sorts the input bits , swapping the input bits and the map locs.. then finding the first 1 input bits and taking that map position..
Then stepping through the map , by 2 digits at a time , and turning it into a chr()
If the map has 2 or more zeros in a row then you know to create 8 zeros.

Here it is ; doing 100 loops of 10K


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 = 100

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 n1
    dim as string zeros = string(8,"0")
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
        n1 = bin(*ubp) : ubp+=1
        n1 = right(zeros+n1,8)
       
        dim as string map=""
        for b as longint =  1 to 8
            map+=str(b)
        next
           
        for b as longint = 0 to 7
            for c as longint = 0 to 7
                if n1[b] <  n1[c] then
                    swap     n1[b] ,    n1[c]
                    swap map[b] , map[c]
                end if
            next
        next
       
        dim as longint place = instr(1,n1,"1")
        map = mid(map,place)
        binari+= map + "0"
    next
   
    print "c bin = "  ; len(binari) ', binari
   
    dim as string final_out = ""
    for a as longint = 1 to len(binari) step 2
        final_out+=chr(valulng(mid(binari,a,2)))
    next
   
    print "c out = "; 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

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

Re: Squares

Postby albert » Jun 05, 2019 2:04

It doesn't work after all.......

dim as string binari=""
dim as string n1
dim as string zeros = string(8,"0")
dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
for a as longint = 1 to len(chrs) step 1

Had ulongint ptr "ubp" instead of ubyte ptr..

With ubyte ptr is constantly expands the data...

Back to the drawing board!!!
albert
Posts: 5017
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jun 05, 2019 2:12

How would you swap the map bytes???

Code: Select all

   
    dim as string chrs = "12345678901234567890"
   
    dim as string binari=""
    dim as string n1
    dim as string zeros = string(64,"0")
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
        n1 = bin(*ubp) : ubp+=1
        n1 = right(zeros+n1,64)
       
        dim as string map=""
        for b as longint =  1 to 64
            map+=right("00"+ str(b),2)
        next
           
        for b as longint = 0 to 63
            for c as longint = 0 to 63
                if n1[b] <  n1[c] then
                    swap n1[b] , n1[c]
                    swap map[b] , map[c]  ' map = 2 bytes how would you swap the map locations????
                end if
            next
        next
       
        dim as longint place = instr(1,n1,"1")
        map = mid(map,place)
        binari+= map + "0"
    next
       
albert
Posts: 5017
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jun 05, 2019 18:24

I got compression... There's no stupid errors in the code this time...

The delema is : that after you create the "map" , the input "binari" string , is holding some stray zeros.

It searches the input "binari" string for "11" , "10" , "01" , "00" and puts a 4,3,2 or 1 in the map at that location.
The search and replace , leaves some stray zeros in the input string...

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 = 40

print "Press a key to decompress." 
sleep

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

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

comp = Zlibrary.unpack(comp)

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

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string n1
    dim as string zeros = string(64,"0")
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = bin(*ubp) : ubp+=1
        n1 = right(zeros+n1,64)
        binari+= n1
    next
   
    print "c inp = "  ; len(chrs) ', binari
    print "c bin = "  ; len(binari) ', binari
   
   dim as string map = string(len(binari),chr(0))
   for a as longint = 3 to 0 step -1
       n1 = right("00"+bin(a),2)
       dim as longint place=0
       do
           place=instr(place+1,binari,n1)
           mid(binari,place,2) = string(2,chr(0))
           mid(map,place,1) = str(a+1)
        loop until place=0
    next
   
    'After map , binari is holding some stray zeros... What to do?
   
    dim as string outputs=""
    for a as longint = 1 to len(map) step 1
        n1 = mid(map,a,1)
        if n1<> chr(0) then outputs+=n1
    next
   
   print "c map = "  ; len(outputs) ', outputs
   
    dim as string final_out = ""
    for a as longint = 1 to len(outputs) step 2
        final_out+=chr(valulng(mid(outputs,a,2)))
    next
   
    print "c out = "; 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

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

Re: Squares

Postby albert » Jun 05, 2019 21:41

I've been playing around and trying to write a de-compressor..

There's no way to tell where the stray zeros are located..It can't be de-compressed..
albert
Posts: 5017
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jun 06, 2019 2:09

I got a formula that compresses.

The output bits don't have to be 8 bits , sometimes 9 , 10 or 11 bits or more will compress.

n1 = mid(binari,a,2)
if n1="00" then outputs+="1"
if n1="01" then outputs+="01"
if n1="10" then outputs+="001"
if n1="11" then outputs+="010"

I play around with dodicat's Zlib code. and when i get a formula that compresses , i put it into the test bed.. and try to write a de-compressor..

Here's Dodocat'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
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 = 40

print "Press a key to decompress." 
sleep

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

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

comp = Zlibrary.unpack(comp)

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

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string n1
    dim as string zeros = string(64,"0")
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = bin(*ubp) : ubp+=1
        n1 = right(zeros+n1,64)
        binari+= n1
    next
   
    print "c inp = "  ; len(chrs) ', binari
    print "c bin = "  ; len(binari) ', binari
   
    dim as string outputs=""
    for a as longint = 1 to len(binari) step 2
        n1=mid(binari,a,2)
        if n1="00" then outputs+="1"
        if n1="01" then outputs+="01"
        if n1="10" then outputs+="001"
        if n1="11" then outputs+="010"
    next
   
    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 "c out = "; 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



Here's the test bed , where i write the de-compressor

Code: Select all


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

screen 19

dim as double time1,time2,time3,time4
do
   
    randomize
   
    dim as string s=""
    For n As Long = 1 To 8
        s+=chr(Int(Rnd*256))'+8)
    Next
   
    time1=timer
    'begin compress
        dim as string comp=s
        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."
   
    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 n1
    dim as string zeros = string(64,"0")
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = bin(*ubp) : ubp+=1
        n1 = right(zeros+n1,64)
        binari+= n1
    next
   
    print "c inp = "  ; len(chrs) ', binari
    print "c bin = "  ; len(binari) , binari
   
    dim as string outputs=""
    for a as longint = 1 to len(binari) step 2
        n1=mid(binari,a,2)
        if n1="00" then outputs+="1"
        if n1="01" then outputs+="01"
        if n1="10" then outputs+="001"
        if n1="11" then outputs+="010"
    next
   
    print "c bin = "  ; 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 = str(count) + final_out
   
    print "c out = "; len(final_out)
       
    return final_out
       
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
       
    dim as ubyte count = val(left(chrs,1))
   
    chrs=mid(chrs,2)
   
   
    dim as string binari=""
    dim as string n1
    dim as string zeros = string(8,"0")
    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
        n1 = right(zeros+n1,8)
        binari+= n1
    next
   
    binari=left(binari,len(binari)-count)
   
    print "d bin = "  ; len(binari) , binari
   
    dim as string final_out = chrs
   
    return final_out

end function



The problem is the a 01 01 could be mistaken for a 010 1

Return to “General”

Who is online

Users browsing this forum: No registered users and 5 guests