#| -*-Scheme-*-

$Id: cpress.scm,v 1.14 2003/02/14 18:28:32 cph Exp $

Copyright (c) 1992-1999 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Data Compressor

(declare (usual-integrations))

;; This declaration is worth up to 30% speedup
(declare
 (ignore-reference-traps
  (set root-nodes oldest-node newest-node window-filled? byte-buffer)))

;; This does not seem to make much difference:
(declare (ignore-reference-traps (set current-pointer current-bp command-bp)))

;;; This compression program is based on the algorithm described in
;;; "Data Compression with Finite Windows", by Edward R. Fiala and
;;; Daniel H. Greene, Xerox CSL-89-3.  A version of this paper
;;; appeared in "Communications of the Association for Computing
;;; Machinery", 32(1), 1989.

;;; This is a one-pass lossless substitution algorithm.  The algorithm
;;; works by finding large blocks of text in the input stream and
;;; replacing them with shorter references to earlier occurrences of
;;; identical text.  In order to limit the amount of memory needed by
;;; the compressor and expander, a sliding "window" is used to
;;; remember the input stream, and "copy" references may only refer to
;;; text within that window.

;;; The output stream of the compressor is a series of "commands", of
;;; which there are two kinds: "literal" and "copy".  A literal
;;; command specifies a sequence of bytes that appear in the input
;;; stream.  A copy command is a reference to some earlier part of the
;;; input stream, consisting of a length field and a relative pointer
;;; to the position of the referenced text.

;;; Fiala and Greene describe five algorithms, which they name A1, A2,
;;; B1, B2, and C2:

;;; A1 and B1 use a simple encoding of commands that is suitable for
;;; byte-addressed machines.  This encoding is adequate for many
;;; purposes but does not achieve the compression ratios of the other
;;; algorithms.

;;; A2 and B2 use a more complex encoding that results in a
;;; significantly better compression ratio.  The price is that the
;;; compression and expansion are slower than that achieved with A1
;;; and B2.

;;; C2's encoding is even more complex, and results in the best
;;; overall compression ratio.  The compression speed of C2 is the
;;; same as that of B2, and the expansion is about 25% slower.

;;; A1 and A2 encode the relative pointers in copy commands as
;;; positions in the input byte stream.  B1 and B2 encode these
;;; pointers as positions in the output command stream, which the
;;; expander then translates back into byte positions.  The B
;;; algorithms speed up compression by approximately a factor of three
;;; over their A counterparts, while slowing expansion slightly.  The
;;; reason that compression is so much faster is that the A algorithms
;;; require much more complex data structures to keep track of the
;;; information in the window.

;;; C2 is like B2, except that it encodes further information about
;;; the data structures it is using to represent the window, assumes
;;; that the expander reproduces those data structures, and takes
;;; advantage of that assumption to achieve shorter references.

;;; This program implements the window data structures required by
;;; the algorithms B1, B2, and C2.  The encoder, which appears below,
;;; determines the algorithm.

(define input-port)
(define output-port)

(define (compress ifile ofile)
  (call-with-binary-input-file (merge-pathnames ifile)
    (lambda (input)
      (call-with-binary-output-file (merge-pathnames ofile)
        (lambda (output)				      
	  (write-string "Compressed-B1-1.00" output)
	  (compress-ports input output))))))

(define (compress-ports input output)
  (fluid-let ((root-nodes (make-vector 256 false))
	      (oldest-node false)
	      (newest-node false)
	      (window-filled? false)
	      (compress-continuation)
	      (byte-buffer (make-byte-buffer))
	      (current-pointer 0)
	      (current-bp 0)
	      (command-bp 0)
	      (output-buffer (make-output-buffer))
	      (input-port input)
	      (output-port output))
    (call-with-current-continuation
     (lambda (continuation)
       (set! compress-continuation continuation)
       (idle)))
    (flush-output-buffer)))

