トップ > utility

端末操作

common lisp utility

今日は端末操作用のエスケープシーケンスを調べる機会があったので、その内の自分が良く使いそうな操作をcommon lispのパッケージとしてまとめておくことにする。

(defpackage ppterm
  (:use :common-lisp)
  (:export *colorset*
           color
           clear
           cursor))
(in-package :ppterm)

(defvar *colorset* '(:black :red :green :brown :blue :purple :cyan :light-gray))
(defvar *fg-color-codes* (loop FOR i FROM 30 TO 37 COLLECT i))
(defvar *bg-color-codes* (loop FOR i FROM 40 TO 47 COLLECT i))

(defconstant +ESC-CHAR+ (code-char #o33))

;; 文字の色(+その他)変更用のエスケープシーケンス
(deftype colorset () `(member ,@*colorset*))
(defun color (string &key color back bold underline inverse)
  (declare ((or null colorset) color back)
           (boolean bold underline inverse))
  (with-output-to-string (out)
    ;; エスケープシーケンス開始
    (format out "~C["   +ESC-CHAR+)

    ;; 文字の色などを設定
    (format out "~{~D~^;~}"
      (remove nil
        (list
         ;; 文字色
         (when color
           #.`(ecase color
                ,@(mapcar (lambda (color code) `(,color ,code))
                          *colorset* *fg-color-codes*)))
         ;; 背景色
         (when back
           #.`(ecase back
                ,@(mapcar (lambda (color code) `(,color ,code))
                          *colorset* *bg-color-codes*)))
         ;; 太字
         (when bold      1)
         ;; 下線
         (when underline 4)
         ;; 反転
         (when inverse   7))))
     
    ;; 文字列出力
    (format out "m~A" string)

    ;; エスケープシーケンス終了
    (format out "~C[0m" +ESC-CHAR+)))

;; カーソル位置設定用のエスケープシーケンス
(deftype cursor-position () '(integer 0 #.most-positive-fixnum))
(defun cursor (&key x y up down left right)
  (declare ((or null cursor-position) x y up down left right))
  (when (and x (null y))  (setf y 0))
  (when (and y (null x))  (setf x 0))
 
  (with-output-to-string (out)
    (when x 
      (format out "~C[~D;~DH" +ESC-CHAR+ y x)) ;; カーソル位置を(x,y)で指定
    (when up
      (format out "~C[~DA" +ESC-CHAR+ up))     ;; カーソルをup分上に移動
    (when down
      (format out "~C[~DB" +ESC-CHAR+ down))   ;; カーソルをdown分下に移動
    (when left
      (format out "~C[~DD" +ESC-CHAR+ left))   ;; カーソルをleft分右に移動
    (when right
      (format out "~C[~DC" +ESC-CHAR+ right))));; カーソルをright分左に移動

;; 画面クリア用のエスケープシーケンス
;; lineがtなら、一行のみを、nilなら画面全体をクリアする
(defun clear (&optional line)
  (declare (boolean line))
  (with-output-to-string (out)
    (format out "~C[~:[2J~;K~]" +ESC-CHAR+ line)))

使用例。



> (ppterm:color "赤い文字" :color :red)



    

  • 

      

    • > "赤い文字"
      • 

    •


少し長い例。
三目並べ 。※いろいろ適当

;; 盤を表示。ここでpptermを使用。
(defun print-board (board)
  (princ (ppterm:clear))
  (loop FOR x FROM 0 TO 2 DO
    (loop FOR y FROM 0 TO 2 DO
      (princ (ppterm:cursor :x (* 2 (1+ x)) :y (1+ y)))
      (case (aref board x y)
        (:first  (princ (ppterm:color "■" :color :red  :bold t)))
        (:second (princ (ppterm:color "■" :color :blue :bold t)))
        (otherwise (princ (ppterm:color "□" :color :black)))))))

;; ゲームが終了したかどうかの判定
(defun finish? (board)
  (loop FOR player IN '(:first :second) DO
    (when (or (some 
               (lambda (i)
                 (or (loop FOR x FROM 0 TO 2 ALWAYS (eq (aref board x i) player))   ; 横一列
                     (loop FOR y FROM 0 TO 2 ALWAYS (eq (aref board i y) player)))) ; 縦一列
               '(0 1 2)) 
              (loop FOR x FROM 0 TO 2 
                    FOR y FROM 0 TO 2 
                ALWAYS (eq (aref board x y) player))  ; 斜め1
              (loop FOR x FROM 0 TO 2 
                    FOR y FROM 2 DOWNTO 0
                ALWAYS (eq (aref board x y) player))) ; 斜め2
      (return-from finish? player)))
  
  (when (loop FOR i FROM 0 BELOW (array-total-size board) ; 全部のマスが埋まっているかどうか
              ALWAYS (row-major-aref board i))
    (return-from finish? :draw)))

;; 
(defun game ()
  (let ((board (make-array '(3 3) :initial-element nil)))
    (loop UNTIL (finish? board) 
          FOR player = :first THEN (if (eq player :first) :second :first)
      DO
      (loop
       (print-board board)
       (format t "~&~:[後手~;先手~](x y): " (eq player :first))
       (force-output)
       (let ((x (read))
             (y (read)))
         (when (and (<= 0 x 2)
                    (<= 0 y 2)
                    (null (aref board x y)))
           (setf (aref board x y) player)
           (return)))))
    (print-board board)
    (format t "~&~A" (finish? board))
    (force-output))
  (values))

;; 実行
> (game)
; ...
; ...

fnlet

common lisp utility

funcallを省略するためのマクロ。
実際には使わなそうだけど、一応残しておく。

(defmacro fnlet (letargs &body body)
  `(macrolet 
    ,(mapcar 
      (lambda (letarg)
        (destructuring-bind (fn-name fn)
                            (if (listp letarg)
                                letarg
                              `(,letarg ,letarg))
          `(,fn-name (&rest args)
             `(funcall ,',fn ,@args))))
      letargs)
    ,@body))

;;;;;;;;;;;;
;;;; 使用例
;; WikipediaのStandard MLの項目に載っていた数値微分の定義
(defun d (delta fn x)
  (fnlet (fn)       ; (fn ...) == (funcall fn ...)
    (/ (- (fn (+ x delta))
          (fn (- x delta)))
       (* 2 delta))))

(defun my-mapcar (fn list)
  (fnlet ((! fn))   ; (! ...) == (funcall fn ...)
    (if (endp list)
        '()
      (cons (!(car list)) (my-mapcar fn (cdr list))))))

maphash-to-list

common lisp sbcl utility optimize

common lispではハッシュが使い難い(と思う)。
その理由の一つは、リストのようにマッピング関数がない*1せいだと思うので、そのための関数を定義。
ユーティリティ関数っぽくいろいろ装飾。
※ 宣言はsbcl(1.0.37)用に特化

(declaim (inline maphash-to-list))  ; sbclのmaphash関数にはinline宣言されているようなので、それに合わせる
(defun maphash-to-list (function-designator hash-table &aux acc)
"For each entry in HASH-TABLE, call the designated two-argument function on
 the key and value of the entry. Return list of the function return values."

  ;; 引数の型チェック等を行って欲しいため、safetyやdebugをここでは0にしない
  ;;
  ;; (/= safety 0)なら、関数呼び出し時に型チェックが行われる
  ;; - http://www.sbcl.org/manual/#Declarations-as-Assertions
  ;; 
  ;; (>= debug 1)なら、関数の引数情報が保持される => (describe ...)の結果が親切
  ;; - http://www.sbcl.org/manual/#Debugger-Policy-Control
  (declare (optimize (safety 1) (debug 1) (speed 3))
           (hash-table hash-table)
           ((or symbol function) function-designator))
  (locally
   ;; この時点では引数の型が正しいことが確定しているので、debug及びsafetyを0に設定
   (declare (optimize (debug 0) (safety 0)))
   (let ((fn (if (typep function-designator 'function)
                 function-designator
               (symbol-function function-designator))))
     (maphash
      (lambda (k v)
        (push (funcall fn k v) acc))
      hash-table))
   acc))

;;;;;;;
;;; 例
> (let ((hash (make-hash-table)))
    (setf (gethash :key hash) :value
          (gethash 1 hash) 2
          (gethash "a" hash) "b")
  
    ;; キーだけを集める
    (maphash-to-list (lambda (k v) k) hash))
--> ("a" 1 :KEY)

比較のために、型チェックを全く行わない版も定義。

(declaim (inline maphash-to-list-fast))
(defun maphash-to-list-fast (function-designator hash-table &aux acc)
  (declare (optimize (safety 0) (debug 0) (speed 3))
           (hash-table hash-table)
           (function function-designator))
  (maphash
   (lambda (k v)
     (push (funcall function-designator k v) acc))
   hash-table)
  acc)

比較。

;;;;;;;;;;;;;;;;;;
;;; 型チェック確認
> (maphash-to-list 1 1)
debugger invoked on a TYPE-ERROR in thread #<THREAD "initial thread" RUNNING
                                             {AA087C1}>:
  The value 1 is not of type (OR SYMBOL FUNCTION).  ; 型が違う

> (maphash-to-list-fast 1 1)
CORRUPTION WARNING in SBCL pid 9089(tid 3085166256):
Memory fault at 3b (pc=0xb61914a, sp=0xb7907b88)
The integrity of this image is possibly compromised.
Continuing with fingers crossed.

debugger invoked on a SB-SYS:MEMORY-FAULT-ERROR in thread #<THREAD
                                                            "initial thread" RUNNING
                                                            {AA087C1}>:
  Unhandled memory fault at #x3B.  ; Unhandled memory?

;;;;;;;;;;;;;
;;;; 処理速度
;; 要素数1000のハッシュを作成
> (defparameter *hash*
    (let ((hash (make-hash-table)))
      (loop FOR i FROM 0 BELOW 1000 DO
        (setf (gethash i hash) (random 10000000)))
      hash))
--> *HASH*

;; maphash関数の場合
> (time
   (dotimes (i 100000 'done)
     (declare (optimize (speed 3) (debug 0) (safety 0)))
     (let (acc)
       (maphash
         (lambda (k v)
           (declare (fixnum k v))
           (push (+ k v) acc))
         *hash*))))
Evaluation took:
  0.845 seconds of real time
  0.844052 seconds of total run time (0.844052 user, 0.000000 system)
  [ Run times consist of 0.060 seconds GC time, and 0.785 seconds non-GC time. ]
  99.88% CPU
  2,680,836,701 processor cycles
  800,000,936 bytes consed
--> DONE

;; maphash-to-list関数の場合
> (time
   (dotimes (i 100000 'done)
     (declare (optimize (speed 3) (debug 0) (safety 0)))
     (maphash-to-list 
      (lambda (k v)
        (declare (fixnum k v))
        (+ k v))
      *hash*)))
Evaluation took:
  0.849 seconds of real time
  0.848054 seconds of total run time (0.844053 user, 0.004001 system)
  [ Run times consist of 0.072 seconds GC time, and 0.777 seconds non-GC time. ]
  99.88% CPU
  2,693,672,940 processor cycles
  800,002,736 bytes consed
--> DONE

;; maphash-to-list-fast関数の場合
> (time
   (dotimes (i 100000 'done)
     (declare (optimize (speed 3) (debug 0) (safety 0)))
     (maphash-to-list-fast
      (lambda (k v)
        (declare (fixnum k v))
        (+ k v))
      *hash*)))
  Evaluation took:
  0.848 seconds of real time
  0.844052 seconds of total run time (0.836052 user, 0.008000 system)
  [ Run times consist of 0.064 seconds GC time, and 0.781 seconds non-GC time. ]
  99.53% CPU
  2,687,459,342 processor cycles
  800,005,176 bytes consed
--> DONE

どれもほとんど速度は変わらない。
今回のような関数の場合は、入り口部分で型チェックをしたからといってそこがボトルネックとなることもないので(inline化されているならなおさら)、安全性を高め文書化するために、適切な宣言を行った方が良い。
結構サボリがちだけど、今後ユーティリティ関数やライブラリを書く時には気をつけないと...。

*1:loopマクロを使えば出来ないことはないけど、これはこれで使い難いように思う。ハッシュのキーと値の両方を使いたい時は特に。

equal-case

common lisp utility

equal等値なキーを扱えるようにしたcase。
主にstring型に対して適用することを想定。

;; TODO: 重複キーのチェック(警告)をつけるべき
(defmacro equal-case (expr &rest clauses)
  (let ((v (gensym)))
    `(let ((,v ,expr))
       (cond ,@(stable-sort
                (mapcar 
                 (lambda (clause) 
                   (destructuring-bind (keys . forms) clause
                     (cond ((member keys '(t otherwise))  ; (otherwise|t ...)なら
                            `(t ,@forms))
                           ((consp keys)                  ; ((... ... ...) ...)なら
                            `((member ,v ',keys :test #'equal) ,@forms))
                           (t                             ; (... ...)なら
                            `((equal ,v ,keys) ,@forms)))))
                 clauses)
                ;; otherwise or t が、一番最後の節になるようにする
                #'< :key (lambda (x) (if (eq (car x) t) 1 0)))))))

;; ついでにアナフォリック版も定義
(defmacro a.equal-case (expr &rest clauses)
  `(let ((it ,expr))
     (equal-case it
       ,@clauses)))

使用例。

> (equal-case "integer" 
     ("string"            'int) 
     (otherwise           'unknown) 
     (("integer" "float") 'number))
--> NUMBER

> (a.equal-case "number" 
     ("string"            (format nil "~A is ~A" it 'int))
     (otherwise           (format nil "~A is ~A" it 'unknown))
     (("integer" "float") (format nil "~A is ~A" it 'number)))
--> "number is UNKNOWN"

列の分割

common lisp utility

文字列の分割を行いたいけど、cl-ppcreパッケージをその(cl-ppcre:split関数の)ためだけに使用したくはなかったので、分割関数を作成した。

;; 第一版: 平易
(defun split (delim seq &aux (len (length delim)))
  (declare (unmuffle-conditions compiler-note))
  (when (zerop len)
    (return-from split (list seq)))　; これが無いと、delim=空列、の際に無限ループとなる

  (loop FOR beg = 0 THEN (+ end len)
        FOR end = (search delim seq :start2 beg)
        COLLECT (subseq seq beg end)
        WHILE end))

;; 第二版: 少し高機能: 開始位置、終端位置、分割個数が指定可能
(defun split (delim seq &key (start 0) end limit)
  (when (and (numberp limit)
             (not (plusp limit)))
    (return-from split '()))

  (when (zerop len)
    (return-from split (list seq)))

  (loop WITH len = (length delim)
        FOR beg~ = start THEN (+ end~ len)
        FOR end~ = (if (and limit (zerop (decf limit)))
                       nil
                     (search delim seq :start2 beg~ :end2 end))
        COLLECT (subseq seq beg~ (or end~ end))
        WHILE end~))

上の関数は、文字列に限らず列一般に対して適用できるという(cl-ppcre:split関数に比べて些細な)利点がある。

> (split "ab" "123abc")
--> ("123" "c")

> (split "a" '(1 2 3 #\a #\b c))
--> ((1 2 3) (#\b C))

> (split "a" "aaaaaaaaa")  ; 区切り文字が連接していると空列となる
--> ("" "" "" "" "" "" "" "" "" "")

> (split "a" "aaaaaaaaa" :limit 3) ; 要素数を三個までに限定
--> ("" "" "aaaaaaa")

> (split "ab" "123abcd" :start 1)  ; 開始位置指定: (split "ab" (subseq "123abcd" 1))と等しい
--> ("23" "cd")

最近は、LOOPマクロを多用するようになった。
以前は、再帰関数で頑張っていたのに...。

ビットストリーム -DEFLATE用-

common lisp utility

RFC1951のDEFLATE圧縮データフォーマットを実装するために作成したビットストリーム。
DEFLATEを実装するのに当面必要な関数だけが定義してあり、インターフェースは適当。

;;;;;;;;;;;;;;;
;;;; パッケージ
(defpackage :bit-stream
  (:use :common-lisp)
  (:export :bit-stream
           :make-bit-stream
           :with-bit-stream
           :flush-bit-stream
           :read-bit
           :read-fixnum
           :write-bits
           :bits))
(in-package :bit-stream)

;;;;;;;;;;;
;;;; 構造体
;; バイナリストリームをラップしたビットストリーム用の構造体
(defstruct (bit-stream (:constructor make-bit-stream (stream)))
  stream    ; オリジナルのバイナリストリーム   ※ element-typeは(unsigned-byte 8)でなければならない
  (octet 0) ; 8bit整数: 要素数8のビットバッファ
  (pos 0))  ; octetの添字

;; 整数とビット長から、ビット配列を作成する
;; ex. (bits #b10 4) ==> #*0010
(defun bits (num bit-length)
  (let ((bits (make-array bit-length :element-type 'bit)))
    (dotimes (i bit-length bits)
      (setf (sbit bits i) (ldb (byte 1 (- bit-length 1 i)) num)))))

;; 引数のビット配列を出力する
;; reverse引数がtの場合は、bitsの上位ビットと下位ビットが逆転して出力される
;;  ex. (write-bits #*11110000 stream)            ==> 出力データ: #b11110000
;;      (write-bits #*11110000 stream :reverse t) ==> 出力データ: #b00001111
(defun write-bits (bits bit-stream &key reverse)
  (with-slots (stream octet pos) bit-stream
    (loop FOR bit ACROSS (if reverse bits (reverse bits)) DO
      (when (= 8 pos)
        (write-byte octet stream)
        (setf octet 0 pos 0))
      (setf (ldb (byte 1 pos) octet) bit)
      (incf pos))))

;; bit-streamのバッファに残っているデータを出力する
;; バッファ内のビット数が8未満の場合、足りない分は0ビットで埋められる
(defun flush-bit-stream (bit-stream)
  (with-slots (pos) bit-stream
    (write-bits (bits 0 (- 9 pos)) bit-stream)))

;; ビットストリームの作成および(確実な)終了を行うマクロ
(defmacro with-bit-stream ((stream source-binary-stream) &body body)
  `(let ((,stream (make-bit-stream ,source-binary-stream)))
     (unwind-protect
         (progn ,@body)
       (when (output-stream-p (bit-stream-stream ,stream))
         (flush-bit-stream ,stream)))))

;; ビットストリームから1ビット読み込む
(defun read-bit (bit-stream)
  (with-slots (stream octet pos) bit-stream
    (when (= 0 pos)
      (setf octet (read-byte stream))
      (setf pos 8))
    (prog1 
        (ldb (byte 1 (- 8 pos)) octet)
      (decf pos))))

;; ビットストリームからbit-lengthビット読み込む(固定ビット長の整数読込)
(defun read-fixnum (bit-length bit-stream)
  (loop FOR i FROM 0 BELOW bit-length 
        SUMMING (ash (read-bit bit-stream) i)))

使用例。

> (import 'bit-stream:bits)

;; ビット出力
> (with-open-file (out "test" :element-type '(unsigned-byte 8)
                              :direction :output)
    (bit-stream:with-bit-stream (bout out)
      (bit-stream:write-bits #*11100 bout)        ; 値:   28, ビット長: 5
      (bit-stream:write-bits (bits 1 4)     bout) ; 値:    1, ビット長: 4
      (bit-stream:write-bits (bits 2000 12) bout) ; 値: 2000, ビット長: 12
      'done))
--> DONE

;; ビット入力
> (with-open-file (in "test" :element-type '(unsigned-byte 8))
    (bit-stream:with-bit-stream (bin in)
      (print (bit-stream:read-fixnum 5  bin)) ; ビット長: 5
      (print (bit-stream:read-fixnum 4  bin)) ; ビット長: 4
      (print (bit-stream:read-fixnum 12 bin)) ; ビット長: 12
      'done))
28
1
2000
--> DONE

ハッシュトライ

common lisp utility algorithm

最近ちょくちょくトライを使いたくなることがあるので、少しまとまったハッシュトライの実装を書いておく。
位置付け的には開発用。使用頻度が高いようなら、もう少しちゃんとしたものに書き直す。
※ 2010/01/03: print-objectメソッド追加、common-prefix-search関数追加、hash-trieから冗長なtestフィールドを除外

ソースコード

依存: common-utils or nlet,a.when.a.if

(defpackage :hash-trie
  (:use :common-lisp :common-utils) ; nlet, a.if, a.whenは、common-utilsパッケージ内で定義されている
  (:export :make-trie
           :get-node :get-node1
           :get-elem :get-elem1
           :rem-elem :rem-elem1
           :common-prefix-search
           :map-trie
           :to-list
           :element-count
           :hash-trie))
(in-package :hash-trie)

(defstruct (hash-trie (:constructor 
                       make-trie (&key (test 'eql) 
                                  &aux (hash (make-hash-table :test test)))))
  hash)

(declaim (ftype (function (hash-trie) fixnum) element-count))
(defmethod print-object ((o hash-trie) stream)
  (print-unreadable-object (o stream :type t :identity t)
    (format stream "~S ~A ~S ~D" 
            :test  (hash-table-test (hash-trie-hash o))
            :count (element-count o))))

(defmacro get-node1 (key trie) `(gethash ,key (hash-trie-hash ,trie)))
(defmacro rem-node1 (key trie) `(remhash ,key (hash-trie-hash ,trie)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((ELEMENT-NODE-KEY '#.(gensym)))
    (defmacro get-elem1 (trie) `(gethash ',ELEMENT-NODE-KEY (hash-trie-hash ,trie)))
    (defmacro rem-elem1 (trie) `(remhash ',ELEMENT-NODE-KEY (hash-trie-hash ,trie)))
    (defun element-node-key-p (key) (eq key ELEMENT-NODE-KEY))))

(defun coerce-to-list (seq)
  (if (listp seq) seq (coerce seq 'list)))

(defun get-node-force (key-seq trie)
  (nlet self ((keys (coerce-to-list key-seq)) (trie trie))
    (if (null keys)
        trie
      (a.if #1=(get-node1 (car keys) trie)
          (self (cdr keys) it)
        (self (cdr keys) (setf #1# (make-trie :test (hash-table-test
                                                     (hash-trie-hash trie)))))))))

;; --> (values key-seqに一致したノード                          ; 一致するノードが無かった場合はnil
;;             key-seqの要素に一致した最後のノード              ; ≒ 検索に失敗したノード
;;             trieの中に見つかったkey-seqの最後の要素の位置+1) ; ≒ 検索に失敗した要素位置
(defun get-node (key-seq trie)
  (nlet self ((keys (coerce-to-list key-seq)) (trie trie) (i 0))
    (if (null keys)
        (values trie trie i)
      (a.if (get-node1 (car keys) trie)
          (self (cdr keys) it (1+ i))
        (values nil trie i)))))

(defun get-elem (key-seq trie)
  (nlet self ((keys (coerce-to-list key-seq)) (trie trie))
    (if (null keys)
        (get-elem1 trie)
      (a.if (get-node1 (car keys) trie)
           (self (cdr keys) it)
        (values nil nil)))))

(defsetf get-elem (key-seq trie) (new-value)
  `(let ((terminal-node (get-node-force ,key-seq ,trie)))
     (setf (get-elem1 terminal-node) ,new-value)
     ,new-value))

(defun map-trie (fn trie)
  (nlet self ((trie trie) keys)
    (maphash (lambda (key val)
               (if (element-node-key-p key)
                   (funcall fn (reverse keys) val)
                 (self val (cons key keys))))
             (hash-trie-hash trie))))

(defun to-list (trie)
  (nlet self ((trie trie))
    (let ((acc '()))
      (maphash (lambda (key val)
                 (push
                  (if (element-node-key-p key)
                      val
                    (cons key (self val)))
                  acc))
               (hash-trie-hash trie))
      acc)))

(defun element-count (trie &aux (count 0))
  (nlet self ((trie trie))
    (maphash (lambda (key val)
               (if (element-node-key-p key)
                   (incf count)
                 (self val)))
             (hash-trie-hash trie)))
  count)

;; key-seqに対応する要素が存在した場合はtを、しなかった場合はnilを返す
;; 要素削除後にできる空ノードも合わせて削除される
(defun rem-elem (key-seq trie)
  (nlet self ((keys (coerce-to-list key-seq)) (trie trie))
    (if (null keys)
        (rem-elem1 trie)
      (a.when (get-node1 (car keys) trie)
        (prog1 (self (cdr keys) it)
          (when (zerop (hash-table-count (hash-trie-hash it)))
            (rem-node1 (car keys) trie)))))))

(defun common-prefix-search (key-seq trie)
  (let ((elems '()))
    (nlet self ((keys (coerce-to-list key-seq)) (trie trie) (i 0))
      (when keys
        (let ((node (get-node1 (car keys) trie)))
          (when node
            (a.when (get-elem1 node)
              (push (list i it node) elems))
            (self (cdr keys) node (1+ i))))))
    (values (nreverse elems))))

;; [TODO]
;;  - key-seqを引数に取る関数には、:startおよび:endキーワード引数を指定できるようにする
;;  - リスト以外の列が渡された場合の処理の効率化   ※ 現状は全部(coerce ... 'list)しているので非効率
;;  - 整理/コメント
;;  - etc

仕様説明を兼ねた使用例

> (rename-package :hash-trie :hash-trie '(:trie))

;;;;;;;;;;;;;;;;;;;
;;;; 基本的な使い方
;; 作成
> (defvar *trie* (trie:make-trie))  ; testキーワード引数が指定可能(デフォルトは#'eql)。test引数は、内部で利用しているハッシュテーブルに渡される
--> *TRIE*

;; 要素追加
> (setf (trie:get-elem "abc" *trie*) :val1)
--> :VAL1

;; 要素取得: 返り値の形式は、gethashと同様
> (trie:get-elem "abc" *trie*)
--> :VAL1
    T

> (trie:get-elem "ab" *trie*)
--> NIL 
    NIL

;; 要素数取得: 毎回全要素を走査するので遅い
> (trie:element-count *trie*)
--> 1

;; 要素追加2: キーの列がリストでも配列でも区別しない
> (setf (trie:get-elem '(#\a #\b #\e #\f) *trie*) :val2)
--> VAL2

;; リスト(ツリー)に変換
> (trie:to-list *trie*)
--> ((#\a (#\b (#\e (#\f :VAL2)) 
               (#\c :VAL1))))

;; マッピング
> (trie:map-trie (lambda (k v) (format t "KEY:~A, VAL:~A~%" k v)) *trie*)
KEY:(a b c), VAL:VAL1
KEY:(a b e f), VAL:VAL2
--> NIL


;;;;;;;;;;;;;;;;;
;;;; その他の関数
;; ノード取得(検索)
;; ※ get-nodeで取得したノードは、それ自体がhash-trieなので、hash-trieに対する任意の関数が適用可能
> (trie:get-node "ab" *trie*)
--> #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 2 {B1B4491}> ; キー列"ab"に対応するノード
    #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 2 {B1B4491}> ; 同上
    2                         ; 検索に失敗したキー列の要素の位置。今回は成功したので、(length "ab")

;; ノード取得(検索): 失敗時
> (trie:get-node "abcd" *trie*)
--> NIL                      ; 取得に失敗  
    #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 1 {B1B46D1}> ; 最後に使われたノード  ※"abc"に対応するノード
    3                        ; 検索に失敗した要素の位置 ※ 3=="d"の位置で失敗

;; 呼び出しを複数に分けた場合
> (eq (trie:get-node "abef" *trie*)
      (trie:get-node "ef" (trie:get-node "ab" *trie*)))
--> T 


;; 要素削除
> (trie:rem-elem "abef" *trie*)
--> T

> (trie:to-list *trie*)
--> ((#\a (#\b (#\c :VAL1))))

;; - get-elem1,rem-elem1は、それぞれ空列を渡した場合のget-elem,rem-elemと等しい
;; - get-node1は、要素数が1の列を渡した場合のget-nodeと等しい
> (trie:get-elem1 (trie:get-node1 #\c (trie:get-node1 #\b (trie:get-node1 #\a *trie*))))
--> :VAL1
    T

;; rem-elem1(or 空列を渡したrem-elem)の場合、要素削除後に要素を持たないゴミノードが残ってしまう
;;   ==> ルートノード(*trie*)に対して、(trie:rem-elem "abc" *trie*)を呼び出した方が良い
> (trie:rem-elem1 (trie:get-node1 #\c (trie:get-node1 #\b (trie:get-node1 #\a *trie*))))
--> T

> (trie:to-list *trie*)
--> ((#\a (#\b (#\c))))

> (trie:element-count *trie*)
--> 0

;; common-prefix-search
> (let ((trie (trie:make-trie)))
    (dolist (k '("東京都" "東京" "京都府" "東京都立図書館"))
      (setf (trie:get-elem k trie) k))
    (setf *trie* trie))
--> #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 4 {B07F231}>

> (trie:common-prefix-search "東京都立図書館に出かける" *trie*)
--> ((1 "東京" #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 3 {B07F711}>)
     (2 "東京都" #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 2 {B07F951}>)
     (6 "東京都立図書館" #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 1 {B080991}>))

>  (progn (princ (trie:to-list (third (first *)))) 'done)
--> (東京 
     (都 
      (立
       (図
        (書
         (館 
          東京都立図書館)))) 
      東京都))

a.when, a.if 

アナフォリックwhenとアナフォリックif。
『On Lisp』のawhen,aifマクロと同機能。 ※ 個人的にはアナフォリックマクロは、'a'で始めるより'a.'で始める方が好きなので、名前は若干異なっている。

(defmacro a.when (expr &body body)
  `(let ((,it ,expr))
     (when ,it
       ,@body)))

(defmacro a.if (expr consequent &optional alternative)
  `(let ((,it ,expr))
     (if ,it
         ,consequent
       ,alternative)))