I'm not sure I'm handling files that have only one type of byte in them since the root of the binary tree is a leaf node... :/
don't try to compress a 0 byte file, there is no error checking
Code: Select all
option explicit
'' simple binary tree
namespace bt
type node_t
index as integer
node_flags as ubyte
node(1) as node_t ptr
end type
const leaf_node = 0, branch_node = 1
function create_leaf (index as integer = 0) as node_t ptr
dim as node_t ptr node_new = callocate(sizeof(node_t))
node_new->index = index
node_new->node_flags = leaf_node
return node_new
end function
function create_branch (index as integer = 0, byval node0 as node_t ptr = 0, byval node1 as node_t ptr = 0) as node_t ptr
dim as node_t ptr node_new = callocate(sizeof(node_t))
node_new->index = index
node_new->node_flags = branch_node
node_new->node(0) = node0
node_new->node(1) = node1
return node_new
end function
function destroy (byval node_given as node_t ptr) as ubyte
if node_given->node_flags and branch_node then
if node_given->node(0) then destroy(node_given->node(0))
if node_given->node(1) then destroy(node_given->node(1))
end if
deallocate(node_given)
return 0
end function
function calculate_size (byval node_given as node_t ptr) as uinteger
dim as uinteger size
if node_given->node_flags and branch_node then
if node_given->node(0) then size += calculate_size(node_given->node(0))
if node_given->node(1) then size += calculate_size(node_given->node(1))
else
size += 8
end if
size += 1
return size
end function
function save_tree (byval node_given as node_t ptr, bt_data as ubyte ptr, bt_data_ptr as uinteger = 0, bt_data_bit_ptr as byte = 8) as ubyte
if bt_data_bit_ptr = 0 then
bt_data_ptr += 1
bt_data_bit_ptr = 8
end if
bt_data_bit_ptr -= 1
if node_given->node_flags and branch_node then
bt_data[bt_data_ptr] = bitreset(bt_data[bt_data_ptr], bt_data_bit_ptr)
if node_given->node(0) then save_tree(node_given->node(0), bt_data, bt_data_ptr, bt_data_bit_ptr)
if node_given->node(1) then save_tree(node_given->node(1), bt_data, bt_data_ptr, bt_data_bit_ptr)
else
bt_data[bt_data_ptr] = bitset(bt_data[bt_data_ptr], bt_data_bit_ptr)
dim as ubyte i
for i = 0 to 7
if bt_data_bit_ptr = 0 then
bt_data_ptr += 1
bt_data_bit_ptr = 8
end if
bt_data_bit_ptr -= 1
if bit(node_given->index, 7 - i) then
bt_data[bt_data_ptr] = bitset(bt_data[bt_data_ptr], bt_data_bit_ptr)
else
bt_data[bt_data_ptr] = bitreset(bt_data[bt_data_ptr], bt_data_bit_ptr)
end if
next
end if
return 0
end function
function load_tree (byval bt_data as ubyte ptr, bt_data_ptr as uinteger = 0, bt_data_bit_ptr as byte = 8) as node_t ptr
dim as node_t ptr return_node
if bt_data_bit_ptr = 0 then
bt_data_ptr += 1
bt_data_bit_ptr = 8
end if
bt_data_bit_ptr -= 1
if bit(bt_data[bt_data_ptr], bt_data_bit_ptr) = 0 then
return_node = create_branch(-1)
return_node->node(0) = load_tree(bt_data, bt_data_ptr, bt_data_bit_ptr)
return_node->node(1) = load_tree(bt_data, bt_data_ptr, bt_data_bit_ptr)
else
dim as uinteger index
dim as ubyte i
for i = 0 to 7
if bt_data_bit_ptr = 0 then
bt_data_ptr += 1
bt_data_bit_ptr = 8
end if
bt_data_bit_ptr -= 1
if bit(bt_data[bt_data_ptr], bt_data_bit_ptr) then
index = bitset(index, 7 - i)
else
index = bitreset(index, 7 - i)
end if
next
return_node = create_leaf(index)
end if
return return_node
end function
function dump (byval node_given as node_t ptr, indent as ubyte = 0) as ubyte
if node_given->node_flags and branch_node then
print string(indent, 32) & "branch: " & node_given->index
if node_given->node(0) then dump(node_given->node(0), indent + 2)
if node_given->node(1) then dump(node_given->node(1), indent + 2)
else
print string(indent, 32) & "leaf: " & node_given->index
end if
return 0
end function
function qtable (byval node_given as node_t ptr, path() as uinteger, bits() as ubyte, byref cpath as uinteger = 0, byref cbits as ubyte = 0) as ubyte
if cbits > 31 then print "QTABLE FAILED!" : stop
if node_given->node_flags and branch_node then
if node_given->node(0) then qtable(node_given->node(0), path(), bits(), (cpath shl 1), cbits + 1)
if node_given->node(1) then qtable(node_given->node(1), path(), bits(), (cpath shl 1) or 1, cbits + 1)
else
path(node_given->index) = cpath
bits(node_given->index) = cbits
end if
return 0
end function
end namespace
'' simple linked list
namespace ll
type node_t
index as integer
prev_node as node_t ptr
next_node as node_t ptr
foo as any ptr
end type
const as uinteger no_node = 0
declare function create (index as integer = 0) as node_t ptr
declare function destroy (byval node_given as node_t ptr) as node_t ptr
declare function insert_after (byval node_given as node_t ptr, index as integer = 0) as node_t ptr
declare function delete (byval node_given as node_t ptr) as node_t ptr
declare function nswap (byval node_given1 as node_t ptr, byval node_given2 as node_t ptr) as ubyte
declare function seek_first (byval node_given as node_t ptr) as node_t ptr
declare function sort_index (byval node_given as node_t ptr) as ubyte
declare function count (byval node_given as node_t ptr) as uinteger
declare function dump (byval node_given as node_t ptr) as ubyte
function create (index as integer = 0) as node_t ptr
dim as node_t ptr node_new = callocate(sizeof(node_t))
node_new->index = index
return node_new
end function
function destroy (byval node_given as node_t ptr) as node_t ptr
dim as node_t ptr node_current = node_given
node_current = seek_first(node_current)
do until (node_current->next_node = no_node)
node_current = node_current->next_node
deallocate(node_current->prev_node)
loop
deallocate(node_current)
return no_node
end function
function insert_after (byval node_given as node_t ptr, index as integer = 0) as node_t ptr
dim as node_t ptr node_new = callocate(sizeof(node_t))
if not(node_given->next_node = no_node) then
node_new->next_node = node_given->next_node
node_given->next_node->prev_node = node_new
end if
node_given->next_node = node_new
node_new->prev_node = node_given
node_new->index = index
return node_new
end function
function delete (byval node_given as node_t ptr) as node_t ptr
dim as node_t ptr node_current
if (node_given->prev_node = no_node) and (node_given->prev_node = no_node) then
node_current = no_node
elseif (node_given->prev_node = no_node) then
node_current = node_given->next_node
node_given->next_node->prev_node = no_node
elseif (node_given->next_node = no_node) then
node_current = node_given->prev_node
node_given->prev_node->next_node = no_node
else
node_current = node_given->next_node
node_given->prev_node->next_node = node_given->next_node
node_given->next_node->prev_node = node_given->prev_node
end if
deallocate(node_given)
return node_current
end function
function nswap (byval node_given1 as node_t ptr, byval node_given2 as node_t ptr) as ubyte
swap node_given1->index, node_given2->index
swap node_given1->foo, node_given2->foo
return 0
end function
function seek_first (byval node_given as node_t ptr) as node_t ptr
dim as node_t ptr node_current = node_given
do until (node_current->prev_node = no_node)
node_current = node_current->prev_node
loop
return node_current
end function
function sort_index (byval node_given as node_t ptr) as ubyte
dim as node_t ptr node_current = node_given
dim as node_t ptr node_grab, node_match
node_current = seek_first(node_current)
node_grab = node_current
do until (node_grab->next_node = no_node)
node_match = node_grab
node_current = node_grab
do until (node_current->next_node = no_node)
node_current = node_current->next_node
if (node_current->index < node_match->index) then node_match = node_current
loop
if (node_match <> node_grab) then nswap(node_match, node_grab)
node_grab = node_grab->next_node
loop
return 0
end function
function count (byval node_given as node_t ptr) as uinteger
dim as node_t ptr node_current = node_given
dim as uinteger ncount = 1
node_current = seek_first(node_current)
do until (node_current->next_node = no_node)
node_current = node_current->next_node
ncount += 1
loop
return ncount
end function
function dump (byval node_given as node_t ptr) as ubyte
dim as node_t ptr node_current = node_given
node_current = seek_first(node_current)
print "index", "foo", "previous", "next"
do
print hex(node_current->index, 8), hex(node_current->foo, 8),;
if not(node_current->prev_node = no_node) then
print hex(node_current->prev_node->index, 8),;
else
print " -",;
end if
if not(node_current->next_node = no_node) then
print hex(node_current->next_node->index, 8)
else
print " -"
exit do
end if
node_current = node_current->next_node
loop
return 0
end function
end namespace
select case command$(1)
case "c"
dim as ubyte ptr ddata, cdata, tdata
dim as uinteger ds, cs, ts, di, ci
dim as ubyte cb = 8
dim as uinteger f = freefile
open command$(2) for binary access read as #f
ds = lof(f)
ddata = callocate(ds)
get #f, , *ddata, ds
close #f
print " building tree..."
dim as uinteger u(255)
for di = 0 to ds - 1
u(ddata[di]) += 1
next
dim as ll.node_t ptr l
dim as bt.node_t ptr b
dim as uinteger i
for i = 0 to 255
if u(i) then
if l then
l = ll.insert_after(l, u(i))
else
l = ll.create(u(i))
end if
l->foo = bt.create_leaf(i)
end if
next
do while ll.count(l) > 1
ll.sort_index(l)
l = ll.seek_first(l)
l->foo = bt.create_branch(-1, l->foo, l->next_node->foo)
l->index += l->next_node->index
ll.delete(l->next_node)
loop
b = l->foo
ll.destroy(l)
ts = (bt.calculate_size(b) + 7) \ 8
tdata = callocate(ts)
bt.save_tree(b, tdata)
dim as uinteger o = freefile
open command$(3) for binary access write as #o
put #o, , "HUFF"
put #o, , ts
seek #f, 13
put #o, , ds
put #o, , *tdata, ts
dim as uinteger qtp(255)
dim as ubyte qtb(255)
bt.qtable(b, qtp(), qtb())
print " compressing...";
cdata = callocate(ds)
for di = 0 to ds - 1
if qtb(ddata[di]) then
for i = 0 to qtb(ddata[di]) - 1
if cb = 0 then
ci += 1
cb = 8
end if
cb -= 1
cdata[ci] shl= 1
cdata[ci] or= abs(bit(qtp(ddata[di]), qtb(ddata[di]) - i - 1))
next
end if
if di mod 1024 = 0 then locate , 80 - 26 : print " " & string(fix(di / ds * 20), ".") & string(20 - fix(di / ds * 20), "o") & " " & fix(di / ds * 100) & "%";
next
cdata[ci] shl= cb
put #o, , *cdata, ci + 1
put #o, 9, ci + 1
bt.destroy(b)
deallocate(ddata)
deallocate(cdata)
case "d"
dim as ubyte ptr tdata, cdata, ddata
dim as uinteger ts, cs, ds, ci, di
dim as ubyte cb = 8
dim as uinteger f = freefile
open command$(2) for binary access read as #f
seek #f, 5
get #f, , ts
tdata = callocate(ts)
get #f, , cs
cdata = callocate(cs)
get #f, , ds
ddata = callocate(ds)
get #f, , *tdata, ts
get #f, , *cdata, cs
close #f
print " reading tree..."
dim as bt.node_t ptr tr = bt.load_tree(tdata), tc
deallocate(tdata)
print " decompressing...";
do while di < ds
tc = tr
do while tc->node_flags and bt.branch_node
if cb = 0 then
ci += 1
cb = 8
end if
cb -= 1
tc = tc->node(abs(bit(cdata[ci], cb)))
loop
ddata[di] = tc->index
di += 1
if di mod 1024 = 0 then locate , 80 - 26 : print " " & string(fix(di / ds * 20), ".") & string(20 - fix(di / ds * 20), "o") & " " & fix(di / ds * 100) & "%";
loop
dim as uinteger o = freefile
open command$(3) for binary access write as #o
put #o, , *ddata, ds
close #o
bt.destroy(tr)
deallocate(cdata)
deallocate(ddata)
case "t"
dim as ubyte ptr tdata
dim as uinteger ts, cs, ds
dim as uinteger f = freefile
open command$(2) for binary access read as #f
seek #f, 5
get #f, , ts
tdata = callocate(ts)
get #f, , cs
get #f, , ds
get #f, , *tdata, ts
close #f
dim as bt.node_t ptr tr = bt.load_tree(tdata), tc
deallocate(tdata)
bt.dump(tr)
bt.destroy(tr)
case else
print command$(0) & " c|d src dst"
end select