this is a prefix compressor i've been working on. It works by switching characters in a file with prefix codes of varying lengths, some shorter than the character and some longer. If you've come across things like "fibinacci encoders/compressors", this one is a little different because it optimizes the prefix codes a bit (or 2, *slaps knee*).
Use it for whatever you want. If it's in a project you don't need to include any credits, but if you want to share the source code somewhere else try to include my name ;)
-edit: forgot to say: This should only use ~1-2mb of memory (never bothered to check) regardless of the file. It is also fast (though i haven't benchmarked that either)
;******************************************************************************************************************************
;************************************************* Prefix compression *********************************************************
;******************************************************************************************************************************
;by Alec Dee
;this compression method swaps bytes with prefix codes of lengths 2 Or greater. The prefix codes are generated by
;fibinacci numbers with some improvement To the original codes, For example:
;Before After
;11 11
;011 011
;0011 001
;1011 101
;00011 000
;10011 100
;01011 010
;the Last "block" of prefixes can have the Last two 1's taken away And the second To Last block can have the Last
;1 taken away, For shorter prefixes.
;this compressor also uses order-1 modeling. This changes the frequency of characters based on the last character
;read, english text usually has big compression improvements with this method
Dim counts(0,0)
Dim places(0,0)
Dim replaces(0,0)
Dim fibs(0)
Dim prefix_codes(0)
Dim prefix_lengths(0)
Function prefix(file$,newfile$)
in=ReadFile(file)
If in=0
RuntimeError file+" cannot be read"
EndIf
out=WriteFile(newfile)
If out=0
RuntimeError newfile+" cannot be written"
EndIf
size=FileSize(file)
Dim counts(255,255)
Dim places(255,255)
Dim replaces(255,255)
Dim fibs(13)
;holds the binary string of prefix codes
Dim prefix_codes(255)
;holds the lengths of the prefix codes
Dim prefix_lengths(255)
;these fibinacci numbers are going to be used to compute the prefix codes
fibs(0)=1
fibs(1)=2
fibs(2)=3
fibs(3)=5
fibs(4)=8
fibs(5)=13
fibs(6)=21
fibs(7)=34
fibs(8)=55
fibs(9)=89
fibs(10)=144
fibs(11)=233
fibs(12)=377
oldpos=0
prepos=0
bit=0
;compute the prefix's
For i=0 To 255
bit=i+1
If fibs(oldpos+1)=bit
oldpos=oldpos+1
EndIf
prefix_lengths(i)=oldpos+1
prepos=oldpos
prefix_codes(i)=1
While prepos>-1
If fibs(prepos)<=bit
prefix_codes(i)=prefix_codes(i)+(1 Shl (prefix_lengths(i)-prepos))
bit=bit-fibs(prepos)
EndIf
prepos=prepos-1
Wend
Next
;remove unecessary bits from the end prefix's
For i=0 To 255
move=prefix_lengths(i)-oldpos+1
If move>0
prefix_lengths(i)=prefix_lengths(i)-move
prefix_codes(i)=prefix_codes(i) Shr move
EndIf
Next
last_byte=0
buffer=0
bits_left=7
max_frequency=16382 ;when one of the counts(x,x) crosses this it's values get halved, if you change this value make sure to
;change it for unprefix
;set the default values for count, and lookup tables
For i=0 To 255
For t=0 To 255
counts(i,t)=0
places(i,t)=t
replaces(i,t)=t
Next
Next
;read each bit of the file
For i=1 To size
c=ReadByte(in)
counts(last_byte,c)=counts(last_byte,c)+32
If counts(last_byte,c)>max_frequency
For t=0 To 255
counts(last_byte,t)=counts(last_byte,t) Shr 1
Next
EndIf
;find the character's place (rank according to other counts)
place=replaces(last_byte,c)
;output the prefix code for that place, which is hopefully has a length < 8
For t=prefix_lengths(place) To 0 Step -1
buffer=buffer Or (((prefix_codes(place) Shr t) And 1) Shl bits_left)
bits_left=bits_left-1
;if the output buffer gets filled, output the buffer and reset it
If bits_left=-1
WriteByte out,buffer
bits_left=7
buffer=0
EndIf
Next
;sort the character based on it's neighbors
If place>0
While counts(last_byte,places(last_byte,place-1))<counts(last_byte,places(last_byte,place))
oldplace=places(last_byte,place-1)
places(last_byte,place-1)=places(last_byte,place)
places(last_byte,place)=oldplace
replaces(last_byte,c)=replaces(last_byte,c)-1
replaces(last_byte,oldplace)=replaces(last_byte,oldplace)+1
place=place-1
If place=0
Exit
EndIf
Wend
EndIf
;record this byte, this is what's needed for the order-1 effect
last_byte=c
Next
;the buffer wasn't completely filled, but has imformation anyway, so output it
If bits_left<>7
WriteByte out,buffer
EndIf
Dim counts(0,0)
Dim places(0,0)
Dim replaces(0,0)
Dim fibs(0)
Dim prefix_codes(0)
Dim prefix_lengths(0)
CloseFile(in)
CloseFile(out)
End Function
;this decompresses the prefix encoded files
;the prefix codes aren't used in this one, because they aren't needed. Prefix values can be calculated instead just using
;the fibinacci numbers
Function unprefix(file$,newfile$)
in=ReadFile(file)
If in=0
RuntimeError file+" cannot be read"
EndIf
out=WriteFile(newfile)
If out=0
RuntimeError newfile+" cannot be written"
EndIf
size=FileSize(file)
Dim counts(255,255)
Dim places(255,255)
Dim replaces(255,255)
Dim fibs(12)
fibs(0)=1
fibs(1)=2
fibs(2)=3
fibs(3)=5
fibs(4)=8
fibs(5)=13
fibs(6)=21
fibs(7)=34
fibs(8)=55
fibs(9)=89
fibs(10)=144
fibs(11)=233
fibs(12)=377
last_byte=0
bitval=0
prepos=0
thisbit=0
lastbit=0
madesymbol=0
max_frequency=16382
For i=0 To 255
For t=0 To 255
counts(i,t)=0
places(i,t)=t
replaces(i,t)=t
Next
Next
For i=1 To size
c=ReadByte(in)
For mask=7 To 0 Step -1
thisbit=(c Shr mask) And 1
If lastbit And thisbit
madesymbol=1
ElseIf prepos=10
If thisbit
bitval=bitval+144
Else
bitval=bitval+233
EndIf
madesymbol=1
Else
bitval=bitval+thisbit*fibs(prepos)
prepos=prepos+1
lastbit=thisbit
EndIf
If madesymbol
bitval=bitval-1
symbol=places(last_byte,bitval)
WriteByte out,symbol
counts(last_byte,symbol)=counts(last_byte,symbol)+32
If counts(last_byte,symbol)>max_frequency
For t=0 To 255
counts(last_byte,t)=counts(last_byte,t) Shr 1
Next
EndIf
place=bitval
If place>0
While counts(last_byte,places(last_byte,place-1))<counts(last_byte,places(last_byte,place))
oldplace=places(last_byte,place-1)
places(last_byte,place-1)=places(last_byte,place)
places(last_byte,place)=oldplace
replaces(last_byte,symbol)=replaces(last_byte,c)-1
replaces(last_byte,oldplace)=replaces(last_byte,oldplace)+1
place=place-1
If place=0
Exit
EndIf
Wend
EndIf
last_byte=symbol
bitval=0
prepos=0
madesymbol=0
lastbit=0
EndIf
Next
Next
Dim counts(0,0)
Dim places(0,0)
Dim replaces(0,0)
Dim fibs(0)
CloseFile(in)
CloseFile(out)
End Function
;prefix("agog.bmp","alec.txt")
;unprefix("alec.txt","agog2.bmp")
;sometimes this compressor doesn't compress everything completely, try compressing more than once
;prefix("agog.bmp","alec1.txt")
;prefix("alec1.txt","alec2.txt")
;unprefix("alec2.txt","alec3.txt")
;unprefix("alec3.txt","agog2.bmp")
|
