気ままに書き散らかした小片。
リンク:
GNU Emacs Lisp Reference Manual
fold (リストの畳み込み)
Scheme の高階関数 fold を再帰で実装してみよう。kons は2引数の関数とし、knil は初期値、ls はリストである。 リストの各要素を e1,e2,e3...en とすると、左端の要素 e1 を初期値 knil に kons し、更に左から順にとられた要素を累積的に kons して行く(畳み込んで行く)。fold は次の結果を返す。
(kons en (kons … (kons e3 (kons e2 (kons e1 knil))) … ))
fold-right は、右端の要素 en を初期値 knil に kons し、更に右から順にとられた要素を累積的に kons して行く。
(kons e1 (kons e2 (kons e3 … (kons en knil) … )))
foldl の実装(引数のリストは1個)
(defun foldl (kons knil ls)
(if (null ls)
knil
(foldl kons (funcall kons (car ls) knil) (cdr ls))))
(foldl 'cons nil '(1 2 3))
=>(3 2 1)
;; trace
1 -> foldl: kons=cons knil=nil ls=(1 2 3)
| 2 -> foldl: kons=cons knil=(1) ls=(2 3)
| | 3 -> foldl: kons=cons knil=(2 1) ls=(3)
| | | 4 -> foldl: kons=cons knil=(3 2 1) ls=nil
| | | 4 <- foldl: (3 2 1)
| | 3 <- foldl: (3 2 1)
| 2 <- foldl: (3 2 1)
1 <- foldl: (3 2 1)
foldr の実装(引数のリストは1個)
(defun foldr (kons knil ls)
(if (null ls)
knil
(funcall kons (car ls) (foldr kons knil (cdr ls)))))
(foldr 'cons nil '(1 2 3))
=>(1 2 3)
;; trace
1 -> foldr: kons=cons knil=nil ls=(1 2 3)
| 2 -> foldr: kons=cons knil=nil ls=(2 3)
| | 3 -> foldr: kons=cons knil=nil ls=(3)
| | | 4 -> foldr: kons=cons knil=nil ls=nil
| | | 4 <- foldr: nil
| | 3 <- foldr: (3)
| 2 <- foldr: (2 3)
1 <- foldr: (1 2 3)
foldr の再帰が解りにくいかも知れない。参考までに同じような再帰プロセスを辿る高階関数を考えてみる。リストの右側から関数を適用して行くので名前を mapc-right とした。この関数は副作用目的なので、kons のような返り値を貼り合わせる糊がない。
(defun mapc-right (func ls)
(unless (null ls)
(mapc-right func (cdr ls))
(funcall func (car ls))))
(mapc-right 'insert '("a" "b" "c"))
cba
=>nil
;; trace
1 -> mapc-right: func=insert ls=("a" "b" "c")
| 2 -> mapc-right: func=insert ls=("b" "c")
| | 3 -> mapc-right: func=insert ls=("c")
| | | 4 -> mapc-right: func=insert ls=nil
| | | 4 <- mapc-right: nil
| | 3 <- mapc-right: nil
| 2 <- mapc-right: nil
1 <- mapc-right: nil
;; 参考
(mapc 'insert '("a" "b" "c"))
abc
=>("a" "b" "c")
fold の使用例
(foldl '+ 0 '(1 2 3 4 5 6 7 8 9 10)) =>55 (foldl '* 1 '(1 2 3 4 5 6 7 8 9 10)) =>3628800 ;; reverse (foldl 'cons nil '(1 2 3 4 5 6 7 8 9 10)) =>(10 9 8 7 6 5 4 3 2 1) ;; 逆順に出力 (foldr (lambda (x k) (princ x (current-buffer))) nil '(1 2 3)) 321
fold (反復)
せっかく再帰で fold を実装しても Emacs Lisp では再帰が使える場面は限られる。変数 max-lisp-eval-depth で再帰の深さが制限されている。末尾呼び出しが最適化されることもない。これでは fold は使えない。反復構文を使って fold を書き直そう。
foldl の実装(引数のリストは1個)
;; cl-do 1
(defun foldl (kons knil ls)
(do ((ls ls (cdr ls))
(knil knil (funcall kons (car ls) knil)))
((null ls) knil)))
;; cl-do 2
(defun foldl (kons knil ls)
(do ((ls ls (cdr ls)))
((null ls) knil)
(setq knil (funcall kons (car ls) knil))))
;; while
(defun foldl (kons knil ls)
(while ls
(setq knil (funcall kons (car ls) knil))
(pop ls))
knil)
;; dolist
(defun foldl (kons knil ls)
(dolist (x ls knil)
(setq knil (funcall kons x knil))))
;; mapc (defun foldl (kons knil ls) (mapc (lambda (x) (setq knil (funcall kons x knil))) ls) knil)
foldr の実装
(defun foldr (kons knil ls) (foldl kons knil (reverse ls)))
iota
Scheme の iota 関数を再帰で定義してみよう。
(defun iota (count &optional start step)
(let ((start (or start 0))
(step (or step 1)))
(if (<= count 0)
nil
(cons start (iota (- count 1) (+ start step) step)))))
CL の defun* を使えば、オプショナル引数にデフォルト値を指定することができる。
(defun* iota (count &optional (start 0) (step 1))
(if (<= count 0)
nil
(cons start (iota (- count 1) (+ start step) step))))
;; cl-labels
(defun* iota (count &optional (start 0) (step 1))
(labels ((rec (count start)
(if (= count 0)
nil
(cons start (rec (- count 1) (+ start step))))))
(rec count start)))
上の3つは再帰なので Emacs では使えない。スタックオーバーフローが発生する前にエラーで止まってしまう。max-lisp-eval-depth の初期値は 300 である。
(iota 100) Debugger entered--Lisp error: (error "Lisp nesting exceeds `max-lisp-eval-depth'")
反復構文を使っていくつか書いてみた。
;; while
(defun iota (count &optional start step)
(let ((start (or start 0))
(step (or step 1))
(result nil))
(while (> count 0)
(setq result (cons start result)
start (+ start step)
count (- count 1)))
(nreverse result)))
;; dotimes
(defun iota (count &optional start step)
(let ((start (or start 0))
(step (or step 1))
(ans nil))
(dotimes (x count (nreverse ans))
(push start ans)
(setq start (+ start step)))))
;; cl-do
(defun* iota (count &optional (start 0) (step 1))
(do ((count count (- count 1))
(start start (+ start step))
(acc nil (cons start acc)))
((<= count 0) (nreverse acc))))
;; foldl
(defun* iota (count &optional (start 0) (step 1))
(nreverse
(foldl (lambda (x k) (cons (+ (car k) step) k))
(list start)
(make-list (- count 1) nil))))
Scheme の SLIB で定義されているもの。list-tabulate を使っている。
(defun list-tabulate (len proc)
(do ((i (- len 1) (- i 1))
(ans '() (cons (funcall proc i) ans)))
((< i 0) ans)))
(defun iota (count &rest args)
(let ((start (if (null args) 0 (car args)))
(step (if (or (null args) (null (cdr args))) 1 (cadr args))))
(list-tabulate count (lambda (idx) (+ start (* step idx))))))
(list-tabulate 10 (lambda (i) (sqrt (1+ i)))) =>(1.0 1.4142135623730951 1.7320508075688772 2.0 2.23606797749979 ...)
factorial (階乗)
階乗を計算する再帰関数 factorial は次のようなものだ。Emacs Lisp でも動作する。
(defun factorial (n)
(if (= n 1)
1
(* n (factorial (- n 1)))))
しかし、Emacs Lisp の場合、再帰の制限の前に扱える整数の範囲を超えてしまうので、11の階乗までしか計算できなかった。12の階乗は 479001600 にならないといけない。
(factorial 11) =>39916800 (factorial 12) =>-57869312
29ビットの2進整数の最大値は10進で268435455になる。これに1を足すと-268435456になり、マニュアルによればこれが Emacs の扱える整数の最小の範囲である。(GNU Emacs 22.1.1)
;; 最大値 (1- (expt 2 28)) =>268435455 #b01111111111111111111111111111 =>268435455 (foldl (lambda (x k) (+ (expt 2 x) k)) 0 (iota 28 0)) =>268435455 ;; 最小値 (expt 2 28) =>-268435456 #b10000000000000000000000000000 =>-268435456 (1+ (foldl (lambda (x k) (+ (expt 2 x) k)) 0 (iota 28 0))) =>-268435456
const (定数を返す関数を返す)
(defun const (x) (lexical-let ((x x)) (lambda (i) x))) (defun const (x) `(lambda (i) ,x)) (list-tabulate 10 (const 1)) =>(1 1 1 1 1 1 1 1 1 1)
compose (関数の合成)
次のは f と g の合成関数を返す。f と g は1引数関数で、返された関数も1引数関数。
(defun compose (f g)
(lexical-let ((f f) (g g))
(lambda (x) (funcall f (funcall g x)))))
(defun compose (f g)
`(lambda (x) (funcall #',f (funcall #',g x))))
(defun compose (f g)
`(lambda (x) (funcall (function ,f) (funcall (function ,g) x))))
(list-tabulate 10 (compose 'sqrt '1+))
=>(1.0 1.4142135623730951 1.7320508075688772 2.0 2.23606797749979 ...)
今度は、On Lisp で定義されている compose を foldr で実装してみた。これは、最後の関数以外は1引数関数で任意の数の関数を合成できる。返り値の関数の引数は最後の関数の引数と同じ。
(defun compose (&rest fns)
(if fns
(lexical-let ((fns fns))
(lambda (&rest args)
(foldr #'funcall (apply (car (last fns)) args) (butlast fns))))
#'identity))
次に、compose を使って complement を実装してみる。
(defun complement (pred) (compose #'not pred)) (mapcar (complement 'evenp) '(1 2 3)) ;=> (t nil t) (mapcar* (complement '=) '(1 2 3) '(1 1 3)) ;=> (nil t nil)
any-pred
Scheme の any-pred を実装してみた。
(defun any-pred (&rest pred)
(lexical-let ((pred pred))
(lambda (&rest args)
(block nil
(mapc (lambda (f)
(let ((r (apply f args)))
(and r (return r))))
pred)
nil))))
(fset 'string-or-symbol? (any-pred 'stringp 'symbolp))
(string-or-symbol? "abc") ;=>t
(string-or-symbol? 'abc) ;=>t
(string-or-symbol? 3) ;=>nil
(fset '<> (any-pred '< '>))
(<> 3 4) ;=>t
(<> 3 3) ;=>nil
(funcall (any-pred (lambda (x) (memq x '(a b c)))
(lambda (x) (memq x '(1 2 3))))
'b)
=>(b c)
every-pred
同じく every-pred 。
(defun every-pred (&rest pred)
(lexical-let ((pred pred))
(lambda (&rest args)
(block nil
(let (ans)
(mapc (lambda (f)
(or (setq ans (apply f args))
(return ans)))
pred)
ans)))))
(defun positive? (x) (> x 0)) (defun negative? (x) (< x 0))
(funcall (every-pred 'oddp 'positive?) 3) ;=> t (funcall (every-pred 'oddp 'positive?) 4) ;=> nil (funcall (every-pred 'oddp 'positive?) -3) ;=>nil (fset 'my-safe-length (every-pred 'listp 'length)) ;safe-length は Emacs にある。 (my-safe-length '(a b c)) ;=> 3 (my-safe-length "aaa") ;=> nil
and=>
ある式を評価した結果が真のときにだけ、その値を使って何らかの処理をしたい場合がある。Emacs Lisp では、評価値で局所変数を束縛しておいて、本体内で束縛変数を使った分岐処理を書くことになると思う。しかし、scheme なら cond 式が使える。
(cond (expr => func))
Emacs Lisp の場合。
(let ((var expr))
(and var
(funcall func var)))
マクロを書いてみた。expr の評価値が真の場合*のみ*、その値で func を呼んだ結果が and=> の評価値となる。expr の値が nil なら nil を返す。
(defmacro and=> (expr func)
(let ((var (make-symbol "var")))
`(let ((,var ,expr))
(and ,var (funcall ,func ,var)))))
(and=> t (const 1)) ;=> 1 (and=> nil (const 1)) ;=> nil
and=> を使った any-pred 。
(defun any-pred (&rest pred)
(lexical-let ((pred pred))
(lambda (&rest args)
(block nil
(mapc (lambda (f)
(and=> (apply f args) (lambda (r) (return r))))
pred)
nil))))
let=>
and=> は式の評価値を関数に渡すが、次の let=> なども考えられると思う。変数 var を式 expr の評価値で束縛して、真の場合*のみ* body を評価する。
(defmacro let=> (var expr &rest body)
`(let ((,var ,expr))
(when ,var
,@body)))
let=> を使った any-pred 。
(defun any-pred (&rest pred)
(lexical-let ((pred pred))
(lambda (&rest args)
(block nil
(mapc (lambda (f) (let=> r (apply f args) (return r)))
pred)
nil))))
for-each
Scheme の for-each は Emacs Lisp の mapc のように副作用目的で使う関数だが、引数のリストを複数とることができる。TSPL で定義されているものを Emacs Lisp で書いてみた。
(defun for-each (f ls &rest more)
(do ((ls ls (cdr ls)) (more more (mapcar #'cdr more)))
((null ls))
(apply f (car ls) (mapcar #'car more))))
実行例
(let ((same-count 0))
(for-each
(lambda (x y)
(if (= x y)
(setq same-count (+ same-count 1))))
'(1 2 3 4 5 6)
'(2 3 3 4 7 6))
same-count)
=>3
この定義は mapcar の動作をはっきりとイメージすれば良く理解できる。
(for-each (compose 'print '+) '(1 2 3) '(4 5 6) '(7 8 9)) 12 15 18 ls = (1 2 3) : more = ((4 5 6) (7 8 9)) ;ls = ls : more = more (apply f 1 (4 7)) ;1 = (car ls) : (4 7) = (mapcar 'car more) (f 1 4 7) =>12 ls = (2 3) : more = ((5 6) (8 9)) ;ls = (cdr ls) : more = (mapcar 'cdr more) (apply f 2 (5 8)) ;2 = (car ls) : (5 8) = (mapcar 'car more) (f 2 5 8) =>15 ls = (3) : more = ((6) (9)) ;ls = (cdr ls) : more = (mapcar 'cdr more) (apply f 3 (6 9)) ;3 = (car ls) : (6 9) = (mapcar 'car more) (f 3 6 9) =>18
map
今度は map を定義してみよう。まずは引数のリストが1個の再帰版。
(defun map1 (f ls)
(if (null ls)
'()
(cons (funcall f (car ls)) (map1 f (cdr ls)))))
(map1 (lambda (x) (* x x)) '(1 2 3)) ;=>(1 4 9)
反復構文を使っても簡単に実装できる。
(defun map1 (f ls)
(do ((ls ls (cdr ls))
(a nil (cons (funcall f (car ls)) a)))
((null ls) (nreverse a))))
(defun map1 (f ls)
(let (a)
(while ls
(push (funcall f (car ls)) a)
(pop ls))
(nreverse a)))
(defun map1 (f ls)
(let (a)
(dolist (x ls (nreverse a))
(push (funcall f x) a))))
複数のリストをとる map は、関数を適用した結果をリストに集めればよいので、for-each の定義からすぐ実装できる。CL に同名の関数があるので、名前を map* とした。
(defun map* (f ls &rest more)
(do ((ls ls (cdr ls)) (more more (mapcar #'cdr more))
(a nil (cons (apply f (car ls) (mapcar #'car more)) a)))
((null ls) (nreverse a))))
実行例
(map* 'car '((a b) (c d) (e f))) ;=>(a c e) (map* 'cadr '((a b) (c d) (e f))) ;=>(b d f) (map* 'cons '(a b c) '(d e f)) ;=>((a . d) (b . e) (c . f)) (map* '+ '(1 2 3) '(4 5 6) '(7 8 9)) ;=>(12 15 18)
fold (リストの畳み込み) 2
引数のリストを複数とることができる fold を実装しよう。for-each や map と似た形で定義できないだろうかと考えた。knil に kons しながら累積して行くところで大夫悩んだ。引数の各リストの長さは同じであるとする。
(defun fold (kons knil ls &rest more)
(do ((ls ls (cdr ls)) (more more (mapcar #'cdr more))
(knil knil (apply
kons
(apply #'list (car ls) (append (mapcar #'car more) (list knil))))))
((null ls) knil)))
quasiquote, unquote, unquote-splicing を使えばすっきり書ける。
(defun fold (kons knil ls &rest more)
(do ((ls ls (cdr ls)) (more more (mapcar #'cdr more))
(knil knil (apply kons `(,(car ls) ,@(mapcar #'car more) ,knil))))
((null ls) knil)))
実行例
(fold 'cons '() '(1 2 3)) ;=>(3 2 1) (fold 'list '() '(1 2 3) '(4 5 6)) ;=>(3 6 (2 5 (1 4 nil))) (fold '+ 0 '(1 2 3) '(4 5 6) '(7 8 9)) ;=>45 (fold 'acons '() '(1 2 3) '(4 5 6)) ;=>((3 . 6) (2 . 5) (1 . 4))
次は fold-right の定義。初め、apply を使うことが思い浮かばず、少し悩んだ。
(defun fold-right (kons knil ls &rest more) (apply #'fold kons knil (reverse ls) (mapcar #'reverse more)))
実行例
(fold-right 'cons '() '(a b c d e)) ;=>(a b c d e) (fold-right 'list '() '(1 2 3) '(4 5 6)) ;=>(1 4 (2 5 (3 6 nil))) (fold-right '+ 0 '(1 2 3) '(4 5 6) '(7 8 9)) ;=>45 (fold-right 'acons '() '(1 2 3) '(4 5 6)) ;=>((1 . 4) (2 . 5) (3 . 6))
以上の定義で、mapcar の代わりに定義済みの map* を使っても上手く行く。
let1
Gauche の let1 がとても便利だ。Emacs Lisp でも使いたい。
(defmacro let1 (var expr &rest body)
`(let ((,var ,expr))
,@body))
let は lambda 式で書けるので次のようにも定義できる。
(defmacro let1 (var expr &rest body) `((lambda (,var) ,@body) ,expr))
circular-list
循環リストを構築する circular-list を定義してみた。1個以上のオブジェクトを引数にとる。
(defun circular-list (obj &rest args)
(let1 cl (cons obj args)
(setcdr (last cl) cl)
cl))
(let1 cl (circular-list 1 2 3 4 5) cl) =>(1 2 3 4 5 1 2 3 4 . #4) (let1 cl (circular-list 1 2 3 4 5) (nth 9 cl)) =>5
循環リストかどうかを調べる circular-list-p も定義した。
(defun circular-list-p (ls)
(do ((fast (cddr ls) (cddr fast))
(slow (cdr ls) (cdr slow)))
((null fast))
(and (equal fast slow) (return t))))
(let1 cl (apply 'circular-list (iota 10)) (circular-list-p cl)) =>t (let1 cl (iota 10) (circular-list-p cl)) =>nil
filter
filter は、リストに pred を適用した結果、真を返す要素を集める。
(defun filter (pred ls)
(if (null ls)
nil
(let1 o (car ls)
(if (funcall pred o)
(cons o (filter pred (cdr ls)))
(filter pred (cdr ls))))))
(defun filter (pred ls)
(do ((ls ls (cdr ls))
(a nil (let1 o (car ls)
(if (funcall pred o) (cons o a) a))))
((null ls) (nreverse a))))
(defun filter (pred ls)
(let (a)
(while ls
(let1 o (car ls)
(when (funcall pred o) (push o a)))
(pop ls))
(nreverse a)))
(defun filter (pred ls)
(let (a)
(dolist (x ls (nreverse a))
(and (funcall pred x) (push x a)))))
(filter 'evenp (iota 10)) =>(0 2 4 6 8)
append-map
append-map は map の結果を平坦化する。定義済みの map* か CL の mapcar* を使う(CL の mapcan と同じようなもの？)。SICP では、flatmap として定義されている。Haskell や OCaml では concatMap というらしい。
(defun append-map (f ls &rest more) (apply 'append (apply 'map* f ls more)))
fringe
append-map を使って、fringe を定義する。fringe は、引数として木をとり、木のすべての要素を左から右の順に並べたリストを返す(SICP Exercise 2.28)。
(defun fringe (tree)
(if (listp tree)
(append-map 'fringe tree)
(list tree)))
count-leaves
count-leaves (SICP Exercise 2.35) は木の、葉の数をすべて数える。定義済みの fold を使った。
(defun count-leaves (tree) (foldl (lambda (x y) (if (consp x) (+ (count-leaves x) y) (+ 1 y))) 0 tree)) (defun count-leaves (tree) (foldl '+ 0 (mapcar (lambda (s) (if (consp s) (count-leaves s) 1)) tree)))
count
count を定義した。CL に同名の関数があるので count* とした。
(defun count* (pred ls &rest more)
(let* ((x (cons ls more))
(n (apply 'min (mapcar 'length (cons ls more)))))
(do ((n n (- n 1))
(x x (mapcar 'cdr x))
(ans 0 (if (apply pred (mapcar 'car x)) (+ ans 1) ans)))
((= n 0) ans))))
関数名の変更
Emacs Lisp では名前空間が共有されるので、関数名にプレフィックスを付けて名前をユニークにするのが慣習だ。一般に、プレフィックスと残りのシンボルを `-' で分けるのだが、`-' は打ちにくいので、`:' で分けて Scheme の `s' の一文字をプレフィックスにすることにした(コンパイル時に展開されるマクロはそのままにする)。CL の関数名と衝突するのを避けるために付けた `*' も取ることにした。したがって、count* だったら s:count になる。
count では、「与えられたリストのうち最も短いリスト」という仕様を満たすように定義したが、他の関数も合わせて修正する。
filter-map
filter-map は、filter と map を組み合わせたもの。真になる場合の結果を集める。
(defun s:filter-map (f ls &rest more)
(let* ((x (cons ls more))
(n (apply 'min (mapcar 'length x))))
(do ((n n (- n 1))
(x x (mapcar 'cdr x))
(ans nil (let1 r (apply f (mapcar 'car x))
(if r (cons r ans) ans))))
((= n 0) (nreverse ans)))))
(s:filter-map (lambda (x) (and (numberp x) (* x x))) '(a 1 b 3 c 7)) =>(1 9 49)
take / drop / split-at
(defun s:take (x i)
(do ((i (- i 1) (- i 1)) (x x (cdr x))
(ans nil (cons (car x) ans)))
((or (< i 0) (null x)) (nreverse ans))))
(defun s:drop (x i) (nthcdr i x))
(defun s:split-at (x i)
(if (or (> i (length x))
(< i 0))
(error "Given list is too short: %S" x)
(list (s:take x i) (s:drop x i))))
(s:take '(a b c d e) 2) => (a b) (s:drop '(a b c d e) 2) => (c d e) (s:split-at '(a b c d e) 2) => ((a b) (c d e))
find / list-index / last
find と list-index と last を定義した。find は pred が真を返す最初の要素を返す。
(defun s:find (pred ls)
(do ((ls ls (if (funcall pred (car ls))
(return (car ls))
(cdr ls))))
((null ls) nil)))
(defun s:list-index (pred ls)
(do ((i 0 (+ i 1))
(ls ls (if (funcall pred (car ls))
(return i)
(cdr ls))))
((null ls) nil)))
(defun s:last (ls) (car (last ls)))
partition
partition を定義した。
(defun s:partition (pred ls)
(do ((ls ls (cdr ls))
(drop nil)
(take nil (if (funcall pred (car ls))
(cons (car ls) take)
(push (car ls) drop)
take)))
((null ls) (list (nreverse take) (nreverse drop)))))
(s:partition 'oddp '(3 1 4 5 9 2 6)) =>((3 1 5 9) (4 2 6))
take-while / drop-while
take-while と drop-while を定義した。
(defun s:take-while (pred ls)
(do ((ls ls (cdr ls))
(ans nil (if (funcall pred (car ls))
(cons (car ls) ans)
(return (nreverse ans)))))
((null ls) (nreverse ans))))
(defun s:drop-while (pred ls)
(do ((ls ls (if (funcall pred (car ls))
(cdr ls)
(return ls))))
((null ls) ls)))
any / every
(defun s:any (pred ls &rest more)
(let* ((x (cons ls more))
(n (apply 'min (mapcar 'length x))))
(do ((n n (- n 1))
(x x (mapcar 'cdr x))
(ans (apply pred (mapcar 'car x))
(apply pred (mapcar 'car x))))
((= n 0) ans)
(when ans (return ans)))))
(defun s:every (pred ls &rest more)
(let* ((x (cons ls more))
(n (apply 'min (mapcar 'length x))))
(do ((n n (- n 1))
(x x (mapcar 'cdr x))
(ans (apply pred (mapcar 'car x))
(apply pred (mapcar 'car x))))
((= n 0) ans)
(unless ans (return nil)))))