LISPUSER

LISPMEMOLisp is a programmable programming language. -- John Foderaro

(top)  (memo)  (rss)

Common Lisp や Prolog で Reduce(l|r)

404 Blog Not Found:Code Snippets - reduce(l|r)を実装汁! ネタ。 Common Lisp には標準であったので話にならなかった。10 分を切れてよかった。

(defun reducel (fn lst) (reduce fn lst))
(defun reducer (fn lst) (reduce fn lst :from-end t))

つまらないので Prolog 版。うむ、やっぱり Prolog はいい。call で高階関数も使えるし(funcall が許せない人には不評かもしれないが)。

% reducel/3
reducel(Fn, [Head | Tail], Result) :- reducel(Fn, Head, Tail, Result).
% reducel/4
reducel(_, Result, [], Result).
reducel(Fn, Init, [Head | Tail], Result) :-
    call(Fn, Init, Head, Temp),
    reducel(Fn, Temp, Tail, Result).

% reducer/3
reducer(Fn, List, Result) :-
    reverse(List, [Init | Temp]),
    reverse(Temp, Tail),
    reducer(Fn, Init, Tail, Result).
% reducer/4
reducer(_, Result, [], Result).
reducer(Fn, Init, [Head | Tail], Result) :-
    reducer(Fn, Init, Tail, Temp),
    call(Fn, Head, Temp, Result).

ついでに Allegro Prolog 版。直訳。

;; reducel/3
(<-- (reducel ?fn (?x . ?xs) ?result) (reducel ?fn ?x ?xs ?result))
;; reducel/4
(<-- (reducel ? ?result () ?result))
(<-  (reducel ?fn ?init (?x . ?xs) ?result)
     (is ?temp (funcall ?fn ?init ?x))
     (reducel ?fn ?temp ?xs ?result))

;; reducer/3
(<-- (reducer ?fn ?lst ?result)
     (is (?x ?xs) (list (first (last ?lst))
            (butlast ?lst)))
     (reducer ?fn ?x ?xs ?result))
;; reducer/4
(<-- (reducer ? ?result () ?result))
(<-  (reducer ?fn ?init (?x . ?xs) ?result)
     (reducer ?fn ?init ?xs ?temp)
     (is ?result (funcall ?fn ?x ?temp)))

最後に組み込みの reduce を使わずに CL で書いた例。 Scheme の人が再帰版は書くでしょうからあえて反復で。

;; Scheme かぶれ fold
(defun fold (fn init lst)
  (do* ((result init (funcall fn (car lst) result))
           (lst lst (cdr lst)))
       ((null lst) result)))

;; 今回ほしい foldl == (fold (lambda (x y) (funcall fn y x)) init lst)
(defun foldl (fn init lst)
  (do* ((result init (funcall fn result (car lst)))
        (lst lst (cdr lst)))
       ((null lst) result)))

(defun foldr (fn init lst &aux (lst (reverse lst)))
  (do* ((result init (funcall fn (car lst) result))
       (lst lst (cdr lst)))
       ((null lst) result)))
;; リスト専用 Reduce 実装 == (fold fn (car lst) (cdr lst))
(defun reducel (fn lst)
  (do* ((result (car lst) (funcall fn result (car lst)))
        (lst (cdr lst) (cdr lst)))
       ((null lst) result)))

;; リスト専用 Reduce 実装 == (foldr fn (car (last lst)) (reverse (butlast lst)))
(defun reducer (fn lst &aux (lst (reverse lst)))
  (do* ((result (car lst) (funcall fn (car lst) result))
        (lst (cdr lst) (cdr lst)))
       ((null lst) result)))

ネイティブコンパイラを備えた処理系だと、実はこんなんでも組み込みの reduce に迫る勢い。 いや、組み込みの reduce はシーケンス全般に使えるので全然違うんだけど。

