#!/usr/bin/newlisp
#
# Implementation of the LZW compression (Lempel-Ziv-Welch). Works with all file types.
# Suggestion by Norman. Tested on Slackware Linux and Windows2000.
#
# Version 1.0:	-initial release
# Version 1.01: -small speed improvement on compression routine
#				-now compression ratio (1, 2, 3) can be given as argument
#				-additional checks and error messages
# Version 1.1:	-tremendous speed improvement on compression using associative coding
# Version 1.11: -added function to create self extracting file (lzx)
#
# Nov 30, 2005 - march 17, 2006 / Peter van Eerten.
#
# This compression method is used on the internet with GIF and TIFF files.
# Theory here: http://www.dogma.net/markn/articles/lzw/lzw.htm
#
# The purpose of this code is educational. It seems there are (expired) patent issues with the
# LZW data compression. Please consult http://lzw.info/ if you want to use this code commercially.
#
#--------------------------------------------------------------------------------------------------
#
# Usage compression:
#
#	(LZW:compression <infile> <outfile> [compressionratio])
#
#			The (optional) compression ratio can be a value of 1, 2 or 3. A higher value means
#				a better compression, but is also slower. Default: 1.
#
#
# Usage decompression:
#
#	(LZW:decompression <infile> <outfile>)
#
#
# Usage lzx:
#
#	(LZW:lzx <infile> [compressionratio])
#
#--------------------------------------------------------------------------------------------------