(define (idle)
  ;; This is the top of the compression loop.  We've just emitted a
  ;; command.  If the next two bytes can be matched against some text
  ;; in the window, start a copy command, otherwise start a literal.
  (guarantee-buffer-space 2)
  (let ((node (match-first)))
    (if (not node)
	(generate-literal)
	(let ((node (match-next node 1)))
	  (if (not node)
	      (generate-literal)
	      (generate-copy node 2))))))

(define (generate-literal)
  (guarantee-buffer-space (fix:+ literal-max 2))
  (letrec
      ((loop
	(lambda (nb)
	  (let ((node (match-first)))
	    (if (not node)
		(continue nb)
		(let ((node (match-next node 1)))
		  (if (not node)
		      (continue nb)
		      (let ((node (match-next node 2)))
			(if (not node)
			    (begin
			      (unread-byte)
			      (continue nb))
			    (let ((nb*
				   (let ((cbp current-bp)
					 (nbp (node-bp node)))
				     (fix:- (if (fix:< cbp nbp)
						(fix:+ cbp buffer-size)
						cbp)
					    nbp))))
			      (if (fix:< nb* 3)
				  ;; Don't consider matches that
				  ;; would result in a copy that is
				  ;; copying from itself.
				  (begin
				    (unread-bytes 2)
				    (continue nb))
				  (begin
				    (write-literal nb)
				    (generate-copy node 3))))))))))))
       (continue
	(lambda (nb)
	  (increment-current-pointer)
	  (increment-bp)
	  (let ((nb (fix:+ nb 1)))
	    (if (fix:< nb literal-max)
		(loop nb)
		(begin
		  (write-literal nb)
		  (idle)))))))
    (increment-current-pointer)
    (increment-bp)
    (loop 1)))

(define (generate-copy node nb)
  (guarantee-buffer-space copy-max)
  (let ((copy-pointer current-pointer))
    (let ((finish
	   (lambda (nb pointer bp)
	     (let ((nb*
		    (fix:- (let ((bp* command-bp))
			     (if (fix:< bp* bp)
				 (fix:+ bp* buffer-size)
				 bp*))
			   bp))
		   (do-copy
		    (lambda (nb)
		      (write-copy nb pointer copy-pointer)
		      (increment-current-pointer)
		      (idle))))
	       ;; NB is the number of bytes that we want to write a
	       ;; copy command for; NB* is the number of bytes between
	       ;; the start of the copy and the current position.  If
	       ;; NB* is less than NB, we must truncate the copy in
	       ;; order to prevent it from copying from itself.  If
	       ;; NB* is 1, then don't copy -- it's too short.
	       (if (fix:<= nb nb*)
		   (do-copy nb)
		   (begin
		     (unread-bytes (fix:- nb nb*))
		     (if (fix:= nb* 1)
			 (generate-literal)
			 (do-copy nb*))))))))
      (let loop ((node node) (nb nb))
	(let ((pointer (node-pointer node))
	      (bp (node-bp node)))
	  (if (not (byte-ready?))
	      (finish nb pointer bp)
	      (let ((node* (match-next node nb)))
		(if (not node*)
		    (finish nb pointer bp)
		    (let ((nb (fix:+ nb 1)))
		      (if (fix:< nb copy-max)
			  (loop node* nb)
			  (if (eq? node node*)
			      (finish nb pointer bp)
			      (let ((pointer (node-pointer node*))
				    (bp (node-bp node*)))
				(update-node-pointer node*)
				(finish nb pointer bp)))))))))))))

(define (match-first)
  (let ((byte (read-byte)))
    (let ((node (vector-ref root-nodes byte)))
      (if (not node)
	  (add-child false byte (make-node 0)))
      node)))

(define (match-next node nb)
  (let ((byte (peek-byte)))
    (if (fix:= (node-nb node) nb)
	(begin
	  (update-node-pointer node)
	  (let loop ((child (node-children node)))
	    (cond ((not child)
		   (add-child node byte (make-node 0))
		   false)
		  ((fix:= byte (node-byte child))
		   (discard-byte)
		   child)
		  (else
		   (loop (node-next child))))))
	(let ((byte* (node-ref node nb)))
	  (if (fix:= byte byte*)
	      (begin
		(discard-byte)
		node)
	      (begin
		(let ((parent (make-node nb)))
		  (replace-child node parent)
		  (add-child parent byte* node)
		  (add-child parent byte (make-node 0)))
		false))))))

