Squares

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

Re: Squares

Postby albert » Aug 05, 2019 0:33

Made it better...

Now the problem is ; telling 3 bit values from 2 bit values.

Compresses 90+% after 40 loops... Compresses a megabyte to 3 digits..


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 outs1=""
    dim as string zeros = string(64,"0")
    dim as ulongint n1
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = *ulp : ulp+=1
        outs1+=right( zeros + bin(n1),64)
    next
   
    dim as string outputs=""
    dim as string num
    for a as longint = 1 to len(outs1) step 3
       
        num = mid(outs1,a,3)
       
        if num = "000" then outputs+="00"   ' all 0's
        if num = "001" then outputs+="01"   ' bit 1 set
        if num = "010" then outputs+="10"   ' bit2 set
        if num = "011" then outputs+="11"   ' bits 2 and 1 set
       
        if num = "100" then outputs+="100" ' bit 3 set
        if num = "101" then outputs+="101"  ' bits 3 and 1 set
        if num = "110" then outputs+="110" ' bits 3 and 2 set
        if num = "111" then outputs+="111"  ' bits 3 2 1 set
       
    next
   
    dim as string final=""
    for a as longint = 1 to len(outputs) step 8
        final+=chr(val("&B"+mid(outputs,a,8)))
    next
       
    return final
       
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    return chrs

end function

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

Re: Squares

Postby albert » Aug 05, 2019 21:09

@Richard
@Dodicat

I need your math skills....

This code takes a binary byte , and adds the set-bit positions.. 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8

How do you turn the added value , back into the binary byte??

It adds 0's and adds 1's , separately...

For some reason if you count the number of bits set , it doesn't compress.. ( 36 * 10 ) + 8 = 368 9 bits per byte...

But outputs+= chr( bits1 ) + chr( bits0 ) compresses 80% after 40 loops... Theres a lot of repetitive values..

Code: Select all


screen 19

do
   
    randomize
    dim as string bins = right("00000000" + bin(int(rnd*256)),8)
   
    dim as ubyte bits0 = 0
    dim as ubyte bits1 = 0
    for a as longint = 0 to 7
       
        if bins[a] = 48 then bits0+=(8-a)
        if bins[a] = 49 then bits1+=(8-a)
       
    next
   
    print
    print "inp = " ; bins
    print
    print "1's = " ; bits1
    print "0's = " ; bits0
   
   ' how to turn "bits" back into bins???
       
    sleep
   
loop until inkey=chr(27)

sleep
end



Here it is in Dodicats Zlib code.. See for yourself....

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 outs1=""
    dim as string zeros = string(64,"0")
    dim as ulongint n1
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = *ulp : ulp+=1
        outs1+=right( zeros + bin(n1),64)
    next
   
    dim as string outputs=""
    dim as string num
    for a as longint = 1 to len(outs1) step 8
       
        num = mid(outs1,a,8)
       
        dim as ubyte bits0 = 0
        dim as ubyte bits1 = 0
        for b as longint = 0 to 7
           
            if num[b] = 48 then bits0+=(8-b)
            if num[b] = 49 then bits1+=(8-b)
           
        next
       
        outputs+=chr(bits1) + chr(bits0)
       
        'print num , outputs
       
    next
   
    return outputs
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    return chrs

end function

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

Re: Squares

Postby albert » Aug 06, 2019 0:37

@Richard
@Dodicat

It compresses the same 80% , with 16 bits.......Using outputs+= chr( bits1 ) + chr( bits0 ) + chr( count )

So now we have both sums ( 0's ) , ( 1's ) , plus the number of set bits...

How to reverse it???

Code: Select all


screen 19

