Squares

General FreeBASIC programming questions.
Locked
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Try this Albert.
Create a folder (I call mine folder1) with some files.
You can have other folders containing files inside folder1 also.

#inclib "zlib1" here, you will have a different name I think.
Then run this code beside your folder.

Code: Select all

 

#Include "dir.bi"
#include "file.bi"
#inclib "zlib1"

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

Namespace fbz

Dim  As String file
Dim  As Integer f
Dim As boolean expand,folder
Dim  As Integer passed_length
Dim  As Ubyte Ptr source,destination

Sub string_split(Byval s As String,chars As String,result() As String)
    Redim result(0)
    Dim As String var1,var2
    Dim As Long pst,LC=Len(chars)
    #macro split(stri)
    pst=Instr(stri,chars)
    var1="":var2=""
    If pst<>0 Then
        var1=Mid(stri,1,pst-1)
        var2=Mid(stri,pst+LC)
    Else
        var1=stri
    End If
    If Len(var1) Then 
        Redim Preserve result(1 To Ubound(result)+1)
        result(Ubound(result))=var1
    End If
    #endmacro
    Do
        split(s):s=var2
    Loop Until var2=""
End Sub

Function getfileuc(file As String) As String
    If Fileexists(file)=0 Then Print file;" not found":Sleep:End
    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
    f=Freefile
    Open file For Binary Access Read As #f
    Dim As String text
    If Lof(f) > 0 Then
        text = String(Lof(f), 0)
        Get #f, , text
    End If
    Close #f
    splice(text,"|",var1,var2)
    text=var2
    passed_length=Valint(var1)
    Return text
End Function

Function getfile(file As String) As String
    If Fileexists(file)=0 Then Print file;" not found":Sleep:End
    f=Freefile
    Open file For Binary Access Read As #f
    Dim As String text
    If Lof(f) > 0 Then
        text = String(Lof(f), 0)
        Get #f, , text
    End If
    Close #f
    Return text
End Function

