Why Functional Programming Matters

LISP Programming

先日の関数型言語勉強会@北海道で「なぜ関数プログラミングは重要か」を印刷したプリントを全員に配布していました。カフェとかでも気軽に読めて重宝しました。笑
うちにも一応プリンタあるんだけど、超古くて動作遅いし、ヘッドクリーニングしても謎の線（！）が沢山出てくるのでほとんど使っていない。プリンタ欲しいなぁ。。。


話が反れてしまった。
それで、勉強がてら論文中の「3.関数の貼り合わせ」に出てくる関数たち（論文中のソースはMirandaで書かれている）をCommon Lispで書いてみました。なぜLispかは聞いてはいけない。
Lispのイディオムとか関係無しに、なるべく原文に似せて書いたつもり・・・。（背景色白の方が原文（引用））
もし変なところとかあったらご指摘願います。一通り書き終わってから思ったけど、Schemeで書けば良かった。。（funcallだらけ）

           +---+
sum nil =  | 0 |
           +---+
                          +---+
sum (cons num list) = num | + |  sum list
                          +---+
CL-USER > (defun sum (lst)
            (if (null lst)
                0
              (+ (car lst) (sum (cdr lst))) ))
SUM

CL-USER > (sum '(1 2 3))
6

sum = reduce add 0

ここに出現するreduceとCommon Lispのreduceは仕様が違うのでreduce2として定義し直した

CL-USER > (defun reduce2 (fn n)
            #'(lambda (lst)
                (reduce fn lst
                        :from-end t
                        :initial-value n)))
REDUCE2

CL-USER > (setq sum2 (reduce2 #'+ 0))
#<anonymous interpreted function 216D1242>

CL-USER > (funcall sum2 '(1 2 3))
6

product =  reduce multiply 1

anytrue =  reduce or false

alltrue =  reduce and true

Lispのorとandはマクロなのでちょっと加工

CL-USER > (setq product (reduce2 #'* 1))
#<anonymous interpreted function 200BAC3A>

CL-USER > (funcall product '(2 3 4))
24

CL-USER > (defun or2 (a b)
            (or a b))
OR2

CL-USER > (defun and2 (a b)
            (and a b))
AND2

CL-USER > (setq anytrue (reduce2 #'or2 nil))
#<anonymous interpreted function 21753F6A>

CL-USER > (funcall anytrue '(nil nil 1 nil))
1

CL-USER > (funcall anytrue '(nil nil nil nil))
NIL

CL-USER > (setq alltrue (reduce2 #'and2 t))
#<anonymous interpreted function 216C86AA>

CL-USER > (funcall alltrue '(1 2 3 nil 4 5))
NIL

CL-USER > (funcall alltrue '(1 2 3 4 5))
T

append a  b =  reduce cons b a

append [1,2] [3,4] = reduce cons [3,4] [1,2]
                   = (reduce cons [3,4]) (cons 1 (cons 2  nil))
                   = cons 1  (cons 2 [3,4]))
                             (replacing cons by  cons and nil by [3,4])
                   = [1,2,3,4]
CL-USER > (setq append2
                #'(lambda (a b)
                    (funcall (reduce2 #'cons b) a) ))
#<anonymous interpreted function 200E51CA>

CL-USER > (funcall append2 '(1 2 3) '(4 5 6))
(1 2 3 4 5 6)

doubleall = reduce (cons . double) nil
〜
doubleall = map double
map f =  reduce (cons .  f) nil
〜
summatrix = sum .  map sum
CL-USER > (setq doubleall
                (reduce2 #'(lambda (a b) (cons (* 2 a) b)) nil) )
#<anonymous interpreted function 200F91AA>

CL-USER > (funcall doubleall '(1 2 3 4 5))
(2 4 6 8 10)

CL-USER > (defun map2 (fn)
            (reduce2 #'(lambda (a b) (cons (funcall fn a) b)) nil))
MAP2

CL-USER > (setq doubleall2 (map2 #'(lambda (n) (* 2 n))))
#<anonymous interpreted function 216E6832>

CL-USER > (funcall doubleall2 '(1 2 3 4 5))
(2 4 6 8 10)

;;sumは最初の方で定義した関数
CL-USER > (defun summatrix (lst)
            (sum (funcall (map2 #'sum) lst)) )
SUMMATRIX

CL-USER > (summatrix '((1 2 3) (4 5 6) (7 8 9 10)))
55


ここからはツリー

node 1
    (cons (node 2  nil)
          (cons (node 3
                     (cons (node 4 nil) nil))
                nil))

redtree f  g a  (node label subtrees) =
        f label (redtree' f g a subtrees)
redtree' f g  a  (cons subtree rest) =
         g  (redtree f g  a subtree) (redtree' f g a rest)
redtree' f g  a  nil = a
CL-USER > 
;;検証用に使うやつ
(setq test-tree
      (cons 1
            (cons (cons 2 nil)
                  (cons (cons 3
                              (cons (cons 4 nil) nil))
                        nil))))
(1 (2) (3 (4)))

CL-USER > 
(defun redtree2 (f g a)
  #'(lambda (node)
      (if (consp node)
          (funcall g
                   (funcall (redtree f g a) (car node))
                   (funcall (redtree2 f g a) (cdr node)) )
        a)))
REDTREE2

CL-USER > 
(defun redtree (f g a)
  #'(lambda (tree)
      (funcall f
               (car tree)
               (funcall (redtree2 f g a) (cdr tree)) )))
REDTREE

sumtree =  redtree add add 0

add 1
   (add (add 2 0)
        (add (add 3
             (add (add 4 0)  0))
                  0))
= 10
CL-USER > (setq sumtree (redtree #'+ #'+ 0))
#<anonymous interpreted function 217749BA>

CL-USER > (funcall sumtree test-tree)
10

labels =  redtree cons append nil

cons 1
     (append (cons 2 nil)
             (append (cons 3
                           (append (cons 4 nil) nil))
                     nil))
= [1,2,3,4]
CL-USER > (setq labels (redtree #'cons append2 nil))
#<anonymous interpreted function 20094AEA>

CL-USER > (funcall labels test-tree)
(1 2 3 4)

maptree f  = redtree (node . f) cons nil
CL-USER > 
(defun maptree (f)
  (redtree #'(lambda (a b) (cons (funcall f a) b))
           #'cons
           nil))
MAPTREE

CL-USER > (funcall (maptree #'1+) test-tree)
(2 (3) (4 (5)))


これらの書き方がLispとして良いかどうかは別として（笑）何とか終わった。
4章以降は遅延評価について書かれているんですが、これはHaskellを勉強した時にでも...（逃