do
   
    randomize
    dim as string bins = right(string(16,"0")+bin(int(rnd*65536)),16)
   
    dim as ubyte bits0 = 0
    dim as ubyte bits1 = 0
    dim as ubyte count = 0
    for a as longint = 0 to 15
       
        if bins[a] = 48 then bits0+=(16-a)
        if bins[a] = 49 then bits1+=(16-a) : count+=1
       
    next
   
    print
    print "inp = " ; bins
    print
    print "bit sum 1 = " ; bits1
    print "bit sum 0 = " ; bits0
    print "bits set  = " ; count
   
   ' how to turn "bits" back into bins???
       
    sleep
   
loop until inkey=chr(27)

sleep
end



Here it is in Dodicats 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." ; " 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 outs1=""
    dim as string zeros = string(64,"0")
    dim as ulongint n1
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = *ulp : ulp+=1
        outs1+=right( zeros + bin(n1),64)
    next
   
    dim as string outputs=""
    dim as string num
    dim as longint hi = 0
    for a as longint = 1 to len(outs1) step 16
       
        num = mid(outs1,a,16)
       
        dim as ubyte bits0 = 0
        dim as ubyte bits1 = 0
        dim as ubyte count = 0
        for b as longint = 0 to 15
           
            if num[b] = 48 then bits0+=(16-b)
            if num[b] = 49 then bits1+=(16-b) : count+=1
           
        next
       
        outputs+= chr(bits1) + chr(bits0) + chr(count)
       
        'print num , outputs
       
    next
   
    return outputs
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    return chrs

end function

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

Re: Squares

Postby albert » Aug 06, 2019 15:31

@Dodicat
@Richard

I figured out how to reverse it... But there's lots of duplicates.. Got to try a different formula..

Code: Select all


screen 19

dim as longint size = 16 ' adjust to desired value.

dim as string bits(0 to size)
dim as string vals(0 to size)

dim as string bins
for a as longint = 0 to (2^size)-1
   
    bins = right(string(size,"0")+bin(a),size)
   
    dim as ubyte bits0 = 0
    dim as ubyte bits1 = 0
    dim as ubyte count = 0
    for b as longint = 0 to 15
       
        if bins[b] = 48 then bits0+=(16-b)
        if bins[b] = 49 then bits1+=(16-b) : count+=1
       
    next
   
    bits(count)+=mkshort(a)
    vals(count)+=chr(bits0) + chr(bits1)
   
next

for a as longint = lbound(bits) to ubound(bits)
    print a , len(bits(a)) \ 2 ', bits(a)
next

print left(bits(8),400)
dim as string outs = left(vals(8),800)
for a as longint = 1 to len(outs) step 2
    print mid(outs,a,2) + " " ;
next

sleep

sleep
end

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

Re: Squares

Postby albert » Aug 07, 2019 1:21

@Dodicat

Can you post your "Factor Solving" code??

I need to find the factors of numbers...
Richard
Posts: 2955
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Postby Richard » Aug 07, 2019 8:58

Try this. example at the end...

Code: Select all

'=======================================================================
' Factorise a 64 bit Unsigned Long Integer, resolution within 13 seconds
'=======================================================================
Type factor_table               ' 216 bytes = 8 + 8*16 + 4*16 + 4 + 8
    number As Ulongint          ' the input number to factorise
    prime(0 To 15) As Ulongint  ' prime factors found, maximum possible = 15
    count(0 To 15) As Short     ' repeat count for each prime factor found
    nf As Short                 ' the number of different prime factors found
    seconds As Double           ' time in seconds used for the factorisation
End Type

'=======================================================================
' macro used by factorisation routine
'=======================================================================
#macro divisor_step(skip)   ' test if this trial divisor is a factor of number
divisor += skip
Do
    residue = num Mod divisor   ' remainder of this trial division
    If residue = 0 Then         ' a factor has been found
        If .prime(.nf) = divisor Then  ' previous prime factor repeats
            .count(.nf) += 1
        Else                    ' a new factor has been found
            .nf += 1            ' initiate a new factor entry
            .prime(.nf) = divisor
            .count(.nf) = 1
        End If
        num = num \ divisor     ' remove the factor
        limit = Sqr(num)        ' move the limit down
    End If
Loop Until residue <> 0         ' finished repeats of this divisor
#endmacro