;;;; PATRICIA Tree Database

(define root-nodes)
(define oldest-node)
(define newest-node)
(define window-filled?)

(define-structure (node (constructor %make-node (nb older)))
  ;; The parent of this node, or #F for a root node.
  (parent false)

  ;; The children of this node.  Either #F for no children, or the
  ;; first child.  The remaining children are accessed through the
  ;; NODE-NEXT fields.  A node will never have exactly one child.
  (children false)

  ;; The adjacent siblings of this node, or #F if none.
  (previous false)
  (next false)

  ;; The first byte of the substring between the parent and this node.
  (byte false)

  ;; The number of bytes in the string represented by this node,
  ;; counting down from the root of the tree.
  (nb 0)

  ;; The adjacent nodes in the node pointer ordering.  The OLDER node
  ;; has less recent POINTER and BP, while the newer node has more recent.
  (older false)
  (newer false)

  ;; The command pointer for this node.
  (pointer current-pointer)

  ;; The byte pointer for this node.
  (bp current-bp))

(define (make-node nb)
  (let ((node (%make-node nb newest-node)))
    (if newest-node
	(set-node-newer! newest-node node)
	(set! oldest-node node))
    (set! newest-node node)
    node))

(define (update-node-pointer node)
  (set-node-pointer! node current-pointer)
  (set-node-bp! node current-bp)
  (let ((older (node-older node))
	(newer (node-newer node)))
    (if newer
	(begin
	  (set-node-older! newer older)
	  (if older
	      (set-node-newer! older newer)
	      (set! oldest-node newer))
	  (set-node-newer! node false)
	  (set-node-older! node newest-node)
	  (set-node-newer! newest-node node)
	  (set! newest-node node)
	  unspecific))))

(define (add-child parent byte child)
  (set-node-parent! child parent)
  (set-node-byte! child byte)
  (if parent
      (let ((sibling (node-children parent)))
	(set-node-next! child sibling)
	(if sibling (set-node-previous! sibling child))
	(set-node-children! parent child))
      (vector-set! root-nodes byte child)))

(define (replace-child child child*)
  (let ((parent (node-parent child))
	(byte (node-byte child)))
    (set-node-parent! child* parent)
    (set-node-byte! child* byte)
    (if parent
	(begin
	  (let ((previous (node-previous child)))
	    (set-node-previous! child* previous)
	    (if previous
		(set-node-next! previous child*)
		(set-node-children! parent child*)))
	  (let ((next (node-next child)))
	    (set-node-next! child* next)
	    (if next
		(set-node-previous! next child*))))
	(vector-set! root-nodes byte child*))))

(define (set-oldest-node node pointer)
  (let ((node
	 (do ((node node (node-newer node)))
	     ((not (fix:= (node-pointer node) pointer)) node))))
    (if (not (eq? node oldest-node))
	(let ((older (node-older node)))
	  (set-node-older! node false)
	  (set! oldest-node node)
	  ;; We don't have to do anything complicated to delete a node.
	  ;; If the node has any children, we know that they are also
	  ;; being deleted, because a descendant cannot be newer than
	  ;; its ancestor.  However, we want to avoid deleting a child
	  ;; from its parent if the parent is also going to be deleted,
	  ;; so we first mark each of the nodes being deleted, and then
	  ;; only do the deletion if the parent is not marked.
	  (do ((node older (node-older node)))
	      ((not node))
	    (set-node-nb! node false))
	  (do ((node older (node-older node)))
	      ((not node))
	    (let ((parent (node-parent node)))
	      (cond ((not parent)
		     (vector-set! root-nodes (node-byte node) false))
		    ((node-nb parent)
		     (delete-child parent node))))
	    (set-node-nb! node true))
	  unspecific))))