(context 'LZW)

#--------------------------------------------------------------------------------------------------

(set 'input_bit_count 0)
(set 'input_bit_buffer 0)

(define (input_code input)

	(while (and (<= input_bit_count 24) (!= (set 'tt (read-char input)) nil))

		(set 'input_bit_buffer (| input_bit_buffer (<< tt (- 24 input_bit_count) ) ))
		(set 'input_bit_count (+ input_bit_count 8))
	)

	(set 'shift (- 32 BITS))
	(set 'return_value (& (>> input_bit_buffer shift)  (- (<< 2 (- 31 shift)) 1)  )) # Sign bit workaround (thanks Lutz!)

	(set 'input_bit_buffer (<< input_bit_buffer BITS))
	(set 'input_bit_count (- input_bit_count BITS))
	return_value
)

#--------------------------------------------------------------------------------------------------

(define (decompress infile outfile, in out car table next str chr which)

	(set 'in (open infile "read"))
	(set 'out (open outfile "write"))
	(cond ((not in) (println "\nERROR: File not found! Exiting...")(exit)))

	(set 'BITS (read-char in))
	(set 'MAXVALUE (- (<< 1 BITS) 1))
	(set 'MAXCODE (- MAXVALUE 1))

	(set 'table (map list (sequence 0 255)))
	(set 'next 256)

	(set 'str (input_code in))
	(write-char out str)
	(set 'car str)

	(while (!= (set 'chr (input_code in)) MAXVALUE)

		(if (>= chr next)
			(begin
				(set 'which (table str))
				(push car which -1)
			)
			(set 'which (table chr))
		)

		(set 'car (first which))

		(while (> (length which) 0)
			(write-char out (pop which))
		)

		(cond ((<= next MAXCODE) (push (append (table str) (list car)) table -1) (inc 'next)))
		(set 'str chr)
	)

	(close out)
	(close in)
)

#--------------------------------------------------------------------------------------------------

(set 'output_bit_count 0)
(set 'output_bit_buffer 0)

(define (output_code output code)

	(set 'output_bit_buffer (| output_bit_buffer (<< code (- 32 BITS output_bit_count) )))
	(set 'output_bit_count (+ output_bit_count BITS))
	(while (>= output_bit_count 8)

 		(write-char output (>> output_bit_buffer 24))
		(set 'output_bit_buffer (<< output_bit_buffer 8))
		(set 'output_bit_count (- output_bit_count 8))
	)
)

#--------------------------------------------------------------------------------------------------

(define (compress infile outfile ratio, in out next str chr code car)

	(set 'in (open infile "read"))
	(set 'out (open outfile "write"))
	(cond ((not in) (println "\nERROR: File not found! Exiting...")(exit)))

	(if (or (< ratio 1) (> ratio 3) (= ratio nil))
		(set 'BITS 12)
		(set 'BITS (+ ratio 11))
	)
	(write-char out BITS)
	(set 'MAXVALUE (- (<< 1 BITS) 1))
	(set 'MAXCODE (- MAXVALUE 1))
	
	(set 'next 256)

	(set 'str (read-char in))

	(while (set 'chr (read-char in))

		(set 'code (+ (<< str 8) chr))

		(if (set 'car (eval (sym code 'LZW)))			# Using associative coding now, instead of the 'find'

			(set 'str car)
			(begin
				(cond ((<= next MAXCODE) (set (sym code 'LZW) next) (inc 'next)))	# Assign a value to the sym'ed code
				(output_code out str)
				(set 'str chr)
			)
		)
	)

	(output_code out str)
	(output_code out MAXVALUE)
	(output_code out 0)

	(close out)
	(close in)
)

#--------------------------------------------------------------------------------------------------

(define (lzx infile ratio, in out header next str chr code car)

(set 'in (open infile "read"))
(cond ((not in) (println "\nERROR: File not found! Exiting...")(exit)))

(set 'out (open (append infile ".lzx") "write"))

# First we create a header, containing the decompression routine
(set 'header (append [text]#!/usr/bin/newlisp
(set 'input_bit_count 0)
(set 'input_bit_buffer 0)
(define (input_code input)
	(while (and (<= input_bit_count 24) (!= (set 'tt (read-char input)) nil))
		(set 'input_bit_buffer (| input_bit_buffer (<< tt (- 24 input_bit_count) ) ))
		(set 'input_bit_count (+ input_bit_count 8)))
	(set 'shift (- 32 BITS))
	(set 'return_value (& (>> input_bit_buffer shift)  (- (<< 2 (- 31 shift)) 1)  ))
	(set 'input_bit_buffer (<< input_bit_buffer BITS))
	(set 'input_bit_count (- input_bit_count BITS))
	return_value)
(set 'in (open (nth 1 (main-args)) "read"))
(set 'out (open "[/text] infile [text]" "write"))
(until (= (read-line in) "[text]"))
(set 'BITS (read-char in))
(set 'MAXVALUE (- (<< 1 BITS) 1))
(set 'MAXCODE (- MAXVALUE 1))
(set 'table (map list (sequence 0 255)))
(set 'next 256)
(set 'str (input_code in))
(write-char out str)
(set 'car str)
(while (!= (set 'chr (input_code in)) MAXVALUE)
	(if (>= chr next)
		(begin
			(set 'which (table str))
			(push car which -1))
		(set 'which (table chr)))
	(set 'car (first which))
	(while (> (length which) 0)
		(write-char out (pop which)))
	(cond ((<= next MAXCODE) (push (append (table str) (list car)) table -1) (inc 'next)))
	(set 'str chr))
(close out)
(close in)
(exit)
[/text]))

# Write header to file, also the [text] tag
(write-buffer out header)
(write-line "[text]" out)

# Now start compression as we are used to (same routine as in 'compress')
(if (or (< ratio 1) (> ratio 3) (= ratio nil))
	(set 'BITS 12)
	(set 'BITS (+ ratio 11))
)
(write-char out BITS)

(set 'MAXVALUE (- (<< 1 BITS) 1))
(set 'MAXCODE (- MAXVALUE 1))

(set 'next 256)

(set 'str (read-char in))

(while (set 'chr (read-char in))

	(set 'code (+ (<< str 8) chr))

	(if (set 'car (eval (sym code 'LZW)))

		(set 'str car)
		(begin
			(cond ((<= next MAXCODE) (set (sym code 'LZW) next) (inc 'next)))
			(output_code out str)
			(set 'str chr)
		)
	)
)

(output_code out str)
(output_code out MAXVALUE)
(output_code out 0)

# Finalize the [text] tag
(write-line "[/text]" out)

(close out)
(close in)

# If no Win32, set executable rights
(if (!= (last (sys-info)) 6) (! (append "chmod 755 " infile ".lzx")))

)

#--------------------------------------------------------------------------------------------------

(context 'MAIN)

#(print "Starting compression, please wait... ")
#(println "Time spent (msecs): " (time (LZW:compress "dump.txt" "dump.lzw" 1)))

#(print "Starting decompression, please wait... ")
#(println "Time spent (msecs): " (time (LZW:decompress "dump.lzw" "dump.org")))

(LZW:lzx "dump.txt")

(exit)