' huffman more optimized byte oriented version, 1st november 2010

#include once "crt.bi"

type tree_t
	isinternal as integer
	c          as ubyte
	weight     as uinteger
	l          as tree_t ptr
	r          as tree_t ptr
	code       as uinteger
	code_len   as uinteger
	declare destructor _
		( _
		)
end type

destructor tree_t _
	( _
	)

	delete l
	delete r

end destructor

function tree_add _
	( _
		byval root as tree_t ptr ptr, _
		byval c    as ubyte _
	) as tree_t ptr

	if root[c] = NULL then
		root[c] = new tree_t
		root[c]->c = c
	end if

	root[c]->weight += 1

	function = root[c]

end function

function nodecmp cdecl _
	( _
		byval l as tree_t ptr ptr, _
		byval r as tree_t ptr ptr _
	) as integer

	if (*l)->weight < (*r)->weight then
		function = 1
	elseif (*l)->weight > (*r)->weight then
		function = -1
	end if

end function

' This is the first stage of building the huffman tree
' we take the input array, and build the tree itself, inserting internal nodes
' in the right places
function buildhuff _
	( _
		byval array     as tree_t ptr ptr, _
		byval array_len as integer _
	) as tree_t ptr

	dim as tree_t ptr queueA(0 to array_len - 1)
	dim as tree_t ptr queueB(0 to array_len - 1)
	dim as integer queueA_len
	dim as integer queueB_len

	for i as integer = 0 to array_len - 1
		queueA(queueA_len) = array[i]
		queueA_len += 1
	next i

	dim as tree_t ptr huffroot

	while (queueA_len > 0) or (queueB_len > 0)
		dim as tree_t ptr l, r

		if (queueA_len > 0) and (queueB_len > 0) then
			if queueA(queueA_len - 1)->weight <= queueB(queueB_len - 1)->weight then
				l = queueA(queueA_len - 1)
				queueA_len -= 1
			elseif queueA(queueA_len - 1)->weight > queueB(queueB_len - 1)->weight then
				l = queueB(queueB_len - 1)
				queueB_len -= 1
			end if
		elseif queueA_len > 0 then
			l = queueA(queueA_len - 1)
			queueA_len -= 1
		elseif queueB_len > 0 then
			l = queueB(queueB_len - 1)
			queueB_len -= 1
		end if

		if (queueA_len > 0) and (queueB_len > 0) then
			if queueA(queueA_len - 1)->weight <= queueB(queueB_len - 1)->weight then
				r = queueA(queueA_len - 1)
				queueA_len -= 1
			elseif queueA(queueA_len - 1)->weight > queueB(queueB_len - 1)->weight then
				r = queueB(queueB_len - 1)
				queueB_len -= 1
			end if
		elseif queueA_len > 0 then
			r = queueA(queueA_len - 1)
			queueA_len -= 1
		elseif queueB_len > 0 then
			r = queueB(queueB_len - 1)
			queueB_len -= 1
		end if

		if r = NULL then
			huffroot = l
			exit while
		end if

		dim as tree_t ptr node

		node = new tree_t( -1, 0, l->weight + r->weight, l, r )

		queueB_len += 1

		for i as integer = queueB_len - 1 to 1 step -1
			queueB(i) = queueB(i - 1)
		next i

		queueB(0) = node
	wend

	function = huffroot

end function

' This is the second stage of building the huffman tree
' we walk the tree, generating the codes
sub buildhuff2 _
	( _
		byval node     as tree_t ptr, _
		byval code     as uinteger = 0, _
		byval code_len as uinteger = 0 _
	)

	if node = NULL then exit sub

	if node->isinternal = 0 then
		node->code = code
		node->code_len = code_len
	else
		buildhuff2( node->l, code or (0 shl code_len), code_len + 1 )
		buildhuff2( node->r, code or (1 shl code_len), code_len + 1 )
	end if

end sub

#macro readbit( in_p, in_size, in_pos, b, bitbuffer, bitbuffer_pos )
	if bitbuffer_pos = 0 then
		bitbuffer = *cast( uinteger ptr, @in_p[in_pos] )
		in_pos += 4
	end if

	b = (bitbuffer shr bitbuffer_pos) and 1
	bitbuffer_pos = (bitbuffer_pos + 1) and 31 ' mod 32
#endmacro

sub decompress_loop _
	( _
		byval in_p      as ubyte ptr, _
		byval in_size   as uinteger, _
		byval in_pos    as uinteger, _
		byval out_p     as ubyte ptr, _
		byval todo      as uinteger, _
		byval huffroot  as tree_t ptr _
	)

	dim as uinteger bitbuffer
	dim as uinteger bitbuffer_pos
	dim as uinteger out_pos

	while todo
		dim as tree_t ptr curr = huffroot

		while curr->isinternal
			dim as uinteger b = any

			readbit( in_p, in_size, in_pos, b, bitbuffer, bitbuffer_pos )

			if b = 1 then
				curr = curr->r
			else
				curr = curr->l
			end if
		wend

		*cast( ubyte ptr, @out_p[out_pos] ) = curr->c
		out_pos += 1
		todo -= 1
	wend

end sub