(define (delete-child parent child)
  (let ((previous (node-previous child))
	(next (node-next child)))
    (if next
	(set-node-previous! next previous))
    (if previous
	(set-node-next! previous next)
	(set-node-children! parent next)))
  (let ((child (node-children parent)))
    ;; If only one child remains, splice out PARENT.
    (if (not (node-next child))
	(begin
	  (replace-child parent child)
	  (let ((older (node-older parent))
		(newer (node-newer parent)))
	    (if older
		(set-node-newer! older newer))
	    (if newer
		(set-node-older! newer older))
	    (if (eq? parent oldest-node)
		(set! oldest-node newer))
	    (if (eq? parent newest-node)
		(set! newest-node older))
	    unspecific)))))

;;;; The Byte Buffer

;;; Maximum number of bytes that the byte buffer can hold.
;;; The optimal size for this buffer is
;;;  (+ (* COPY-MAX POINTER-MAX) BUFFER-READ)
(define-integrable buffer-size 69632)
(define-integrable buffer-size-optimal? true)

;;; When input is needed from the input port, we attempt to read this
;;; many bytes all at once.  It is assumed that BUFFER-SIZE is an
;;; integral multiple of this number.
(define-integrable buffer-read 4096)

(define compress-continuation)
(define byte-buffer)

(define-structure (bb (constructor make-byte-buffer ()))
  (vector (make-string buffer-size) read-only true)
  (ptr 0)
  (end 0)
  (eof? false))

(define (byte-ready?)
  (let ((bb byte-buffer))
    (if (fix:= (bb-ptr bb) (bb-end bb))
	(guarantee-buffer-data bb true)
	true)))

(define (read-byte)
  ;; Get a byte from the byte buffer.  If we are reading bytes in the
  ;; process of generating a copy command, NODE is the current
  ;; position in the copy, otherwise it is #F.  If we encounter EOF
  ;; while reading this byte, NODE is used to emit the final command.
  (let ((bb byte-buffer))
    (let ((byte (%peek-byte bb)))
      (%discard-byte bb)
      byte)))

(define (peek-byte)
  (%peek-byte byte-buffer))

(define (discard-byte)
  (%discard-byte byte-buffer))

(declare (integrate-operator %peek-byte %discard-byte))

(define (%peek-byte bb)
  (if (fix:= (bb-ptr bb) (bb-end bb))
      (guarantee-buffer-data bb false))
  (vector-8b-ref (bb-vector bb) (bb-ptr bb)))

(define (%discard-byte bb)
  (set-bb-ptr! bb
	       (if (fix:= (bb-ptr bb) (fix:- buffer-size 1))
		   0
		   (fix:+ (bb-ptr bb) 1))))

(define (unread-byte)
  (let ((bb byte-buffer))
    (set-bb-ptr! bb
		 (if (fix:= (bb-ptr bb) 0)
		     (fix:- buffer-size 1)
		     (fix:- (bb-ptr bb) 1)))))

(define (unread-bytes nb)
  (let ((bb byte-buffer))
    (set-bb-ptr! bb
		 (let ((ptr (fix:- (bb-ptr bb) nb)))
		   (if (fix:< ptr 0)
		       (fix:+ ptr buffer-size)
		       ptr)))))

(define (node-ref node nb)
  ;; Read byte NB in the string for NODE.
  (vector-8b-ref (bb-vector byte-buffer)
		 (let ((bp (fix:+ (node-bp node) nb)))
		   (if (fix:< bp buffer-size)
		       bp
		       (fix:- bp buffer-size)))))

