Squares

[albert]

I tried to make it so you cant have any combos that equal other combos...

I modified the outputs , to make it easier to separate 3 bits vals , from 4 bit vals.

s1 = mid(bits,a,4)

if s1 = "0000" then outs1+="100"
if s1 = "0001" then outs1+="101"
if s1 = "0010" then outs1+="110"
if s1 = "0011" then outs1+="111"
if s1 = "0100" then outs1+="1001"
if s1 = "0101" then outs1+="1011"
if s1 = "0110" then outs1+="1101"

if s1 = "0111" then outs1+="0000"
if s1 = "1000" then outs1+="0001"
if s1 = "1001" then outs1+="0010"
if s1 = "1010" then outs1+="0011"
if s1 = "1011" then outs1+="0100"
if s1 = "1100" then outs1+="0101"
if s1 = "1101" then outs1+="0110"
if s1 = "1110" then outs1+="0111"

if s1 = "1111" then outs1+="1100"

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

dim shared as ubyte show = 1 'if doing larger than 8 bytes set show to 0

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
        if show = 0 then
            do
                dim as longint chk = len(comp) - 1
                comp = compress_loop(comp)
                if len(comp) >= chk then exit do
            loop
        else
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
        end if
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    'print "inp = " ; (s)
    print string(99,"=")
    'print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string bits = ""
    dim as string zeros = string(64,"0")
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    dim as string n1
    for a as longint = 1 to len(chrs) step 8
        n1 = zeros + bin(*ulp) : ulp+=1
        bits+=right(n1,64)
    next
    
    if show = 1 then print "c inp = "; len(bits) , bits

    dim as string outs1=""
    dim as string s1
    for a as longint = 1 to len(bits) step 4
        
        s1 = mid(bits,a,4)
        
        if s1 = "0000" then outs1+="100"
        if s1 = "0001" then outs1+="101"
        if s1 = "0010" then outs1+="110"
        if s1 = "0011" then outs1+="111"
        if s1 = "0100" then outs1+="1001"
        if s1 = "0101" then outs1+="1011"
        if s1 = "0110" then outs1+="1101"
        
        if s1 = "0111" then outs1+="0000"
        if s1 = "1000" then outs1+="0001"
        if s1 = "1001" then outs1+="0010"
        if s1 = "1010" then outs1+="0011"
        if s1 = "1011" then outs1+="0100"
        if s1 = "1100" then outs1+="0101"
        if s1 = "1101" then outs1+="0110"
        if s1 = "1110" then outs1+="0111"
        
        if s1 = "1111" then outs1+="1100"
        

    next
    
    if show = 1 then print "c out = "; len(outs1) , outs1
    
    dim as longint count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(outs1)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then outs1+="0" : count+=1
    loop until dec1=0
    
    dim as string final = ""
    for a as longint = 1 to len(outs1) step 8
        final+=chr(val("&B"+mid(outs1,a,8)))
    next
    
    final = chr(count) + final
    
    print "c fin = "; len(final) ' , final
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
    
    dim as longint count = asc(left(chrs,1))
    chrs = mid(chrs,2)

    dim as string bits = ""
    dim as string zeros = string(8,"0")
    dim as string n1
    for a as longint = 1 to len(chrs) step 1
        n1 = zeros + bin( chrs[a-1] )
        bits+=right(n1,8)
    next
    
    bits = left(bits,len(bits)-count)
    
    if show = 1 then print "d inp = "; len(bits) , bits
   
    return chrs

end function

[albert]

@Dodicat

I redid it again...

if it starts with a 0 then you know its 4 bits. If it starts with a 1 , it could be a 4 or 5

just telling 100 from 1000 and 1001 , and telling 101 from 1010 and 1011

Compresses 1,000,000 bytes , down to 3 digits....

s1 = mid(bits,a,4)

if s1 = "0000" then outs1+="100"
if s1 = "0001" then outs1+="101"
if s1 = "0010" then outs1+="110"
if s1 = "0011" then outs1+="111"

if s1 = "0100" then outs1+="0000"
if s1 = "0101" then outs1+="0001"
if s1 = "0110" then outs1+="0010"
if s1 = "0111" then outs1+="0011"
if s1 = "1000" then outs1+="0100"
if s1 = "1001" then outs1+="0101"
if s1 = "1010" then outs1+="0110"
if s1 = "1011" then outs1+="0111"

if s1 = "1100" then outs1+="1000"
if s1 = "1101" then outs1+="1001"
if s1 = "1110" then outs1+="1010"
if s1 = "1111" then outs1+="1011"

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