'=======================================================================
' factorisation routine
'=======================================================================
Sub factors( Byref table As factor_table )
    With table
        .seconds = Timer
        .nf = 0   ' number of different factors found so far
        Dim As Ulongint num = .number, residue
        Dim As Ulongint divisor = 0, limit = Sqr(num)
        ' start with the silly test
        If num < 2 Then     ' zero and one default here to prime because,
            .nf = 1         '  they have only one entry in the table,
            .count(1) = 1   '   they have a count of one, and that one
            .prime(1) = num '    factor's value is equal to the number.
            .seconds = 0
        Else
            ' then small prime divisors
            divisor_step(2)  ' test  2
            divisor_step(1)  ' test  3
            divisor_step(2)  ' test  5
            divisor_step(2)  ' test  7
            Do  ' then full ahead with a repeat cycle of ( 2 * 3 * 5 ) = 30
                divisor_step(4)   ' 11   41   71   101   131 note:
                divisor_step(2)   ' 13   43   73   103   133  that
                divisor_step(4)   ' 17   47   77   107   137  each
                divisor_step(2)   ' 19   49   79   109   139  column
                divisor_step(4)   ' 23   53   83   113   143  rises by
                divisor_step(6)   ' 29   59   89   119   149  the repeat
                divisor_step(2)   ' 31   61   91   121   151  cycle's period
                divisor_step(6)   ' 37   67   97   127   157  of thirty 
                ' check once every cycle of 30 to detect number is a prime
                If divisor > limit Then ' the number remaining must be prime
                    If num > 1 Then
                        .nf += 1
                        .prime(.nf) = num
                        .count(.nf) = 1
                    End If
                    Exit Do
                End If
            Loop Until num = 1
            .seconds = Timer - .seconds
        End If
    End With
End Sub

'=======================================================================
Dim t As factor_table
With t
    .number = 1022
    factors( t )
    Print "prime", "power"
    For i As Short = 0 To .nf
        Print .prime( i ), .count( i )
    Next i
End With
Sleep
dodicat
Posts: 5951
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Aug 07, 2019 10:10

Hi Albert.
I dug up two
method 1:

Code: Select all

 

type Pfactors
    as ulongint f(64) 'to hold all factors in ulongint range
    as ulong numfactors
    as ulongint number
end type

Function getprimefactors(number As Ulongint,p as pfactors) As Integer
    Dim As long i
    #macro fill(x)
    i+=1
    p.f(i)=x
    p.numfactors=i
    #endmacro
    #macro Eliminate(x)
    while number mod x=0
        number=number\x :fill(x):check=check*x:limit=Sqr(number)+1
    wend
    #endmacro
    Dim As Ulongint original=number,divisor=0ull,limit=sqr(number)+1,check=1ull

    Eliminate(2)
    Eliminate(3)
   
    While divisor<limit
        divisor=divisor+6
        Eliminate((divisor-1))
        Eliminate((divisor+1))
    Wend
    If number>1 Then
    fill(number)
    check=check*number
    end if
    number=original
    p.number=number
    Return check=original
End Function


Sub PrintPrimeFactors(p As pfactors)
    dim as string msg,comma
     if p.numfactors=1 then msg="Prime" else msg="("+str(p.numfactors)+" prime factors)"
    print p.number,
    For z As Integer=1 To p.numfactors
       if z<p.numfactors then comma="," else comma=""
         Print P.f(z);comma;
    Next z
    print tab(60); msg
End Sub

'======================== ==================================

'   maximum=      18446744073709551615

redim  as pfactors P()
dim as long counter
for n as long=389999900 to 390000200
    counter+=1
    redim preserve p(1 to counter)
   if GetPrimeFactors(n,P(counter))=0 then print "Error":sleep
next n

width ,3000

dim as long max,idx
for n as long=lbound(p) to ubound(p)
    if max<p(n).numfactors then max=p(n).numfactors:idx=p(n).number
    printprimefactors(p(n))
