エントロピー符号, 再帰で書き直しました。

2013-03-01-entropy-code-v2.lisp

;;;; Last modified: 2013-12-18 00:49:33 tkych


;;====================================================================
;; エントロピー符号, ver.2
;;====================================================================
;; - [エントロピー符号 〜 横へな 2013.3.1 の参考問題](http://nabetani.sakura.ne.jp/hena/ord8entco/)
;; - [オフラインリアルタイムどう書く第8回の参考問題](http://qiita.com/Nabetani/items/24b9be4ee3bae4c89a95)

;; Code:   Char
;; ------------
;; 000     #\t
;; 0010    #\s
;; 0011    #\n
;; 0100    #\i
;; 01010   #\d
;; 0101101 #\c
;; 010111  #\l
;; 0110    #\o
;; 0111    #\a
;; 10      #\e
;; 1100    #\r
;; 1101    #\h
;; 111     terminal 

;;--------------------------------------------------------------------
;; Package
;;--------------------------------------------------------------------

(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :anaphora))
(defpackage :entropy-code
  (:use :cl)
  (:import-from :anaphora
                :it :aetypecase))
(in-package :entropy-code)


;;--------------------------------------------------------------------
;; Main
;;--------------------------------------------------------------------

(defstruct (node (:constructor node)
                 (:conc-name nil))
  zero code one)

(defparameter *code-tree* (node))

(defun insert (label path &optional (tree *code-tree*))
  (labels ((rec (path tree)
             (if (endp path)
                 (setf (code tree) label)
                 (destructuring-bind (p . ps) path
                   (rec ps (ecase p
                             (0 (or (zero tree)
                                    (setf (zero tree) (node))))
                             (1 (or (one tree)
                                    (setf (one tree) (node))))))))))
    (rec (map 'list #'digit-char-p path) tree)))

(insert #\t "000")
(insert #\s "0010")
(insert #\n "0011")
(insert #\i "0100")
(insert #\d "01010")
(insert #\c "0101101")
(insert #\l "010111")
(insert #\o "0110")
(insert #\a "0111")
(insert #\e "10")
(insert #\r "1100")
(insert #\h "1101")
(insert :terminal "111")

(defun decode (path &optional (root *code-tree*))
  (labels ((rec (path tree acc count)
             (if (or (null tree) (endp path))
                 "*invalid*"
                 (destructuring-bind (p . ps) path
                   (ecase p
                     (0 (let ((zero (zero tree)))
                          (if (null zero)
                              "*invalid*"
                              (aetypecase (code zero)
                                (null      (rec ps zero acc (1+ count)))
                                (keyword   (format nil "~{~A~}:~D" (nreverse acc) count))
                                (character (rec ps root (cons it acc) (1+ count)))))))
                     (1 (let ((one (one tree)))
                          (if (null one)
                              "*invalid*"
                              (aetypecase (code one)
                                (null      (rec ps one acc (1+ count)))
                                (keyword   (format nil "~{~A~}:~D" (nreverse acc) count))
                                (character (rec ps root (cons it acc) (1+ count))))))))))))
    (rec (map 'list #'digit-char-p path) root '() 1)))

;; "16d9d4fbd" -> "100001101011100110110010111111011011"
(defun parse (input)
  (with-output-to-string (s)
    (loop :for c :across input
          :do (princ (nreverse (format nil "~4,'0B" (digit-char-p c 16))) s))))

(defun main (input)
  (decode (parse input)))


;;--------------------------------------------------------------------
;; Tests
;;--------------------------------------------------------------------

(defun =>? (got want)
  (assert (string= got want)))

(progn
  (=>? (main "16d9d4fbd") "ethanol:30")
  (=>? (main "df") "e:5")
  (=>? (main "ad7") "c:10")
  (=>? (main "870dcb") "t:6")
  (=>? (main "880f63d") "test:15")
  (=>? (main "a57cbe56") "cat:17")
  (=>? (main "36abef2") "roll:23")
  (=>? (main "ad576cd8") "chant:25")
  (=>? (main "3e2a3db4fb9") "rails:25")
  (=>? (main "51aa3b4c2") "eeeteee:18")
  (=>? (main "ad5f1a07affe") "charset:31")
  (=>? (main "4ab8a86d7afb0f") "slideshare:42")
  (=>? (main "ac4b0b9faef") "doctor:30")
  (=>? (main "cafebabe") "nlh:17")
  (=>? (main "43e7") "sra:15")
  (=>? (main "53e7") "eera:15")
  (=>? (main "86cf") "tera:16")
  (=>? (main "b6cf") "hon:15")
  (=>? (main "0") "*invalid*")
  (=>? (main "c") "*invalid*")
  (=>? (main "d") "*invalid*")
  (=>? (main "e") "*invalid*")
  (=>? (main "babecafe") "*invalid*")
  (=>? (main "8d") "*invalid*")
  (=>? (main "ad") "*invalid*")
  (=>? (main "af") "*invalid*")
  (=>? (main "ab6e0") "*invalid*")
  (=>? (main "a4371") "*invalid*")
  (=>? (main "a4371") "*invalid*")
  (=>? (main "96e3") "*invalid*")
  (=>? (main "0dc71") "*invalid*")
  (=>? (main "2a9f51") "*invalid*")
  (=>? (main "a43fb2") "*invalid*")
  (=>? (main "ab6e75") "*invalid*")
  (=>? (main "a5dcfa") "*invalid*")
  (=>? (main "ca97")    "*invalid*")
  (=>? (main "6822dcb") "*invalid*")
  )


;;====================================================================