(define (guarantee-buffer-data bb probe?)
  ;; We have read all of the bytes in the buffer, so it's time to get
  ;; some more.  If PROBE? is false and we're at EOF, do a non-local
  ;; exit to finish the compression.  If the last read was short, that
  ;; means we are now at EOF.
  (if (bb-eof? bb)
      (if probe?
	  false
	  (compress-finished))
      (let* ((end (bb-end bb))
	     (end* (fix:+ end buffer-read)))
	;; Calls to GUARANTEE-BUFFER-SPACE make sure that this read will
	;; not overwrite any data that we are still using.  Otherwise, we
	;; might have to invalidate some nodes here, and that would
	;; consequently make the program more complicated because we
	;; couldn't be sure that any nodes we were holding were valid
	;; across a call to READ-BYTE.
	(let ((nb
	       (input-port/read-substring! input-port
					   (bb-vector bb) end end*)))
	  (cond ((not nb)
		 (error "Input port must be in blocking mode:" input-port)
		 false)
		((fix:= nb buffer-read)
		 ;; A full block was read.
		 (set-bb-end! bb (if (fix:= end* buffer-size) 0 end*))
		 true)
		((fix:= nb 0)
		 ;; We're at EOF.
		 (if probe?
		     (begin
		       (set-bb-eof?! bb true)
		       false)
		     (compress-finished)))
		((and (fix:< 0 nb) (fix:< nb buffer-read))
		 ;; A partial block was read, meaning that
		 ;; this is the last block.  Set BB-EOF? to
		 ;; indicate that there is no more data after
		 ;; this block is exhausted.
		 (set-bb-eof?! bb true)
		 (set-bb-end! bb (fix:+ end nb))
		 true)
		(else
		 (error "Illegal result from read:" nb buffer-read)
		 false))))))

(define (compress-finished)
  ;; This is called from GUARANTEE-BUFFER-DATA when EOF is
  ;; encountered.  If any data remains in the buffer which has not yet
  ;; been emitted as a literal or copy, it is emitted as a literal.
  (let ((bp command-bp)
	(ptr (bb-ptr byte-buffer)))
    (if (not (fix:= ptr bp))
	(let loop
	    ((nb (fix:- (if (fix:< bp ptr) ptr (fix:+ ptr buffer-size)) bp)))
	  (if (fix:<= nb literal-max)
	      (write-literal nb)
	      (begin
		(write-literal literal-max)
		(loop (fix:- nb literal-max)))))))
  (compress-continuation unspecific))

(define (guarantee-buffer-space nb)
  ;; Make sure that the byte buffer has enough space to hold NB bytes.
  ;; If necessary, invalidate old commands until this is true.  If the
  ;; buffer size is optimal, this is never necessary, because the
  ;; buffer is big enough to hold all of the commands in the window.
  (if (and (not buffer-size-optimal?)
	   oldest-node)
      (let ((end (bb-end byte-buffer)))
	(if (fix:< (let ((bp command-bp))
		   (fix:- (if (fix:<= bp end)
			    end
			    (fix:+ end buffer-size))
			bp))
		 nb)
	    (let ((start (node-bp oldest-node))
		  (nb (if (fix:< buffer-read nb) nb buffer-read)))
	      (if (fix:< (fix:- (if (fix:< end start)
				start
				(fix:+ start buffer-size))
			    end)
		       nb)
		  (let ((node
			 (let ((end
				(let ((end (fix:+ end nb)))
				  (if (fix:< end buffer-size)
				      end
				      (fix:- end buffer-size)))))
			   (if (fix:< start end)
			       (do ((node oldest-node (node-newer node)))
				   ((not
				     (let ((bp (node-bp node)))
				       (and (fix:<= start bp)
					    (fix:< bp end))))
				    node))
			       (do ((node oldest-node (node-newer node)))
				   ((not
				     (let ((bp (node-bp node)))
				       (or (and (fix:<= start bp)
						(fix:< bp buffer-size))
					   (fix:< bp end))))
				    node))))))
		    (set-oldest-node node
				     (node-pointer (node-older node))))))))))

;;;; The Encoder
;;;  This is the B1 encoder of Fiala and Greene.

;;; Maximum length of a literal.
(define-integrable literal-max 16)

;;; Maximum length of a copy.
(define-integrable copy-max 16)

;;; Maximum displacement of a copy, in "pointers".  Consequently, this
;;; is the size of the compression window in pointers.
(define-integrable pointer-max 4096)

