function Binary(byte as integer) as string
dim i, b as integer
dim bin as string
b=byte
for i=7 downto 0
bin=bin+str(b\pow(2,i))
b=b mod pow(2,i)
next
return bin
end function
function FindRepeatedBytes(str1 as string, str2 as string, maxDistance as integer) as integer
dim pos, curInStr, skip, length as integer
dim source, find as string
source=right(str1, maxDistance*8)
find=str2
do
//inStr is a search function which returns 0 if the string to be found does not occur,
//and n+1 if n characters precede its first occurrence
curInStr=inStr(source, find)
if curInStr > 0 then
if curInStr mod 8 = 1 then
pos=skip+curInStr\8+1
end if
skip=skip+ceil(curInStr/8)
source=right(source, len(source)-ceil(curInStr/8)*8)
end if
loop until curInStr=0
return pos
end function
dim i, j, byte, position, count, offset, length, max as integer
dim newBytes, compressed, raw as string
dim in, out as binaryStream
dim file as folderItem
dim stop as boolean
file=GetOpenFolderItem("type") //displays "Open File" dialog box
if file <> nil then
in=file.OpenAsBinaryFile(false)
in.position=in.length-1
while not stop
count=0
do
byte=in.ReadByte
if in.position=1 then
stop=true
else
in.position=in.position-2
end if
newBytes=newBytes+Binary(byte)
if len(raw) < max*8 then
offset=len(raw)\8-position
else
offset=max-position
end if
if len(newBytes) <= 32 then
max=pow(2, 6+len(newBytes)\8)
else
max=4096
end if
position=FindRepeatedBytes(raw, newBytes, max)
count=count+1
loop until position=0 or count > 256 or stop
if len(newBytes) > 16 then
if not stop then
in.position=in.position+1
count=count-1
newBytes=left(newBytes, len(newBytes)-8)
end if
if length > 0 then
if length <= 8 then
compressed=left(compressed, len(compressed)-length*8)+right(Binary(length-1), 5)+right(compressed, length*8)
else
compressed=left(compressed, len(compressed)-length*8)+"111"+Binary(length-9)+right(compressed, length*8)
end if
length=0
end if
select case count
case 2
compressed=compressed+"01"+Binary(offset)
case 3
compressed=compressed+"100"+right(Binary(offset\256), 1)+Binary(offset mod 256)
case 4
compressed=compressed+"101"+right(Binary(offset\256), 2)+Binary(offset mod 256)
else
compressed=compressed+"110"+Binary(count-1)+right(Binary(offset\256), 4)+Binary(offset mod 256)
end select
else
if length+count <= 264 then
compressed=compressed+newBytes
length=length+count
else
compressed=left(compressed, len(compressed)-length*8)+"111"+Binary(length-9)+right(compressed, length*8)
compressed=compressed+newBytes
length=count
end if
end if
raw=raw+newBytes
if len(raw) > 32768 then
raw=right(raw, 32768)
end if
newBytes=""
wend
if length > 0 then
if length <= 8 then
compressed=left(compressed, len(compressed)-length*8)+right(Binary(length-1), 5)+right(compressed, length*8)
else
compressed=left(compressed, len(compressed)-length*8)+"111"+Binary(length-9)+right(compressed, length*8)
end if
length=0
end if
out=GetFolderItem(file.name+" Compressed").CreateBinaryFile("type") //creates a binary file with the original file name plus "Compressed"
j=len(compressed) mod 8
out.WriteByte j
if left(compressed, 1) = "0" then
if j > 4 then
for i=7 downto j
newBytes=newBytes+"0"
next
compressed=left(compressed, 5)+newBytes+right(compressed, len(compressed)-5)
elseif j=4 then
compressed=left(compressed, 4)+"0000"+right(compressed, len(compressed)-4)
elseif j=0 then
compressed=compressed+"00000000"
end if
else
for i=7 downto j
newBytes=newBytes+"0"
next
if j=0 then
compressed=newBytes+compressed
elseif j < 3 then
compressed=left(compressed, j)+newBytes+right(compressed, len(compressed)-j)
elseif j < 5 then
compressed=left(compressed, 3)+newBytes+right(compressed, len(compressed)-3)
else
compressed=left(compressed, 7)+newBytes+right(compressed, len(compressed)-7)
end if
end if
max=ceil(len(compressed)/8)
out.WriteByte 0
out.WriteLong in.length
out.WriteLong max+10
for i=1 to max
byte=0
for j=7 downto 0
byte=byte+val(right(compressed,1))*pow(2,j)
compressed=left(compressed, len(compressed)-1)
next
out.WriteByte byte
next
in.close
out.close
end if