簡単なプログラム
●可変長ベクタ
今回はオブジェクト指向の簡単な例題として、ベクタ (一次元配列) を自動的に拡張する「可変長ベクタ (variable length vector)」を作ってみましょう。ISLisp の配列は生成するときに大きさを指定しますが、その後で大きさを変更することはできません。可変長ベクタはデータを追加するとき、満杯の場合は自動的にベクタを拡張します。可変長ベクタは Perl, Python, Ruby などでは標準でサポートされている機能です。
●可変長ベクタの仕様
クラス名は <vlvec> とします。今回は簡単な例題ということで、ベクタの末尾にデータを追加するとき、ベクタが満杯ならば容量を 2 倍に増やすことにしましょう。可変長ベクタクラス <vlvec> のメソッドを表 1 に示します。
| メソッド | 機能 |
|---|---|
| vlvec-ref v n | n 番目の要素を参照する |
| vlvec-set v n x | n 番目の要素を x に書き換える |
| vlvec-push v x | vlvec の末尾に x を追加する |
| vlvec-pop v | vlvec の末尾要素を取り出す |
| vlvec-swap v i j | vlvec の要素を交換する |
| vlvec-clear v | vlvec を空にする |
| vlvec-emptyp v | vlvec が空ならば真 (T) を返す |
| vlvec-length v | vlvec の要素数を返す |
| vlvec-size v | vlvec の容量を返す |
| vlvec-fold v f a | vlvec の先頭から畳み込む |
| vlvec-foldr v f a | vlvec の末尾から畳み込む |
| vlvec-for-each v f | vlvec の先頭から巡回する |
| vlvec-for-each-back v f | vlvec の末尾から巡回する |
| vlvec->list v | vlvex をリストに変換する |
| vlvec->vector v | vlvec を vector に変換する |
| list->vlvec xs | リストを vlvec に変換する |
| vlvec->vectore v | vector を vlvec に変換する |
引数 v はクラス <vlvec> のインスタンスで、引数 n は整数値です。プログラムのポイントはフィルポインタ (fillp) の使い方です。ベクタの中で 0 番目から fillp - 1 番目までの要素を有効なデータとして扱います。つまり、fillp でデータの要素数を管理するわけです。
vlvec-push で末尾にデータを追加する場合、fillp の位置にデータを書き込み、fillp の値を +1 します。vlvec-pop で末尾からデータを取り出す場合、fillp の値を -1 してから、fillp の位置にある要素を返します。これはスタックの動作と同じになります。
データを追加するとき、fillp の値とベクタの大きさ (size) を比較します。同じ値の場合、ベクタは満杯なので容量を 2 倍に増やします。ISLisp の場合、ベクタの大きさを変更することはできないので、新しいベクタを生成して元のベクタからデータをコピーします。なお、今回は簡単なプログラムなので vlvec-pop でデータを削除するとき、ベクタの大きさを自動的に減らすことはしません。ご注意くださいませ。
詳細は プログラムリスト１ をお読みください。
●実行例
ISLisp>(load "vlvec.lsp") T ISLisp>(load "macro.lsp") T ISLisp>(defglobal a (create (class <vlvec>))) A ISLisp>(vlvec-length a) 0 ISLisp>(vlvec-emptyp a) T ISLisp>(vlvec-size a) 8 ISLisp>(dotimes (x 10) (vlvec-push a x)) NIL ISLisp>(vlvec-length a) 10 ISLisp>(vlvec-emptyp a) NIL ISLisp>(vlvec-size a) 16 ISLisp>(dotimes (x 10) (print (vlvec-ref a x))) 0 1 2 3 4 5 6 7 8 9 NIL ISLisp>(dotimes (x 10) (vlvec-set a x (* (vlvec-ref a x) 2))) NIL ISLisp>(dotimes (x 10) (print (vlvec-ref a x))) 0 2 4 6 8 10 12 14 16 18 NIL ISLisp>(while (not (vlvec-emptyp a)) (print (vlvec-pop a))) 18 16 14 12 10 8 6 4 2 0 NIL ISLisp>(vlvec-length a) 0 ISLisp>(vlvec-emptyp a) T ISLisp>(defglobal b (list->vlvec '(a b c d e f g h))) B ISLisp>b #<INSTANCE <VLVEC> 0025C85E> ISLisp>(vlvec-for-each b #'print) A B C D E F G H NIL ISLisp>(vlvec-for-each-back b #'print) H G F E D C B A NIL ISLisp>(vlvec->list b) (A B C D E F G H) ISLisp>(vlvec-length b) 8 ISLisp>(vlvec-size b) 8 ISLisp>(defglobal c (vector->vlvec #(1 2 3 4 5 6 7 8 9 10))) C ISLisp>(vlvec->vector c) #(1 2 3 4 5 6 7 8 9 10) ISLisp>(vlvec-fold c #'+ 0) 55 ISLisp>(vlvec-foldr c #'+ 0) 55 ISLisp>(vlvec-length c) 10 ISLisp>(vlvec-size c) 10 ISLisp>(vlvec-emptyp c) NIL
●ヒープ
今回は簡単な例題として、「ヒープ (heap)」というデータ構造を作ってみましょう。ヒープは「半順序木 (partial ordered tree)」をベクタで実現したデータ構造です。一般的な二分木では、親よりも左側の子のほうが小さく、親よりも右側の子が大きい、という関係を満たすように作ります。「半順序木」の場合、親は子より小さいか等しい、という関係を満たすように作ります。したがって、木の根（ベクタの添字 0）には、必ず最小値のデータが格納されます。下図にヒープとベクタの関係を示します。
図 1 : ヒープとベクタの対応関係
ヒープを利用すると、最小値をすぐに見つけることができ、新しくデータを挿入する場合も、高々要素の個数 (n) の対数 (log2 n) に比例する程度の時間で済みます。アルゴリズムの説明は以下に示す拙作のページをお読みください。
●ヒープの仕様
クラス名は <heap> としました。ヒープはデータの大小関係を比較する関数が必要になりますが、ここでデータの比較に算術演算子を使うと、そのヒープは数値データだけにしか適用できなくなります。データの種類に合わせて比較関数を選択できると便利です。
この場合、2 つの方法が考えられます。ひとつは比較関数をメソッドで定義する方法です。たとえば、データの大小関係をメソッド compare で比較するようにプログラムを作成します。データの種類に合わせてメソッド compare を定義しておけば、あとは ISLisp の方で適切なメソッドを選択してくれます。
もうひとつは、ヒープを生成するときに比較関数を指定する方法です。たとえば、比較関数を格納するスロット compare を用意し、引数で指定した比較関数をそこにセットします。データを比較するときは、スロット compare に格納されている関数を呼び出せばいいわけです。
どちらの方法でも簡単にプログラムできますが、今回は前者の方法でプログラムを作ってみましょう。たとえば、数値を比較するメソッドは次のようになります。
リスト : 数値用のメソッド compare (defmethod compare ((x <number>) (y <number>)) (cond ((= x y) 0) ((< x y) -1) (t 1)))
クラス <heap> で定義するメソッドを表 2 に示します。
| メソッド | 機能 |
|---|---|
| heap-push h x | ヒープ h にデータ x を追加する |
| heap-pop h | ヒープ h からデータを取り出す |
| heap-peek h | ヒープ h の先頭データを参照する |
| heap-length h | ヒープ h に格納されている要素数を返す |
| heap-clear h | ヒープ h を空にする |
| heap-emptyp h | ヒープ h が空ならば #t を返す |
ヒープは可変長配列クラス <vlvec> を使って実装します。詳細は プログラムリスト をお読みください。
●実行例
ISLisp>(load "vlvec.lsp") T ISLisp>(load "macro.lsp") T ISLisp>(defglobal h (create (class <heap>))) H ISLisp>h #<INSTANCE <HEAP> 00263A5E> ISLisp>(dolist (x '(5 6 4 7 3 8 2 9 1)) (heap-push h x)) NIL ISLisp>(heap-emptyp h) NIL ISLisp>(heap-length h) 9 ISLisp>(while (not (heap-emptyp h)) (format (standard-output) "~A~%" (heap-pop h))) 1 2 3 4 5 6 7 8 9 NIL ISLisp>(heap-emptyp h) T ISLisp>(heap-length h) 0 ISLisp>(defmethod compare ((xs <list>) (ys <list>)) (compare (car xs) (car ys))) COMPARE ISLisp>(defglobal a (create (class <heap>))) A ISLisp>(dolist (x '((5 . 0) (6 . 1) (4 . 2) (3 . 3) (7 . 4) (2 . 5))) (heap-push a x)) NIL ISLisp>(heap-emptyp a) NIL ISLisp>(heap-length a) 6 ISLisp>(while (not (heap-emptyp a)) (print (heap-pop a))) (2 . 5) (3 . 3) (4 . 2) (5 . 0) (6 . 1) (7 . 4) NIL ISLisp>(heap-emptyp a) T ISLisp>(heap-length a) 0
●プログラムリスト
;;;
;;; vlvec.lsp : ISLisp 用可変長ベクタとヒープ
;;;
;;; Copyright (C) 2021 Makoto Hiroi
;;;
;;; テスト用
(defun print (x) (format (standard-output) "~A~%" x))
;;; クラス定義
(defclass <vlvec> ()
((buffer :accessor vlvec-buffer :initform nil :initarg buffer)
(size :accessor vlvec-size :initform 8 :initarg size)
(fillp :accessor vlvec-fillp :initform 0 :initarg fillp)))
(defmethod initialize-object :after ((v <vlvec>) xs)
(if (null (vlvec-buffer v))
(setf (vlvec-buffer v) (create-vector (vlvec-size v)))))
;;; メソッドの定義
(defgeneric vlvec-ref (v i))
(defgeneric vlvec-set (v i x))
(defgeneric vlvec-push (v x))
(defgeneric vlvec-pop (v))
(defgeneric vlvec-swap (v i j))
(defgeneric vlvec-length (v))
(defgeneric vlvec-clear (v))
(defgeneric vlvec-emptyp (v))
(defgeneric vlvec-fold (v f a))
(defgeneric vlvec-foldr (v f a))
(defgeneric vlvec->list (v))
(defgeneric list->vlvec (xs))
(defgeneric vlvec->vector (v))
(defgeneric vector->vlvec (vec))
(defgeneric vlvec-for-each (v f))
(defgeneric vlvec-for-each-back (v f))
;;; 参照
(defmethod vlvec-ref ((v <vlvec>) (i <integer>))
(if (and (<= 0 i) (< i (vlvec-fillp v)))
(aref (vlvec-buffer v) i)
(error "vlvec-ref: index out of range")))
;;; 更新
(defmethod vlvec-set ((v <vlvec>) (i <integer>) item)
(if (and (<= 0 i) (< i (vlvec-fillp v)))
(setf (aref (vlvec-buffer v) i) item)
(error "vlvec-set: index out of range")))
;;; バッファの拡張
(defun extend-buffer (v)
(let ((src (vlvec-buffer v))
(dst (create-vector (* (vlvec-size v) 2))))
(for ((i 0 (+ i 1)))
((= i (vlvec-size v)))
(setf (aref dst i) (aref src i)))
(setf (vlvec-buffer v) dst)
(setf (vlvec-size v) (* (vlvec-size v) 2))))
;;; 追加
(defmethod vlvec-push ((v <vlvec>) item)
(if (<= (vlvec-size v) (vlvec-fillp v))
(extend-buffer v))
(setf (aref (vlvec-buffer v) (vlvec-fillp v)) item)
(setf (vlvec-fillp v) (+ (vlvec-fillp v) 1))
item)
;;; 取り出し
(defmethod vlvec-pop ((v <vlvec>))
(cond
((< 0 (vlvec-fillp v))
(setf (vlvec-fillp v) (- (vlvec-fillp v) 1))
(aref (vlvec-buffer v) (vlvec-fillp v)))
(t
(error "vlvec-pop: empty vlvec"))))
;;; 要素の交換
(defmethod vlvec-swap ((v <vlvec>) (i <integer>) (j <integer>))
(if (or (< i 0) (>= i (vlvec-fillp v))
(< j 0) (>= j (vlvec-fillp v)))
(error "vlvec-swap: index out of range")
(let* ((buff (vlvec-buffer v))
(item (aref buff i)))
(setf (aref buff i) (aref buff j))
(setf (aref buff j) item))))
;;; 要素の個数
(defmethod vlvec-length ((v <vlvec>)) (vlvec-fillp v))
;;; クリア
(defmethod vlvec-clear ((v <vlvec>)) (setf (vlvec-fillp v) 0))
;;; 空か
(defmethod vlvec-emptyp ((v <vlvec>)) (= (vlvec-fillp v) 0))
;;; 畳み込み
(defmethod vlvec-fold ((v <vlvec>) f init)
(for ((i 0 (+ i 1))
(a init (funcall f a (aref (vlvec-buffer v) i))))
((= i (vlvec-fillp v)) a)))
(defmethod vlvec-foldr ((v <vlvec>) f init)
(for ((i (- (vlvec-fillp v) 1) (- i 1))
(a init (funcall f (aref (vlvec-buffer v) i) a)))
((< i 0) a)))
;;; 巡回
(defmethod vlvec-for-each ((v <vlvec>) f)
(for ((i 0 (+ i 1)))
((= i (vlvec-fillp v)))
(funcall f (aref (vlvec-buffer v) i))))
(defmethod vlvec-for-each-back ((v <vlvec>) f)
(for ((i (- (vlvec-fillp v) 1) (- i 1)))
((< i 0))
(funcall f (aref (vlvec-buffer v) i))))
;;; 変換
(defmethod vlvec->list ((v <vlvec>)) (vlvec-foldr v #'cons nil))
(defmethod list->vlvec ((xs <list>))
(for ((v (create (class <vlvec>)))
(xs xs (cdr xs)))
((null xs) v)
(vlvec-push v (car xs))))
(defmethod vlvec->vector ((v <vlvec>))
(subseq (vlvec-buffer v) 0 (vlvec-size v)))
(defmethod vector->vlvec ((vec <general-vector>))
(let ((len (length vec)))
(create (class <vlvec>) 'buffer (subseq vec 0 len) 'size len 'fillp len)))
;;;
;;; ヒープ
;;;
;;; 比較関数
(defgeneric compare (x y))
;;; 数値用
(defmethod compare ((x <number>) (y <number>))
(cond ((= x y) 0)
((< x y) -1)
(t 1)))
;;; クラス定義
(defclass <heap> ()
((buffer :accessor heap-buffer :initform (create (class <vlvec>)))))
;;; 操作関数
;;; ヒープの構築
(defun upheap (buff n)
(for ((n n p)
(p (div (- n 1) 2) (div (- p 1) 2)))
((or (< p 0)
(<= (compare (vlvec-ref buff p) (vlvec-ref buff n)) 0)))
(vlvec-swap buff p n)))
; ヒープの再構築
(defun downheap (buff n nums)
(for ((n n c)
(c (+ (* n 2) 1) (+ (* c 2) 1)))
((>= c nums))
(if (and (< (+ c 1) nums)
(> (compare (vlvec-ref buff c) (vlvec-ref buff (+ c 1))) 0))
(setq c (+ c 1)))
(if (> (compare (vlvec-ref buff n) (vlvec-ref buff c)) 0)
(vlvec-swap buff n c))))
;;; メソッドの定義
(defgeneric heap-emptyp (h))
(defgeneric heap-length (h))
(defgeneric heap-clear (h))
(defgeneric heap-push (h x))
(defgeneric heap-pop (h))
(defgeneric heap-peek (h))
;;; 空か
(defmethod heap-emptyp ((h <heap>))
(vlvec-emptyp (heap-buffer h)))
;;; 要素数
(defmethod heap-length ((h <heap>))
(vlvec-length (heap-buffer h)))
;;; クリア
(defmethod heap-clear ((h <heap>))
(vlvec-clear (heap-buffer h)))
;;; データの追加
(defmethod heap-push ((h <heap>) x)
(vlvec-push (heap-buffer h) x)
(upheap (heap-buffer h) (- (heap-length h) 1)))
;;; 先頭データの参照
(defmethod heap-peek ((h <heap>))
(if (heap-emptyp h)
(error "heep-peek : heap is empty")
(vlvec-ref (heap-buffer h) 0)))
;;; データの取り出し
(defmethod heap-pop ((h <heap>))
(let* ((x (heap-peek h))
(b (heap-buffer h))
(z (vlvec-pop b)))
(cond
((not (vlvec-emptyp b))
(vlvec-set b 0 z)
(downheap b 0 (vlvec-length b))))
x))
●リスト操作関数 (改訂版)
- マクロ を使ったリスト操作関数の改訂版
- cxxr, cxxxr, cxxxxr. first ... tenth は cxr.lsp に分離
- remove, find, position, count などは列関数 (seq.lsp) に統合
●基本的な操作
- cxxr, cxxxr, cxxxxr
car と cdr の組み合わせ - first, second, ..., tenth
リストの要素を求める - last-pair xs
リスト xs の末尾セルを求める - last xs
リスト xs の末尾要素を求める - take xs n
リスト xs の先頭から n 個の要素を取り出す - drop xs n
リスト xs の先頭から n 個の要素を取り除く - revappend xs ys
リスト xs を反転して ys と連結する
ISLisp>(load "list.lsp") T ISLisp>(load "cxr.lsp") T ISLisp>(defglobal a '(1 2 3 4 5 6 7 8 9 10)) A ISLisp>(cadr a) 2 ISLisp>(caddr a) 3 ISLisp>(cadddr a) 4 ISLisp>(first a) 1 ISLisp>(second a) 2 ISLisp>(ninth a) 9 ISLisp>(tenth a) 10 ISLisp>(last-pair a) (10) ISLisp>(last a) 10 ISLisp>(take a 0) NIL ISLisp>(take a 5) (1 2 3 4 5) ISLisp>(take a 10) (1 2 3 4 5 6 7 8 9 10) ISLisp>(drop a 0) (1 2 3 4 5 6 7 8 9 10) ISLisp>(drop a 5) (6 7 8 9 10) ISLisp>(drop a 10) NIL
●コピーと置換
- copy-list xs
リスト xs のトップレベルをコピーする - copy-tree tree
リスト tree 全体をコピーする - copy-alist alist
連想リスト alist をコピーする
コピーされるのはトップレベルとキーと値を格納しているセルだけ - subst new old tree
old と等しい (eql) リスト tree の要素を new に置き換える - subst-if new pred tree
述語 pred が真を返す要素を new に置き換える - subst-if-not new pred tree
述語 pred が偽を返す要素を new に置き換える
ISLisp>(defglobal a '((a 1 2 3) (b 4 5 6) (c 7 8 9))) A ISLisp>(defglobal b (copy-list a)) B ISLisp>b ((A 1 2 3) (B 4 5 6) (C 7 8 9)) ISLisp>(eq (car a) (car b)) T ISLisp>(defglobal c (copy-tree a)) C ISLisp>c ((A 1 2 3) (B 4 5 6) (C 7 8 9)) ISLisp>(eq (car a) (car c)) NIL ISLisp>(defglobal d (copy-alist a)) D ISLisp>d ((A 1 2 3) (B 4 5 6) (C 7 8 9)) ISLisp>(eq (car a) (car d)) NIL ISLisp>(eq (cdar a) (cdar d)) T ISLisp>(defglobal e '(0 (1 (2 (3 . 4) 5) 6) 7)) E ISLisp>(subst 9 4 e) (0 (1 (2 (3 . 9) 5) 6) 7) ISLisp>(subst 9 7 e) (0 (1 (2 (3 . 4) 5) 6) 9) ISLisp>(subst-if 8 (lambda (x) (and (numberp x) (= (mod x 2) 0))) e) (8 (1 (8 (3 . 8) 5) 8) 7) ISLisp>(subst-if-not 8 #'listp e) (8 (8 (8 (8 . 8) 8) 8) 8)
●リストの生成
- iota n m
n から m までの整数列 (リスト) を生成する - tabulate f n m
f(n), ..., f(m) の値をリストに格納して返す - unfold p f g seed
解きほぐし (逆畳み込み)
f(seed) の値をリストに格納して返す。次項は g(seed) で生成する。p(seed) が真のときリストの生成を終了する。
ISLisp>(iota 1 10) (1 2 3 4 5 6 7 8 9 10) ISLisp>(iota 1 1) (1) ISLisp>(iota 1 0) NIL ISLisp>(tabulate #'identity 1 10) (1 2 3 4 5 6 7 8 9 10) ISLisp>(tabulate (lambda (x) (* x x)) 1 10) (1 4 9 16 25 36 49 64 81 100) ISLisp>(tabulate (lambda (x) (* x x x)) 1 10) (1 8 27 64 125 216 343 512 729 1000) ISLisp>(unfold (lambda (x) (> x 10)) #'identity (lambda (x) (+ x 1)) 1) (1 2 3 4 5 6 7 8 9 10) ISLisp>(unfold (lambda (x) (> x 20)) #'identity (lambda (x) (+ x 2)) 1) (1 3 5 7 9 11 13 15 17 19) ISLisp>(unfold (lambda (x) (> x 20)) (lambda (x) (* x x)) (lambda (x) (+ x 2)) 1) (1 9 25 49 81 121 169 225 289 361)
●畳み込み
- fold-left f a xs1 [xs2 ...]
リストの先頭から畳み込む
関数 f の第 1 引数に累積値、それ以降にリストの要素が渡される - fold-right f a xs1 [xs2 ...]
リストの末尾から畳み込む
関数 f の第 1 引数に累積値、それ以降にリストの要素が渡される
ISLisp>(fold-left #'+ 0 (iota 1 10)) 55 ISLisp>(fold-right #'+ 0 (iota 1 10)) 55 ISLisp>(fold-left (lambda (a x y) (cons (cons x y) a)) nil '(1 2 3 4) '(5 6 7 8)) ((4 . 8) (3 . 7) (2 . 6) (1 . 5)) ISLisp>(fold-right (lambda (a x y) (cons (cons x y) a)) nil '(1 2 3 4) '(5 6 7 8)) ((1 . 5) (2 . 6) (3 . 7) (4 . 8))
●for-each, partition, any, all
- for-each f xs1 [xs2 ...]
リストの要素に関数 f を適用する - partition pred xs
リスト xs を述語 pred の真偽で二分割する - any pred xs1 [xs2 ...]
述語 pred をリストの要素に適用し、真を返す要素が一つでもあれば T を返す。 - all pred xs1 [xs2 ...]
述語 pred をリストの要素に適用し、偽を返す要素が一つでもあれば NIL を返す。
ISLisp>(defun display (x) (format (standard-output) "~S~%" x)) DISPLAY ISLisp>(for-each #'display '(1 2 3 4 5 6 7 8)) 1 2 3 4 5 6 7 8 NIL ISLisp>(for-each (lambda (x y) (display (list x y))) '(1 2 3 4) '(5 6 7 8)) (1 5) (2 6) (3 7) (4 8) NIL ISLisp>(partition (lambda (x) (= (mod x 2) 0)) (iota 1 10)) ((2 4 6 8 10) (1 3 5 7 9)) ISLisp>(partition (lambda (x) (= (mod x 2) 1)) (iota 1 10)) ((1 3 5 7 9) (2 4 6 8 10)) ISLisp>(partition (lambda (x) (<= x 5)) (iota 1 10)) ((1 2 3 4 5) (6 7 8 9 10)) ISLisp>(partition (lambda (x) (> x 5)) (iota 1 10)) ((6 7 8 9 10) (1 2 3 4 5)) ISLisp>(any (lambda (x) (<= x 5)) '(5 6 7 8 9)) T ISLisp>(any (lambda (x) (<= x 5)) '(6 7 8 9 10)) NIL ISLisp>(any #'<= '(5 6 7 8 9) '(5 4 3 2 1)) T ISLisp>(any #'<= '(5 6 7 8 9) '(4 3 2 1 0)) NIL ISLisp>(all (lambda (x) (<= 5 x)) '(5 6 7 8 9)) T ISLisp>(all (lambda (x) (<= 5 x)) '(5 6 7 8 0)) NIL ISLisp>(all #'<= '(1 2 3 4 5) '(6 7 8 9 10)) T ISLisp>(all #'<= '(1 2 3 4 5) '(6 7 8 9 0)) NIL
●集合演算
- member-if pred xs
述語 pred が真となる最初の要素を探す - member-if-not pred xs
述語 pred が偽となる最初の要素を探す - remove-duplicates xs
重複要素を削除する (等値判定は eql を使う) - union xs ys
和集合を求める - intersection xs ys
積集合を求める - difference xs ys
差集合を求める - subsetp xs ys
xs が ys の部分集合であれば真を返す
ISLisp>(member-if (lambda (x) (= (mod x 2) 0)) '(1 2 3 4 5 6 7 8)) (2 3 4 5 6 7 8) ISLisp>(member-if (lambda (x) (= (mod x 2) 0)) '(1 3 5 7 9)) NIL ISLisp>(member-if-not (lambda (x) (= (mod x 2) 0)) '(1 2 3 4 5 6 7 8)) (1 2 3 4 5 6 7 8) ISLisp>(member-if-not (lambda (x) (= (mod x 2) 1)) '(1 3 5 7 9)) NIL ISLisp>(remove-duplicates '(1 2 1 2 3 1 2 3 4 1 2 3 4 5 6)) (1 2 3 4 5 6) ISLisp>(remove-duplicates '(1 1 1 1 1 1)) (1) ISLisp>(remove-duplicates '(1 2 3 4 5 6)) (1 2 3 4 5 6) ISLisp>(union '(1 2 3 4) '(3 4 5 6)) (1 2 3 4 5 6) ISLisp>(union '(1 2 3 4) '(5 6 7 8)) (1 2 3 4 5 6 7 8) ISLisp>(union '(1 2 3 4) '(4 3 2 1)) (4 3 2 1) ISLisp>(intersection '(1 2 3 4) '(3 4 5 6)) (3 4) ISLisp>(intersection '(1 2 3 4) '(5 6 7 8)) NIL ISLisp>(intersection '(1 2 3 4) '(4 3 2 1)) (1 2 3 4) ISLisp>(difference '(1 2 3 4) '(3 4 5 6)) (1 2) ISLisp>(difference '(1 2 3 4) '(5 6 7 8)) (1 2 3 4) ISLisp>(difference '(1 2 3 4) '(4 3 2 1)) NIL ISLisp>(subsetp '(1 2 3 4) '(3 4 5 6)) NIL ISLisp>(subsetp '(3 4) '(3 4 5 6)) T ISLisp>(subsetp '(3 4 5 6) '(3 4 5 6)) T ISLisp>(subsetp nil '(3 4 5 6)) T
●連想リスト
- acons k v alist
連想リスト alist にキー k と値 v を追加する - pairlis ks vs alist
alist にキー (リスト ks の要素) と値 (リスト vs の要素) を追加する - assoc-if pred alist
述語 pred が真を返す最初のキーを探す - assoc-if pred alist
述語 pred が偽を返す最初のキーを探す - rassoc value alist
value と等しい (eql) 最初の値を探す - rassoc-if pred alist
述語 pred が真を返す最初の値を探す - rassoc-if pred alist
述語 pred が偽を返す最初の値を探す
ISLisp>(defglobal a '((a . 0) (b . 1) (c . 2))) A ISLisp>(acons 'd 3 a) ((D . 3) (A . 0) (B . 1) (C . 2)) ISLisp>a ((A . 0) (B . 1) (C . 2)) ISLisp>(pairlis '(d e f) '(3 4 5) a) ((D . 3) (E . 4) (F . 5) (A . 0) (B . 1) (C . 2)) ISLisp>a ((A . 0) (B . 1) (C . 2)) ISLisp>(assoc-if (lambda (x) (eq 'c x)) a) (C . 2) ISLisp>(assoc-if (lambda (x) (eq 'd x)) a) NIL ISLisp>(assoc-if-not (lambda (x) (eq 'c x)) a) (A . 0) ISLisp>(assoc-if-not #'symbolp a) NIL ISLisp>(rassoc 2 a) (C . 2) ISLisp>(rassoc 3 a) NIL ISLisp>(rassoc-if (lambda (x) (= (mod x 2) 1)) a) (B . 1) ISLisp>(rassoc-if (lambda (x) (= x 4)) a) NIL ISLisp>(rassoc-if-not (lambda (x) (= (mod x 2) 1)) a) (A . 0) ISLisp>(rassoc-if-not (lambda (x) (< x 3)) a) NIL
●プログラムリスト
;;; ;;; cxr.lsp : car と cdr の組み合わせ ;;; ;;; Copyright (C) 2021 Makoto Hiroi ;;; ;;; ISLisp には car と cdr しかない (defun caar (xs) (car (car xs))) (defun cadr (xs) (car (cdr xs))) (defun cdar (xs) (cdr (car xs))) (defun cddr (xs) (cdr (cdr xs))) (defun caaar (xs) (car (car (car xs)))) (defun caadr (xs) (car (car (cdr xs)))) (defun cadar (xs) (car (cdr (car xs)))) (defun caddr (xs) (car (cdr (cdr xs)))) (defun cdaar (xs) (cdr (car (car xs)))) (defun cdadr (xs) (cdr (car (cdr xs)))) (defun cddar (xs) (cdr (cdr (car xs)))) (defun cdddr (xs) (cdr (cdr (cdr xs)))) (defun caaaar (xs) (car (car (car (car xs))))) (defun caaadr (xs) (car (car (car (cdr xs))))) (defun caadar (xs) (car (car (cdr (car xs))))) (defun caaddr (xs) (car (car (cdr (cdr xs))))) (defun cadaar (xs) (car (cdr (car (car xs))))) (defun cadadr (xs) (car (cdr (car (cdr xs))))) (defun caddar (xs) (car (cdr (cdr (car xs))))) (defun cadddr (xs) (car (cdr (cdr (cdr xs))))) (defun cdaaar (xs) (cdr (car (car (car xs))))) (defun cdaadr (xs) (cdr (car (car (cdr xs))))) (defun cdadar (xs) (cdr (car (cdr (car xs))))) (defun cdaddr (xs) (cdr (car (cdr (cdr xs))))) (defun cddaar (xs) (cdr (cdr (car (car xs))))) (defun cddadr (xs) (cdr (cdr (car (cdr xs))))) (defun cdddar (xs) (cdr (cdr (cdr (car xs))))) (defun cddddr (xs) (cdr (cdr (cdr (cdr xs))))) (defun first (xs) (car xs)) (defun second (xs) (elt xs 1)) (defun third (xs) (elt xs 2)) (defun fourth (xs) (elt xs 3)) (defun fifth (xs) (elt xs 4)) (defun sixth (xs) (elt xs 5)) (defun seventh (xs) (elt xs 6)) (defun eigthth (xs) (elt xs 7)) (defun ninth (xs) (elt xs 8)) (defun tenth (xs) (elt xs 9)) ;;; end-of-file
;;;
;;; list.lsp : ISLisp 用リスト操作関数
;;;
;;; Copyright (C) 2016-2021 Makoto Hiroi
;;;
(load "macro.lsp")
;;; 末尾のセル
(defun last-pair (xs)
(for ((xs xs (cdr xs)))
((null (cdr xs)) xs)))
;;; 末尾の要素
(defun last (xs) (car (last-pair xs)))
;;; 先頭から n 個の要素を取り出す
(defun take (xs n)
(for ((xs xs (cdr xs))
(n n (- n 1))
(a nil (cons (car xs) a)))
((= n 0) (nreverse a))))
;;; 先頭から n 個の要素を取り除く
(defun drop (xs n)
(for ((xs xs (cdr xs))
(n n (- n 1)))
((= n 0) xs)))
;;;
;;; 連結 : ISLisp には append と nconc がある
;;;
;;; xs を反転して ys と連結する
(defun revappend (xs ys)
(dolist (x xs ys) (push x ys)))
;;;
;;; コピーと置換
;;;
(defun copy-tree (tree)
(cond
((consp tree)
(cons (copy-tree (car tree))
(copy-tree (cdr tree))))
(t tree)))
(defun copy-list (xs)
(let ((zs nil))
(dolist (x xs (nreverse zs))
(push x zs))))
(defun copy-alist (xs)
(let ((zs nil))
(dolist (x xs (nreverse zs))
(push (cons (car x) (cdr x)) zs))))
(defun subst-if (new pred tree)
(cond
((funcall pred tree) new)
((consp tree)
(cons (subst-if new pred (car tree))
(subst-if new pred (cdr tree))))
(t tree)))
(defun subst (new old tree)
(subst-if new (lambda (x) (eql x old)) tree))
(defun subst-if-not (new pred tree)
(subst-if new (lambda (x) (not (funcall pred x))) tree))
;;;
;;; リストの生成: ISLisp には create-list がある
;;;
(defun iota (n m)
(for ((m m (- m 1))
(a nil))
((> n m) a)
(push m a)))
(defun tabulate (f n m)
(for ((m m (- m 1))
(a nil))
((> n m) a)
(push (funcall f m) a)))
;;; 解きほぐし (末尾再帰ではない)
(defun unfold (p f g seed)
(if (funcall p seed)
nil
(cons (funcall f seed) (unfold p f g (funcall g seed)))))
;;;
;;; 畳み込み
;;;
;;; 先頭から
(defun fold-left-1 (f a xs)
(dolist (x xs a) (setq a (funcall f a x))))
(defun fold-left (f a xs &rest args)
(if (null args)
(fold-left-1 f a xs)
(for ((ys (cons xs args) (mapcar #'cdr ys))
(a a (apply f a (mapcar #'car ys))))
((member nil ys) a))))
;;; 末尾から (末尾再帰ではない)
(defun fold-right-1 (f a xs)
(if (null xs)
a
(funcall f (fold-right-1 f a (cdr xs)) (car xs))))
(defun fold-right-n (f a xss)
(if (member nil xss)
a
(apply f (fold-right-n f a (mapcar #'cdr xss)) (mapcar #'car xss))))
(defun fold-right (f a xs &rest args)
(if (null args)
(fold-right-1 f a xs)
(fold-right-n f a (cons xs args))))
;;;
;;; 巡回
;;;
(defun for-each (f xs &rest args)
(if (null args)
(dolist (x xs) (funcall f x))
(for ((ys (cons xs args) (mapcar #'cdr ys)))
((member nil ys))
(apply f (mapcar #'car ys)))))
;;;
;;; 分割
;;;
(defun partition (pred xs)
(let ((ys nil) (zs nil))
(dolist (x xs (list (nreverse ys) (nreverse zs)))
(if (funcall pred x)
(push x ys)
(push x zs)))))
;;;
;;; 述語 (リスト専用)
;;;
(defun any-1 (pred xs)
(dolist (x xs)
(if (funcall pred x) (return t))))
(defun any-n (pred xss)
(block
exit
(for ((xss xss (mapcar #'cdr xss)))
((member nil xss))
(when
(apply pred (mapcar #'car xss))
(return-from exit t)))))
(defun any (pred xs &rest args)
(if (null args)
(any-1 pred xs)
(any-n pred (cons xs args))))
(defun all-1 (pred xs)
(dolist (x xs t)
(unless (funcall pred x) (return))))
(defun all-n (pred xss)
(block
exit
(for ((xss xss (mapcar #'cdr xss)))
((member nil xss) t)
(unless
(apply pred (mapcar #'car xss))
(return-from exit nil)))))
(defun all (pred xs &rest args)
(if (null args)
(all-1 pred xs)
(all-n pred (cons xs args))))
;;;
;;; 集合演算
;;;
;;;
;;; 検査 : member は ISLisp にある
;;;
(defun member-if (pred xs)
(block
exit
(for ((xs xs (cdr xs)))
((null xs))
(when
(funcall pred (car xs))
(return-from exit xs)))))
(defun member-if-not (pred xs)
(member-if (lambda (x) (not (funcall pred x))) xs))
;;; 重複要素を削除する
(defun remove-duplicates (xs)
(let ((ys nil))
(dolist (x xs (nreverse ys))
(unless
(member x ys)
(push x ys)))))
;;; 和集合
(defun union (xs ys)
(let ((zs nil))
(dolist (x xs (revappend zs ys))
(unless
(member x ys)
(push x zs)))))
;;; 積集合
(defun intersection (xs ys)
(let ((zs nil))
(dolist (x xs (nreverse zs))
(when
(member x ys)
(push x zs)))))
;;; 差集合
(defun difference (xs ys)
(let ((zs nil))
(dolist (x xs (nreverse zs))
(unless
(member x ys)
(push x zs)))))
;;; 部分集合
(defun subsetp (xs ys)
(dolist (x xs t)
(unless
(member x ys)
(return nil))))
;;;
;;; 連想リスト : ISLisp には assoc がある
;;;
(defun acons (k v alist)
(cons (cons k v) alist))
(defun pairlis (ks vs alist)
(fold-right (lambda (a k v) (acons k v a)) alist ks vs))
(defun assoc-if (pred xs)
(dolist (x xs)
(if (funcall pred (car x)) (return x))))
(defun assoc-if-not (pred xs)
(assoc-if (lambda (x) (not (funcall pred x))) xs))
(defun rassoc-if (pred xs)
(dolist (x xs)
(if (funcall pred (cdr x)) (return x))))
(defun rassoc (v xs)
(rassoc-if (lambda (x) (eql x v)) xs))
(defun rassoc-if-not (pred xs)
(rassoc-if (lambda (x) (not (funcall pred x))) xs))
;;; end-of-file