cleanup

huffman.lisp

@@ -28,6 +28,7 @@
 (defun comp-interim (left right)
   "sort interum nodes"
   (< (car left) (car right)))
+
 (defun freq2huffman (interim-nodes)
   (loop
     until (singlep interim-nodes)
@@ -50,7 +51,7 @@
                       (setq code (ash code 1))))
                   (setq codelen ,codelen-form))
            collect (cons ,key-form (cons code codelen)))))
-(macroexpand '(mkcanon (for pair in sorted-huffman-list while pair) (car pair) (cdr (cdr pair))))
+;; (macroexpand '(mkcanon (for pair in sorted-huffman-list while pair) (car pair) (cdr (cdr pair))))
 
 (defun comp-huffman (left right)
   "sort huffman mappings by code length & value"
@@ -96,35 +97,47 @@
 
 ; ---
 
-(defmacro buf-drain-bitstream (buf bit-stream cmp)
+(defun read-number (instream)
+  (let* ((right-mask (mk-mask 5))
+         (first-byte (read-byte instream nil nil))
+         (bytes-to-read (ash first-byte -5))
+         (result (logand first-byte right-mask)))
+    (loop for i from 1 to bytes-to-read
+          for c = (read-byte instream nil nil)
+          do (setq result (logior (ash result 8) c)))
+    result))
+
+(defun write-number (num outstream)
+  (let ((n 0)
+        (temp num))
+    (loop while (> (integer-length temp) 5)
+          do (setq temp (ash temp -8))
+             (incf n))
+    (write-byte (logior (ash n 5) temp) outstream)
+    (loop for i from (- n 1) downto 0
+          do (write-byte (logand (ash num (* i -8)) (mk-mask 8)) outstream))))
+
+;; (with-open-file (outstream "test" :element-type '(unsigned-byte 8) :direction :output :if-exists :supersede)
+;;   (write-number 31 outstream)
+;;   (write-number 32 outstream)
+;;   (write-number 1024 outstream)
+;;   (write-number 1099511627776 outstream)
+;;   )
+;; ;
+;; (with-open-file (instream "test" :element-type '(unsigned-byte 8) :direction :input)
+;;   (format t "~%~d" (read-number instream))
+;;   (format t "~%~d" (read-number instream))
+;;   (format t "~%~d" (read-number instream))
+;;   (format t "~%~d" (read-number instream))
+;;   )
+
+; ---
+
+(defmacro stream-drain-bitstream (outstream bit-stream cmp)
   `(loop while (>= (cdr ,bit-stream) ,cmp)
          do (multiple-value-bind (new-bit-stream popped-byte) (bitstream-pop8 ,bit-stream)
               (setq ,bit-stream new-bit-stream)
-              (push popped-byte ,buf))))
-
-(defmacro build-encoded-message-block (encoding-map instream buf bit-stream)
-  `(loop
-     for i from 0 to 255
-     for c = (read-byte ,instream nil nil)
-     while c
-     do (setq ,bit-stream (bitstream-push ,bit-stream (gethash c ,encoding-map)))
-     do (buf-drain-bitstream ,buf ,bit-stream 8)
-     finally (return i)))
-
-(defmacro write-encoded-message-block (encoding-map instream outstream)
-  `(let* ((bit-stream (cons 0 0))
-          (buf (list))
-          (len (build-encoded-message-block ,encoding-map ,instream buf bit-stream)))
-     (buf-drain-bitstream buf bit-stream 1)
-     (when (> len 0)
-       (write-byte (- len 1) ,outstream)
-       (write-sequence (reverse buf) ,outstream)
-       (format t "~%wrote Block with ~d codes" len)
-       )
-     len))
-
-(defmacro write-encoded-message (encoding-map instream outstream)
-  `(loop for blk-count from 1 while (= 256 (write-encoded-message-block ,encoding-map ,instream ,outstream)) finally (return blk-count)))
+              (write-byte popped-byte ,outstream))))
 
 (defun encode (instream outstream)
   (file-position instream :start)
@@ -137,40 +150,33 @@
             do (progn
                  (write-byte (car pair) outstream); write the key
                  (write-byte (cdr (cdr pair)) outstream); write the code-length
-                 (bitstream-format (cdr pair))
-                 (format t " <-- ~:C" (code-char (car pair)))
                  (setf (gethash (car pair) encoding-map) (cdr pair))
                  ))
       ;; Writing the contents
       (file-position instream :start)
-      (format t "~%wrote ~d blocks" (write-encoded-message encoding-map instream outstream))
-      )))
+      (let ((bit-stream (cons 0 0)))
+        (write-number (file-length instream) outstream)
+        (loop for c = (read-byte instream nil nil)
+              while c
+              do (setq bit-stream (bitstream-push bit-stream (gethash c encoding-map)))
+                 (stream-drain-bitstream outstream bit-stream 8))
+        (stream-drain-bitstream outstream bit-stream 1)))))
 
 (defun decode (instream outstream)
   (let ((canon (stream2canon instream))
         (decoding-map (make-hash-table :test #'equal)))
-    (format t "~%Reading dictionary")
     (loop for pair in canon
           do (setf (gethash (cdr pair) decoding-map) (car pair)))
-    (loop for len = (read-byte instream nil nil)
-          while len
-          do (let ((source (cons 0 0)))
-               (format t "~%Expecting to see ~d codes" (+ len 1))
-               (write-sequence
-                (loop for k from 0 to len
-                      collect (let ((sink (cons 0 0)))
-                                (loop until (gethash sink decoding-map)
-                                      do (progn
-                                           (when (= (cdr source) 0)
+    (let ((len (read-number instream)) (source (cons 0 0)) (sink (cons 0 0)))
+      (loop for i from 1 to len
+            do (loop until (gethash sink decoding-map)
+                     do (when (= (cdr source) 0)
                           (setq source (cons (read-byte instream) 8)))
                         (multiple-value-bind (new-source popped) (bitstream-pop1 source)
                           (setq source new-source)
                           (setq sink (bitstream-push sink (cons popped 1))))
-                                           )
-                                      finally (return (gethash sink decoding-map)))))
-                outstream)
-               ))
-    ))
+                     finally (write-byte (gethash sink decoding-map) outstream)
+                             (setq sink (cons 0 0)))))))
 
 (defmacro with-stream-translate (in-filename out-filename &body body)
   `(with-open-file (instream ,in-filename :element-type '(unsigned-byte 8) :direction :input)
@@ -180,8 +186,9 @@
 (defun main (&optional (args (or #+CLISP *args* #+SBCL *posix-argv* #+LISPWORKS system:*line-arguments-list* #+CMU extensions:*command-line-words* nil)))
   (with-stream-translate (nth 2 args) (nth 3 args)
     (funcall
-      (case (intern (string-upcase (nth 1 args))) ('e #'encode) ('d #'decode))
+     (case (intern (string-upcase (nth 1 args))) (e #'encode) (d #'decode))
      instream outstream)))
+
 ;(main (list "_" "e" "test-input.txt" "test-output.txt.hf"))
 ;(main (list "_" "d" "test-output.txt.hf" "test-output.txt"))