ISLisp のマクロは Common Lisp と同じく「伝統的なマクロ」です。マクロは Common Lisp と同じく defmacro で定義します。
defmacro マクロ名 (仮引数 ...) Ｓ式 ...
マクロの詳しい説明は、拙作のページ「Common Lisp 入門: マクロ」をお読みください。ここでは Common Lisp を参考に、ちょっと便利なマクロを実際に作ってみましょう。なお、作成したマクロの動作確認は OK! ISLisp と Easy-ISLisp で行いました。
when は test が真を返すとき残りの body を順番に実行します。unless は test が偽を返すとき残りの body を順番に実行します。
リスト : when と unless (defmacro when (test &rest args) `(if ,test (progn ,@args))) (defmacro unless (test &rest args) `(if ,test nil (progn ,@args)))
ISLisp>(when (< 1 2) 1 2 3 4 5) 5 ISLisp>(when (> 1 2) 1 2 3 4 5) NIL ISLisp>(unless (< 1 2) 1 2 3 4 5) NIL ISLisp>(unless (> 1 2) 1 2 3 4 5) 5
prog1 は最初に評価した S 式 first の値が返り値となります。prog2 は 2 番目に評価した S 式 second の値が返り値となります。prog1 や prog2 は、変数の値を取り出しておいてから、変数の値を更新する処理などで役に立ちます。
リスト : prog1 と prog2
(defmacro prog1 (expr &rest args)
(let ((x (gensym)))
`(let ((,x ,expr))
(progn ,@args)
,x)))
(defmacro prog2 (expr1 expr2 &rest args)
`(progn ,expr1 (prog1 ,expr2 ,@args)))
ISLisp>(prog1 1 2 3 4 5) 1 ISLisp>(prog2 1 2 3 4 5) 2 ISLisp>(defglobal a '(1 2 3 4 5)) A ISLisp>(prog1 (car a) (setq a (cdr a))) 1 ISLisp>a (2 3 4 5)
incf は第 2 引数が省略されると、第 1 引数 place で指定された場所に格納されている数値に 1 を加えます。第 2 引数 delta が与えられると、その値を加えます。incf は足し算した結果を返します。decf は incf とは逆に引き算を行います。
リスト : incf と decf
(defmacro incf (place &rest args)
(let ((delta (if args (car args) 1)))
`(setf ,place (+ ,place ,delta))))
(defmacro decf (place &rest args)
(let ((delta (if args (car args) 1)))
`(setf ,place (- ,place ,delta))))
ISLisp>(defglobal a 10) A ISLisp>(incf a) 11 ISLisp>a 11 ISLisp>(decf a) 10 ISLisp>a 10 ISLisp>(incf a 10) 20 ISLisp>(decf a (+ 1 2 3)) 14
incf, decf は setf を使っているので、リストや配列の要素を書き換えることができます。
ISLisp>(defglobal b '(1 2 3 4 5)) B ISLisp>(incf (car b)) 2 ISLisp>b (2 2 3 4 5) ISLisp>(decf (car (cdr (cdr b)))) 2 ISLisp>b (2 2 2 4 5) ISLisp>(defglobal c #(1 2 3 4 5)) C ISLisp>(incf (aref c 4)) 6 ISLisp>c #(1 2 3 4 6) ISLisp>(decf (elt c 1)) 1 ISLisp>c #(1 1 3 4 6)
push は第 1 引数 place に格納されているリストの先頭に item を追加し、その結果を返します。place の内容は書き換えられることに注意してください。pop は place に格納されているリストの先頭要素を返します。そして、先頭要素を取り除いたリストを place にセットします。
リスト : push と pop (defmacro push (x place) `(setf ,place (cons ,x ,place))) (defmacro pop (place) `(prog1 (car ,place) (setf ,place (cdr ,place))))
ISLisp>(defglobal xs nil) XS ISLisp>(push 1 xs) (1) ISLisp>(push 2 xs) (2 1) ISLisp>(push 3 xs) (3 2 1) ISLisp>(pop xs) 3 ISLisp>xs (2 1) ISLisp>(pop xs) 2 ISLisp>xs (1) ISLisp>(pop xs) 1 ISLisp>xs NIL
push と pop も setf を使っているので、リストや配列の要素を書き換えることができます。
ISLisp>(defglobal ys '(nil nil nil)) YS ISLisp>(push 1 (car ys)) (1) ISLisp>ys ((1) NIL NIL) ISLisp>(push 2 (car (cdr (cdr ys)))) (2) ISLisp>ys ((1) NIL (2)) ISLisp>(pop (car (cdr (cdr ys)))) 2 ISLisp>ys ((1) NIL NIL) ISLisp>(pop (car ys)) 1 ISLisp>ys (NIL NIL NIL)
次は繰り返しを実現するマクロを取り上げます。
Common Lisp の場合、loop マクロは単純なループと拡張されたループ機能の二種類があります。Common Lisp で loop マクロというと、後者の拡張版のほうが有名ですが、作ることはもちろん使いこなすのも難しいので、今回は単純版のほうを作ります。
loop は最も単純な繰り返しです。与えられた S 式をずっと繰り返し評価します。ようするに「無限ループ」になります。したがって、繰り返しを止めるなんらかの方法が必要です。これにはマクロ return を使います。return は引数をひとつ与えることができます。繰り返しの中で return が評価されると、繰り返しはそこで中断されます。そして、与えられた引数を評価し、その評価結果が繰り返しの返り値となります。引数が省略された場合は NIL が返り値となります。
リスト : loop と return
(defmacro loop (&rest body)
`(block nil (tagbody loop1 ,@body (go loop1))))
(defmacro return (&rest args)
(let ((result (if args (car args))))
`(return-from nil ,result)))
今回は繰り返しの実装に tagbody と go を使いましたが、ISLisp の関数 (特殊形式) for や while を使ってもかまいません。ただし、ISLisp は Common Lisp と違って、for や while は暗黙の block で囲まれていないので、block で脱出先のタグ NIL を設定する必要があります。return は return-from nil に書き換えるだけです。
ISLisp>(defun display (x) (format (standard-output) "~A~%" x)) DISPLAY ISLisp>(let ((x 0)) (loop (display x) (if (< 5 x) (return) (incf x)))) 0 1 2 3 4 5 6 NIL ISLisp>(let ((x 0)) (loop (display x) (if (< 5 x) (return 'oops) (incf x)))) 0 1 2 3 4 5 6 OOPS
dotimes は limit で指定した回数だけ、与えられた body を繰り返し評価します。dotimes は最初に limit を評価します。このとき、その評価結果は 0 以上の整数値でなければいけません。評価結果を n とすると、0 から n - 1 までの整数が順番に変数 var に代入され、そのあとの body を順番に評価します。最後に result を評価し、その結果が dotimes の返り値になります。result が省略された場合は NIL が返り値になります。
dolist は最初に init-form を評価します。このとき、評価結果はリストでなければいけません。dolist はリストの要素を順番に変数 var に代入して body を評価します。リストの要素がなくなったら result を評価し、その結果が dolist の返り値になります。result が省略された場合、dotimes と同じく NIL が返されます。
リスト : dotimes と dolist
(defmacro dotimes (var-list &rest body)
(let ((var (car var-list))
(limit (car (cdr var-list)))
(result (if (cdr (cdr var-list)) (car (cdr (cdr var-list))))))
`(block
nil
(for ((,var 0 (+ ,var 1)))
((>= ,var ,limit) ,result)
,@body))))
(defmacro dolist (var-list &rest body)
(let ((var (car var-list))
(xs (car (cdr var-list)))
(ys (gensym))
(result (if (cdr (cdr var-list)) (car (cdr (cdr var-list))))))
`(block
nil
(for ((,var nil)
(,ys ,xs (cdr ,ys)))
((null ,ys) ,result)
(setq ,var (car ,ys))
,@body))))
ISLisp>(dotimes (x 5) (display x)) 0 1 2 3 4 NIL ISLisp>(dotimes (x 5 'oops) (display x)) 0 1 2 3 4 OOPS ISLisp>(dotimes (x 5 'oops) (display x) (if (< 2 x) (return))) 0 1 2 3 NIL ISLisp>(dotimes (x 5 'oops) (display x) (if (< 2 x) (return 'oops1))) 0 1 2 3 OOPS1 ISLisp>(dolist (x '(1 2 3 4 5)) (display x)) 1 2 3 4 5 NIL ISLisp>(dolist (x '(1 2 3 4 5) 'oops) (display x)) 1 2 3 4 5 OOPS ISLisp>(dolist (x '(1 2 3 4 5) 'oops) (display x) (if (< 2 x) (return))) 1 2 3 NIL ISLisp>(dolist (x '(1 2 3 4 5) 'oops) (display x) (if (< 2 x) (return 'oops2))) 1 2 3 OOPS2
これらのマクロは一つのファイル (macro.lsp) にまとめておくと簡単に再利用することができます。
それでは簡単な例題として、逆ボーランド記法の数式 xs (リスト) を計算する関数 rpn xs を作ってみましょう。
逆ポーランド記法 (RPN : Reverse Polish Notation) は演算子を後ろに置く書き方で、数式が 1 + 2 であれば 1 2 + のように書きます。逆ポーランド記法の利点は、計算する順番に演算子が現れるため、カッコが不要になることです。たとえば、1 と 2 の和と 3 と 4 の和との積という数式は次のようになります。
(1 + 2) * (3 + 4) => 1 2 + 3 4 + *
逆ポーランド記法は、日本語の読み方とまったく同じです。1 2 + で 1 と 2 の和を求め、3 4 + で 3 と 4 を求め、最後に 2 つの結果を掛け算して答えが求まります。
逆ポーランド記法の数式はスタックを使うと簡単に計算することができます。アルゴリズムは次のようになります。
1. 数値はスタックに追加する。 2. 演算子であればスタックから 2 つ数値を取り出し、演算結果をスタックに追加する。 3. 最後にスタックに残った値が答えになる。
たったこれだけの規則で数式を計算することができます。プログラムは次のようになります。
リスト : 逆ポーランド記法の計算 (rpn.lsp)
(load "macro.lsp")
(defun rpn (xs)
(let ((zs nil))
(dolist (x xs (if (and (consp zs) (null (cdr zs))) ; (singlep zs) を使ってもよい
(car zs)
"invalid expression"))
(if (numberp x)
(push x zs)
(let ((b (pop zs)) (a (pop zs)))
(if (or (null b) (null a))
(return "stack underflow"))
(case
x
((+) (push (+ a b) zs))
((-) (push (- a b) zs))
((*) (push (* a b) zs))
((/) (push (quotient a b) zs))
(t (return "invalid operation"))))))))
関数 rpn の引数 XS が数式を表すリストです。局所変数 ZS がスタックを表します。XS の要素は dolist で順番に取り出して変数 X にセットします。dolist が終了したらスタックトップの値を返します。このとき、スタックが空または複数の値が格納されている場合はエラーメッセージを返します。
次に、X が数値の場合はそれをスタックに追加します。そうでなければ、X は演算子を表すシンボルです。この場合、最低でも 2 つの値がスタックになければいけません。0 個または 1 個しかない場合は return でエラーメッセージを返します。あとは演算子を case で場合分けして、計算結果をスタックに追加します。このとき、先頭の要素 b が第 2 引数、2 番目の要素 a が第 1 引数になることに注意してください。
簡単な実行例を示します。
ISLisp>(load "rpn.lsp") T ISLisp>(rpn '(1 2 + 3 4 + *)) 21 ISLisp>(rpn '(1 2 + 3 4 - *)) -3 ISLisp>(rpn '(1 2 + 3 4 + 5 6 + * *)) 231 ISLisp>(rpn '(1 2 + 3 4 + 5 6 + * /)) 0.038961 ISLisp>(rpn '(1 2 + 3 4 + * 5 6 + /)) 1.90909
$ ./eisl Easy-ISLisp Ver1.93 > (load "rpn.lsp") T > (rpn '(1 2 + 3 4 + *)) 21 > (rpn '(1 2 + 3 4 - *)) -3 > (rpn '(1 2 + 3 4 + 5 6 + * *)) 231 > (rpn '(1 2 + 3 4 + 5 6 + * /)) 0.03896103896103896 > (rpn '(1 2 + 3 4 + * 5 6 + /)) 1.909090909090909
ところで、昔の Lisp 処理系では、引数を評価するタイプを EXPR 型や SUBR 型、引数を評価しないタイプを NEXPR 型や FSUBR 型と呼び、ユーザーが NEXPR 型の関数を定義することができました。Common Lisp, ISLisp, Scheme の場合、ユーザーが定義できるのは関数とマクロだけです。特殊形式の関数を定義する場合はマクロを使うことになります。
マクロを実行する場合、必ずマクロ展開が行われるため、通常の関数よりも実行時間は遅くなります。だったら、NEXPR 型の関数を定義できるようにした方が実行速度の点で有利なはずです。ところが、近代的な Lisp 処理系では必要最低限の特殊形式を定義し、よく使われる制御構造はマクロで定義されています。これではインタプリタでの動作が遅くなります。
では、なぜ実行速度が遅くなるのにマクロを使っているのでしょう。それは、近代的な Lisp 処理系の多くがコンパイラの使用を前提としているからです。たとえば、OK! Lisp はプログラムをバイトコードにコンパイルしてから実行します。Common Lisp では CLISP がプログラムをバイトコードに、SBCL はネイティブコードにコンパイルします。
プログラムでマクロを呼び出している場所は、コンパイル時にマクロ展開されるため、コンパイル済みのコードにはマクロ呼び出しがなくなってしまうのです。つまり、コンパイル済みのコードは、マクロを呼び出す処理とマクロ展開の処理がなくなることにより、確実にインタプリタよりも高速に実行することができるのです。逆にいえば、コンパイラを使わないとマクロを効果的に使うことはできません。
Easy-Lisp のインタプリタはバイトコードではありませんが、compile-file でソースファイルをＣ言語に変換し、それを GCC でコンパイルすることができます。このとき、マクロ定義ファイルを load で読み込んでいるとコンパイルでエラーになります。
$ ./eisl Easy-ISLisp Ver1.96 > (import "compiler") T > (compile-file "rpn.lsp") type inference initialize pass1 pass2 compiling RPN compile error undefined global variable X T
マクロはコンパイルするときにマクロ展開されます。load はファイルをロードするコードにコンパイルされますが、実際にロードされるわけではありません。つまり、コンパイラは dolist, push, pop などがマクロであることを認識していないのです。このため、コンパイラは dolist の引数 (x ...) を関数呼び出しとして処理しようとするのですが、シンボル X が未定義のためエラーになります。
したがって、コンパイルするときにも macro.lsp をロードしなければいけません。Easy-ISLisp の場合、次のように import を使うとコンパイルするときでも macro.lsp をロードすることができます。
(import "macro")
ただし、macro.lsp はサブディレクトリ library に配置してください。それではコンパイルしてみましょう。
$ ./eisl Easy-ISLisp Ver1.96 > (import "compiler") T > (compile-file "rpn.lsp") type inference initialize pass1 pass2 compiling RPN finalize invoke CC T > (load "rpn.o") T > (rpn '(1 2 + 3 4 + *)) 21 > (rpn '(1 2 + 3 4 - *)) -3 > (rpn '(1 2 + 3 4 + 5 6 + * *)) 231 > (rpn '(1 2 + 3 4 + 5 6 + * /)) 0.03896103896103896 > (rpn '(1 2 + 3 4 + * 5 6 + /)) 1.909090909090909
Easy-ISLisp ver 1.93 ではコンパイルエラーになりましたが、ver 1.96 では正常にコンパイルすることができました。コンパイルするとオブジェクトファイル rpn.o が生成されるので、それを (load "rpn.o") でロードします。これでコンパイル済みの関数 rpn を使用することができます。迅速に対応していただいた笹川さんに感謝いたします。
;;;
;;; macro.lsp : ISLisp 用マクロ
;;;
;;; Copyright (C) 2021 Makoto Hiroi
;;;
;;; when test body ...
(defmacro when (test &rest args)
`(if ,test (progn ,@args)))
;;; unless test body ...
(defmacro unless (test &rest args)
`(if ,test nil (progn ,@args)))
;;; prog1 expr body ...
(defmacro prog1 (expr &rest args)
(let ((x (gensym)))
`(let ((,x ,expr))
(progn ,@args)
,x)))
;;; prog2 expr1 expr2 body ...
(defmacro prog2 (expr1 expr2 &rest args)
`(progn ,expr1 (prog1 ,expr2 ,@args)))
;;; incf place [value]
(defmacro incf (place &rest args)
(let ((delta (if args (car args) 1)))
`(setf ,place (+ ,place ,delta))))
;;; decf place [value]
(defmacro decf (place &rest args)
(let ((delta (if args (car args) 1)))
`(setf ,place (- ,place ,delta))))
;;; push item place
(defmacro push (x place)
`(setf ,place (cons ,x ,place)))
;;; pop place
(defmacro pop (place)
`(prog1 (car ,place) (setf ,place (cdr ,place))))
;;; loop body ...
(defmacro loop (&rest body)
`(block nil (tagbody loop1 ,@body (go loop1))))
;;; return [result]
(defmacro return (&rest args)
(let ((result (if args (car args))))
`(return-from nil ,result)))
;;; dotimes (var limit [result]) body ...
(defmacro dotimes (var-list &rest body)
(let ((var (car var-list))
(limit (car (cdr var-list)))
(result (if (cdr (cdr var-list)) (car (cdr (cdr var-list))))))
`(block
nil
(for ((,var 0 (+ ,var 1)))
((>= ,var ,limit) ,result)
,@body))))
;;; dolist (var list [result]) body ...
(defmacro dolist (var-list &rest body)
(let ((var (car var-list))
(xs (car (cdr var-list)))
(ys (gensym))
(result (if (cdr (cdr var-list)) (car (cdr (cdr var-list))))))
`(block
nil
(for ((,var nil)
(,ys ,xs (cdr ,ys)))
((null ,ys) ,result)
(setq ,var (car ,ys))
,@body))))
Lisp / Scheme のリストはデータを格納する CAR 部と次のセルを格納する CDR 部から構成されています。これに対し、双方向リストは次のセルだけでなく、前のセルも格納するデータ構造です。次の図を見てください。
prev next prev next prev next
┌─┬─┬─┐ ┌─┬─┬─┐ ┌─┬─┬─┐
←─┼ │ │ │←─┼ │ │ │←─┼ │ │ │←─
─→│ │ │ ┼─→│ │ │ ┼─→│ │ │ ┼─→
└─┴─┴─┘ └─┴─┴─┘ └─┴─┴─┘
data data data
図 1 : 双方向リスト
Lisp / Scheme のリストは後方向にしかセルをたどることができませんが、双方向リストは前後どちらの方向へもセルをたどることができます。また、セルを削除する場合も、前後のセルがわかるので簡単に削除することができます。
双方向リストの詳しい説明は以下に示す拙作のページをお読みください。
それでは実際に双方向リストを ISLisp でプログラムしてみましょう。作成するメソッドを表 1 に示します。
| メソッド | 機能 |
|---|---|
| dlist-ref d n | n 番目のデータを参照する |
| dlist-set d n x | n 番目のデータを x に書き換える |
| dlist-insert d n x | n 番目にデータ x を挿入する |
| dlist-delete d n | n 番目のデータを削除する |
| dlist-length d | 要素の個数を返す |
| dlist-clear d | 双方向リストを空にする |
| dlist-emptyp d | 双方向リストが空ならば真 (T) を返す |
| dlist->list d | 双方向リストをリストに変換する |
| list->dlist xs | リスト xs を双方向リストに変換する |
| dlist-for-each d fn | 双方向リストの先頭から要素に関数 fn を適用する |
| dlist-for-each-back d fn | 双方向リストの末尾から要素に関数 fn を適用する |
| dlist-fold d fn init | 先頭から畳み込みを行う |
| dlist-foldr d fn init | 末尾から畳み込みを行う |
引数 d は双方向リストです。メソッド dlist-ref, dlist-set, dlist-insert, dlist-delete の引数 n は整数値で、負の場合は後ろから数えることにします。たとえば、(dlist-ref d 0) は先頭の要素を、(dlist-ref d -1) は最後尾の要素を参照します。
dlist-insert は指定した位置 n にデータを挿入します。たとえば、(dlist-insert! d 0 x) は双方向リストの先頭に x を追加します。(dlist-insert d -1 x) は双方向リストの最後尾に x を追加します。つまり、追加するデータ x が n 番目の要素になるわけです。
詳細はプログラムリスト２をお読みください。
それでは実行してみましょう。動作確認は OK! ISLisp と Easy-ISLisp (インタプリタ) で行いました。
ISLisp>(load "dlist.lsp") T ISLisp>(load "macro.lsp") T ISLisp>(defun display (x) (format (standard-output) "~A~%" x)) DISPLAY ISLisp>(defglobal a (create (class <dlist>))) A ISLisp>(dlist-emptyp a) T ISLisp>(dlist-length a) 0 ISLisp>(dotimes (x 10) (dlist-insert a -1 x)) NIL ISLisp>(dlist-emptyp a) NIL ISLisp>(dlist-length a) 10 ISLisp>(dotimes (x 10) (display (dlist-ref a x))) 0 1 2 3 4 5 6 7 8 9 NIL ISLisp>(dotimes (x 10) (dlist-set a x (* (dlist-ref a x) 10))) NIL ISLisp>(dlist->list a) (0 10 20 30 40 50 60 70 80 90) ISLisp>(dlist-delete a 0) 0 ISLisp>(dlist->list a) (10 20 30 40 50 60 70 80 90) ISLisp>(dlist-delete a -1) 90 ISLisp>(dlist->list a) (10 20 30 40 50 60 70 80) ISLisp>(dlist-for-each a #'display) 10 20 30 40 50 60 70 80 NIL ISLisp>(dlist-for-each-back a #'display) 80 70 60 50 40 30 20 10 NIL ISLisp>(dlist-fold a #'+ 0) 360 ISLisp>(dlist-foldr a #'+ 0) 360 ISLisp>(dlist-foldr a #'cons nil) (10 20 30 40 50 60 70 80) ISLisp>(dlist-length a) 8 ISLisp>(dlist-clear a) NIL ISLisp>(dlist-length a) 0 ISLisp>(dlist-emptyp a) T
次は、双方向リスト <dlist> を使ってキュー <queue> を作ってみましょう。定義するメソッドを表 2 に示します。
| メソッド | 機能 |
|---|---|
| enqueue q x | キュー q にデータを追加する |
| dequeue q | キュー q からデータを取り出す |
| queue-peek q | キュー q の先頭要素を参照する |
| queue-length q | キュー q に格納されている要素数を返す |
| queue-emptyp q | キュー q が空ならば真 (T) を返す |
| queue-clear q | キュー q を空にする |
詳細はプログラムリスト２をお読みください。簡単な実行例を示します。
ISLisp>(defglobal q (create (class <queue>))) Q ISLisp>(queue-emptyp q) T ISLisp>(queue-length q) 0 ISLisp>(dotimes (x 8) (enqueue q x)) NIL ISLisp>(queue-emptyp q) NIL ISLisp>(queue-length q) 8 ISLisp>(while (not (queue-emptyp q)) (display (dequeue q))) 0 1 2 3 4 5 6 7 NIL ISLisp>(queue-emptyp q) T ISLisp>(queue-length q) 0
最後に、「ディーキュー : deque (double ended queue)」というデータ構造を双方向リストを使って実装しましょう。ディーキューは「両端キュー」のことで、「デック」と呼ばれることもあります。キューの場合、データの追加は最後尾に、データの取り出しは先頭に対してのみ行えます。これに対しディーキューは、先頭および最後尾のどちらでもデータの追加と取り出しが行えるデータ構造です。ディーキューは双方向リストを使うと簡単に実現できます。
最初に作成するメソッドを表 3 に示します。データを追加するメソッドには push を、取り出すメソッドには pop を付けました。
| メソッド | 機能 |
|---|---|
| deque-push-front d x | ディーキュー d の先頭にデータを追加する |
| deque-push-back d x | ディーキュー d の末尾にデータを追加する |
| deque-pop-front d | ディーキュー d の先頭からデータを取り出す |
| deque-pop-back d | ディーキュー d の末尾からデータを取り出す |
| deque-peek-front d | ディーキュー d の先頭にあるデータを求める |
| deque-peek-back d | ディーキュー d の末尾にあるデータを求める |
| deque-length d | ディーキュー d に格納されている要素数を返す |
| deque-emptyp d | ディーキュー d が空ならば真 (T) を返す |
| deque-clear d | ディーキュー d を空にする |
詳細はプログラムリスト２をお読みください。簡単な実行例を示します。
ISLisp>(defglobal d (create (class <deque>))) D ISLisp>(deque-emptyp d) T ISLisp>(deque-length d) 0 ISLisp>(dotimes (x 5) (deque-push-front d x)) NIL ISLisp>(dotimes (x 5) (deque-push-back d x)) NIL ISLisp>(deque-emptyp d) NIL ISLisp>(deque-length d) 10 ISLisp>(dotimes (x 10) (display (deque-pop-front d))) 4 3 2 1 0 0 1 2 3 4 NIL ISLisp>(deque-emptyp d) T ISLisp>(deque-length d) 0
;;;
;;; dlist.lsp : ISLisp 用双方向リスト
;;;
;;; Copyright (C) 2021 Makoto Hiroi
;;;
;;; メソッドの宣言
(defgeneric dlist-ref (d n))
(defgeneric dlist-set (d n value))
(defgeneric dlist-insert (d n value))
(defgeneric dlist-delete (d n))
(defgeneric dlist-fold (d func init))
(defgeneric dlist-foldr (d func init))
(defgeneric dlist-length (d))
(defgeneric dlist-clear (d))
(defgeneric dlist-emptyp (d))
(defgeneric list->dlist (ls))
(defgeneric dlist->list (d))
(defgeneric dlist-for-each (d func))
(defgeneric dlist-for-each-back (d func))
;;; セルの定義
(defclass <cell> ()
((item :accessor cell-item :initform nil :initarg item)
(prev :accessor cell-prev :initform nil :initarg prev)
(next :accessor cell-next :initform nil :initarg next)))
;;; 空リストを作る
(defun make-empty ()
(let ((cp (create (class <cell>))))
(setf (cell-prev cp) cp)
(setf (cell-next cp) cp)
cp))
;;; 双方向リストの定義
(defclass <dlist> ()
((top :accessor dlist-top :initform (make-empty))
(cnt :accessor dlist-cnt :initform 0)))
;;; 前から n 番目のセルを返す (作業用関数)
(defun cell-nth (d n)
(for ((cp (dlist-top d) (cell-next cp))
(i -1 (+ i 1)))
((= n i) cp)))
;;; 後ろから n 番目のセルを返す (作業用関数)
(defun cell-nth-back (d n)
(for ((cp (dlist-top d) (cell-prev cp))
(i -1 (+ i 1)))
((= n i) cp)))
;;; 参照
(defmethod dlist-ref ((d <dlist>) (n <integer>))
(let ((m (if (< n 0) (abs (+ n 1)) n)))
(if (< m (dlist-cnt d))
(cell-item (if (< n 0) (cell-nth-back d m) (cell-nth d m)))
(error "dlist-ref: out of range"))))
;;; 書き換え
(defmethod dlist-set ((d <dlist>) (n <integer>) value)
(let ((m (if (< n 0) (abs (+ n 1)) n)))
(if (< m (dlist-cnt d))
(setf (cell-item (if (< n 0) (cell-nth-back d m) (cell-nth d m)))
value)
(error "dlist-set: out of range"))))
;;; セルの挿入
;;; p - next -> cp - next -> q
(defun cell-insert (p cp q)
(setf (cell-next cp) q)
(setf (cell-prev cp) p)
(setf (cell-prev q) cp)
(setf (cell-next p) cp))
;;; n 番目に value を挿入
;;; n - 1 番目のセルを求め、その後ろに value を挿入する
(defmethod dlist-insert ((d <dlist>) (n <integer>) value)
(let ((m (- (if (< n 0) (abs (+ n 1)) n) 1)))
(if (< m (dlist-cnt d))
(let* ((p (if (< n 0) (cell-nth-back d m) (cell-nth d m)))
(q (if (< n 0) (cell-prev p) (cell-next p)))
(cp (create (class <cell>) 'item value)))
(if (< n 0)
(cell-insert q cp p)
(cell-insert p cp q))
(setf (dlist-cnt d) (+ (dlist-cnt d) 1))
value)
(error "dlist-insert: out of range"))))
;;;; n 番目のセルの削除
(defmethod dlist-delete ((d <dlist>) (n <integer>))
(let ((m (if (< n 0) (abs (+ n 1)) n)))
(if (< m (dlist-cnt d))
;; p - next -> [cp] - next -> q
(let* ((cp (if (< n 0) (cell-nth-back d m) (cell-nth d m)))
(p (cell-prev cp))
(q (cell-next cp)))
(setf (cell-next p) q)
(setf (cell-prev q) p)
(setf (dlist-cnt d) (- (dlist-cnt d) 1))
(cell-item cp))
(error "dlist-delete: out of range"))))
;;; 畳み込み
(defmethod dlist-fold ((d <dlist>) func init)
(for ((cp (cell-next (dlist-top d)) (cell-next cp))
(a init (funcall func a (cell-item cp))))
((eq cp (dlist-top d)) a)))
(defmethod dlist-foldr ((d <dlist>) func init)
(for ((cp (cell-prev (dlist-top d)) (cell-prev cp))
(a init (funcall func (cell-item cp) a)))
((eq cp (dlist-top d)) a)))
;;; サイズ
(defmethod dlist-length ((d <dlist>)) (dlist-cnt d))
;;; クリア
(defmethod dlist-clear ((d <dlist>))
(let ((cp (dlist-top d)))
(setf (cell-next cp) cp)
(setf (cell-prev cp) cp)
(setf (dlist-cnt d) 0)
nil))
;;; 空リストか？
(defmethod dlist-emptyp ((d <dlist>)) (= (dlist-cnt d) 0))
;;; 変換
(defmethod list->dlist ((xs <list>))
(for ((d (create (class <dlist>)))
(xs xs (cdr xs)))
((null xs) d)
(dlist-insert d -1 (car xs))))
(defmethod dlist->list ((d <dlist>))
(dlist-foldr d (lambda (x y) (cons x y)) nil))
;;; 巡回
(defmethod dlist-for-each ((d <dlist>) func)
(for ((cp (cell-next (dlist-top d)) (cell-next cp)))
((eq (dlist-top d) cp))
(funcall func (cell-item cp))))
(defmethod dlist-for-each-back ((d <dlist>) func)
(for ((cp (cell-prev (dlist-top d)) (cell-prev cp)))
((eq (dlist-top d) cp))
(funcall func (cell-item cp))))
;;;
;;; キュー
;;;
(defgeneric enqueue (q x))
(defgeneric dequeue (q))
(defgeneric queue-peek (q))
(defgeneric queue-length (q))
(defgeneric queue-emptyp (q))
(defgeneric queue-clear (q))
;;; クラス定義
(defclass <queue> ()
((buffer :accessor queue-buffer :initform (create (class <dlist>)) :initarg buffer)))
;;; キューは空か？
(defmethod queue-emptyp ((q <queue>)) (dlist-emptyp (queue-buffer q)))
;;; キューのサイズ
(defmethod queue-length ((q <queue>)) (dlist-length (queue-buffer q)))
;;; 参照
(defmethod queue-peek ((q <queue>)) (dlist-ref (queue-buffer q) 0))
;;; 挿入
(defmethod enqueue ((q <queue>) item)
(dlist-insert (queue-buffer q) -1 item))
;;; 取得
(defmethod dequeue ((q <queue>))
(if (queue-emptyp q)
(error "dequeue: empty queue")
(dlist-delete (queue-buffer q) 0)))
;;;
;;; ディーキュー
;;;
(defgeneric deque-push-front (q x))
(defgeneric deque-push-back (q x))
(defgeneric deque-pop-front (q))
(defgeneric deque-pop-back (q))
(defgeneric deque-peek-front (q))
(defgeneric deque-peek-back (q))
(defgeneric deque-length (q))
(defgeneric deque-emptyp (q))
(defgeneric deque-clear (q))
;;; クラス定義
(defclass <deque> ()
((buffer :accessor deque-buffer :initform (create (class <dlist>)) :initarg buffer)))
;;; 先頭に追加
(defmethod deque-push-front ((q <deque>) item)
(dlist-insert (deque-buffer q) 0 item))
;;; 末尾に追加
(defmethod deque-push-back ((q <deque>) item)
(dlist-insert (deque-buffer q) -1 item))
;;; 先頭要素を取り出す
(defmethod deque-pop-front ((q <deque>))
(dlist-delete (deque-buffer q) 0))
;;; 末尾要素を取り出す
(defmethod deque-pop-back ((q <deque>))
(dlist-delete (deque-buffer q) -1))
;;; 先頭要素を参照する
(defmethod deque-peek-front ((q <deque>))
(dlist-ref (deque-buffer q) 0))
;;; 末尾要素を参照する
(defmethod deque-peek-back ((q <deque>))
(dlist-ref (deque-buffer q) -1))
;;; 要素数を求める
(defmethod deque-length ((q <deque>)) (dlist-length (deque-buffer q)))
;;; ディーキューは空か？
(defmethod deque-emptyp ((q <deque>)) (dlist-emptyp (deque-buffer q)))
;;; ディーキューを空にする
(defmethod deque-clear ((q <deque>)) (dlist-clear (deque-buffer q)))