エントロピー符号, http://qiita.com/Nabetani/items/24b9be4ee3bae4c89a95

2013-03-01-entropy-code.lisp

;;;; Last modified: 2013-11-24 23:17:22 tkych


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

;; 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 


;;--------------------------------------------------------------------

(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)


;;--------------------------------------------------------------------
;; Code-Tree
;;--------------------------------------------------------------------

(defstruct node
  val
  left
  right)

(defvar *code-tree-root* (make-node))

(defun defnode (path val)
  (loop :with curr-node := *code-tree-root*
        :for p :across path
        :do (ecase p
              (#\0 (let ((left-node (node-left curr-node)))
                     (if left-node
                         (setf curr-node left-node)
                         (setf (node-left curr-node) (make-node)
                               curr-node             (node-left curr-node)))))
              (#\1 (let ((right-node (node-right curr-node)))
                     (if right-node
                         (setf curr-node right-node)
                         (setf (node-right curr-node) (make-node)
                               curr-node              (node-right curr-node))))))
        :finally (setf (node-val curr-node) val))
  *code-tree-root*)

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


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

;; (to-bits "16d9d4fbd") => "100001101011100110110010111111011011"
(defun to-bits (input)
  (with-output-to-string (s)
    (loop :for i :from 0 :below (length input)
          :for n := (parse-integer input :start i :end (1+ i) :radix 16)
          :do (princ (nreverse (format nil "~4,'0B" n)) s))))

(defun decode (bits &optional (code-tree *code-tree-root*))
  (loop :with len := (length bits)
        :with result := '()
        :for i :from 0
        :until (<= len i)
        :for c := (schar bits i)
        :with curr-node := code-tree
        :do (ecase c
              (#\0 (let ((left-node (node-left curr-node)))
                     (unless left-node
                       (return "*invalid*"))
                     (aetypecase (node-val left-node)
                       (null      (setf curr-node left-node))
                       (character (push it result)
                                  (setf curr-node code-tree))
                       (keyword   (return (format nil "~{~A~}:~D"
                                                  (nreverse result) (1+ i)))))))
              (#\1 (let ((right-node (node-right curr-node)))
                     (unless right-node
                       (return "*invalid*"))
                     (aetypecase (node-val right-node)
                       (null      (setf curr-node right-node))
                       (character (push it result)
                                  (setf curr-node code-tree))
                       (keyword   (return (format nil "~{~A~}:~D"
                                                  (nreverse result) (1+ i))))))))
        :finally (return "*invalid*")))

(defun main (input)
  (decode (to-bits 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*")
  )


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