next
print
print "number with most factors in the range "
dim as pfactors biggest
print cbool(getprimefactors(idx,biggest))
printprimefactors(biggest)
sleep

 

Method 2

Code: Select all

 'rem prime factors
#lang "fblite"
option gosub

1 lowers%=10000000
2 uppers%=10000200
10 For counts% = lowers% To uppers%
20 number% = counts%
30
40 Print number%;"= ";
50 divisor% = 2
60 While divisor% <= number%
70 Gosub 490
80 divisor% = divisor% + 1
90 Wend       
100 Print
101 Next counts%
102 Print

rem subroutine
490
500 If number%/divisor%-Int(number%/divisor%) = 0 Then
510 c$="x"
520 number% = number% / divisor%
530 If number% = 1 Then c$=""
540 Print divisor%;c$;
550 Goto 490
560 End If
570 If counts%<=uppers% Then Return
580 Sleep 

note:
I had to dig deeper for method 2
albert
Posts: 5068
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Aug 07, 2019 18:20

Thanks you guys!!

I figured out another compression....It steps by 4 bits...

Just have to figure out where the single "0's are located. Out of 0 to 15 ( 16 values ) , there's 6 values that use a zero..

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 outs1=""
    dim as string zeros = string(64,"0")
    dim as ulongint n1
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = *ulp : ulp+=1
        outs1+=right( zeros + bin(n1),64)
    next
   
    dim as string outputs=""
    for a as longint = 0 to len(outs1)-1 step 4
       
        n1 = val("&B"+mid(outs1,a,4))
       
        if n1 = 00 then outputs+="01"
        if n1 = 01 then outputs+="10"
        if n1 = 02 then outputs+="11"
       
        if n1 = 03 then outputs+="02"
        if n1 = 04 then outputs+="20"
        if n1 = 05 then outputs+="22"
       
        if n1 = 06 then outputs+="03"
        if n1 = 07 then outputs+="30"
        if n1 = 08 then outputs+="33"
       
        if n1 = 09 then outputs+="12"
        if n1 = 10 then outputs+="21"
       
        if n1 = 11 then outputs+="13"
        if n1 = 12 then outputs+="31"
       
        if n1 = 13 then outputs+="23"
        if n1 = 14 then outputs+="32"
       
        if n1 = 15 then outputs+="0"
   
    next
   
    dim as string final=""
    for a as longint = 1 to len(outputs) step 3
        final+=chr(valulng("&O"+mid(outputs,a,3)))
    next   
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    return chrs

end function

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

Re: Squares

Postby albert » Aug 07, 2019 20:38

@Dodicat

Trying to isolate the stray zeros....

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

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string outs1=""
    dim as string zeros = string(64,"0")
    dim as ulongint n1
    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = *ulp : ulp+=1
        outs1+=right( zeros + bin(n1),64)
    next
   
    dim as string outputs=""
    for a as longint = 1 to len(outs1) step 4
       
        n1 = val("&B"+mid(outs1,a,4))
       
        if n1 = 00 then outputs+="01"
        if n1 = 01 then outputs+="10"
        if n1 = 02 then outputs+="11"
       
        if n1 = 03 then outputs+="02"
        if n1 = 04 then outputs+="20"
        if n1 = 05 then outputs+="22"
       
        if n1 = 06 then outputs+="03"
        if n1 = 07 then outputs+="30"
        if n1 = 08 then outputs+="33"
       
        if n1 = 09 then outputs+="12"
        if n1 = 10 then outputs+="21"
       
        if n1 = 11 then outputs+="13"
        if n1 = 12 then outputs+="31"
       
        if n1 = 13 then outputs+="23"
        if n1 = 14 then outputs+="32"
       
        if n1 = 15 then outputs+="0"
   
    next
   
    print "c inp = " ; len(outs1) , outs1
    print "c out = " ; len(outputs) , outputs
   
    dim as longint count = 0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(outputs)/3)
        dec1=instr(1,str1,".")
        if dec1<>0 then outputs ="0" +outputs : count+=1
    loop until dec1=0
   
    dim as string final=""
    for a as longint = 1 to len(outputs) step 3
        final+=chr(valulng("&O"+mid(outputs,a,3)))
    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 outs1=""
    for a as longint = 1 to len(chrs) step 1
        outs1+=right( "000" + oct( chrs[a-1] ),3)
    next
   
    outs1 = mid(outs1,count+1)
   
    print "d inp = " ; len(outs1) , outs1
   
    dim as string outputs1=""
    for a as longint = 1 to len(outs1) step 1
        if mid(outs1,a,1) = "0" then outputs1+=" 0 " else outputs1+= mid(outs1,a,2) + " " : a+=1
    next
   
    dim as string outputs2=""
    for a as longint = 1 to len(outs1) step 2
        outputs2+= mid(outs1,a,2) + " "
    next
   
    print "d chk = " ; len(outputs1) , outputs1
    print "d chk = " ; len(outputs2) , outputs2
   
    ' got to create output...
   
    return chrs