dim shared as ubyte show = 1 'if doing larger than 8 bytes set show to 0

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
        if show = 0 then
            do
                dim as longint chk = len(comp) - 1
                comp = compress_loop(comp)
                if len(comp) >= chk then exit do
            loop
        else
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
        end if
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    'print "inp = " ; (s)
    print string(99,"=")
    'print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string bits = ""
    dim as string zeros = string(64,"0")
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    dim as string n1
    for a as longint = 1 to len(chrs) step 8
        n1 = zeros + bin(*ulp) : ulp+=1
        bits+=right(n1,64)
    next
    
    if show = 1 then print "c inp = "; len(bits) , bits

    dim as string outs1=""
    dim as string s1
    for a as longint = 1 to len(bits) step 4
        
        s1 = mid(bits,a,4)
        
        if s1 = "0000" then outs1+="100"
        if s1 = "0001" then outs1+="101"
        if s1 = "0010" then outs1+="110"
        if s1 = "0011" then outs1+="111"
        
        if s1 = "0100" then outs1+="0000"
        if s1 = "0101" then outs1+="0001"
        if s1 = "0110" then outs1+="0010"
        if s1 = "0111" then outs1+="0011"
        if s1 = "1000" then outs1+="0100"
        if s1 = "1001" then outs1+="0101"
        if s1 = "1010" then outs1+="0110"
        if s1 = "1011" then outs1+="0111"
        
        if s1 = "1100" then outs1+="1000"
        if s1 = "1101" then outs1+="1001"
        if s1 = "1110" then outs1+="1010"
        if s1 = "1111" then outs1+="1011"
        

    next
    
    if show = 1 then print "c out = "; len(outs1) , outs1
    
    dim as longint count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(outs1)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then outs1+="0" : count+=1
    loop until dec1=0
    
    dim as string final = ""
    for a as longint = 1 to len(outs1) step 8
        final+=chr(val("&B"+mid(outs1,a,8)))
    next
    
    final = chr(count) + final
    
    print "c fin = "; len(final) ' , final
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
    
    dim as longint count = asc(left(chrs,1))
    chrs = mid(chrs,2)

    dim as string bits = ""
    dim as string zeros = string(8,"0")
    dim as string n1
    for a as longint = 1 to len(chrs) step 1
        n1 = zeros + bin( chrs[a-1] )
        bits+=right(n1,8)
    next
    
    bits = left(bits,len(bits)-count)
    
    if show = 1 then print "d inp = "; len(bits) , bits
   
    return chrs

end function

[albert]

@Dodicat

I tried reversing it , putting the "100" , "101" , "110" , "111" at the bottom , and it only compresses 50%..

So i have to try it on real files...

[albert]

@Dodicat

Here it is on real files...

You can play with it all you like , it doesn't write to the hard drive....

Compresses *.ZIP files down to under 200 bytes...

I tried it on a 6 megabyte *.mp3 file , and it compressed down to 97 bytes....So it's worth trying to work out..

Code: Select all

#define WIN_INCLUDEALL
#Include "windows.bi"
#Include "File.bi"

declare sub getfilename()

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

dim shared as string file , extension , file_data , bytes , file_name
dim as ubyte value1

Dim As MSG msg
Dim shared As HWND hWnd

screen 19
'=====================================================================
'=====================================================================
'get file
'=====================================================================
'=====================================================================
getfilename()
if FileExists(file) then
    
    print "Loading file ... please wait.."
    
    for a as ulongint = len(file)-1 to 0 step -1
        bytes=chr(file[a])
        if bytes = "\" then file_name = mid(file,a+2):exit for
    next
   
    print file_name

    file_data = ""
    open file for binary as #1
        do
            get #1,,value1
            file_data = file_data + chr(value1)
        loop until eof(1)
    close #1
    
    print "File loaded... Compressing.." 
    