記憶によれば srfi-1 の fold はここで「Scheme かぶれ」と紹介している fold だった記憶がある。 reduce も fold 使て実現していたような。 (funcall fn (car lst) init) の語順でないと

(fold cons () '(1 2 3 4)) == (reverse '(1 2 3 4)) == '(4 3 2 1)
(foldr cons () '(1 2 3 4)) == (copy-sequence '(1 2 3 4)) == '(1 2 3 4)

が実現できないからだ。今回の課題の fold だと、 (fold cons () '(1 2 3 4)) => ((((nil . 1) . 2) . 3) . 4) となるはず。Scheme かぶれだと (fold cons () '(1 2 3 4)) => '(4 3 2 1) になる。 どっちが正しいんだっけかな?正しいとかあるのか?まぁ、 (lambda (fn x y) (funcall fn y x)) をかませば相互変換可能なのでどうでもいいのだが。

んで、この fold 系は特に Schemer が大好きだ。Lisper が reduce をキメたら気持ち良いような場所で fold を使ってくる可能性がある。 そこで、この企画。

Common Lisper のための畳み込み入門 (fold)

Common Lisp なら reduce ! reduce を使うべし! これはリスト(には限らないが、Schemer に話を合わせるためリストのみに限定して解説する)を ズバっと一発で処理するためのオペレータだ。mapcar よりも一般的なオペレータだ。

大抵のリスト処理オペレータはこれを使って実装できる。