end function

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

Re: Squares

Postby albert » Aug 08, 2019 19:43

@Dodicat

I came up with a sure fire way to compress data... You raise the base...

Instead of 256 chars , you make up 512 or more chars.

Then ; draw the number out , in the 512 chars. But each char would take 64 bits , for an 8 x 8 char.
albert
Posts: 5068
Joined: Sep 28, 2006 2:41
Location: California, USA

DATA COMPRESSION

Postby albert » Aug 09, 2019 19:53

@Dodicat

This is the closest i've come to compression...So far..

Set the size to 100,000 or higher , and it compresses 9% after 40 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 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 bytes=""
   dim as longint count1 , count2 , minus
   dim as longint n1
   for a as longint = 1 to len(chrs) step 1
       
       n1 = chrs[a-1]
       
        count1=0
        count2=0
        do
            count1+=10
            count2+=1
        loop until count1>= n1
       
        minus = count1 - n1
       
        'print n1 , count1 , count2 , minus
        'sleep
        'if inkey= " " then end
       
        bytes+=chr( ( (count2-1) * 10 )  + minus )
           
   next
   
    return bytes
 
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    return chrs

end function

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

Re: Squares

Postby albert » Aug 09, 2019 21:17

@Dodicat

I screwed up...

Bytes 251 , 252 , 253 , 254 are rolling over...
.........259...258...257...256.........................so it's getting a little compression...
albert
Posts: 5068
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Aug 10, 2019 0:01

Still working on compression...
albert
Posts: 5068
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Aug 10, 2019 19:32

@Dodicat

Compresses 9% to 12% after 40 loops...

if bits = "000" then outputs+="0"
if bits = "001" then outputs+="1"
if bits = "010" then outputs+="12"
if bits = "011" then outputs+="21"

if bits = "100" then outputs+="22"
if bits = "101" then outputs+="23"
if bits = "110" then outputs+="32"
if bits = "111" then outputs+="3"

