Huffman code自体は難しくない
Huffman codeについてはWikipediaの解説が分かりやすいので、ここでは割愛しますが、紙と鉛筆を使ってハフマン木を書いてみるとわかりやすいように思います。
さて、プログラムの話になりますが、今回はOCamlにあってCommon Lispに無いものでいろいろ悩みました。
OCamlでは値を持てる列挙型みたいなヴァリアント型というものがあります。これは再帰にすることもできます。Rustのenumと似ています。しかし、Common Lispで同様のことを行うのはなかなか難しかったです。Common Lispにも列挙型的なものはあるようで、以下のような形で定義するようです。
(deftype my-enum ()
'(member a b c))
最初はこれを何とかうまく使うには？と考えておりましたが、私の知識不足も相まって、どうもしっくりこなかったので、結局クラスを使うことにしました(構造体でも良かったのかもしれませんが)
次にOption型がCommon Lispではありませんでしたので、こちらも自分で定義することとなりました。Option型は何かしら値がある場合はSome、無ければNone、というRustを書いたことがある方にとっては馴染み深いものです。こちらもせっかくなのでざっくりと大雑把ではありますが、クラスで定義しました。今考えるとひょっとしたら無くてもいいんじゃないかとも思います。今後また考えてみようかと思います。
今回できあがったコードは以下のようになりました。
;; L-50 Huffman code
;;;;;; Option Class ;;;;;;;;;;;;;;;;;;
(defclass some* ()
((val
:initarg :val
:accessor val)))
(defclass none* () nil)
(defgeneric unwrap (kind))
(defmethod unwrap ((kind some*))
(with-accessors ((val val)) kind
val))
(defmethod unwrap ((kind none*)) nil)
(defun option (&optional x)
(cond
((null x) (make-instance 'none*))
(t
(make-instance 'some* :val x))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;; Tree Class ;;;;;;;;;;;;;;;;;;
(defclass leaf ()
((val
:initarg :val
:accessor val)))
(defclass node ()
((v1
:initarg :v1
:accessor v1)
(v2
:initarg :v2
:accessor v2)))
(defgeneric get-val (kind))
(defmethod get-val ((kind leaf))
(with-accessors ((val val)) kind
val))
(defmethod get-val ((kind node))
(with-accessors ((v1 v1) (v2 v2)) kind
(list v1 v2)))
(defun tree (x &optional y)
(cond
((null y) (make-instance 'leaf :val x))
(t (make-instance 'node :v1 x :v2 y))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass pq ()
((data
:initarg :data
:initform (make-array 101 :initial-element '())
:accessor data)
(fst
:initarg :fst
:initform 101
:accessor fst)))
(defmethod add ((q pq) p x)
(progn
(setf (elt (slot-value q 'data) p)
(cons x (elt (slot-value q 'data) p)))
(setf (slot-value q 'fst) (min p (slot-value q 'fst)))))
(defmethod get-min ((q pq))
(if (= (slot-value q 'fst) 101)
(option nil)
(let ((l (elt (slot-value q 'data) (slot-value q 'fst))))
(cond
((endp l) (error "False"))
(t
(let ((p (slot-value q 'fst)))
(progn
(setf (elt (slot-value q 'data) (slot-value q 'fst)) (cdr l))
(loop
:while (and (< (slot-value q 'fst) 101)
(endp (elt (slot-value q 'data) (slot-value q 'fst))))
:do (setf (slot-value q 'fst) (+ 1 (slot-value q 'fst))))
(option (list p (car l))))))))))
(defun huffman-tree (q)
(let ((x (get-min q))
(y (get-min q)))
(cond
((and (typep x 'some*) (typep y 'some*)) (progn
(add q
(+ (car (unwrap x))
(car (unwrap y)))
(tree (cadr (unwrap x))
(cadr (unwrap y))))
(huffman-tree q)))
((and (typep x 'some*) (typep y 'none*)) (cadr (unwrap x)))
((and (typep x 'none*) (typep y 'some*)) (cadr (unwrap y)))
(t (error "False")))))
(defun prefixes-of-tree (q &optional prefix)
(cond
((typep q 'leaf) (list (list (get-val q) prefix)))
((typep q 'node) (let ((t0 (car (get-val q)))
(t1 (cadr (get-val q))))
(if (null prefix)
(append (prefixes-of-tree t0 "0")
(prefixes-of-tree t1 "1"))
(append (prefixes-of-tree t0 (concatenate 'string prefix "0"))
(prefixes-of-tree t1 (concatenate 'string prefix "1"))))))))
(defun huffman (fs)
(when (= (reduce #'(lambda (s p) (+ s (cadr p))) fs :initial-value 0) 100)
(let ((q (make-instance 'pq)))
(progn
(dolist (i fs)
(add q (cadr i) (tree (car i))))
(prefixes-of-tree (huffman-tree q))))))
使い方は以下のように、記号と出現回数のペアのリストを使います。
* (defvar fs '(("a" 45) ("b" 13) ("c" 12) ("d" 16) ("e" 9) ("f" 5)))
FS
* (huffman fs)
(("a" "0") ("c" "100") ("b" "101") ("f" "1100") ("e" "1101") ("d" "111"))
結果は無事OCamlのL99-50と同じになりました。しかしながらまだまだ無駄が多そうなコードであります……