昨日はHaskellで二分探索木の勉強をした。
Common Lispでもそれと同じようなことをしている人を見つけた。
ありがたい。浅くしかコードを読んでいないが、コピー・アンド・ペーストして実行することで、溜飲を下げる。
(ql:quickload :optima) (use-package :optima) (defstruct (leaf (:constructor leaf))) (defstruct (node (:constructor node (color left label right))) color left label right) (defun rb-member (x tree) (match tree ((leaf) nil) ((node left label right) (cond ((< x label) (rb-member x left)) ((> x label) (rb-member x right)) (t t))))) (defun red (left label right) (node :red left label right)) (defun black (left label right) (node :black left label right)) (defpattern red (left label right) `(node (color :red) (left,left) (label ,label) (right ,right))) (defpattern black (left label right) `(node (color :black) (left,left) (label ,label) (right ,right))) (defun balance (tree) (match tree ((or (black (red (red a x b) y c) z d) (black (red a x (red b y c)) z d) (black a x (red (red b y c) z d)) (black a x (red b y (red c z d)))) (red (black a x b) y (black c z d))) (otherwise tree))) (defun rb-insert (x tree) (labels ((ins (tree) (match tree ((leaf) (red (leaf) x (leaf))) ((node color left label right) (cond ((< x label) (balance (node color (ins left) label right))) ((> x label) (balance (node color left label (ins right)))) (t tree)))))) (match (ins tree) ((node left label right) (black left label right)))))
上が書かれたファイルをロードしてからREPLで下のようにやってみる。
CL-USER> (setq tree (leaf)) #S(LEAF) CL-USER> (mapcar (lambda (xx) (setq tree (rb-insert xx tree))) '(8 6 4 1 7 3 5)) (#S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 8 :RIGHT #S(LEAF)) #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(LEAF) :LABEL 6 :RIGHT #S(LEAF)) :LABEL 8 :RIGHT #S(LEAF)) #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 4 :RIGHT #S(LEAF)) :LABEL 6 :RIGHT #S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 8 :RIGHT #S(LEAF))) #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(LEAF) :LABEL 1 :RIGHT #S(LEAF)) :LABEL 4 :RIGHT #S(LEAF)) :LABEL 6 :RIGHT #S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 8 :RIGHT #S(LEAF))) #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(LEAF) :LABEL 1 :RIGHT #S(LEAF)) :LABEL 4 :RIGHT #S(LEAF)) :LABEL 6 :RIGHT #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(LEAF) :LABEL 7 :RIGHT #S(LEAF)) :LABEL 8 :RIGHT #S(LEAF))) #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 1 :RIGHT #S(LEAF)) :LABEL 3 :RIGHT #S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 4 :RIGHT #S(LEAF))) :LABEL 6 :RIGHT #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(LEAF) :LABEL 7 :RIGHT #S(LEAF)) :LABEL 8 :RIGHT #S(LEAF))) #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 1 :RIGHT #S(LEAF)) :LABEL 3 :RIGHT #S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 4 :RIGHT #S(NODE :COLOR :RED :LEFT #S(LEAF) :LABEL 5 :RIGHT #S(LEAF)))) :LABEL 6 :RIGHT #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(LEAF) :LABEL 7 :RIGHT #S(LEAF)) :LABEL 8 :RIGHT #S(LEAF)))) CL-USER> tree #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 1 :RIGHT #S(LEAF)) :LABEL 3 :RIGHT #S(NODE :COLOR :BLACK :LEFT #S(LEAF) :LABEL 4 :RIGHT #S(NODE :COLOR :RED :LEFT #S(LEAF) :LABEL 5 :RIGHT #S(LEAF)))) :LABEL 6 :RIGHT #S(NODE :COLOR :BLACK :LEFT #S(NODE :COLOR :RED :LEFT #S(LEAF) :LABEL 7 :RIGHT #S(LEAF)) :LABEL 8 :RIGHT #S(LEAF))) CL-USER> (rb-member 8 tree) T CL-USER> (rb-member 100 tree) NIL CL-USER> (rb-member 1 tree) T CL-USER> (rb-member 10 tree) NIL CL-USER> (mapcar (lambda (xx) (rb-member xx tree)) '(1 2 3 4 5 6 7 8 9 10)) (T NIL T T T T T T NIL NIL)
Common Lispの方の木はごちゃごちゃしていて、Haskellの方をやっていなかったら、すごく理解しにくかったと思う。わかっていても (mapcar (lambda (xx) (setq tree (rb-insert xx tree))) '(8 6 4 1 7 3 5)) の後のは目が滑って迷子になる。