Got to find the stray 1's and 3's ,,, The zeros are presolved , since no other combo uses a zero.

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

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string bytes=""
    dim as string zeros=string(64,"0")
    dim as ulongint n1
    dim as ulongint ptr usp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = *usp : usp+=1
        bytes+=right(zeros+bin(n1),64)
    next
   
    dim as longint count1=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(bytes)/3)
        dec1=instr(1,str1,".")
        if dec1<>0 then bytes = "0" + bytes : count1+=1
    loop until dec1=0
   
    print "c inp =  "; len(bytes) , bytes
   
    dim as string outputs=""
    dim as string bits
    for a as longint = 1 to len(bytes) step 3
       
        bits = mid(bytes,a,3)
       
        if bits = "000" then outputs+="0"
        if bits = "001" then outputs+="1"
        if bits = "010" then outputs+="12"
        if bits = "011" then outputs+="21"
       
        if bits = "100" then outputs+="22"
        if bits = "101" then outputs+="23"
        if bits = "110" then outputs+="32"
        if bits = "111" then outputs+="3"
   
    next
   
    print "c out =  "; len(outputs) , outputs
   
    dim as longint count2=0
    do
        str1=str(len(outputs)/3)
        dec1=instr(1,str1,".")
        if dec1<>0 then outputs+="0" : count2+=1
    loop until dec1=0
   
    dim as string final=""
    for a as longint = 1 to len(outputs) step 3
        final+=chr(val("&O"+mid(outputs,a,3)))
    next
   
    print "c fin =  "; len(final) ' , final
   
    final = chr(count1) + chr(count2) + final
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as longint count1 = asc(left(chrs,1))
    chrs = mid(chrs,2)
    dim as longint count2 = asc(left(chrs,1))
    chrs = mid(chrs,2)
   
    dim as string bytes=""
    dim as ulongint n1
    for a as longint = 0 to len(chrs)-1 step 1
        n1 = chrs[a]
        bytes+=right("000"+oct(n1),3)
    next
   
    bytes = left(bytes,len(bytes)-count2)
   
    print "d inp =  "; len(bytes) , bytes
   
    return chrs

end function

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

Re: Squares

Postby albert » Aug 10, 2019 20:20

@Dodicat

Never mind..

It only works on 10,000 , more or less doesn't compress.. It expands.. Tried 1,000 , 20,000 , 100,000 , 1,000,000 , they all expand...

8,000 to 10,000 compresses 8% to 12% after 40 loops...
Maybe you could break the data , into chunks of 8,192 , 8,192 compresses..

Here it is in your 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 8192
            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 bytes=""
    dim as string zeros=string(64,"0")
    dim as ulongint n1
    dim as ulongint ptr usp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        n1 = *usp : usp+=1
        bytes+=right(zeros+bin(n1),64)
    next
   
    print "c inp =  "; len(bytes) ', bytes
   
    dim as longint count1=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(bytes)/3)
        dec1=instr(1,str1,".")
        if dec1<>0 then bytes = "0" + bytes : count1+=1
    loop until dec1=0
   
    dim as string outputs=""
    dim as string bits
    for a as longint = 1 to len(bytes) step 3
       
        bits = mid(bytes,a,3)
       
        if bits = "000" then outputs+="0"
        if bits = "001" then outputs+="1"
        if bits = "010" then outputs+="12"
        if bits = "011" then outputs+="21"
       
        if bits = "100" then outputs+="22"
        if bits = "101" then outputs+="23"
        if bits = "110" then outputs+="32"
        if bits = "111" then outputs+="3"
   
    next
   
    print "c out =  "; len(outputs) ', outputs
   
    dim as longint count2=0
    do
        str1=str(len(outputs)/3)
        dec1=instr(1,str1,".")
        if dec1<>0 then outputs+="0" : count2+=1
    loop until dec1=0
   
    dim as string final=""
    for a as longint = 1 to len(outputs) step 3
        final+=chr(val("&O"+mid(outputs,a,3)))
    next
   
    print "c fin =  "; len(final) ' , final
   
    final = chr(count1) + chr(count2) + final
   
    return final
   
end function
'===============================================================================
'============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as longint count1 = asc(left(chrs,1))
    chrs = mid(chrs,2)
    dim as longint count2 = asc(left(chrs,1))
    chrs = mid(chrs,2)
   
    dim as string bytes=""
    dim as ulongint n1
    for a as longint = 0 to len(chrs)-1 step 1
        n1 = chrs[a]
        bytes+=right("000"+oct(n1),3)
    next
   
    bytes = left(bytes,len(bytes)-count2)
   
    print "d inp =  "; len(bytes) ', bytes
   
    return chrs

end function



EDITED...

Never mind...

it only compresses 30% after 300 loops , with 8,192
With 10,000 , it compresses 50% after 400 loops.

Return to “General”

Who is online

Users browsing this forum: MrSwiss and 53 guests