sub huff_decode_mem _
	( _
		byval in_p     as ubyte ptr, _
		byval in_size  as uinteger, _
		byval out_p    as ubyte ptr _
	)

	dim as uinteger array_len
	dim as uinteger todo
	dim as uinteger in_pos

	todo = *cast( uinteger ptr, @in_p[in_pos] )
	in_pos += 4

	array_len = *cast( uinteger ptr, @in_p[in_pos] )
	in_pos += 4

	dim as tree_t ptr ptr array = callocate( array_len * sizeof( tree_t ptr ) )

	for i as uinteger = 0 to array_len - 1
		array[i] = new tree_t
		array[i]->weight = *cast( uinteger ptr, @in_p[in_pos] )
		in_pos += 4
		array[i]->c = *cast( ubyte ptr, @in_p[in_pos] )
		in_pos += 1
	next i

	dim as tree_t ptr huffroot = buildhuff( array, array_len )

	buildhuff2( huffroot )

	decompress_loop( in_p, in_size, in_pos, out_p, todo, huffroot )

	deallocate( array )

	delete huffroot

end sub

#macro writebits( out_p, out_size, out_pos, code, code_len, bitbuffer, bitbuffer_pos )
	for i as integer = 0 to code_len - 1
		dim as integer cb = (code shr i) and 1
		bitbuffer or= cb shl bitbuffer_pos
		bitbuffer_pos = (bitbuffer_pos + 1) and 31 ' mod 32
		if bitbuffer_pos = 0 then
			*cast( uinteger ptr, @out_p[out_pos] ) = bitbuffer
			out_pos += 4
			bitbuffer = 0
		end if
	next i
#endmacro

function emit_compressed _
	( _
		byval out_p     as ubyte ptr, _
		byval out_size  as uinteger, _
		byval out_pos   as uinteger, _
		byval root      as tree_t ptr ptr, _
		byval in_p      as ubyte ptr, _
		byval in_size   as uinteger _
	) as integer

	dim as uinteger bitbuffer
	dim as uinteger  bitbuffer_pos

	for i as uinteger = 0 to in_size - 1
		dim as tree_t ptr node = root[in_p[i]]
		writebits( out_p, out_size, out_pos, node->code, node->code_len, bitbuffer, bitbuffer_pos )
	next i

	if bitbuffer_pos then
		*cast( uinteger ptr, @out_p[out_pos] ) = bitbuffer
		out_pos += 4
		bitbuffer_pos = 0
		bitbuffer = 0
	end if

	function = out_pos

end function

function huff_encode_mem _
	( _
		byval in_p      as ubyte ptr, _
		byval in_size   as uinteger, _
		byval out_p     as ubyte ptr, _
		byval out_size  as uinteger _
	) as integer

	dim as uinteger   array_len
	dim as tree_t ptr root(0 to 255)
	dim as uinteger   out_pos

	for i as uinteger = 0 to in_size - 1
		tree_add( @root(0), in_p[i] )
	next i

	*cast( uinteger ptr, @out_p[out_pos] ) = in_size
	out_pos += 4

	dim as tree_t ptr ptr array = callocate( 256 * sizeof( tree_t ptr ) )

	for i as integer = 0 to 255
		if root(i) then
			array[array_len] = root(i)
			array_len += 1
		end if
	next i

	qsort( array, array_len, sizeof( tree_t ptr ), cast( any ptr, @nodecmp ) )

	dim as tree_t ptr huffroot = buildhuff( array, array_len )

	buildhuff2( huffroot )

	*cast( uinteger ptr, @out_p[out_pos] ) = array_len
	out_pos += 4

	for i as uinteger = 0 to array_len - 1
		*cast( uinteger ptr, @out_p[out_pos] ) = array[i]->weight
		out_pos += 4
		*cast( ubyte ptr, @out_p[out_pos] ) = array[i]->c
		out_pos += 1
	next i

	out_pos = emit_compressed( out_p, out_size, out_pos, @root(0), in_p, in_size )

	deallocate( array )

	delete huffroot

	function = out_pos

end function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

dim as FILE ptr hfile_out
dim as integer  reverse
dim as double   t1

reverse = (command( 1 ) = "-r")

t1 = timer( )
if reverse then
	dim as string in_s
	dim as ubyte ptr out_p
	dim as uinteger out_size

	open command( 2 ) for binary access read as #1
		in_s = input( lof( 1 ), 1 )
	close #1

	out_size = *cast( uinteger ptr, @in_s[0] )
	out_p = callocate( out_size )

	huff_decode_mem( @in_s[0], len( in_s ), out_p )

	open command( 3 ) for binary access write as #1
		put #1, , *out_p, out_size
	close #1

	deallocate( out_p )
else
	dim as string in_s
	dim as uinteger out_len

	open command( 1 ) for binary access read as #1
		in_s = input( lof( 1 ), 1 )
	close #1

	dim as uinteger out_size = len( in_s ) * 2
	dim as ubyte ptr out_p = callocate( out_size )

	out_len = huff_encode_mem( @in_s[0], len( in_s ), out_p, out_size )

	open command( 2 ) for binary access write as #1
		put #1, , *out_p, out_len
	close #1

	deallocate( out_p )
end if
t1 = timer( ) - t1

if reverse then
	print "decompressed " & command( 2 ) & " in " & int( t1 * 1000 ) & "ms"
else
	print "compressed " & command( 1 ) & " in " & int( t1 * 1000 ) & "ms"
end if