M.Hiroi's Home Page

Common Lisp Programming

お気楽 ISLisp プログラミング超入門

[ Home | Common Lisp | ISLisp ]

簡単なプログラム

●列関数

Common Lisp ライクな「列関数」です。リスト (<list>)、文字列 (<string>)、ベクタ (<general-vector>) を、列 (sequence) として統一して扱うことができます。

●列の変換

ISLisp>(list->vector '(1 2 3 4 5))
#(1 2 3 4 5)
ISLisp>(list->string '(#\1 #\2 #\3 #\4 #\5))
"12345"
ISLisp>(vector->list #(1 2 3 4 5))
(1 2 3 4 5)
ISLisp>(vector->string #(#\1 #\2 #\3 #\4 #\5))
"12345"
ISLisp>(string->list "12345")
(#\1 #\2 #\3 #\4 #\5)
ISLisp>(string->vector "12345")
#(#\1 #\2 #\3 #\4 #\5)

●列の探索

ISLisp>(find 3 '(1 2 3 4 5 6 7 8))
3
ISLisp>(find 9 '(1 2 3 4 5 6 7 8))
NIL
ISLisp>(find 3 #(1 2 3 4 5 6 7 8))
3
ISLisp>(find 9 #(1 2 3 4 5 6 7 8))
NIL
ISLisp>(find #\3 "12345678")
#\3
ISLisp>(find #\9 "12345678")
NIL

ISLisp>(defun evenp (x) (= (mod x 2) 0))
EVENP
ISLisp>(defun oddp (x) (= (mod x 2) 1))
ODDP

ISLisp>(find-if #'evenp '(1 2 3 4 5 6 7 8))
2
ISLisp>(find-if-not #'evenp '(1 2 3 4 5 6 7 8))
1
ISLisp>(find-if #'evenp #(1 2 3 4 5 6 7 8))
2
ISLisp>(find-if-not #'evenp #(1 2 3 4 5 6 7 8))
1

ISLisp>(position 3 '(1 2 3 4 5 6 7 8))
2
ISLisp>(position 9 '(1 2 3 4 5 6 7 8))
-1
ISLisp>(position 3 #(1 2 3 4 5 6 7 8))
2
ISLisp>(position 9 #(1 2 3 4 5 6 7 8))
-1
ISLisp>(position #\3 "12345678")
2
ISLisp>(position #\9 "12345678")
-1
ISLisp>(position-if #'oddp '(1 2 3 4 5 6 7 8))
0
ISLisp>(position-if-not #'oddp #(1 2 3 4 5 6 7 8))
1

ISLisp>(count 3 '(1 2 1 2 3 1 2 3 4))
2
ISLisp>(count 0 '(1 2 1 2 3 1 2 3 4))
0
ISLisp>(count 3 #(1 2 1 2 3 1 2 3 4))
2
ISLisp>(count 0 #(1 2 1 2 3 1 2 3 4))
0
ISLisp>(count #\3 "121231234")
2
ISLisp>(count #\0 "121231234")
0
ISLisp>(count-if #'evenp '(1 2 1 2 3 1 2 3 4))
4
ISLisp>(count-if-not #'evenp #(1 2 1 2 3 1 2 3 4))
5

●列の修正

ISLisp>(defglobal a '(a b c d e f))
A
ISLisp>a
(A B C D E F)
ISLisp>(fill a 'g)
(G G G G G G)
ISLisp>a
(G G G G G G)
ISLisp>(defglobal b #(a b c d e f))
B
ISLisp>(fill b 'g)
#(G G G G G G)
ISLisp>b
#(G G G G G G)
ISLisp>(defglobal c "abcdef")
C
ISLisp>(fill c #\g)
"gggggg"
ISLisp>c
"gggggg"

ISLisp>(remove 'a '(a b a b c a b c d))
(B B C B C D)
ISLisp>(remove 'a #(a b a b c a b c d))
#(B B C B C D)
ISLisp>(remove #\a "ababcabcd")
"bbcbcd"
ISLisp>(remove-if #'evenp '(1 2 3 4 5 6 7 8 9))
(1 3 5 7 9)
ISLisp>(remove-if-not #'evenp #(1 2 3 4 5 6 7 8 9))
#(2 4 6 8)

ISLisp>(substitute 'z 'a '(a b a b c a b c d))
(Z B Z B C Z B C D)
ISLisp>(substitute 'z 'a #(a b a b c a b c d))
#(Z B Z B C Z B C D)
ISLisp>(substitute #\z #\a "ababcabcd")
"zbzbczbcd"
ISLisp>(substitute-if 0 #'evenp '(1 2 3 4 5 6 7 8 9))
(1 0 3 0 5 0 7 0 9)
ISLisp>(substitute-if-not 0 #'evenp #(1 2 3 4 5 6 7 8 9))
#(0 2 0 4 0 6 0 8 0)

ISLisp>(defglobal a '(a b a b c a b c d))
A
ISLisp>(nsubstitute 'z 'a a)
(Z B Z B C Z B C D)
ISLisp>a
(Z B Z B C Z B C D)
ISLisp>(defglobal b #(a b a b c a b c d))
B
ISLisp>(nsubstitute 'z 'a b)
#(Z B Z B C Z B C D)
ISLisp>b
#(Z B Z B C Z B C D)
ISLisp>(defglobal c "ababcabcd"))
C
ISLisp>(nsubstitute #\z #\a c)
"zbzbczbcd"
ISLisp>c
"zbzbczbcd"
ISLisp>(defglobal a '(1 2 3 4 5 6 7 8 9))
A
ISLisp>(nsubstitute-if 0 #'evenp a)
(1 0 3 0 5 0 7 0 9)
ISLisp>a
(1 0 3 0 5 0 7 0 9)
ISLisp>(defglobal b #(1 2 3 4 5 6 7 8 9))
B
ISLisp>(nsubstitute-if-not 1 #'evenp b)
#(1 2 1 4 1 6 1 8 1)
ISLisp>b
#(1 2 1 4 1 6 1 8 1)

●連結

ISLisp>(concatenate '<list> '(1 2 3 4) #(5 6 7 8) "abcd")
(1 2 3 4 5 6 7 8 #\a #\b #\c #\d)
ISLisp>(concatenate '<general-vector> '(1 2 3 4) #(5 6 7 8) "abcd")
#(1 2 3 4 5 6 7 8 #\a #\b #\c #\d)
ISLisp>(concatenate '<string> '(#\1 #\2 #\3 #\4) #(#\5 #\6 #\7 #\8) "abcd")
"12345678abcd"

●マッピングと畳み込み

ISLisp>(map '<list> #'list '(1 2 3 4) #(5 6 7 8) "abcd")
((1 5 #\a) (2 6 #\b) (3 7 #\c) (4 8 #\d))
ISLisp>(map '<general-vector> #'list '(1 2 3 4) #(5 6 7 8) "abcd")
#((1 5 #\a) (2 6 #\b) (3 7 #\c) (4 8 #\d))
ISLisp>(map '<string> (lambda (x y) (if (char< x y) x y)) "AbCd" "aBcD")
"ABCD"
ISLisp>(reduce (lambda (a x y z) (cons (list x y z) a)) nil '(1 2 3 4) #(5 6 7 8) "abcd")
((4 8 #\d) (3 7 #\c) (2 6 #\b) (1 5 #\a))
ISLisp>(reduce-right (lambda (a x y z) (cons (list x y z) a)) nil '(1 2 3 4) #(5 6 7 8) "abcd")
((1 5 #\a) (2 6 #\b) (3 7 #\c) (4 8 #\d))

●some と every

ISLisp>(some #'evenp #(1 3 5 7 9))
NIL
ISLisp>(some #'evenp #(1 3 5 7 8 9))
T
ISLisp>(some #'= '(1 2 3 4) #(7 6 5 4))
T
ISLisp>(some #'= '(1 2 3 4) #(7 6 5 8))
NIL
ISLisp>(some #'char= "abcd" "ABCd")
T
ISLisp>(some #'char= "abcd" "ABCD")
NIL
ISLisp>(every #'oddp '(1 3 5 7 9))
T
ISLisp>(every #'oddp '(1 3 5 7 9 10))
NIL
ISLisp>(every #'= '(1 2 3 4) #(1 2 3 4))
T
ISLisp>(every #'= '(1 2 3 4) #(1 2 3 5))
NIL
ISLisp>(every #'char= "abcd" "abcd")
T
ISLisp>(every #'char= "abcd" "abcD")
NIL

●プログラムリスト

;;;
;;; seq.lsp : ISLisp 用列関数
;;;
;;;           Copyright (C) 2021 Makoto Hiroi
;;;
(load "macro.lsp")

;;;
;;; ISLisp の列関数 : length, elt, set-elt, subseq, map-into
;;;

;;;
;;; 列の変換 : list->vector, list->string, vector->list,
;;;            vector->string, string->list, string->vector
;;;

(defun list->vector (xs) (convert xs <general-vector>))
(defun list->string (xs)
  (let ((in (create-string-output-stream)))
    (dolist (x xs (get-output-stream-string in))
      (format-char in x))))

(defun vector->list (xs) (convert xs <list>))
(defun vector->string (xs)
  (let ((in (create-string-output-stream)))
    (dotimes (i (length xs) (get-output-stream-string in))
      (format-char in (elt xs i)))))

(defun string->list (xs) (convert xs <list>))
(defun string->vector (xs) (convert xs <general-vector>))

;;;
;;; 列の探索 : find, find-if, find-if-not,
;;;            position, position-if, position-if-not,
;;;            count, count-if, count-if-not
;;;

(defun find-if (pred xs)
  (if (listp xs)
      (dolist (x xs) (if (funcall pred x) (return x)))
    (dotimes (i (length xs))
      (let ((x (elt xs i)))
	(if (funcall pred x) (return x))))))

(defun find (item xs)
  (find-if (lambda (x) (eql x item)) xs))

(defun find-if-not (pred xs)
  (find-if (lambda (x) (not (funcall pred x))) xs))

(defun position-if (pred xs)
  (if (listp xs)
      (let ((i 0))
	(dolist (x xs -1)
	  (if (funcall pred x) (return i) (incf i))))
    (dotimes (i (length xs) -1)
      (let ((x (elt xs i)))
	(if (funcall pred x) (return i))))))

(defun position (item xs)
  (position-if (lambda (x) (eql x item)) xs))

(defun position-if-not (pred xs)
  (position-if (lambda (x) (not (funcall pred x))) xs))

(defun count-if (pred xs)
  (let ((c 0))
    (if (listp xs)
	(dolist (x xs c)
	  (if (funcall pred x) (incf c)))
      (dotimes (i (length xs) c)
	(let ((x (elt xs i)))
	  (if (funcall pred x) (incf c)))))))

(defun count (item xs)
  (count-if (lambda (x) (eql x item)) xs))

(defun count-if-not (pred xs)
  (count-if (lambda (x) (not (funcall pred x))) xs))

;;;
;;; 列の修正 : fill, remove, remove-if, remove-if-not
;;;            substitute, substitute-if, substitute-if-not,
;;;            nsubstitute, nsubstitute-if, nsubstitute-if-not,

(defun fill (xs item)
  (if (listp xs)
      (for ((ys xs (cdr ys)))
	   ((null ys) xs)
	   (set-car item ys))
    (dotimes (i (length xs) xs)
      (set-elt item xs i))))

(defun remove-if-not (pred xs)
  (let ((zs nil))
    (if (listp xs)
	(dolist (x xs (nreverse zs))
	  (if (funcall pred x) (push x zs)))
      (dotimes (i (length xs) (if (stringp xs)
				  (list->string (nreverse zs))
				(list->vector (nreverse zs))))
	(let ((x (elt xs i)))
	  (if (funcall pred x) (push x zs)))))))

(defun remove (item xs)
  (remove-if (lambda (x) (eql x item)) xs))

(defun remove-if (pred xs)
  (remove-if-not (lambda (x) (not (funcall pred x))) xs))

(defun substitute-if (newitem pred xs)
  (if (listp xs)
      (let ((a nil))
	(dolist (x xs (nreverse a))
	  (push (if (funcall pred x) newitem x) a)))
    (let* ((k (length xs))
	   (a (subseq xs 0 k)))
      (dotimes (i k a)
	(if (funcall pred (elt a i))
	    (set-elt newitem a i))))))

(defun substitute (newitem olditem xs)
  (substitute-if newitem (lambda (x) (eql x olditem)) xs))

(defun substitute-if-not (newitem pred xs)
  (substitute-if newitem (lambda (x) (not (funcall pred x))) xs))

(defun nsubstitute-if (newitem pred xs)
  (if (listp xs)
      (for ((ys xs (cdr ys)))
	   ((null ys) xs)
	   (if (funcall pred (car ys))
	       (set-car newitem ys)))
    (dotimes (i (length xs) xs)
      (if (funcall pred (elt xs i))
	  (set-elt newitem xs i)))))

(defun nsubstitute (newitem olditem xs)
  (nsubstitute-if newitem (lambda (x) (eql x olditem)) xs))

(defun nsubstitute-if-not (newitem pred xs)
  (nsubstitute-if newitem (lambda (x) (not (funcall pred x))) xs))

;;;
;;; 連結, マッピング, 畳み込みなど (リストは非効率)
;;; concatenate, map, reduce, reduce-right, some, every
;;;
(defun concatenate (result-type &rest args)
  (let* ((i 0)
	 (k (apply #'+ (mapcar #'length args)))
	 (s (case result-type
	      ((<list>) (create-list k))
	      ((<string>) (create-string k))
	      ((<general-vector>) (create-vector k))
	      (t (error "concatenate: illegal type")))))
    (dolist (xs args s)
      (dotimes (j (length xs))
	(set-elt (elt xs j) s i)
	(incf i)))))

(defun map (result-type func seq &rest args)
  (let* ((xs (cons seq args))
	 (k (apply #'min (mapcar #'length xs)))
	 (s (case result-type
	      ((<list>) (create-list k))
	      ((<string>) (create-string k))
	      ((<general-vector>) (create-vector k))
	      (t (error "map: illegal type")))))
    (dotimes (i k s)
      (set-elt (apply func (mapcar (lambda (ys) (elt ys i)) xs)) s i))))

(defun reduce (fn init seq &rest args)
  (let* ((xs (cons seq args))
	 (k (apply #'min (mapcar #'length xs)))
	 (a init))
    (dotimes (i k a)
      (setq a (apply fn a (mapcar (lambda (ys) (elt ys i)) xs))))))

(defun reduce-right (fn init seq &rest args)
  (let* ((xs (cons seq args))
	 (k (apply #'min (mapcar #'length xs)))
	 (a init))
    (for ((i (- k 1) (- i 1)))
	 ((< i 0) a)
	 (setq a (apply fn a (mapcar (lambda (ys) (elt ys i)) xs))))))

(defun some (pred seq &rest args)
  (let* ((xs (cons seq args))
	 (k (apply #'min (mapcar #'length xs))))
    (dotimes (i k)
      (let ((result (apply pred (mapcar (lambda (ys) (elt ys i)) xs))))
	(when result (return result))))))

(defun every (pred seq &rest args)
  (let* ((xs (cons seq args))
	 (k (apply #'min (mapcar #'length xs)))
	 (result nil))
    (dotimes (i k result)
      (setq result (apply pred (mapcar (lambda (ys) (elt ys i)) xs)))
      (unless result (return)))))

;;; end-of-file

●マージとソート

リストとベクタ (1 次元配列) をマージする関数とソートする関数を作成します。リストのソートには「マージソート (merge sort)」を、ベクタのソートには「クイックソート (quick sort)」を使っています。これらの関数には要素を比較する述語 pred を渡します。pred x y は、x が y よりも小さいときに限り真を返し、それ以外は偽を返すように定義してください。数値であれば #'< を渡せば動作します。

●使用例

> (load "sort.lsp")
T
> (merge '(1 3 5 7 9) '(0 2 4 6 8) #'<)
(0 1 2 3 4 5 6 7 8 9)
> (merge #(1 3 5 7 9) #(0 2 4 6 8) #'<)
#(0 1 2 3 4 5 6 7 8 9)

> (merge '((1 a) (3 b) (5 c) (7 d)) '((0 e) (2 f) (4 g)) (lambda (x y) (< (car x) (car y))))
((0 E) (1 A) (2 F) (3 B) (4 G) (5 C) (7 D))
> (merge #((1 a) (3 b) (5 c) (7 d)) #((0 e) (2 f) (4 g)) (lambda (x y) (< (car x) (car y))))
#((0 E) (1 A) (2 F) (3 B) (4 G) (5 C) (7 D))

> (defglobal a '(1 3 5 7 9))
A
> (defglobal b '(2 4 6 8))
B
> (defglobal c (merge-list! a b #'<))
C
> c
(1 2 3 4 5 6 7 8 9)
> a
(1 2 3 4 5 6 7 8 9)
> b
(2 3 4 5 6 7 8 9)

> (setq a (tabulate (lambda (x) (random-real)) 1 16))
A
> a
(0.61264 0.839112 0.512932 0.218257 0.998925 0.108809 0.12979 0.400944 0.156679 0.804177 0.137232 0.242887 
0.0163006 0.606969 0.141603 0.717297)
> (sorted a #'<)
NIL
> (sort a #'<)
(0.0163006 0.108809 0.12979 0.137232 0.141603 0.156679 0.218257 0.242887 0.400944 0.512932 0.606969 0.61264 
0.717297 0.804177 0.839112 0.998925)
> a
(0.61264 0.839112 0.512932 0.218257 0.998925 0.108809 0.12979 0.400944 0.156679 0.804177 0.137232 0.242887 
0.0163006 0.606969 0.141603 0.717297)
> (sorted (sort a #'<) #'<)
T
> (setq b (sort! a #'<))
B
> b
(0.0163006 0.108809 0.12979 0.137232 0.141603 0.156679 0.218257 0.242887 0.400944 0.512932 0.606969 0.61264 
0.717297 0.804177 0.839112 0.998925)
> a
(0.61264 0.717297 0.804177 0.839112 0.998925)
> (sorted b #'<)
T

> (import "seq")
T
> (setq a (list->vector (tabulate (lambda (x) (random-real)) 1 32)))
#(0.266666 0.85092 0.902208 0.970634 0.23828 0.0630958 0.457702 0.020023 0.0641713 0.348893 0.890233 
0.663227 0.192214 0.0860558 0.525995 0.949327 0.0697553 0.919026 0.807725 0.352458 0.283315 0.891529 
0.400229 0.769914 0.526745 0.771358 0.292517 0.972775 0.493583 0.524287 0.637552 0.296032)
> (setq b (sort a #'<))
#(0.020023 0.0630958 0.0641713 0.0697553 0.0860558 0.192214 0.23828 0.266666 0.283315 0.292517 0.296032 
0.348893 0.352458 0.400229 0.457702 0.493583 0.524287 0.525995 0.526745 0.637552 0.663227 0.769914 
0.771358 0.807725 0.85092 0.890233 0.891529 0.902208 0.919026 0.949327 0.970634 0.972775)
> a
#(0.266666 0.85092 0.902208 0.970634 0.23828 0.0630958 0.457702 0.020023 0.0641713 0.348893 0.890233 
0.663227 0.192214 0.0860558 0.525995 0.949327 0.0697553 0.919026 0.807725 0.352458 0.283315 0.891529 
0.400229 0.769914 0.526745 0.771358 0.292517 0.972775 0.493583 0.524287 0.637552 0.296032)
> (sorted b #'<)
T
> (setq b (sort! a #'<))
#(0.020023 0.0630958 0.0641713 0.0697553 0.0860558 0.192214 0.23828 0.266666 0.283315 0.292517 0.296032 
0.348893 0.352458 0.400229 0.457702 0.493583 0.524287 0.525995 0.526745 0.637552 0.663227 0.769914 
0.771358 0.807725 0.85092 0.890233 0.891529 0.902208 0.919026 0.949327 0.970634 0.972775)
> a
#(0.020023 0.0630958 0.0641713 0.0697553 0.0860558 0.192214 0.23828 0.266666 0.283315 0.292517 0.296032 
0.348893 0.352458 0.400229 0.457702 0.493583 0.524287 0.525995 0.526745 0.637552 0.663227 0.769914 
0.771358 0.807725 0.85092 0.890233 0.891529 0.902208 0.919026 0.949327 0.970634 0.972775)
> (sorted a #'<)
T

> (setq c (tabulate (lambda (x) (cons (random 10) x)) 1 16))
C
> c
((2 . 1) (9 . 2) (5 . 3) (7 . 4) (3 . 5) (2 . 6) (0 . 7) (2 . 8) (9 . 9) (7 . 10) (8 . 11) (1 . 12) (6 . 13) 
(2 . 14) (6 . 15) (0 . 16))
> (sort c (lambda (x y) (< (car x) (car y))))
((0 . 7) (0 . 16) (1 . 12) (2 . 1) (2 . 6) (2 . 8) (2 . 14) (3 . 5) (5 . 3) (6 . 13) (6 . 15) (7 . 4) (7 . 10) 
(8 . 11) (9 . 2) (9 . 9))

> (defglobal d (list->vector c))
D
> d
#((2 . 1) (9 . 2) (5 . 3) (7 . 4) (3 . 5) (2 . 6) (0 . 7) (2 . 8) (9 . 9) (7 . 10) (8 . 11) (1 . 12) (6 . 13) 
(2 . 14) (6 . 15) (0 . 16))
> (sort! d (lambda (x y) (< (car x) (car y))))
#((0 . 16) (0 . 7) (1 . 12) (2 . 14) (2 . 8) (2 . 6) (2 . 1) (3 . 5) (5 . 3) (6 . 13) (6 . 15) (7 . 4) 
(7 . 10) (8 . 11) (9 . 9) (9 . 2))

マージソートは安定なソート、クイックソートは不安定なソートです。

●プログラムリスト

;;;
;;; sort.lsp : ソート (Easy-ISLisp 用)
;;;
;;;            Copyright (C) 2023 Makoto Hiroi
;;;
(import "list")

;;; 比較関数 pred x y の仕様
;;; x が y より小さいときに限り真を返す
;;; それ以外は偽を返すこと

;;; リストのマージ
(defun merge-list (xs ys pred)
  (cond
   ((null xs) ys)
   ((null ys) xs)
   ((or (funcall pred (car xs) (car ys))
        (not (funcall pred (car ys) (car xs))))
    (cons (car xs) (merge-list (cdr xs) ys pred)))
   (t
    (cons (car ys) (merge-list xs (cdr ys) pred)))))

;;; マージソート
(defun merge-sort (xs n pred)
  (cond
   ((null xs) nil)
   ((= n 1)
    ;; 新しいリストを返す
    (list (car xs)))
   (t
    (let ((m (div n 2)))
      ;; リストを二分割し再帰呼び出しの結果をマージする
      (merge-list (merge-sort xs m pred)
                  (merge-sort (drop xs m) (- n m) pred)
                  pred)))))

;;; 破壊的なマージ
(defun merge-list! (xs ys pred)
  (let* ((hd (cons nil nil))
         (zs hd))
    (while (and xs ys)
      (cond
       ((or (funcall pred (car xs) (car ys))
            (not (funcall pred (car ys) (car xs))))
        (setf (cdr zs) xs)
        (setf zs xs)
        (setf xs (cdr xs)))
       (t
        (setf (cdr zs) ys)
        (setf zs ys)
        (setf ys (cdr ys)))))
    (setf (cdr zs) (if xs xs ys))
    (cdr hd)))

;;; 破壊的なソート
(defun merge-sort! (xs n pred)
  (cond
   ((= n 1)
    (setf (cdr xs) nil)
    xs)
   (t
    (let* ((m (div n 2))
           (ys (drop xs m)))
      (merge-list! (merge-sort! xs m pred)
                   (merge-sort! ys (- n m) pred)
                   pred)))))

;;;
;;; ベクタ用
;;;

;;; ベクタのコピー
(defun copy-vector (xs)
  (let ((ys (create-vector (length xs))))
    (for ((i 0 (+ i 1)))
         ((>= i (length xs)) ys)
         (setf (aref ys i) (aref xs i)))))

;;; マージ
(defun merge-vector (xs ys pred)
  (let ((zs (create-vector (+ (length xs) (length ys))))
        (i 0)
        (j 0)
        (k 0))
    (while (and (< i (length xs)) (< j (length ys)))
      (cond
       ((or (funcall pred (aref xs i) (aref ys j))
            (not (funcall pred (aref ys j) (aref xs i))))
        (setf (aref zs k) (aref xs i))
        (setf i (+ i 1)))
       (t
        (setf (aref zs k) (aref ys j))
        (setf j (+ j 1))))
      (setf k (+ k 1)))
    (while (< i (length xs))
      (setf (aref zs k) (aref xs i))
      (setf k (+ k 1))
      (setf i (+ i 1)))
    (while (< j (length ys))
      (setf (aref zs k) (aref ys j))
      (setf k (+ k 1))
      (setf j (+ j 1)))
    zs))

;;; 単純挿入ソート
(defun insert-sort (buff low high pred)
  (for ((i (+ low 1) (+ i 1)))
       ((> i high) buff)
       (let ((temp (aref buff i))
             (j (- i 1)))
         (while (and (>= j low)
                     (funcall pred temp (aref buff j)))
           (setf (aref buff (+ j 1)) (aref buff j))
           (setf j (- j 1)))
         (setf (aref buff (+ j 1)) temp))))

;;; 中央値を返す
(defun median3 (buff low high pred)
  (let ((a (aref buff low))
        (b (aref buff (div (+ low high) 2)))
        (c (aref buff high)))
    (cond
     ((funcall pred b a)
      (cond
       ((funcall pred c b) b)
       ((funcall pred a c) a)
       (t c)))
     (t
      (cond
       ((funcall pred b c) b)
       ((funcall pred a c) c)
       (t a))))))

;;; クイックソート
(defun quick-sort (buff low high pred)
  (if (< (- high low) 10)
      (insert-sort buff low high pred)
    (let ((p (median3 buff low high pred))
          (i low)
          (j high))
      (block exit
        (while t
          (while (funcall pred (aref buff i) p) (setq i (+ i 1)))
          (while (funcall pred p (aref buff j)) (setq j (- j 1)))
          (if (>= i j) (return-from exit nil))
          (let ((tmp (aref buff i)))
            (setf (aref buff i) (aref buff j))
            (setf (aref buff j) tmp))
          (setq i (+ i 1))
          (setq j (- j 1))))
      (if (< low (- i 1))
          (quick-sort buff low (- i 1) pred))
      (if (> high (+ j 1))
          (quick-sort buff (+ j 1) high pred)))))

;;; 非破壊的なマージ
(defun merge (xs ys pred)
  (if (listp xs)
      (merge-list xs ys pred)
    (merge-vector xs ys pred)))

;;; 非破壊的なソート
(defun sort (xs pred)
  (if (listp xs)
      (merge-sort xs (length xs) pred)
    (let ((ys (copy-vector xs)))
      (quick-sort ys 0 (- (length ys) 1) pred)
      ys)))

;;; 破壊的なソート
(defun sort! (xs pred)
  (cond
   ((listp xs)
    (merge-sort! xs (length xs) pred))
   (t
    (quick-sort xs 0 (- (length xs) 1) pred)
    xs)))

;;; ソートのチェック
(defun list-sorted (xs pred)
  (block
   exit
   (for ((xs xs (cdr xs)))
        ((null (cdr xs)) t)
        (if (funcall pred (car (cdr xs)) (car xs))
            (return-from exit nil)))))

(defun vector-sorted (buff pred)
  (block
   exit
   (for ((i 1 (+ i 1)))
        ((>= i (length buff)) t)
        (if (funcall pred (aref buff i) (aref buff (- i 1)))
            (return-from exit nil)))))

(defun sorted (xs pred)
  (if (listp xs)
      (list-sorted xs pred)
    (vector-sorted xs pred)))

●カッコ列

カッコ列は ( と ) からなる列のことで、バランスが取れているカッコ列は、右カッコで閉じることができる、つまり右カッコに対応する左カッコがある状態のことをいいます。たとえば n = 1 の場合、( ) はバランスの取れたカッコ列ですが、) ( はバランスが取れていません。今回はカッコ列に関する問題を出題するので、ISLisp で解答プログラムを作ってください。

  1. 文字列 s がバランスの取れたカッコ列か判定する述語 kakko-p s
  2. バランスの取れた n 対のカッコ列を生成する高階関数 create-kakko func n
  3. 二分木をカッコ列に変換する関数 tree->kakko ls
  4. tree->kakko の逆変換を行う関数 kakko->tree
  5. カタラン数 (Catalan number) を求める関数 catalan-number n

なお、解答例のプログラム (kakko.lsp) には拙作のライブラリ macro.lsp, cxr.lsp, seq.lsp, combination.lsp を使っています。OK!-ISLIsp の場合、(load "ライブラリ名") で読み込んでいるので、各ライブラリは kakko.lsp と同じディレクトリに置いてください。


















●解答1

リスト : カッコ列の判定

(defun kakko-p (s)
  (let ((l 0) (r 0))
    (dolist (x (string->list s) (= l r))
      (case x
	((#\() (incf l))
	((#\))
	 (incf r)
	 (when
	     (< l r)
	   (return nil)))
	(t (error "illegal character"))))))
ISLisp>(kakko-p "()")
T
ISLisp>(kakko-p ")(")
NIL
ISLisp>(kakko-p "((()))")
T
ISLisp>(kakko-p "((())))")
NIL
ISLisp>(kakko-p "(((()))")
NIL
ISLisp>(kakko-p "()()()()")
T
ISLisp>(kakko-p "()())(()")
NIL

カッコ列の判定は左右のカッコの個数を調べることで簡単に判定することができます。左カッコの個数を変数 l で、右カッコの個数を変数 r でカウントします。バランスの取れた n 対のカッコ列の場合、l, r, n には r <= l <= n の関係が成り立ちます。

r を +1 したとき、r が l よりも大きくなるとバランスが取れていません。return で nil を返します。文字列を最後まで読み込んだら、l と r の値が等しいかチェックします。そうでなければバランスが取れていない (左カッコが多い) ので nil を返します。

●解答2

リスト : カッコ列の生成

(defun create-kakko (f n)
  (labels ((kakko-sub (l r a)
	     (cond
	      ((and (= l r) (= r n))
	       (funcall f (list->string (reverse a))))
	      (t
	       (when (< l n)
		 (kakko-sub (+ l 1) r (cons #\( a)))
	       (when (< r l)
		 (kakko-sub l (+ r 1) (cons #\) a)))))))
    (kakko-sub 0 0 '())))
ISLisp>(create-kakko #'display 1)
"()"
NIL
ISLisp>(create-kakko #'display 2)
"(())"
"()()"
NIL
ISLisp>(create-kakko #'display 3)
"((()))"
"(()())"
"(())()"
"()(())"
"()()()"
NIL
ISLisp>(create-kakko #'display 4)
"(((())))"
"((()()))"
"((())())"
"((()))()"
"(()(()))"
"(()()())"
"(()())()"
"(())(())"
"(())()()"
"()((()))"
"()(()())"
"()(())()"
"()()(())"
"()()()()"
NIL

実際の処理は局所関数 kakko-sub で行います。引数 l が左カッコの個数、r が右カッコの個数を表します。l = r = n の場合、カッコ列がひとつ完成しました。リスト a を反転して list->string で文字列に変換し、引数の関数 func を呼び出します。そうでなければ、kakko-sub を再帰呼び出しします。l < n であれば左カッコを追加し、r < l であれば右カッコを追加します。これでカッコ列を生成することができます。

●解答3

リスト : 二分木をカッコ列に変換

;;; 最後尾のセルを取り除く
(defun butlast (xs)
  (if (null (cdr xs))
      nil
    (cons (car xs) (butlast (cdr xs)))))

(defun tree->kakko (ls)
  (labels ((tree-kakko-sub (ls)
	     (cond
	      ((consp ls)
	       (append (list #\()
		       (tree-kakko-sub (cadr ls))
		       (tree-kakko-sub (caddr ls))))
	      (t (list #\))))))
    (list->string (butlast (tree-kakko-sub ls)))))
ISLisp>(tree->kakko '(N L L))
"()"
ISLisp>(tree->kakko '(N (N L L) L))
"(())"
ISLisp>(tree->kakko '(N (N L L) (N L L)))
"(())()"
ISLisp>(tree->kakko '(N (N (N L L) L) L))
"((()))"

バランスの取れたカッコ列と二分木は 1 対 1 に対応します。二分木を行きがけ順で巡回するとき、途中の節では左カッコ ( を出力して左右の枝をたどり、葉に到達したら右カッコ ) を出力すると、カッコ列を生成することができます。

実際の処理は局所関数 tree-kakko-sub で行います。引数 ls がリストの場合、#\( を出力してから再帰呼び出しして左部分木 (cadr ls) をたどり、それから右部分木 (caddr ls) をたどります。その結果を append で連結すればいいわけです。

葉 (要素) の場合は #\) を格納したリストを返します。ただし、このままでは最後に余分な右カッコが付いてくるので、関数 butlast で最後の要素を削除してから、list->string で文字列に変換しています。

●解答4

リスト : カッコ列を二分木に変換

(defun kakko->tree (ks)
  (labels ((kakko-sub (ls)
             (cond
	      ((null ls) 
	       (list 'L nil))
	      ((eql (car ls) #\))
	       (list 'L (cdr ls)))
	      (t
	       (let* ((xs (kakko-sub (cdr ls)))
		      (ys (kakko-sub (cadr xs))))
		 (list (list 'N (car xs) (car ys)) (cadr ys)))))))
    (kakko-sub (string->list ks))))
ISLisp>(kakko->tree "((()))")
((N (N (N L L) L) L) NIL)
ISLisp>(create-kakko (lambda (s) (display (car (kakko->tree s)))) 3)
(N (N (N L L) L) L)
(N (N L (N L L)) L)
(N (N L L) (N L L))
(N L (N (N L L) L))
(N L (N L (N L L)))
NIL
ISLisp>(create-kakko (lambda (s) (display (car (kakko->tree s)))) 4)
(N (N (N (N L L) L) L) L)
(N (N (N L (N L L)) L) L)
(N (N (N L L) (N L L)) L)
(N (N (N L L) L) (N L L))
(N (N L (N (N L L) L)) L)
(N (N L (N L (N L L))) L)
(N (N L (N L L)) (N L L))
(N (N L L) (N (N L L) L))
(N (N L L) (N L (N L L)))
(N L (N (N (N L L) L) L))
(N L (N (N L (N L L)) L))
(N L (N (N L L) (N L L)))
(N L (N L (N (N L L) L)))
(N L (N L (N L (N L L))))
NIL

実際の処理は局所関数 kakko-sub で行います。kakko-sub は生成した二分木と残りのデータを格納したリストを返します。リスト ls の先頭要素が #\) の場合、kakko-sub を再帰呼び出しして左部分木 x を生成し、それから右部分木 y を生成します。あとは (list 'N x y) を返すだけです。

ls の先頭要素が #\) の場合は葉なので、'L と (cdr ls) を返すだけです。ただし、右カッコがひとつ少ないので、引数 ls が空リストの場合は葉 L と nil を返すようにします。

●解答5

カタラン数 - Wikipedia によると、カッコ列の総数は「カタラン数 (Catalan number)」になるとのことです。カタラン数は次に示す公式で求めることができます。

\( \mathrm{C}_n = \dfrac{{}_{2n}\mathrm{C}_n}{n+1} = \dfrac{(2n)!}{(n+1)!n!} \)

カタラン数は組み合わせの数を求める関数 combination-number を使うと簡単に求めることができます。

リスト : カタラン数

(defun catalan-number (n)
  (div (combination-number (* n 2) n) (+ n 1)))
ISLisp>(dotimes (n 10) (display (catalan-number n)))
1
1
2
5
14
42
132
429
1430
4862
NIL
ISLisp>(catalan-number 10)
16796
ISLisp>(catalan-number 20)
6564120420
ISLisp>(catalan-number 30)
3814986502092304
ISLisp>(catalan-number 40)
2622127042276492108820
ISLisp>(catalan-number 50)
1978261657756160653623774456
ISLisp>(catalan-number 100)
896519947090131496687170070074100632420837521538745909320

●プログラムリスト

;;;
;;; kakko.lsp : カッコ列の問題
;;;
;;;             Copyright (C) 2021 Makoto Hiroi
;;;
(load "cxr.lsp")
(load "seq.lsp")
(load "combination.lsp")

;;; 表示
(defun display (x) (format (standard-output) "~S~%" x))

;;; カッコ列の判定
(defun kakko-p (s)
  (let ((l 0) (r 0))
    (dolist (x (string->list s) (= l r))
      (case x
	((#\() (incf l))
	((#\))
	 (incf r)
	 (when
	     (< l r)
	   (return nil)))
	(t (error "illegal character"))))))

;;; カッコ列の生成
(defun create-kakko (f n)
  (labels ((kakko-sub (l r a)
	     (cond
	      ((and (= l r) (= r n))
	       (funcall f (list->string (reverse a))))
	      (t
	       (when (< l n)
		 (kakko-sub (+ l 1) r (cons #\( a)))
	       (when (< r l)
		 (kakko-sub l (+ r 1) (cons #\) a)))))))
    (kakko-sub 0 0 '())))

;;; 最後尾のセルを取り除く
(defun butlast (xs)
  (if (null (cdr xs))
      nil
    (cons (car xs) (butlast (cdr xs)))))

;;; 二分木をカッコ列に変換
(defun tree->kakko (ls)
  (labels ((tree-kakko-sub (ls)
	     (cond
	      ((consp ls)
	       (append (list #\()
		       (tree-kakko-sub (cadr ls))
		       (tree-kakko-sub (caddr ls))))
	      (t (list #\))))))
    (list->string (butlast (tree-kakko-sub ls)))))

;;; カッコ列を二分木に変換
(defun kakko->tree (ks)
  (labels ((kakko-sub (ls)
             (cond
	      ((null ls) 
	       (list 'L nil))
	      ((eql (car ls) #\))
	       (list 'L (cdr ls)))
	      (t
	       (let* ((xs (kakko-sub (cdr ls)))
		      (ys (kakko-sub (cadr xs))))
		 (list (list 'N (car xs) (car ys)) (cadr ys)))))))
    (kakko-sub (string->list ks))))

;;; カタラン数
(defun catalan-number (n)
  (div (combination-number (* n 2) n) (+ n 1)))

Copyright (C) 2021-2023 Makoto Hiroi
All rights reserved.

[ Home | Common Lisp | ISLisp ]