end if
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
dim shared as ubyte show = 0 'if doing larger than 8 bytes set show to 0
do
   
    randomize
   
    dim as string s= file_data
    'For n As Long = 1 To 8
    '   s+=chr(Int(Rnd*256))'+8)
    'Next
   
    time1=timer
    'begin compress
        dim as string comp = s
        if show = 0 then
            do
                dim as longint chk = len(comp) - 1
                comp = compress_loop(comp)
                if len(comp) >= chk then exit do
            loop
        else
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
        end if
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    'print "inp = " ; (s)
    print string(99,"=")
    'print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string bits = ""
    dim as string zeros = string(64,"0")
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    dim as string n1
    for a as longint = 1 to len(chrs) step 8
        n1 = zeros + bin(*ulp) : ulp+=1
        bits+=right(n1,64)
    next
    
    if show = 1 then print "c inp = "; len(bits) , bits

    dim as string outs1=""
    dim as string s1
    for a as longint = 1 to len(bits) step 4
        
        s1 = mid(bits,a,4)
        
        if s1 = "0000" then outs1+="100"
        if s1 = "0001" then outs1+="101"
        if s1 = "0010" then outs1+="110"
        if s1 = "0011" then outs1+="111"
        
        if s1 = "0100" then outs1+="0000"
        if s1 = "0101" then outs1+="0001"
        if s1 = "0110" then outs1+="0010"
        if s1 = "0111" then outs1+="0011"
        if s1 = "1000" then outs1+="0100"
        if s1 = "1001" then outs1+="0101"
        if s1 = "1010" then outs1+="0110"
        if s1 = "1011" then outs1+="0111"
        
        if s1 = "1100" then outs1+="1000"
        if s1 = "1101" then outs1+="1001"
        if s1 = "1110" then outs1+="1010"
        if s1 = "1111" then outs1+="1011"
        
    next
    
    if show = 1 then print "c out = "; len(outs1) , outs1
    
    dim as longint count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(outs1)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then outs1+="0" : count+=1
    loop until dec1=0
    
    dim as string final = ""
    for a as longint = 1 to len(outs1) step 8
        final+=chr(val("&B"+mid(outs1,a,8)))
    next
    
    final = chr(count) + final
    
    print "c fin = "; len(final) ' , final
   
    return final
   
end function
'============================================================================
'============================================================================
'decompress
'============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
    
    dim as longint count = asc(left(chrs,1))
    chrs = mid(chrs,2)

    dim as string bits = ""
    dim as string zeros = string(8,"0")
    dim as string n1
    for a as longint = 1 to len(chrs) step 1
        n1 = zeros + bin( chrs[a-1] )
        bits+=right(n1,8)
    next
    
    bits = left(bits,len(bits)-count)
    
    if show = 1 then print "d inp = "; len(bits) , bits
   
    return chrs

end function
'===============================================================================
'===============================================================================
'Get File Name
'===============================================================================
'===============================================================================
sub getfilename()
        dim ofn as OPENFILENAME
        dim filename as zstring * MAX_PATH+1
       
        with ofn
                .lStructSize            = sizeof( OPENFILENAME )
                .hwndOwner              = hWnd
                .hInstance              = GetModuleHandle( NULL )
                .lpstrFilter            = strptr( !"All Files, (*.*)\0*.*\0\0" )
                .lpstrCustomFilter      = NULL
                .nMaxCustFilter         = 0
                .nFilterIndex           = 1
                .lpstrFile              = @filename
                .nMaxFile               = sizeof( filename )
                .lpstrFileTitle         = NULL
                .nMaxFileTitle          = 0
                .lpstrInitialDir        = NULL
                '.lpstrTitle            = @"File Open Test"
                .lpstrTitle             = @"File to Compress/Decompress"
                .Flags                  = OFN_EXPLORER 'or OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST
                .nFileOffset            = 0
                .nFileExtension         = 0
                .lpstrDefExt            = NULL
                .lCustData              = 0
                .lpfnHook               = NULL
                .lpTemplateName         = NULL
        end with
       
        if( GetOpenFileName( @ofn ) = FALSE ) then
            file = ""
            return
        else
            file = filename
            extension = right(filename,4)
    end if

end sub

[albert]

Here's some of my songs i had demo'd.... It cost me $325 a piece to get the lyrics put to music..

https://soundcloud.com/user-704620747

I spent a couple thousand on different demo companies....
And "Pearl Snap Studios".. Is the best bet..

https://www.pearlsnapstudios.com/

They turn out the best music and vocals...So if you got poetry and want it put to music , try pearl snap..

[albert]

@Dodicat

I made some modifications.....it's still the same compression formula... I just modified how the program works..

Code: Select all

#define WIN_INCLUDEALL
#Include "windows.bi"
#Include "File.bi"

declare sub getfilename()

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

dim shared as string file , extension , file_data , bytes , file_name
dim as ubyte value1

Dim As MSG msg
Dim shared As HWND hWnd

screen 19
'=====================================================================
'=====================================================================
'get file
'=====================================================================
'=====================================================================
getfilename()
if FileExists(file) then
    
    print "Loading file ... please wait.."
    
    for a as ulongint = len(file)-1 to 0 step -1
        bytes=chr(file[a])
        if bytes = "\" then file_name = mid(file,a+2):exit for
    next
    
    file_data = ""
    open file for binary as #1
        print file_name ; "  " ; lof(1)
        do
            get #1,,value1
            file_data = file_data + chr(value1)
        loop until eof(1)
    close #1
    
    print "File loaded... Compressing.." 
    