'=================   UNPACK ===============
Sub unpack
    Var text=getfileuc(file)
    Dim As Integer stringlength,destinationlength
    stringlength=Len(text)
    destinationlength =passed_length
    destination =Allocate(destinationlength)
    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
    'Build the uncompressed string
    uncompressed=String(destinationlength,0)
    Print "Please wait"
    For i As Integer = 0 To destinationlength- 1
        uncompressed[i]=(destination[i])
    Next
    Redim As String temp()
    string_split(file,"\",temp())
    Var filename= Rtrim(temp(Ubound(temp)),".fbz")
    
    f=Freefile
    Open "_"+filename For Output As #f
    Print #f,uncompressed
    Close #f
    Print "The UNcompressed file is "&"_"+filename
End Sub

'===================  PACK ============

Sub pack
    Var text=getfile(file)
    Dim As Integer stringlength,destinationlength
    stringlength=Len(text)
    destinationlength = compressBound(stringlength)
    destination = Allocate(destinationlength)
    source=@text[0]
    Var mistake=compress(destination, @destinationlength, source, stringlength)
    Redim As String temp()
    string_split(file,"\",temp())
    Var filename=temp(Ubound(temp))
    Print filename & "  To  Compress"
    Print filename & "            Length = ";Len(text)
    Print filename & " Compressed length = ";destinationlength
    Print "Compression = ";destinationlength/Len(text)
    If mistake <>0 Then Print "There was an error"
    Dim As String compressed=String(destinationlength,0)
    For n As Integer=0 To destinationlength-1
        compressed[n]=destination[n]
    Next n
    
    f=Freefile
    Open filename+".fbz" For Output As #f
    Print #f,stringlength &"|";
    Print #f,compressed
    Close #f
    Print "The compressed file is "&filename+".fbz"
End Sub

Function isfolder(fname As String) As boolean
    Return Len(Dir(fname,fbDirectory))
End Function

Function isfile(fname As String) As boolean
    Return Iif(isfolder(fname),0,1)
End Function

Function pipeout(Byval s As String="") Byref As String
    Var f=Freefile
    Dim As String tmp
    Open Pipe s For Input As #f 
    s=""
    Do Until Eof(f)
        Line Input #f,tmp
        s+=tmp+Chr(10)
    Loop
    Close #f
    Return s
End Function



Sub finish Destructor
    Print "ending"
    Deallocate destination
    destination=0
End Sub


End Namespace

'==============  use =========

Sub compressfolder(inputs As String)
    Dim As String s=fbz.pipeout("dir /b " + inputs)
    Dim As String a()
    dim as long counter
    fbz.string_split(s,Chr(10),a())
    Dim As String newfolder=inputs+".fbz"
    if fbz.isfolder(newfolder)=true then shell "rmdir /Q /s "+ newfolder
    Shell "mkdir "+ newfolder
    For n As Long=Lbound(a) To Ubound(a)
        counter+=1
        Dim As String path=(inputs+"\"+a(n))
        If fbz.isfile(path) Then
            fbz.file=path
            fbz.pack
        Shell "move "+ a(n)+".fbz  " + newfolder
        Else
            compressfolder(path) 'for nested folders
            Shell "move "+ path+".fbz  " + newfolder
        End If
        Print
    Next n
    Print "Total number files compressed = ";counter
    Print "Destination folder is  ";newfolder
End Sub


Dim  As String inputs="folder1" '<---------  a folder with files.

If fbz.isfolder(inputs) Then fbz.folder=true
If Instr(inputs,".fbz") Then fbz.expand=true Else fbz.expand=false



'============  'compress a folder + files==========
If fbz.expand=false And fbz.folder=true Then  compressfolder(inputs)



Sleep

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

Re: Squares

Post by albert »

@Dodicat

I need to be able to compress a folder..

But , i need to bring each file , into a looping data compressor , for 10 to ?? iterations , before it goes out to the zip folder..
Also a file ; needs to be greater than 5K to compress.

Can you put in code to allow for a file to be , repetitively compressed and decompressed?

I tried a binary dictionary and it works , it expands for several runs , and then begins compressing.
i also have a working de-compressor written..

So all i need ; is to compress files and folders..
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert.
if you put a fresh extracted distro of freebasic ("freebasic-1.06.0-win64") somewhere and use my compressor, it compresses to 26.9 mb from 138 mb.
It takes about a minute due to all the printing.
The only error I made in my previous code was
dim as long counter
should have been
static as long counter.
but it only shows the total number of files compressed.
After that it won't compress any further with windows zip.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

I just need a place in your code , to loop , compressing and decompressing each file..

My compression algorythym , needs like 10 to 70 loops to compress and decompress.

Can you make it so , it can loop for each file ( in an out ) ..

My algoriyhym , can compress random data , to 50+% to 90+% with enough loops..
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

If your compress algo receives a filename as parameter and saves the compressed file with extension filename .fbz
example

mytext.txt
is compressed and saved as
mytext.txt.fbz

Then you could try this

Code: Select all


#Include "dir.bi"
#include "file.bi"
Sub string_split(Byval s As String,chars As String,result() As String)
    Redim result(0)
    Dim As String var1,var2
    Dim As Long pst,LC=Len(chars)
    #macro split(stri)
    pst=Instr(stri,chars)
    var1="":var2=""
    If pst<>0 Then
        var1=Mid(stri,1,pst-1)
        var2=Mid(stri,pst+LC)
    Else
        var1=stri
    End If
    If Len(var1) Then 
        Redim Preserve result(1 To Ubound(result)+1)
        result(Ubound(result))=var1
    End If
    #endmacro
    Do
        split(s):s=var2
    Loop Until var2=""
End Sub

Function isfolder(fname As String) As boolean
    Return Len(Dir(fname,fbDirectory))
End Function

Function isfile(fname As String) As boolean
    Return Iif(isfolder(fname),0,1)
End Function

Function pipeout(Byval s As String="") Byref As String
    Var f=Freefile
    Dim As String tmp
    Open Pipe s For Input As #f 
    s=""
    Do Until Eof(f)
        Line Input #f,tmp
        s+=tmp+Chr(10)
    Loop
    Close #f
    Return s
End Function

Sub compressfolder(inputs As String)
    Dim As String s=pipeout("dir /b " + inputs)
    Dim As String a()
    static as long counter
    string_split(s,Chr(10),a())
    Dim As String newfolder=inputs+".fbz"
    if isfolder(newfolder)=true then shell "rmdir /Q /s "+ newfolder
    Shell "mkdir "+ newfolder
    For n As Long=Lbound(a) To Ubound(a)
        counter+=1
        Dim As String path=(inputs+"\"+a(n))
        If isfile(path) Then
            
         '   compress(path)'<<<   your compressor here
            
        Shell "move "+ a(n)+".fbz  " + newfolder
        Else
            compressfolder(path) 'for nested folders
            Shell "move "+ path+".fbz  " + newfolder
        End If
        Print
    Next n
    Print "Total number files compressed = ";counter
    Print "Destination folder is  ";newfolder
End Sub

dim as string folder="foldername" '<---- YOUR FOLDER HERE
dim as long count
do
    count+=1
    compressfolder(folder)
    folder+=".fbz"
loop until count=20

  
Where you put in your compressor and folder.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

As it's bringing in the files of the folder , i need to run each of the files through a compression loop..
And as it decompresses , i need to run the files through a decompression loop.

Can you put in code to have a

Declare Function compressor_loop( s as string ) as string
Declare Function decompressor_loop( s as string ) as string

Then divert the files , as they come in , to the right function...
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert.
You could try this looper.
Folders and file names should have no spaces.
If you loop too many the folder name becomes too long, so just a few loops.

Code: Select all

#Include "dir.bi"
#include "file.bi"
#inclib "zlib1"

Extern "C"
Declare Function compressBound(Byval sourceLen As Ulong) As Ulong
Declare Function uncompress(Byval dest As Ubyte Ptr, Byval destLen As Ulong Ptr, Byval source As Const Ubyte Ptr, Byval sourceLen As Ulong) As Long
Declare Function compress(Byval dest As Ubyte Ptr, Byval destLen As Ulong Ptr, Byval source As Const Ubyte Ptr, Byval sourceLen As Ulong) As Long
End Extern
Declare Function rename Cdecl Alias "rename"(Byval As zstring Ptr, Byval As zstring Ptr) As Long

Function String_Split(s_in As String,chars As String,result() As String) As Long
    Dim As Long ctr,ctr2,k,n,LC=Len(chars)
    Dim As boolean tally(Len(s_in))
    #macro check_instring()
    n=0
    While n<Lc
        If chars[n]=s_in[k] Then 
            tally(k)=true
            If (ctr2-1) Then ctr+=1
            ctr2=0
            Exit While
        End If
        n+=1
    Wend
    #endmacro
    
    #macro split()
    If tally(k) Then
        If (ctr2-1) Then ctr+=1:result(ctr)=Mid(s_in,k+2-ctr2,ctr2-1)
        ctr2=0
    End If
    #endmacro
    '==================  LOOP TWICE =======================
    For k  =0 To Len(s_in)-1
        ctr2+=1:check_instring()
    Next k
    If ctr Then Redim result(1 To ctr): ctr=0:ctr2=0 Else  Return 0
    For k  =0 To Len(s_in)-1
        ctr2+=1:split()
    Next k
    '===================== Last one ========================
    If ctr2>0 Then
        Redim Preserve result(1 To ctr+1)
        result(ctr+1)=Mid(s_in,k+1-ctr2,ctr2)
    End If
    Return Ubound(result)
End Function

Function getfile(file As String) As String
    If Fileexists(file)=0 Then Print file;" not found":Sleep:End
    Dim As Integer f=Freefile
    Open file For Binary Access Read As #f
    Dim As String text
    If Lof(f) > 0 Then
        text = String(Lof(f), 0)
        Get #f, , text
    End If
    Close #f
    Return text
End Function

Sub pack(file As String,location As String="")
    Var text=getfile(file)
    Dim As Integer stringlength,destinationlength
    Dim  As Ubyte Ptr source,destination
    stringlength=Len(text)
    destinationlength = compressBound(stringlength)
    destination = Allocate(destinationlength)
    source=@text[0]
    Var mistake=compress(destination, @destinationlength, source, stringlength)
    Redim As String temp()
    string_split(file,"\/",temp())
    Var filename=temp(Ubound(temp))
    Print filename & "  To  Compress"
    ' Print filename & "            Length = ";Len(text)
    'Print filename & " Compressed length = ";destinationlength
    Print "Compression = ";destinationlength/Len(text)
    If mistake <>0 Then Print "There was an error"
    Dim As String compressed=String(destinationlength,0)
    For n As Integer=0 To destinationlength-1
        compressed[n]=destination[n]
    Next n
    
    Dim As Integer f=Freefile
    If location="" Then
        Open filename+".fbz" For Output As #f
        Print #f,stringlength &"|";
        Print #f,compressed
        Close #f
    Else
        Open location+"/"+filename+".fbz" For Output As #f
        Print #f,stringlength &"|";
        Print #f,compressed
        Close #f
    End If
    ' Print "The compressed file is "&filename+".fbz"
    Deallocate(destination)
End Sub

Function isfolder(fname As String) As boolean
    Return Len(Dir(fname,fbDirectory))
End Function

Function isfile(fname As String) As boolean
    Return Iif(isfolder(fname),0,1)
End Function

Function pipeout(Byval s As String="") Byref As String
    Var f=Freefile
    Dim As String tmp
    Open Pipe s For Input As #f 
    s=""
    Do Until Eof(f)
        Line Input #f,tmp
        s+=tmp+Chr(10)
    Loop
    Close #f
    Return s
End Function

Sub compressfolder(inputs As String,flag As Long=0)
    Dim As String s=pipeout("dir /b " + inputs)
    Dim As String a()',nm
    Static As Long counter
    string_split(s,Chr(10),a())
    Dim As String newfolder=inputs+".fbz"
    If isfolder(newfolder)=true Then Shell "rmdir /Q /s "+ newfolder
    Shell "mkdir "+ newfolder
    For n As Long=Lbound(a) To Ubound(a)
        counter+=1
        Dim As String path=(inputs+"\"+a(n))
        If isfile(path) Then
            
            pack(path,newfolder)'<<<   your compressor here
            
            ' Shell "move "+ a(n)+".fbz  " + newfolder
        Else
            compressfolder(path,0) 'for nested folders
            
            Shell "move "+ path+".fbz  " + newfolder
        End If
        ' Print
    Next n
    If flag Then
        print
        Print "Total number files compressed = ";counter
        Print "Destination folder is  ";newfolder
        Print "please wait while cleaning up . . ."
    End If
End Sub


Sub renameloop(folder As String)
    Dim As String s=pipeout("dir /b " + folder)
    Dim As String a()
    string_split(s,Chr(10),a())
    For n As Long=Lbound(a) To Ubound(a)
        Dim As String path=(folder+"\"+a(n))
        If isfile(path) Then
            Var s=Rtrim(a(n),".fbz")
            s+=".fbz"
            rename(folder+"\"+a(n),folder+"\"+s)
            '  Shell "rename "+folder+"\"+a(n)+"  "+s   
        Else
            Var s=Rtrim(a(n),".fbz")
            s+=".fbz"
            renameloop(path) 'for nested folders
            rename(folder+"\"+a(n),folder+"\"+s)
            ' Shell "rename "+path +"  "+s  
        End If
    Next n
End Sub

Sub compressloop(folder As String,num As Long)
    if isfolder(folder)=0 then print folder + "  not found":sleep:end
    Dim As Long count
    Do
        count+=1
        compressfolder(folder,count=num)
        Var f=folder
        folder+=".fbz"
        If Instr(f,".fbz") Then Shell "rmdir /Q /s "+ f
    Loop Until count=num
    renameloop(folder)
    Print "Done"
End Sub

Dim As String folder="folder"'<---- YOUR FOLDER HERE


compressloop(folder,3)

Sleep
  
I have used the zlib compressor so looping is a waste of time as you can see by the compressions.
Try files inside folders inside folders ... inside your main folder.
don't have any empty folders.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

Thanks , I'll have a look-see...

How do you create a static array , inside a function , if you don't know how many elements that will be in the array???

Code: Select all


Declare Function comp( s as string ) as string

screen 19

do
    
    dim as string s = "123456"
    
    dim as string ans = comp(s)
    
    print ans
    
    sleep

loop until inkey = chr(27)


function comp( s as string) as string
    
    static as ubyte runs
    static as string array(1 to 6)  ' how to make it a variable array length??
    static as string dict
    
    if runs = 0 then
    
        for a as longint = lbound(array) to ubound(array)
            array(a) = mid(s,a,1)
        next
        
        for a as longint = lbound(array) to ubound(array)
            dict+=array(a)
        next
    
    end if
    
    runs = 1
    
    return dict
   
end function
    
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

I got it figured out..
You have to redim the static array , inside the function..

Code: Select all


Declare Function comp( s as string ) as string

screen 19

do
    
    dim as string s = "123456"
    
    dim as string ans = comp(s)
    
    print ans
    
    sleep

loop until inkey = chr(27)


function comp( s as string) as string
    
    static as ubyte runs
    static as string array(0)
    static as string dict
    
    if runs = 0 then
        
        redim preserve array(0 to len(s))
        for a as longint = lbound(array) to ubound(array)
            array(a) = mid(s,a,1)
        next
        
        for a as longint = lbound(array) to ubound(array)
            dict+=array(a)
        next
    
    end if
    
    runs = 1
    
    return dict
    
    
end function

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

Re: Squares

Post by dodicat »

To be correct, you should
static as string array()
Then redim preserve and load it on the first run.

Code: Select all

Declare Function comp( s as string ) as string

screen 19

do
    
    dim as string s = "123456"
    
    dim as string ans = comp(s)
    
    print "ANS "; ans
    
    sleep

loop until inkey = chr(27)


function comp( s as string) as string
    
    static as ubyte runs
    static as string array()
    dim as string dict
    
    if runs = 0 then
        redim preserve array(1 to len(s))
        for a as longint = lbound(array) to ubound(array)
            array(a) = mid(s,a,1)
        next
      runs=1  
    end if

    for a as longint = lbound(array) to ubound(array)
            dict+=array(a)
        next
    
    
    return dict
    
    
end function
  
or the other way

Code: Select all

Declare Function comp( s as string ) as string

screen 19

do
    
    dim as string s = "123456"
    
    dim as string ans = comp(s)
    
    print "ANS "; ans
    
    sleep

loop until inkey = chr(27)


function comp( s as string) as string
    
    static as ubyte runs
    static as string array(1 to 6)
    dim as string dict
    
    if runs = 0 then
        for a as longint = lbound(array) to ubound(array)
            array(a) = mid(s,a,1)
        next
      runs=1  
    end if

    for a as longint = lbound(array) to ubound(array)
            dict+=array(a)
        next
    
    
    return dict
    
    
end function
  
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

I ran some tests on my compressor...

It was going a few iterations , expanding , and then compressing by several percent. Then it would expand a couple iterations and then compress.

So i compared the pre-compression with the de-compression..
And everywhere it compressed , the de-compression didn't equal the pre-compression..

So it's a total failure....Back to the drawing board...

My tests on the code was , that out of 50 runs , 1 run it would error...with input = 100
On input of 10,000 , it was erroring like every couple runs..
On input of 100,000 , it was erroring every run..

I still need to debug the errors...
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Yea Albert, if nothing else, common sense tells you that you cannot repeat compress into oblivion, especially if you need lossless results.
Anyway, I missed my own millions by a foot of soil and some worms a few days ago.
Detectorists discovered a (yet) small hoard of gold coins in the field 100 yards from this keyboard.
I couldn't count how many times I have taken walks with various dogs around it in these last forty years.
I think now I should get a small detector and carry it around everywhere I go.
I am sure there are kinds which can detect from a jacket pocket, if not, then they should be invented.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

Can you figure out the problem??

Code: Select all


screen 19

do
    dim as string binari=""
    for a as longint = 0 to 100
        binari+=str(int(rnd*2))
    next
    
    dim as string ascii=""
    for a as longint = 1 to len(binari) step 64
        ascii+=mklongint(val("&B"+mid(binari,a,64)))
    next
    
    dim as string compare=""
    for a as longint = 1 to len(ascii) step 8
        compare+=bin(cvlongint(mid(ascii,a,8)))
    next
    
    print
    print binari
    print compare

    sleep
    
loop until inkey=chr(27)

sleep
end

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

Re: Squares

Post by dodicat »

Hi Albert.
valulng--for ulongint
cast(ulongint,cvlongint(~)) -- for ulongint
and bring bin to 64 places for ulongint

Code: Select all

'screen 19
#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
do
    dim as string binari=""
    for z as long=1 to 4 'get number a multiple of 64 digits
    for a as longint = 0 to 63
       if a=0 and z=1 then binari="1" else binari+=str(int(rnd*2))
    next
    next z
    
   ' print len(binari)
    
    dim as string ascii=""
    for a as ulongint = 1 to len(binari) step 64
        ascii+=mklongint(valulng("&B"+mid(binari,a,64)))'mklongintOK for ulongint
    next
    
    dim as string compare=""
    for a as ulongint = 1 to len(ascii) step 8
        compare+=bin(cast(ulongint,cvlongint(mid(ascii,a,8))),64 )'must cast cvlongint to ulongint
    next
    
    print
    print binari
    print compare

    sleep
    
loop until inkey=chr(27)

sleep
end
 
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

If i use valulng(64) it doessn't compress..
if i use val(64) it compresses...but in some places , it errors..

I'm , trying to figure out , how to correct the errors...
Locked