(defpackage :util.reduce (:use :cl)
            (:export #:mapcar #:reverse #:copy-list #:length #:filter)
            (:shadow :mapcar :reverse :copy-list :length))
(in-package :util.reduce)

(defun mapcar (fn lst)
  (reduce (lambda (x y) 
            (cons (funcall fn x) y))
          lst
          :from-end t
          :initial-value nil))

(defun reverse (lst)
  (reduce (lambda (x y) (cons y x))
          lst
          :initial-value nil))

(defun copy-list (lst)
  (reduce #'cons
          lst
          :from-end t
          :initial-value nil))

(defun length (lst)
  (reduce (lambda (x y)
            (declare (ignore y))
            (+ x 1))
          lst
          :initial-value 0))

(defun filter (fn lst)
  (reduce (lambda (x y)
            (if (funcall fn x)
                (cons x y)
                y))
          lst
          :from-end t
          :initial-value nil))

全部 reduce で。まぁ LOOP つかったほうがてっとりばやい時もあるし…と思う私は非関数型 Lisp 脳かも。

さて、最初はこんなの見てもわからないと思います。私はさっぱりでした。やっぱり実装をいろいろ見るべきでしょう。

;; Common Lisp
(defun fold (fn init lst)
  (do* ((result init (funcall fn result (car lst)))
        (lst lst (cdr lst)))
       ((null lst) result)))

(defun foldr (fn init lst &aux (lst (reverse lst)))
  (do* ((result init (funcall fn (car lst) result))
        (lst lst (cdr lst)))
       ((null lst) result)))
;; Allegro Prolog
(<-- (fold ?_ ?result () ?result))
(<-  (fold ?fn ?init (?x . ?xs) ?result)
     (is ?temp (funcall ?fn ?init ?x))
     (fold ?fn ?temp ?xs ?result))

(<-- (foldr ?_ ?result () ?result))
(<-  (foldr ?fn ?init (?x . ?xs) ?result)
     (foldr ?fn ?init ?xs ?temp)
     (is ?result (funcall ?fn ?x ?temp)))
% Prolog
foldl(_, Result, [], Result).
foldl(Fn, Init, [Head | Tail], Result) :- call(Fn, Head, Init, Temp), foldl(Fn, Temp, Tail, Result).

foldr(_, Result, [], Result).
foldr(Fn, Init, [Head | Tail], Result) :- foldr(Fn, Init, Tail, Temp), call(Fn, Head, Temp, Result).

リストを左から畳んでゆくのが fold で右から畳んでゆくのが foldr。 イメージトレーニングしましょう。

(fold #'+ 0 '(1 2 3 4)
--> (funcall #'+ 1 0)
(fold #'+ 1 '(2 3 4))
--> (funcall #'+ 2 '(1))
(fold #'+ 3 '(3 4))
--> (funcall #'+ 3 3)
(fold #'+ 6 '(4))
--> (funcall #'+ 4 6)
(fold #'+ 10 ())
=> 10
(foldr #'+ 0 '(1 2 3 4))
  (foldr #'+ 0 '(2 3 4))
    (foldr #'+ 0 '(3 4))
      (foldr #'+ 0 '(4))
        (foldr #'+ 0 ())
        --> 0
      (+ 4 0)
      --> 4
    (+ 3 4)
    --> 7
  (+ 2 7)
   --> 9
(+ 1 9)
=> 10
;; これは  (+ 1 (+ 2 (+ 3 (+ 4 0)))) とかんがえる
(fold #'cons () '(1 2 3 4)
--> (funcall #'cons 1 ())
(fold #'cons '(1) '(2 3 4))
--> (funcall #'cons 2 '(1))
(fold #'cons '(2 1) '(3 4))
--> (funcall #'cons 3 '(2 1))
(fold #'cons '(3 2 1) '(4))
--> (funcall #'cons 4 '(3 2 1))
(fold #'cons '(4 3 2 1) ())
=> '(4 3 2 1)
(foldr #'cons () '(1 2 3 4))
  (foldr #'cons () '(2 3 4))
    (foldr #'cons () '(3 4))
      (foldr #'cons () '(4))
        (foldr #'cons () ())
        --> ()
      (cons 4 ())
      --> '(4)
    (cons 3 '(4))
    --> '(3 4)
  (cons 2 '(3 4))
   --> '(2 3 4)
(cons 1 '(2 3 4))
=> '(1 2 3 4)
;; これは  (cons 1 (cons 2 (cons 3 (cons 4 ())))) とかんがえる

でもまぁ、理屈に弱い人は何回か手をうごかして実装したほうがはやいかもしれません。 私も何回聞いてもさっぱりわかりませんでしたが、ひたすら実装とテストを繰り返す内に覚えられました。 ここまでやって気がつきましたが、今回は foldr も再帰で実装したわけじゃないからこの説明の動作しませんね…。

(defun fold (fn init lst)
   (if (null lst)
       init
       (fold fn (funcall fn (car lst) init) (cdr lst))))
(defun foldr (fn init lst)
   (if (null lst)
       init
       (funcall fn (car lst) (foldr fn init (cdr lst)))))
CL-USER> (defun fold (fn init lst)
           (if (null lst)
               init
               (fold fn (funcall fn (car lst) init) (cdr lst))))

FOLD
CL-USER> (trace fold)
;; Tracing function FOLD.
(FOLD)
CL-USER> (fold #'+ 0 '(1 2 3 4))
1. Trace: (FOLD '#<SYSTEM-FUNCTION +> '0 '(1 2 3 4))
2. Trace: (FOLD '#<SYSTEM-FUNCTION +> '1 '(2 3 4))
3. Trace: (FOLD '#<SYSTEM-FUNCTION +> '3 '(3 4))
4. Trace: (FOLD '#<SYSTEM-FUNCTION +> '6 '(4))
5. Trace: (FOLD '#<SYSTEM-FUNCTION +> '10 'NIL)
5. Trace: FOLD ==> 10
4. Trace: FOLD ==> 10
3. Trace: FOLD ==> 10
2. Trace: FOLD ==> 10
1. Trace: FOLD ==> 10
10

CL-USER> (defun foldr (fn init lst)
            (if (null lst)
                init
                (funcall fn (car lst) (foldr fn init (cdr lst)))))

FOLDR
CL-USER> (trace foldr)
;; Tracing function FOLDR.
(FOLDR)
CL-USER> (foldr #'+ 0 '(1 2 3 4))
1. Trace: (FOLDR '#<SYSTEM-FUNCTION +> '0 '(1 2 3 4))
2. Trace: (FOLDR '#<SYSTEM-FUNCTION +> '0 '(2 3 4))
3. Trace: (FOLDR '#<SYSTEM-FUNCTION +> '0 '(3 4))
4. Trace: (FOLDR '#<SYSTEM-FUNCTION +> '0 '(4))
5. Trace: (FOLDR '#<SYSTEM-FUNCTION +> '0 'NIL)
5. Trace: FOLDR ==> 0
4. Trace: FOLDR ==> 4
3. Trace: FOLDR ==> 7
2. Trace: FOLDR ==> 9
1. Trace: FOLDR ==> 10
10
CL-USER> (fold #'cons nil '(1 2 3 4))
1. Trace: (FOLD '#<SYSTEM-FUNCTION CONS> 'NIL '(1 2 3 4))
2. Trace: (FOLD '#<SYSTEM-FUNCTION CONS> '(1) '(2 3 4))
3. Trace: (FOLD '#<SYSTEM-FUNCTION CONS> '(2 1) '(3 4))
4. Trace: (FOLD '#<SYSTEM-FUNCTION CONS> '(3 2 1) '(4))
5. Trace: (FOLD '#<SYSTEM-FUNCTION CONS> '(4 3 2 1) 'NIL)
5. Trace: FOLD ==> (4 3 2 1)
4. Trace: FOLD ==> (4 3 2 1)
3. Trace: FOLD ==> (4 3 2 1)
2. Trace: FOLD ==> (4 3 2 1)
1. Trace: FOLD ==> (4 3 2 1)
(4 3 2 1)
CL-USER> (foldr #'cons nil '(1 2 3 4))
1. Trace: (FOLDR '#<SYSTEM-FUNCTION CONS> 'NIL '(1 2 3 4))
2. Trace: (FOLDR '#<SYSTEM-FUNCTION CONS> 'NIL '(2 3 4))
3. Trace: (FOLDR '#<SYSTEM-FUNCTION CONS> 'NIL '(3 4))
4. Trace: (FOLDR '#<SYSTEM-FUNCTION CONS> 'NIL '(4))
5. Trace: (FOLDR '#<SYSTEM-FUNCTION CONS> 'NIL 'NIL)
5. Trace: FOLDR ==> NIL
4. Trace: FOLDR ==> (4)
3. Trace: FOLDR ==> (3 4)
2. Trace: FOLDR ==> (2 3 4)
1. Trace: FOLDR ==> (1 2 3 4)
(1 2 3 4)
CL-USER> 

この再帰形式の定義の場合、fold は末尾再帰なのでコンパイル時の最適化によりループと同じ効率で動作します。

CL-USER> (disassemble 'fold)

Disassembly of function FOLD
3 required arguments
0 optional arguments
No rest parameter
No keyword parameters
14 byte-code instructions:
0     (LOAD&JMPIF 1 L9)
3     L3
3     (LOAD 2)
4     (SKIP&RET 4)
6     L6
6     (LOAD&JMPIFNOT 1 L3)
9     L9
9     (LOAD&PUSH 3)
10    (LOAD&PUSH 4)
11    (LOAD&CAR&PUSH 3)
13    (LOAD&PUSH 5)
14    (FUNCALL&PUSH 2)
16    (LOAD&CDR&PUSH 3)
18    (JMPTAIL 3 7 L6)    <--- 末尾再帰の VM 命令
NIL

最後のおまけ:

Extra Credit

Haskellのfold(l|r)は、なぜfoldx binop []ではなくfoldx binop init []という具合に初期値を必要とするのか、その理由を述べよ。

引数が空リストなったときに実行時エラーになるのが嫌だからですかね?型だけだと要素数が 1 以上である事を指定できなさそうだし。

posted: 2007/05/29 23:08 | permanent link to this entry | Tags: MISC

(top)  (memo)  (rss)