end if
'=====================================================================
'=====================================================================
'start program
'=====================================================================
'=====================================================================
dim as double time1 , time2 , time3 , time4
dim shared as ubyte show = 0  ' if doing larger than 8 bytes or opening a file , then set show to 0
do
    
    randomize
   
    dim as string s = ""
    if len(file_data) > 0 then 
        s = file_data
    else
        For n As Long = 1 To 8
            s+=chr(Int(Rnd*256))
        Next
   end if
   
    time1=timer
    'begin compress
        dim as string comp = s
        if show = 0 then
            do
                dim as longint chk = len(comp) - 1
                comp = compress_loop(comp)
                if len(comp) >= chk then exit do
            loop
        else
            for a as longint = 1 to 1 step 1
                comp = compress_loop(comp)
            next
        end if
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 1 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
   'sleep
   
    'cls
    'draw string( 0,10) , left(s,100)
    'draw string( 0,30) , left(final_out,100)
    print string(99,"=")
    'print "inp = " ; (s)
    print string(99,"=")
    'print "out = " ; (final_out)
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
    print string(99,"=")
   
    sleep
   
loop until inkey = chr(27) or show = 0

sleep
end
'===============================================================================
'===============================================================================
'compress
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string bits = ""
    dim as string zeros = string(64,"0")
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    dim as string n1
    for a as longint = 1 to len(chrs) step 8
        n1 = zeros + bin(*ulp) : ulp+=1
        bits+=right(n1,64)
    next
    
    if show = 1 then print "c inp = "; len(bits) , bits

    dim as string outs1=""
    dim as string s1
    for a as longint = 1 to len(bits) step 4
        
        s1 = mid(bits,a,4)
        
        if s1 = "0000" then outs1+="100"
        if s1 = "0001" then outs1+="101"
        if s1 = "0010" then outs1+="110"
        if s1 = "0011" then outs1+="111"
        
        if s1 = "0100" then outs1+="0000"
        if s1 = "0101" then outs1+="0001"
        if s1 = "0110" then outs1+="0010"
        if s1 = "0111" then outs1+="0011"
        if s1 = "1000" then outs1+="0100"
        if s1 = "1001" then outs1+="0101"
        if s1 = "1010" then outs1+="0110"
        if s1 = "1011" then outs1+="0111"
        
        if s1 = "1100" then outs1+="1000"
        if s1 = "1101" then outs1+="1001"
        if s1 = "1110" then outs1+="1010"
        if s1 = "1111" then outs1+="1011"
        
    next
    
    if show = 1 then print "c out = "; len(outs1) , outs1
    
    dim as longint count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(outs1)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then outs1+="0" : count+=1
    loop until dec1=0
    
    dim as string final = ""
    for a as longint = 1 to len(outs1) step 8
        final+=chr(val("&B"+mid(outs1,a,8)))
    next
    
    final = chr(count) + final
    
    print "c fin = "; len(final) ' , final
   
    return final
   
end function
'============================================================================
'============================================================================
'decompress
'============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
    
    dim as longint count = asc(left(chrs,1))
    chrs = mid(chrs,2)

    dim as string bits = ""
    dim as string zeros = string(8,"0")
    dim as string n1
    for a as longint = 1 to len(chrs) step 1
        n1 = zeros + bin( chrs[a-1] )
        bits+=right(n1,8)
    next
    
    bits = left(bits,len(bits)-count)
    
    if show = 1 then print "d inp = "; len(bits) , bits
   
    return chrs

end function
'===============================================================================
'===============================================================================
'Get File Name
'===============================================================================
'===============================================================================
sub getfilename()
        dim ofn as OPENFILENAME
        dim filename as zstring * MAX_PATH+1
       
        with ofn
                .lStructSize            = sizeof( OPENFILENAME )
                .hwndOwner              = hWnd
                .hInstance              = GetModuleHandle( NULL )
                .lpstrFilter            = strptr( !"All Files, (*.*)\0*.*\0\0" )
                .lpstrCustomFilter      = NULL
                .nMaxCustFilter         = 0
                .nFilterIndex           = 1
                .lpstrFile              = @filename
                .nMaxFile               = sizeof( filename )
                .lpstrFileTitle         = NULL
                .nMaxFileTitle          = 0
                .lpstrInitialDir        = NULL
                '.lpstrTitle            = @"File Open Test"
                .lpstrTitle             = @"File to Compress/Decompress"
                .Flags                  = OFN_EXPLORER 'or OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST
                .nFileOffset            = 0
                .nFileExtension         = 0
                .lpstrDefExt            = NULL
                .lCustData              = 0
                .lpfnHook               = NULL
                .lpTemplateName         = NULL
        end with
       
        if( GetOpenFileName( @ofn ) = FALSE ) then
            file = ""
            return
        else
            file = filename
            extension = right(filename,4)
    end if

end sub

[dodicat]