;;; Current "pointer" in input stream.  The pointer is updated at each
;;; literal character and copy command.
(define current-pointer)

;;; Starting position of current command in byte buffer.
(define current-bp)
(define command-bp)

(define (write-literal nb)
  ;; Output a literal command of length NB, which is greater than zero
  ;; and at most LITERAL-MAX.
  (write-byte (fix:- nb 1))
  (let ((string (bb-vector byte-buffer))
	(start command-bp))
    (let ((end (fix:+ start nb)))
      (if (fix:<= end buffer-size)
	  (begin
	    (write-bytes string start end)
	    (set! command-bp (if (fix:= end buffer-size) 0 end)))
	  (let ((end (fix:- end buffer-size)))
	    (write-bytes string start buffer-size)
	    (write-bytes string 0 end)
	    (set! command-bp end)))))
  unspecific)

(define (write-copy nb pointer copy-pointer)
  ;; Output a copy command of length NB, which is greater than one
  ;; and at most COPY-MAX.  POINTER is the pointer of the text being
  ;; copied, while COPY-POINTER is the pointer of the copy command
  ;; being emitted.
  (let ((length (fix:* (fix:- nb 1) 16))
	(displacement
	 (fix:- (if (fix:<= pointer copy-pointer)
		    copy-pointer
		    (fix:+ copy-pointer pointer-max))
		pointer)))
    (if (fix:< displacement 256)
	(begin
	  (write-byte length)
	  (write-byte displacement))
	(begin
	  (write-byte (fix:+ length (fix:quotient displacement 256)))
	  (write-byte (fix:remainder displacement 256)))))
  (let ((bp
	 (let ((bp (fix:+ current-bp nb)))
	   (if (fix:< bp buffer-size)
	       bp
	       (fix:- bp buffer-size)))))
    (set! current-bp bp)
    (set! command-bp bp))
  unspecific)

(define (increment-bp)
  (set! current-bp
	(let ((bp (fix:+ current-bp 1)))
	  (if (fix:= bp buffer-size)
	      0
	      bp)))
  unspecific)

(define (increment-current-pointer)
  (let ((pointer
	 (let ((pointer (fix:+ current-pointer 1)))
	   (if (fix:= pointer pointer-max)
	       (begin
		 (set! window-filled? true)
		 0)
	       pointer))))
    (set! current-pointer pointer)
    ;; Invalidate any nodes that refer to the previous command with
    ;; number POINTER.  If WINDOW-FILLED? is false, we haven't yet
    ;; generated enough commands for such nodes to exist.
    (if window-filled?
	(set-oldest-node oldest-node pointer))))

(define output-buffer)

(define (make-output-buffer)
  (cons 0 (make-string 4096)))

(define (write-byte byte)
  (let ((ob output-buffer))
    (let ((index (car ob)))
      (vector-8b-set! (cdr ob) index byte)
      (if (fix:= index 4095)
	  (begin
	    (output-port/write-string output-port (cdr ob))
	    (set-car! ob 0))
	  (set-car! ob (fix:+ index 1))))))

(define (write-bytes string start end)
  (let ((ob output-buffer))
    (let ((index (car ob)))
      (let ((new-index (fix:+ index (fix:- end start))))
	(if (fix:< new-index 4096)
	    (begin
	      (let ((buffer (cdr ob)))
		(do ((start start (fix:+ start 1))
		     (index index (fix:+ index 1)))
		    ((fix:= start end))
		  (vector-8b-set! buffer index (vector-8b-ref string start))))
	      (set-car! ob new-index))
	    (do ((start start (fix:+ start 1)))
		((fix:= start end))
	      (write-byte (vector-8b-ref string start))))))))

(define (flush-output-buffer)
  (let ((ob output-buffer))
    (if (fix:< 0 (car ob))
	(output-port/write-substring output-port (cdr ob) 0 (car ob))))
  (output-port/flush-output output-port))

(define (uncompress ifile ofile)
  (uncompress-internal ifile ofile
    (lambda (message . irritants)
      (error message irritants))))