※ lisp で双方向リストを実現したい (2000-09-26) emacs の lisp でプログラムしていて、リング状(endless な)双方向リストを 使う必要が生じましたので作りました。 ちなみに、emacs では kill-yank がリング状リストをしているが、これは前方向に ポインタが移動するだけで、後戻りすることはありません。 双方向リストを実現するためには、before と next 両方を指すポインタと その値を指すポインタを含んだセル dl-cell が必要です。 これの構造は、ソースのコメントを参照してください。 用意した関数は次の通りです。 (dl-make DATAS) DATAS から双方向リストを作り、最初を指す dl-cell を返す (dl-* P) dl-cell の指す値を返す。 (dl-+ P &OPTIONAL N) 次(next)の dl-cellを返す (dl-- P &OPTIONAL N) 前(before)の dl-cell を返す (dl-del P) dl-cell を削除し、次の dl-cell を返す (dl-insert P DATA) dl-cell の前に DATA を挿入する (dl-allcell P) すべての dl-cell をリストにして返す(双方向リストの順) (dl-all P) すべての値をリストにして返す (dl-emptyp P) 双方リストが空ならば nilを返す (dl-length P) 双方向リストの総数 (dl-sort P &OPTIONAL PREDICATE) すべての dl-cell をソートして返す (dl-min P &OPTIONAL PREDICATE) 一番小さい dl-cell を返す (dl-div 例えば、 (setq a (dl-make '( 4 5 6 -2 2 1))) ;双方向リストを作る (print (dl-* a)) ;最初の値 4 を表示 (setq b (dl-+ a 2)) ;2 つ進めたポインタを b に代入 (print (dl-* b)) ;b の値は 6 (print (dl-all b)) ;すべての値(b の指す 6 から順に) (print (mapcar 'dl-* (dl-sort b))) ;ソートしたポインタから値を取り出す ;すべての値を取り出してから、ソートする (sort (dl-all b) '<) のと同じ結果 ---------^ dl.el ; ; dl.el : 双方向リスト ; ; dl-cell: ; ( element backward forward ) ; ; ; リング状双方向リストの構造 ; ; +---------------------------------------------------------+ ; | | ; | +---+---+---+ +---+---+---+ +---+---+---+ | ; +--> | | | ----> | | | ----> | | | ----+ ; +----- | | | | <---- | | | | <---- | | | | <--+ ; | +---+-|-+---+ +---+-|-+---+ +---+-|-+---+ | ; | V V V | ; | "a" "b" "c" | ; | | ; +----------------------------------------------------------+ ; ; ; リング状双方向リストを構成するセル ; ; +---+---+---+ ; | | | ---->next ; before<---- | | | | ; +---+-|-+---+ ; V ; "b" ; ; 単方向セルの lisp で作る双方向リスト用セル (dl-cell) ; ; ; +---+---+ +---+---+ +---+---+ ; |car|cdr| |car|cdr| |car|cdr| ; | | | ---->| | | ---->| | | ---->nil ; +-|-+---+ +-|-+---+ +-|-+---+ ; | | | ; V | | ; "b" | | ; | +-------------->next ; before<-------------------+ ; (progn (provide 'dl) (require 'cl) (defun dl-make (datas) "make dl and return a dl-cell pointing to first of DATAS" (let (backward all) (setq all (mapcar (lambda (e) (setq backward (list e backward nil))) datas)) (rplaca (cdar all) backward) (rplaca (cddr backward) (car all)) (loop with i = backward with j = (cadr i) while (and j (not (eq j backward))) do (rplaca (cddr j) i) (setq i j j (cadr j))) (car all))) (defun dl-*(p) "value pointed by dl-cell" (car p)) (defun dl-+ (p &optional n) "return next dl-cell" (or n (setq n 1)) (while (> 0 n) (setq p (cadr p))(incf n)) (while (< 0 n) (setq p (caddr p))(decf n)) p) (defun dl-- (p &optional n) "return before dl-cell" (dl-+ p (- (or n 1)))) (defun dl-del(p) "delete dl-cell and return next" (and p (not (eq p (dl-+ p))) ;; 空または要素1つ (prog1 (dl-+ p) (rplaca (cddr (dl-- p)) (dl-+ p)) (rplaca (cdr (dl-+ p)) (dl-- p)) (rplaca (cdr p) p) ;; 削除された要素は1つの dl をなす (rplaca (cddr p) p)))) (defun dl-insert(p data) "insert DATA before dl-cell" (let ((cell (list data (dl-- p) p))) (rplaca (cddr (dl-- p)) cell) (rplaca (cdr p ) cell) cell)) (defun dl-allcell (p) "return all dl-cells" (and p (let ((r (list p))(pp (dl-+ p))) (while (and pp (not (eq p pp))) (push pp r) (setq pp (dl-+ pp))) (nreverse r)))) (defun dl-all(p) "return all values of dl" (mapcar 'dl-* (dl-allcell p))) (defun dl-emptyp(p) "return nil, if dl is empty" (not p)) (defun dl-length(p) "return length of dl" (length (dl-allcell p))) (defun dl-sort(p &optional predicate) (sort (dl-allcell p) (lambda (a b) (apply (or predicate '<) (dl-* a) (dl-* b) nil)))) (defun dl-min(p &optional predicate) "return minimum dl-cell, comparing elements using PREDICATE." (let ((r p) (pp (dl-+ p)) (predicate (or predicate '<))) (while (not (eq pp p)) (if (apply predicate (dl-* pp)(dl-* r) nil) (setq r pp)) (setq pp (dl-+ pp))) r)) ---------$ dl.el