Hi Albert.
Tested on fb 1.7, still wrong decompress.
...
I have updated 3D surface plot.
Made it more psychedelic.
I like your music very much.
Anyway, you can change the function (within reason) in InputFunction:
using fb 1.7

Code: Select all

 

Type V3
    As Single x,y,z
End Type

Operator -(v1 As v3,v2 As v3) As v3 'v1-v2 
Return Type(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator

Operator ^ (Byref v1 As v3,Byref v2 As v3) As v3 'cross product
Return Type(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)
End Operator

Type float As V3

Type box
    As v3 p(1 To 4)
    As Ulong c    'colour
    As Single z
End Type

Type angle3D             'FLOATS for angles
    As Single sx,sy,sz
    As Single cx,cy,cz
    Declare Static Function construct(As Single,As Single,As Single) As Angle3D
End Type

Declare Function InputFunction(x As Double,y As Double) As Double

Dim As Integer wx,wy
Screeninfo wx,wy
wy=.9*wy
Screenres wy,wy,32,2
Width wy\8,wy\16 'max dos font size
Color ,Rgb(100,100,100)
'============ globals =============
Const pi=4*Atn(1)
Redim Shared As box b()
Redim Shared As box rot1()
Dim Shared As Angle3D A3d
Dim Shared As V3 CC       'grid centre
Dim Shared As Single MinX
Dim Shared As Single MaxX
Dim Shared As Single MinY
Dim Shared As Single MaxY
Dim Shared As Integer xres,yres
Screeninfo xres,yres
'================================== functions ================

Sub QsortZ(array() As box,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As box x =array(((I+J)\2))
    While I <= J
        While array(I).z > X.z:I+=1:Wend
            While array(J).z < X.z:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
            Wend
            If J >begin Then QsortZ(array(),begin,J)
            If I <Finish Then QsortZ(array(),I,Finish)
        End Sub
        
        Function Angle3D.construct(x As Single,y As Single,z As Single) As Angle3D
            Return   Type (Sin(x),Sin(y),Sin(z), _
            Cos(x),Cos(y),Cos(z))
        End Function
        
        Function Rotate(c As V3,p As V3,a As Angle3D,scale As float=Type(1,1,1)) As V3
            Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
            Return Type<V3>((scale.x)*((a.cy*a.cz)*dx+(-a.cx*a.sz+a.sx*a.sy*a.cz)*dy+(a.sx*a.sz+a.cx*a.sy*a.cz)*dz)+c.x,_
            (scale.y)*((a.cy*a.sz)*dx+(a.cx*a.cz+a.sx*a.sy*a.sz)*dy+(-a.sx*a.cz+a.cx*a.sy*a.sz)*dz)+c.y,_
            (scale.z)*((-a.sy)*dx+(a.sx*a.cy)*dy+(a.cx*a.cy)*dz)+c.z)
        End Function 
        
        Function perspective(p As V3,eyepoint As V3) As V3
            Dim As Single   w=1+(p.z/eyepoint.z)
            If w=0 Then w=1e-6
            Return Type<V3>((p.x-eyepoint.x)/w+eyepoint.x,_
            (p.y-eyepoint.y)/w+eyepoint.y,_
            (p.z-eyepoint.z)/w+eyepoint.z)
        End Function
        
        Function dot(v1 As v3,v2 As v3) As Single 
            Dim As Single d1=Sqr(v1.x*v1.x + v1.y*v1.y + v1.z*v1.z)
            Dim As Single d2=Sqr(v2.x*v2.x + v2.y*v2.y + v2.z*v2.z)
            Dim As Single v1x=v1.x/d1,v1y=v1.y/d1,v1z=v1.z/d1 'normalize
            Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
            Return v1x*v2x+v1y*v2y+v1z*v2z  'dot product
        End Function
        
        Function map(a As Single,b As Single,x As Single,c As Single,d As Single) As Single
            Return ((d)-(c))*((x)-(a))/((b)-(a))+(c)
        End Function
        
        Function rainbow( x As Single ) As Ulong 'idea from bluatigro
            #define rad(n) (pi/180)*(n)
            Dim As Ulong r , g , b
            r = Sin( rad( x ) ) * 127 + 128
            g = Sin( rad( x - 120 ) ) * 127 + 128
            b = Sin( rad( x + 120 ) ) * 127 + 128
            Return Rgb( r And 255 , g And 255 , b And 255 )
        End Function 
        
        Function setgrid(sx As Single,bx As Single,sy As Single,by As Single,st As Single,p() As box,fn As Function(x As Double,y As Double=0) As Double) As v3
            #define U Ubound(p)
            Redim p(0)
            Dim As Single cx,cy,cz,ctr
            Static As Single q=15
            Var sttx=st*(MaxX-MinX)/(bx-sx)
            Var stty=st*(MaxY-MinY)/(by-sy)
            For y As Single=sy To by+st/2 Step st
                For x As Single=sx To bx+st/2 Step st
                    Redim Preserve p(1 To U+1)
                    Var lx=map(sx,bx,x,MinX,MaxX)
                    Var ly=map(sy,by,y,MinY,MaxY)
                    
                    'temp adjust to use limits for .z
                    p(u).p(1)=Type<v3>(lx,ly,          fn(p(u).p(1).x,p(u).p(1).y))
                    p(u).p(2)=Type<v3>(lx+sttx,ly,     fn(p(u).p(2).x,p(u).p(2).y))
                    p(u).p(3)=Type<v3>(lx+sttx,ly+stty,fn(p(u).p(3).x,p(u).p(3).y))
                    p(u).p(4)=Type<v3>(lx,ly+stty,     fn(p(u).p(4).x,p(u).p(4).y))
                    're set
                    p(u).p(1).x=x:     p(u).p(1).y=y
                    p(u).p(2).x=x+st:  p(u).p(2).y=y
                    p(u).p(3).x=x+st:  p(u).p(3).y=y+st
                    p(u).p(4).x=x:     p(u).p(4).y=y+st
                    
                    'p(u).c=Rgb(x*q, x*q xor y*q,y*q) 'another colour option
                    p(u).c=rainbow(((bx/2-x)*(by/2-y)))
                Next x
            Next y
            Dim As Integer x,y
            Screeninfo x,y
            
            For n As Long=Lbound(p) To Ubound(p)
                For g As Long=1 To 4
                    ctr+=1
                    Var xx =map(sx,bx,p(n).p(g).x,.2*x,.8*x)
                    Var yy =map(sy,by,p(n).p(g).y,.2*y,.8*y)
                    p(n).p(g).x=xx
                    p(n).p(g).y=yy
                    cx+=xx
                    cy+=yy
                    cz+= p(n).p(g).z
                Next g
            Next n
            
            Return Type(cx/ctr,cy/ctr,cz/ctr)'centre
        End Function
        
        Sub fill(p() As v3,c As Ulong,im As Any Ptr=0)
            Dim As Long Sy=1e8,By=-1e8,i
            Redim As Long a(Ubound(p)-Lbound(p)+1,1)
            Dim As Long ctr
            For i =Lbound(p) To Ubound(p)
                a(ctr,0)=p(i).x
                a(ctr,1)=p(i).y
                If Sy>p(i).y Then Sy=p(i).y
                If By<p(i).y Then By=p(i).y
                ctr+=1
            Next i
            Dim As Long j,k,dy,dx,x,y,xi(Ubound(a,1))
            Dim As Single S(Ubound(a,1))
            a(Ubound(a,1),0) = a(0,0)
            a(Ubound(a,1),1) = a(0,1)
            For i=0 To Ubound(a,1)-1
                dy=a(i+1,1)-a(i,1)
                dx=a(i+1,0)-a(i,0)
                If dy=0 Then S(i)=1
                If dx=0 Then S(i)=0
                If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
            Next i
            For y=Sy-1 To By+1
                k=0
                For i=0 To Ubound(a,1)-1
                    If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
                    (a(i,1)>y Andalso a(i+1,1)<=y) Then
                    xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
                    k+=1
                End If
            Next i
            For j=0 To k-2
                For i=0 To k-2
                    If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
                Next i
            Next j
            For i = 0 To k - 2 Step 2
                Line im,(xi(i),y)-(xi(i+1)+1,y),c
            Next i
        Next y
    End Sub
    
    Sub drawboxes(b() As box)
        Redim As Long a()
        For n As Long=Lbound(b) To Ubound(b)
            Var rd=Cast(Ubyte Ptr,@b(n).c)[2]
            Var gr=Cast(Ubyte Ptr,@b(n).c)[1]
            Var bl=Cast(Ubyte Ptr,@b(n).c)[0]
            Dim As v3 screencentre=(xres\2,yres\2)
            Var v1=b(n).p(2)-b(n).p(1)
            Var v2=b(n).p(3)-b(n).p(2)
            Var norm=v1^v2 'cross product
            Var dt=dot(norm,Type(1,0,0))
            Var f=map(-1,1,dt,.2,1)
            fill(b(n).p(),Rgb(f*rd,f*gr,f*bl))
        Next
    End Sub
    
    Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
        Static As Double timervalue,_lastsleeptime,t3,frames
        frames+=1
        If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
        Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
        If sleeptime<1 Then sleeptime=1
        _lastsleeptime=sleeptime
        timervalue=Timer
        Return sleeptime
    End Function
    
    Sub setup(x1 As Single,x2 As Single,y1 As Single,y2 As Single,meshsize As Single)
        CC= setgrid(x1,x2,y1,y2,meshsize,b(),@InputFunction)'create grid, CC is the centre
        Redim rot1(Lbound(b) To Ubound(b))                   'working array
        A3d=angle3D.construct(0,-pi/2,0)
        Var dx=x2-x1,dy=y2-y1
        Var s=1/2
        For n As Long=Lbound(b) To Ubound(b)
            For m As Long=1 To 4
                rot1(n).p(m)=rotate(CC,B(n).p(m),A3D,Type(s,s,s)) 'align boxes horizontally based
                rot1(n).c=B(n).c
                B(n).p(m)=rot1(n).p(m)
            Next m
        Next n
    End Sub
    
    Function display() As Long
        #define resetwheel(w,fl) fl=w
        #define wheel(w,f) w-f
        Screenset 1,0
        Static As float ang=(0,-pi/7,pi/2)  'default start view aspect
        Static As Long fps
        Static As String key
        Static As Long mx,my,mw,mb,rflag
        Static As Single sc=1
        
        Const k=60 
        Var f=map(0,40,k,0,.5)
        
        Do
            setup(0,k,0,k,f)
            Getmouse mx,my,mw,mb
            If mb=2 Then 'reset
                ang.z=pi/2:ang.y=-pi/7:ang.x=0
                resetwheel(mw,rflag) 
            End If
            mw=wheel(mw,rflag)
            If mx>0 Then sc=2+(mw/10)'scaler
            key=Inkey
            If key=Chr(255)+"K" Then ang.z-=.05     'left
            If key=Chr(255)+"M" Then ang.z+=.05     'right
            If key=Chr(255)+"P" Then ang.y-=.05     'down
            If key=Chr(255)+"H" Then ang.y+=.05     'up 
            If key="q" Then ang.x+=.05     
            If key="w" Then ang.x-=.05     
            
            A3D=Angle3D.construct(ang.x,ang.y,ang.z)      'set the rotate trigs
            
            For n As Long=Lbound(b) To Ubound(b)
                For m As Long=1 To 4
                    rot1(n).p(m) =rotate(CC,B(n).p(m),A3D,Type(sc,sc,sc))
                    rot1(n).p(m) =perspective(rot1(n).p(m),Type(cc.x,cc.y,800*sc))
                    If mb=1 Then rot1(n).p(m).x-=cc.x-mx: rot1(n).p(m).y-=cc.y-my'follow the mouse
                Next m
                
                rot1(n).z=(rot1(n).p(1).z+rot1(n).p(3).z)/2
            Next n
            
            qsortz(rot1(),Lbound(rot1), Ubound(rot1))
            
            Cls
            Draw String(50,50),"Framerate "&fps
            Draw String (50,80),"keys q and w to rotate round vertical (y) axis" 
            Draw String(50,110),"Use the arrow keys for x and z axis"
            Draw String(50,140), "Mouse wheel to magnify"
            Draw String(50,170),"Right mouse click to reset"
            drawboxes(rot1())
            Flip
            
            Sleep regulate(80,fps),1
        Loop Until key=Chr(27)
        Return 0
    End Function
    
    End display()
    Sleep
    
    Function InputFunction(x As Double,y As Double) As Double ' << --------------- INPUT function -----------
        Var l=15 'set the limits
        'set the x/y domains
        MinX=-l
        MaxX=l
        MinY=-l
        MaxY=l
        If MaxX<MinX Then Swap MaxX,MinX
        If MaxY<MinY Then Swap MaxY,MinY
        If x=0 Then x=.000001 'qsort doesn't like Qnan
        If y=0 Then y=.000001
        Return (Sin(x)/x*Sin(y)/y)*200-.5*x^2
        
        'Return Sin(x)*Cos(y)*20  'egg box
    End Function
    
     

[albert]

@Dodicat

I tried all manner of getting the bits into a string , stepping by different values...
Trying to make it , so the bits would form a pattern that would compress.. nothing worked.

Then i came up with the idea , of randomly selecting bits to add to the output...until the output length equals the input length..

It still doesn't compress. But here it is... See : compress_loop()

Code: Select all

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


Namespace Zlibrary

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

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


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

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

End Namespace


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

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
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." ; " loops = " ; loops ; " out of 40."
    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 bits=""
    dim as string zeros = string(64,"0")
    dim as string s1
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        s1 = zeros + bin(*ulp) : ulp+=1
        bits+=right(s1,64)
    next
    
    print "c inp = " ; len(bits) ', bits
    
    dim as string outs = ""
    randomize 0
    do
        
        dim as longint rand = int( rnd * (len(bits)+1) )
        
        if mid(bits,rand,1) <> "-" then outs+= mid(bits,rand,1) : mid(bits,rand,1) = "-"
        
    loop until len(outs) = len(bits)
    
    print "c out = " ; len(outs) ', outs
    
    dim as string final=""
    for a as longint = 1 to len(outs) step 8
        final+=chr(val("&B"+mid(outs,a,8)))
    next
    
    print "c fin = "; len(final) ' , final
    
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
    
    return chrs

end function

[albert]

@Dodicat

This program uses RND() to generate the value... The problem is ; several values equal each other...There should be 31 unique values..

Whats wrong with it???

Code: Select all

screen 19


    dim as string vals(0 to 31)
    dim as string match
    dim as longint count
    dim as string n1
    for a as longint = 0 to 31 step 1
        n1 = bin(a)
        count = 0
        randomize 0
        do
            match=""
            for b as longint = 1 to len(n1)
                match+=str( int( rnd * 2 ) )
            next
            count+=1
        loop until match = n1
        vals(a) = hex(count)
    next
    
    for a as longint = 0 to ubound(vals)
        print vals(a) ,
    next
    print

sleep
end

[Richard]

You use the same seed "0" every time.
Use Randomize once at the start.

Code: Select all

Screen 19

Randomize 

Dim As String vals(0 To 31)
Dim As String match
Dim As Longint count
Dim As String n1
For a As Longint = 0 To 31 Step 1
    n1 = Bin(a)
    count = 0
    Do
        match=""
        For b As Longint = 1 To Len(n1)
            match+=Str( Int( Rnd * 2 ) )
        Next
        count+=1
    Loop Until match = n1
    vals(a) = Hex(count)
Next

For a As Longint = 0 To Ubound(vals)
    Print vals(a) ,
Next
Print

Sleep
End

[albert]

@Richard

I figured it out... You have to use right( "00" + ? , 2 )

Code: Select all

screen 19

    dim as string dict=""
    dim as string vals
    dim as longint count = 0
    randomize 0
    do
        vals = right("00"+hex( int( rnd * 32 ) ),2)
        if instr( 1 , dict , vals ) = 0 then 
            dict+= vals + " "
            count+=1
            'print count , dict
        end if
    loop until count = 31  or inkey = chr(27)
    
    print "dict = " ; len(dict) , dict
    

sleep
end

[albert]

@Dodicat
@Richard

I finally succeeded in creating compression....Now to write the de-compressor..

10,000 bytes compresses down to under 1,300 bytes after 60 loops..
100,000 bytes compresses down to under 3,000 bytes after 60 loops.
1,000,000 bytes compresses down to under 30,000 bytes after 60 loops
10,000,000 bytes compresses down to under 30,000 bytes after 100 loops. ( but it takes like 10 minutes to compress 100 loops)

Code: Select all

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


Namespace Zlibrary

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

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


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

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

End Namespace


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

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0
dim as longint loops = 0
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." ; " loops = " ; loops ; " out of 60."
    print
    print "press esc to exit."
    sleep
   
    if inkey = chr(27) then exit do
   
loop until loops = 60

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 bits=""
    dim as string zeros = string(64,"0")
    dim as string s1
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        s1 = zeros + bin(*ulp) : ulp+=1
        bits+=right(s1,64)
    next
   
    print "c inp = " ; len(bits) ', bits
    
    dim as string dict=""
    dim as string vals
    dim as longint count = 0
    randomize 0
    do
        vals = right("00"+hex( int( rnd * 32 ) ),2)
        if instr( 1 , dict , vals ) = 0 then 
            dict+= vals
            count+=1
        end if
    loop until count = 31
    
    dim as string rand( 0 to 31)
    count = 0
    for a as longint = 1 to len(dict) step 2
        rand(count) = mid(dict,a,2)
        count+=1
    next
    
    dim as string outs = ""
    dim as longint n1
    for a as longint = 1 to len(bits) step 5
        n1 = val( "&B"+mid(bits,a,5) )
        outs+=ltrim( rand(n1) , "0" )
    next
    
    print "c out = " ; len(outs) ', outs
   
    dim as string final=""
    for a as longint = 1 to len(outs) step 2
        final+=chr(valulng("&H"+mid(outs,a,2)))
    next
   
    print "c fin = "; len(final) ' final
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    return chrs

end function

[albert]

Now i got to figure out what to call it...

I was calling all my other compressors "Binary Data Compressor" outputting *.BDC files.

This one uses hexadecimal ???

I think I'll leave it *.BDC...

[albert]

I can't decompress it... some combos equal other combos... As usual..

Can't tell a 1 , 1 from an 11 and a 1 , B from a 1B

[albert]

It seems that the only way to compress data : Is to make some bytes equal other bytes.
Or to leave off some bits.. ltrim() the binary...