vallog: 2009/01

2009/01/28

[scheme][Gauche][DrScheme]組み合わせ（combination）

この記事を見て、組み合わせを書いてみたくなり、書いてみました。
[アルゴリズム][C#2.0][C#3.0]C#で順列(Permutation)と組み合わせ(Combination)をすべて列挙してみよう
 http://d.hatena.ne.jp/zecl/20090127/p1

結局この辺をカンニングしまくりorz

[scheme]組合せのアルゴリズム
 http://d.hatena.ne.jp/ibaza/20080303/1204476552

ArcでL-99 (P26 リストから指定した個数を抜き出す組み合わせ)
http://cadr.g.hatena.ne.jp/g000001/20080302/1204443536

組合せ
 http://katamayu.net/archives/2006/05/11/012239

最初に書いてみたcombination手続き。

参考にしたのは[scheme]組合せのアルゴリズムのこのアルゴリズム。

nCr（n個からr個取り出す組合せ）は、

1. リストの先頭要素を除いた残りのリストからr-1個を選ぶ組合せのそれぞれに先頭要素を加えたものと、

2. リストの先頭要素を除いたリストからr個を選ぶ組合せ
の合計となる(1および2はそれぞれ再帰処理となる)。

3. n = r のときは選び方は一つなのでリストをそのままリストにして返す。例：(a b c) なら ((a b c)) にして返す

4. r = 1 のときは選び方はn通りあるのでリストの要素をそれぞれリストにして返す。例：(a b c) なら ((a) (b) (c)) にして返す

5. r = 0 または r がリストの要素数より大きいときは空リストを返す。

で、上記のアルゴリズムをそのまま写経したつもりなのがこれ。

;; combination
(define (combination ls r)
(cond
   ((or (null? ls)(null? ls)) '())
   ((or (zero? r)(> r (length ls))) '())
   ((= r 1)(map list ls))
   ((= r (length ls))(list ls))
   (else
    (cons (map (lambda (n)(cons (car ls) n))(combination (cdr ls)(- r 1)))
        (combination (cdr ls) r)))))

出力結果。
出力結果のリストがネストしてる・・・。

(combination '() 1) ;; => ()
(combination '(1 2 3) 4) ;; => ()
(combination '(1 2 3) 1) ;; => ((1) (2) (3))
(combination '(1 2 3) 3) ;; => ((1 2 3))
(combination '(1 2 3 4 5) 2)
;; => (((1 2) (1 3) (1 4) (1 5)) ((2 3) (2 4) (2 5)) ((3 4) (3 5)) (4 5))
(combination '(1 2 3 4 5) 3)
;; => (((1 (2 3) (2 4) (2 5)) (1 (3 4) (3 5)) (1 . #0=(4 5))) ((2 (3 4) (3 5)) (2 . #0#)) (3 . #0#))
(combination '(1 2 3 4 5) 4)
;; => (((1 (2 (3 4) (3 5)) (2 . #0=(4 5))) (1 . #1=(3 . #0#))) (2 . #1#))

cond ～ elseのelseのとこのconsがまずいことに気づく。
組合せをみてappend手続きがあることを知る。修正版combination。

;; combination
(define (combination ls r)
(cond
   ((or (null? ls)(null? ls)) '())
   ((or (zero? r)(> r (length ls))) '())
   ((= r 1)(map list ls))
   ((= r (length ls))(list ls))
   (else
    (append (map (lambda (n)(cons (car ls) n))
         (combination (cdr ls)(- r 1)))
        (combination (cdr ls) r)))))

出力結果。
今度はうまくいったはず！と、思いきや「#0=」「#1=」「#0#」「#1#」ってのが混ざってる・・・。これなに？なんか変な対ができてる・・・orz

(combination '() 1) ;; => ()
(combination '(1 2 3) 4) ;; => ()
(combination '(1 2 3) 1) ;; => ((1) (2) (3))
(combination '(1 2 3) 3) ;; => ((1 2 3))
(combination '(1 2 3 4 5) 2)
;; => ((1 2) (1 3) (1 4) (1 5) (2 3) (2 4) (2 5) (3 4) (3 5) (4 5))
(combination '(1 2 3 4 5) 3)
;; => ((1 2 3) (1 2 4) (1 2 5) (1 3 4) (1 3 5) (1 . #0=(4 5)) (2 3 4) (2 3 5) (2 . #0#) (3 . #0#))
(combination '(1 2 3 4 5) 4)
;; => ((1 2 3 4) (1 2 3 5) (1 2 . #0=(4 5)) (1 . #1=(3 . #0#)) (2 . #1#))

試しに同じcombination手続きをDrSchemeで実行してみたら、意図した通りに出力されてるっぽいのに・・・。

(combination '() 1)
(combination '(1 2 3) 4)
(combination '(1 2 3) 1)
(combination '(1 2 3) 3)
(combination '(1 2 3 4 5) 2)
(combination '(1 2 3 4 5) 3)
(combination '(1 2 3 4 5) 4)

DrSchemeでの実行結果。うまくいってるっぽい・・・。

()
()
((1) (2) (3))
((1 2 3))
((1 2) (1 3) (1 4) (1 5) (2 3) (2 4) (2 5) (3 4) (3 5) (4 5))
((1 2 3) (1 2 4) (1 2 5) (1 3 4) (1 3 5) (1 4 5) (2 3 4) (2 3 5) (2 4 5) (3 4 5))
((1 2 3 4) (1 2 3 5) (1 2 4 5) (1 3 4 5) (2 3 4 5))

Gauche（gosh）でのこの結果はどういうこと？

;; => ((1 2) (1 3) (1 4) (1 5) (2 3) (2 4) (2 5) (3 4) (3 5) (4 5))
(combination '(1 2 3 4 5) 3)
;; => ((1 2 3) (1 2 4) (1 2 5) (1 3 4) (1 3 5) (1 . #0=(4 5)) (2 3 4) (2 3 5) (2 . #0#) (3 . #0#))
(combination '(1 2 3 4 5) 4)
;; => ((1 2 3 4) (1 2 3 5) (1 2 . #0=(4 5)) (1 . #1=(3 . #0#)) (2 . #1#))

追記：

Twitterにて

valvallow	Gauche で #0# とか #0= とか #1= とか出力されちゃってる状態なんだけど、これなに？
valvallow	(((1 (2 (3 4) (3 5)) (2 . #0=(4 5))) (1 . #1=(3 . #0#))) (2 . #1#))
valvallow	みたいな
valvallow	gosh> ((1 2 3) (1 2 4) (1 2 5) (1 3 4) (1 3 5) (1 . #0=(4 5)) (2 3 4) (2 3 5) (2 . #0#) (3 . #0#))
valvallow	DrScheme で同じコード実行してもでてこねー。
kosugi	@valvallow 同じオブジェクト参照の意じゃないかな
valvallow	@kosugi なるほど！ぽいですね！ありがとうございます＞＜

2009/01/26

[scheme][Gauche]for-each, tree-walk, reverse-tree-walk

「プログラミングGauche」P.64～ 66 7.2 手続きを取る手続き

ようは高階関数ということで。foldも高階関数ですね。

for-eachを試してみる。

(for-each (lambda (n) (print (* n n))) '(1 2 3 4 5))

;; => gosh> 1
;; => 4
;; => 9
;; => 16
;; => 25
;; => #<undef>

tree-walk写経。

;; tree-walk
(define (tree-walk tree walker proc)
(walker (lambda (ele)
        (if (list? ele)
        (tree-walk ele walker proc)
        (proc ele)))
      tree))

(tree-walk '(1 (2 3 (4 5 6)) 7 8 9 (10 (11 (12)))) for-each print)
;; => gosh> 1
;; => 2
;; => 3
;; => 4
;; => 5
;; => 6
;; => 7
;; => 8
;; => 9
;; => 10
;; => 11
;; => 12
;; => #<undef>

listを反転させるreverse。

;; reverse
(define (reverse ls)
(define (rev-iter ls ret)
    (if (null? ls)
    ret
    (rev-iter (cdr ls)(cons (car ls) ret))))
(rev-iter ls '()))

(reverse '(1 2 3 4 5)) ;; => (5 4 3 2 1)

listを反転後にfor-eachするreverse-for-each。

;; reverse-for-each
(define (reverse-for-each proc ls)
(for-each proc (reverse ls)))

(reverse-for-each print '(1 2 3 4 5))
;; => gosh> 5
;; => 4
;; => 3
;; => 2
;; => 1
;; => #<undef>

tree-walkにreverse-for-eachとprintを渡してみる。
今気づいたけど、本に書いてあるコードと引数の順番違う。

(tree-walk '(1 (2 3 (4 5 6)) 7 8 9 (10 (11 (12)))) reverse-for-each print)
;; => gosh> 12
;; => 11
;; => 10
;; => 9
;; => 8
;; => 7
;; => 6
;; => 5
;; => 4
;; => 3
;; => 2
;; => 1
;; => #<undef>

[scheme][Gauche]末尾再帰

「プログラミングGauche」P.56～59 6.6 ２種類の再帰

末尾再帰とは

処理の一番最後に再帰呼び出しをして、その結果がそのまま現在の処理の結果として返されるパターンを末尾再帰と呼びます

末尾再帰length

;; length tail-recursive
(define (length3 ls)
(define (len-iter ls n)
    (if (null? ls)
    n
    (len-iter (cdr ls)(+ n 1))))
(len-iter ls 0))

(length3 '(1 2 3 4 5)) ;; => 5
(length3 '()) ;; => 0
(length3 (cons 1 2)) ;; => ERROR: pair required, but got 2

末尾再帰reverse

;; tail-recursive reverse
(define (reverse ls)
(define (reverse-iter ls ret)
    (if (null? ls)
    ret
    (reverse-iter (cdr ls)(cons (car ls) ret))))
(reverse-iter ls '()))

(reverse '(1 2 3 4 5)) ;; => (5 4 3 2 1)
(reverse '()) ;; => ()

SICPの末尾再帰のところ読んでもあまりピンとこなかったんだけど、「プログラミングGauche」の末尾再帰の説明読んでみて、ようやくわかった。あとここ参考になった。

[scheme][Gauche]プログラミングGauche(P.56)練習問題

「プログラミングGauche」P.56 練習問題

リストの長さを計算するlengthを直接(foldを使わずに)定義してみる
リストの中から、条件を満たす要素だけを抜き出したリストを返すfilterを定義してみる

length手続き。

これはいまいち。nullでもリストでもないものが渡されたときの処理を書くべきかも。

;; リストの長さを計算するlengthを直接(foldを使わずに)定義してみる
(define (length2 ls)
(if (null? ls)
0
(+ 1 (length2 (cdr ls)))))

(length2 '(1 2 3 4 5)) ;; => 5
(length2 '()) ;; => 0
(length2 (cons 1 2)) ;; => ERROR: pair required, but got 2

filter手続き。

これは前回（find）の最後のとこで同じのをすでに書いてた。

;; リストの中から、条件を満たす要素だけを抜き出したリストを返すfilterを定義してみる
(define (filter predicate ls)
(cond
   ((null? ls) '())
   ((predicate (car ls))(cons (car ls)(filter predicate (cdr ls))))
   (else (filter predicate (cdr ls)))))

(filter even? '(1 2 3 4 5 6 7 8 9 10)) ;; => (2 4 6 8 10)
(filter odd? '(1 2 3 4 5 6 7 8 9 10)) ;; => (1 3 5 7 9)
(filter even? '()) ;; => ()

2009/01/24

[scheme][Gauche]append2, reverse, find

「プログラミングGauche」P.54 ～ 55

リストとリストを連結するappend2

;; append list
(define (append2 a b)
(if (pair? a)
(cons (car a)(append2 (cdr a) b))
b))

(append2 '(1 2 3) '(4 5 6)) ;; => (1 2 3 4 5 6)
(append2 '(1 (2 3) (4 5 (6))) '(((7 8) 9) 10))
;; => (1 (2 3) (4 5 (6)) ((7 8) 9) 10)

リストを反転させるreverse

;; reverse list
(define (reverse ls)
(fold cons '() ls))

(reverse '(1 2 3 4 5)) ;; => (5 4 3 2 1)

;; reverse list 2

(define (reverse2 ls)
(if (null? (cdr ls))
ls
(append2 (reverse2 (cdr ls))(list (car ls)))))

(reverse2 '(1 2 3 4 5)) ;; => (5 4 3 2 1)

(define (reverse2 ls)
(if (null? (cdr ls))
ls
(append2 (reverse2 (cdr ls)) (cons (car ls) '()))))

(reverse2 '(1 2 3 4 5)) ;; => (5 4 3 2 1)

リストから最初に条件に合致した要素を探し出すfind

;; find
(define (find predicate ls)
(if (null? ls)
      #f
      (if (predicate (car ls))
      (car ls)
      (find predicate (cdr ls)))))

(find odd? '(1 2 3 4 5)) ;; => 1
(find odd? '(1)) ;; => 1
(find odd? '()) ;; => #f
(find odd? '(2 4 6 8 10)) ;; => #f
(find odd? (cons 1 2)) ;; => 1

;; find - cond

(define (find predicate ls)
(cond
   ((null? ls) #f)
   ((predicate (car ls)) (car ls))
   (else (find predicate (cdr ls)))))

(find even? '(1 2 3 4 5)) ;; => 2
(find even? '(1)) ;; => #f
(find even? '(1 3 5 7)) ;; => #f

リストから条件に合致したすべての要素をリストにして返すfind

(define (find predicate ls)
(cond
   ((null? ls) '())
   ((predicate (car ls)) (cons (car ls) (find predicate (cdr ls))))
   (else (find predicate (cdr ls)))))

(find odd? '(1 2 3 4 5 6 7 8 9 10)) ;; => (1 3 5 7 9)
(find even? '(1 2 3 4 5 6 7 8 9 10)) ;; => (2 4 6 8 10)

[scheme][Gauche]deep-copy-list

「プログラミングGauche」P.53
copy-list
deep-copy-list

(use slib)
(require 'trace)

;; copy-list
;; リストを構成する対を複製する。
;; リストの要素（car側）に別のリストがあったとしても、それはコピーしません。
(define (copy-list ls)
(if (pair? ls)
(cons (car ls) (copy-list (cdr ls)))
ls))

(trace copy-list)
(copy-list '(1 2 3 4 5))

traceの結果

CALL copy-list (1 2 3 4 5)
CALL copy-list (2 3 4 5)
CALL copy-list (3 4 5)
   CALL copy-list (4 5)
    CALL copy-list (5)
    RETN copy-list (5 . #[unknown])
   RETN copy-list (4 5 . #[unknown])
RETN copy-list (3 4 5 . #[unknown])
RETN copy-list (2 3 4 5 . #[unknown])
RETN copy-list (1 2 3 4 5 . #[unknown])
(1 2 3 4 5 . #<undef>)

deep-copy-listを定義してみる。
冗長。

;; ネストしたリストもすべてコピーするdeep-copy-list
(define (deep-copy-list ls)
(if (pair? ls)
      (if (pair? (car ls))
        (cons (deep-copy-list (car ls))(deep-copy-list (cdr ls)))
        (cons (car ls)(deep-copy-list (cdr ls))))
      ls))

(trace deep-copy-list)
(deep-copy-list '(1 (2 3) (4 5 6) (7 8) 9 (10 11 12)))

一応うまくいってるみたい。

gosh> CALL deep-copy-list (1 (2 ...) (4 ...) (7 ...) 9 (10 11 12))
CALL deep-copy-list ((2 ...) (4 ...) (7 ...) 9 (10 11 12))
CALL deep-copy-list (2 3)
   CALL deep-copy-list (3)
    CALL deep-copy-list ()
    RETN deep-copy-list ()
   RETN deep-copy-list (3)
RETN deep-copy-list (2 3)
CALL deep-copy-list ((4 ...) (7 8) 9 (10 11 12))
   CALL deep-copy-list (4 5 6)
    CALL deep-copy-list (5 6)
    RETN deep-copy-list (5 6)
   RETN deep-copy-list (4 5 6)
   CALL deep-copy-list ((7 8) 9 (10 11 12))
    CALL deep-copy-list (7 8)
    RETN deep-copy-list (7 8)
    CALL deep-copy-list (9 (10 11 12))
    RETN deep-copy-list (9 (10 11 12))
   RETN deep-copy-list ((7 8) 9 (10 11 12))
RETN deep-copy-list ((4 ...) (7 8) 9 (10 11 12))
RETN deep-copy-list ((2 ...) (4 ...) (7 ...) 9 (10 11 12))
RETN deep-copy-list (1 (2 ...) (4 ...) (7 ...) 9 (10 11 12))
(1 (2 3) (4 5 6) (7 8) 9 (10 11 12))
gosh>

;; cons手続きが重複していたので一つにまとめてみる。
(define (deep-copy-list2 ls)
(if (pair? ls)
      (cons
       (if (pair? (car ls))
         (deep-copy-list2 (car ls))
         (car ls))
       (deep-copy-list2 (cdr ls)))
      ls))

(trace deep-copy-list2)
(deep-copy-list2 '(1 (2 3) (4 5 6) (7 8) 9 (10 11 12)))

CALL deep-copy-list2 (1 (2 ...) (4 ...) (7 ...) 9 (10 11 12))
CALL deep-copy-list2 ((2 ...) (4 ...) (7 ...) 9 (10 11 12))
CALL deep-copy-list2 (2 3)
   CALL deep-copy-list2 (3)
    CALL deep-copy-list2 ()
    RETN deep-copy-list2 ()
   RETN deep-copy-list2 (3)
RETN deep-copy-list2 (2 3)
CALL deep-copy-list2 ((4 ...) (7 8) 9 (10 11 12))
   CALL deep-copy-list2 (4 5 6)
    CALL deep-copy-list2 (5 6)
    RETN deep-copy-list2 (5 6)
   RETN deep-copy-list2 (4 5 6)
   CALL deep-copy-list2 ((7 8) 9 (10 11 12))
    CALL deep-copy-list2 (7 8)
    RETN deep-copy-list2 (7 8)
    CALL deep-copy-list2 (9 (10 11 12))
    RETN deep-copy-list2 (9 (10 11 12))
   RETN deep-copy-list2 ((7 8) 9 (10 11 12))
RETN deep-copy-list2 ((4 ...) (7 8) 9 (10 11 12))
RETN deep-copy-list2 ((2 ...) (4 ...) (7 ...) 9 (10 11 12))
RETN deep-copy-list2 (1 (2 ...) (4 ...) (7 ...) 9 (10 11 12))
(1 (2 3) (4 5 6) (7 8) 9 (10 11 12))

(car ls)が三度も出現するのが嫌だったのでlambdaでくるんでみた。
letもまだいまいちわかんないので、lambdaで。
いまんとこコレが限界ー。

あ、名前もdeep-copy-listからdclに。

(define (dcl3 ls)
(if (pair? ls)
      (cons
       ((lambda (l)
         (if (pair? l)
            (dcl3 l)
            l)) (car ls))
       (dcl3 (cdr ls)))
      ls))

(trace dcl3)
(dcl3 '(1 (2 3) (4 5 6) (7 8) 9 (10 11 12)))

CALL dcl3 (1 (2 ...) (4 ...) (7 8) 9 (10 11 12))
CALL dcl3 ((2 ...) (4 ...) (7 8) 9 (10 11 12))
CALL dcl3 (2 3)
   CALL dcl3 (3)
    CALL dcl3 ()
    RETN dcl3 ()
   RETN dcl3 (3)
RETN dcl3 (2 3)
CALL dcl3 ((4 5 ...) (7 8) 9 (10 11 12))
   CALL dcl3 (4 5 6)
    CALL dcl3 (5 6)
    RETN dcl3 (5 6)
   RETN dcl3 (4 5 6)
   CALL dcl3 ((7 8) 9 (10 11 12))
    CALL dcl3 (7 8)
    RETN dcl3 (7 8)
    CALL dcl3 (9 (10 11 12))
    RETN dcl3 (9 (10 11 12))
   RETN dcl3 ((7 8) 9 (10 11 12))
RETN dcl3 ((4 5 ...) (7 8) 9 (10 11 12))
RETN dcl3 ((2 ...) (4 ...) (7 8) 9 (10 11 12))
RETN dcl3 (1 (2 ...) (4 ...) (7 8) 9 (10 11 12))
(1 (2 3) (4 5 6) (7 8) 9 (10 11 12))

ちょっとインデントを変えてみた。
インデントのタイミングというか位置が、まだよくわからない。
他人のSchemeコードをもっと見るとか、SICPをもっと読み進めるとわかってくるかなー。

(define (dcl3 ls)
(if (pair? ls)
      (cons
       ((lambda (l)
        (if (pair? l)(dcl3 l) l)) (car ls))
       (dcl3 (cdr ls)))
      ls))

(dcl3 '((1 2) 3 4 (5 6 7 8 9) 10 (11 (12 13 14)(15 (16 17 (18)))(19 20) 21) 22))

CALL dcl3 ((...) 3 4 (5 ...) 10 (11 (...) (...) ...) 22)
CALL dcl3 (1 2)
CALL dcl3 (2)
   CALL dcl3 ()
   RETN dcl3 ()
RETN dcl3 (2)
RETN dcl3 (1 2)
CALL dcl3 (3 4 (5 6 ...) 10 (11 (...) (...) ...) 22)
CALL dcl3 (4 (5 6 ...) 10 (11 (...) (...) ...) 22)
   CALL dcl3 ((5 6 ...) 10 (11 (...) (...) ...) 22)
    CALL dcl3 (5 6 7 8 9)
    RETN dcl3 (5 6 7 8 9)
    CALL dcl3 (10 (11 (...) (...) (...) ...) 22)
    RETN dcl3 (10 (11 (...) (...) (...) ...) 22)
   RETN dcl3 ((5 6 ...) 10 (11 (...) (...) ...) 22)
RETN dcl3 (4 (5 6 ...) 10 (11 (...) (...) ...) 22)
RETN dcl3 (3 4 (5 6 ...) 10 (11 (...) (...) ...) 22)
RETN dcl3 ((...) 3 4 (5 ...) 10 (11 (...) (...) ...) 22)
((1 2) 3 4 (5 6 7 8 9) 10 (11 (12 13 14) (15 (16 17 (18))) (19 20) 21) 22)

2009/01/23

[scheme][Gauche]last-pair写経

定義済みのlast-pairを使ってみる。

;; last-pair
(last-pair '(1 2 3));; => (3)
(last-pair (cons 1 (cons 2 3))) ;; => (2 . 3)
(last-pair '()) ;; => ERRO: pair required: ()

pair?の動作も確認してみる。

;; pair?
(pair? '(1 2 3)) ;; => #t
(pair? '()) ;; => #f
(pair? (cons 1 (cons 1 2))) ;; => #t
(pair? (cons 1 2)) ;; => #t
(pair? (cons 1 '())) ;; => #t

いまさらcdrも。

;; cdr
(cdr '()) ;; => ERROR: pair required, but got ()
(cdr (cons 1 2)) ;; => 2
(cdr (cons 1 (cons 2 3))) ;; => (2 . 3)
(cdr '(1 2)) ;; => (2)
(cdr '(1)) ;; => ()

my-last-pairを定義してみる。

;; define my-last-pair
(define (my-last-pair ls)
(if (pair? (cdr ls))
(my-last-pair (cdr ls))
ls))

(my-last-pair '()) ;; => ERROR: pair required, but got ()
(my-last-pair '(1)) ;; => (1)
(my-last-pair (cons 1 2)) ;; => (1 . 2)
(my-last-pair (cons 1 (cons 2 3))) ;; => (2 . 3)
(last-pair (cons 1 (cons 2 3))) ;; => (2 . 3)

2009/01/22

[scheme][Gauche]slibのtraceを使ったデバッグ

Gauche(Scheme) でデバッグをする4つの方法

↑こんな記事があったのでやってみたらすごく便利。trace。

(define (fact n)            
  (if (zero? n)             
      1             
      (* n (fact (- n 1)))))  ;; => fact             
(use slib) ;; => #<undef>            
(require 'trace) ;; => #t             
(trace fact) ;; => #<closure (debug:trace-procedure debug:trace-procedure)>
 
(fact 5)

実行結果

gosh> CALL fact 5 CALL fact 4 CALL fact 3 CALL fact 2 CALL fact 1 RETN fact 1 RETN fact 2 RETN fact 6 RETN fact 24 RETN fact 120 120

追記

vallog: Scheme マクロのデバッグ4種

[Emacs][Meadow]ツールバー（ボタンが並んでるバー）を消す

Meadowのツールバーがウザかったので消しました。

↑これを消してこんな感じに↓

.emacsファイルに以下の一行を追加する

(tool-bar-mode -1)

参考：ツールバーを非表示にする

[Scheme][Gauche]デバッグのリーダーマクロ（#?=）

Gaucheユーザーリファレンス 3.4 デバッグ

;; #?= プリントスタブ リーダーマクロ            
(define (fold2 proc init lis)             
  (if (null? lis)             
      init             
      (fold2 proc #?=(proc (car lis) init) #?=(cdr lis)))) 
 
(fold2 (lambda (a b)(+ b 1)) 0 '(1 2 3 4 5)) 
 
;; => #?="(stdin)":4:(proc (car lis) init)            
;; => #?-    1             
;; => #?="(stdin)":4:(cdr lis)             
;; => #?-    (2 3 4 5)             
;; => #?="(stdin)":4:(proc (car lis) init)             
;; => #?-    2             
;; => #?="(stdin)":4:(cdr lis)             
;; => #?-    (3 4 5)             
;; => #?="(stdin)":4:(proc (car lis) init)             
;; => #?-    3             
;; => #?="(stdin)":4:(cdr lis)             
;; => #?-    (4 5)             
;; => #?="(stdin)":4:(proc (car lis) init)             
;; => #?-    4             
;; => #?="(stdin)":4:(cdr lis)             
;; => #?-    (5)             
;; => #?="(stdin)":4:(proc (car lis) init)             
;; => #?-    5             
;; => #?="(stdin)":4:(cdr lis)             
;; => #?-    ()             
;; => 5

追記

vallog: Scheme マクロのデバッグ4種

[Gauche][Scheme]foldの写経

fold便利やなー。

「プログラミングGauche」P.46 6.3リストの走査より
(fold <手続き> <初期値> <リスト>)
<リスト>が要素(v0 v1 v2 ・・・vN)からなるとき、foldは次のとおりに動作します。

まず、最初の要素v0と<初期値>を引数にして<手続き>を呼ぶ

次に、2番目の要素v1と上の呼び出しの結果を引数にして<手続き>を呼ぶ

次に、3番目の要素v2と上の呼び出しの結果を引数にして<手続き>を呼ぶ

以下同様に繰り返し、最後にvNとそれまでの結果を引数にして<手続き>を呼び、その結果をfoldの戻り値とする

もし<リスト>が空リストであれば、<初期値>がそのまま返されます。

以下写経的なもの

;; 引数のリストの合計を求める
(define (sum-of-numbers ls)
  (fold + 0 ls))

;; 引数のリストの積を求める
(define (product-of-numbers ls)
  (fold * 1 ls))

;; ２つの引数のうちで大きいものを返す
(define (pick-greater a b)
  (if (> a b) a b))

;; 引数のリストのうち最も大きな数値を求める
(define (max-number ls)
  (define (pick-greater a b)
    (if (> a b) a b))
  (fold pick-greater -inf.0 ls))

;; 引数のリストのうち最も小さな数値を求める
(define (min-number ls)
  (define (pick-smaller a b)
    (if (< a b) a b))
  (fold pick-smaller +inf.0 ls))


(min-number '(1 2 3 4 5 6 7 8 9 10)) ;; => 1
(max-number '(1 2 3 4 5 6 7 8 9 10)) ;; => 10
(pick-greater 1 2) ;; => 2
(pick-greater 10 5) ;; => 1-
(sum-of-numbers '(1 2 3 4 5)) ;; => 15
(product-of-numbers '(1 2 3 4 5)) ;; => 120

;; 引数のリストを全て表示する
(define (print-list ls)
  (fold (lambda (a b) (print a)) #f ls))
(print-list '(1 2 3 4 5 6))
;; => 1
;; => 2
;; => 3
;; => 4
;; => 5
;; => 6

;; 引数のリストの長さを求める
(define (length ls)
  (fold (lambda (a b) (+ b 1)) 0 ls))
(length '(1 2 3 4 5)) ;; => 5
(length '(1 2 3)) ;; => 3

;; 引数のリストのうち最も大きな数値を求める(lambda)
(define (max-number ls)
  (if (null? ls)
      (error)
      (fold (lambda (a b)
              (if (> a b) a b))
            (car ls)
            (cdr ls))))
(max-number '(1 2 3 4 5 6 5 4 3 2 1 0)) ;; => 6

;; fold関数の再定義
(define (fold2 func val ls)
  (if (null? ls)
      val
      (fold2 func (func (car ls) val) (cdr ls))))

;; fold2を使用した、引数のリストのうち最も大きな数値を求める
(define (max-num ls)
  (fold2 (lambda (a b) (if (> a b) a b)) 0 ls))

(max-num '(1 2 3 4 5 6 7 8 9 10 9 8 7 6 5 4 3 2 1 0)) ;; => 10

追記

複数のリストに対応したもの。

vallog: fold （複数リスト引数）

[Emacs][Meadow][Gauche]ショートカット

Emacs初心者なのでMeadowの使い方がさっぱりわかりません。
慣れたら使いやすくなるんでしょうか。
取りあえず必要なショートカット（キーバインド？）をメモメモ。
ソースは「プログラミングGauche」とMeadowやEmacsのサイトやブログ記事。
詳しいキーの一覧はこういうところを参照のこと

環境はこちら

-- scheme
C-x C-e カーソル直前のS式を評価
C-c C-e カーソルのS式を含むトップレベルのS式を評価
C-c C-l ファイルをロード
C-c C-r リージョンを評価
C-c C-z Schemeのインタプリタが動いているバッファへフォーカス
C-j 適切なインデントに変換
C-c C-l RET バッファをGaucheに読み込ませる
M-C-/ 一気にインデントを整える

M-C-f 次のS式へ移動
M-C-b 前のS式へ移動
M-C-a カーソルのS式を含むトップレベルのS式先頭へ移動
M-C-e カーソルのS式を含むトップレベルのS式の末尾へ移動
M-C-d 1つ内側のS式へ移動
M-C-u 1つ外側のS式へ移動
M-C-SPC カーソルのS式の次のS式をマーク
M-C-t カーソルのS式の前後の式を交換
M-; コメント入力
M-3 M-; 選択範囲コメントアウト

-- 一般

M-w コピー
C-y 貼り付け
C-w 切り取り

C-x C-f ファイルを開く
C-x C-s ファイルを上書き保存する
C-x C-w ファイルを名前をつけて保存
C-x k ファイルを保存せずに閉じる
C-x C-c Emacs終了
C-x C-u UNDO
C-SPC Mark Set （長押しまたは2回押しで範囲選択）
C-x h 全選択

C-g キャンセル
C-p 前の行
C-n 次の行
C-f 次の文字
C-b 前の文字
C-a 行頭
C-e 行末
C-d カーソル文字削除
C-k カーソル位置から行末までを削除
C-_ UNDO
C-s 検索（日本語不可）
C-x d ディレクトリ一覧

M-f 単語分進む
M-b 単語分戻る
M-a 文頭
M-e 文末
M-k カーソル位置から文末まで削除
M-< ファイル先頭
M-> ファイル末尾
M-% 確認して置き換え
M-x replace-string 一括置き換え

C-x r k 矩形を削除して記憶する
C-x r d 矩形を記憶せずに削除する
C-x r y 最後に削除した矩形を挿入する
C-x r c 矩形としてマークした領域を記憶せず、クリアする
C-x r o マークした領域に空の矩形を挿入する
C-x r t 矩形選択領域の各行に文字列を挿入

C-x o ウィンドウのペイン間移動
M-x describe-bindings キーバインド一覧

リージョンってのは選択範囲のことらしい。
矩形範囲選択のやり方がわからない。
あと、よく勧めてあるので、CapsキーをCtrl、無変換キーをAltにした。（ChgKey）
C-e のCはCtrl
M-f のMはAlt
Meadowで矩形選択 - START YOUR ENGINES

リスト遊び―Emacsで学ぶLispの世界 (ASCII SOFTWARE SCIENCE Language)

[scheme][Gauche]WindowsでプログラミングGauche

WindowsでGaucheやろうと思ったけど、なかなか環境が整わず苦労したのでメモ書き。

いざGaucheやろうと思ってもWindows環境がいまいち揃ってないようなので、このページ（http://kayui.blog38.fc2.com/blog-entry-45.html）を参考にMeadow＋cygwin＋Gauche環境作ろうとしたんだけど、cygwin上でGaucheをコンパイルしようとするとエラー出ちゃって・・・あきらめました。

結果的に、こんなもの（http://practical-scheme.net/wiliki/wiliki.cgi?Gauche:Gauchebox）を見つけたので使ってみるとインストーラで簡単にMeadow3＋Gaucheの環境ができました！簡単便利♪

Gauchebox(http://practical-scheme.net/wiliki/wiliki.cgi?Gauche:Gauchebox)

以下環境とは無関係。

Gauche作者の川合史朗さんすごいですねぇ。

OOエンジニアの輪～第 21 回川合史朗さんの巻～

川合史朗＠Gaucheは、ハワイで俳優をしている／Tech総研

まだSICPもほとんど読んでない状況で「プログラミングGauche」なる本を買いました。

少し立ち読んでたら面白そうだったんで。
ついでに「The Root of .NET Framework」も買いました。

2009/01/01

ブログを移行してきました。

以前のブログ： http://ameblo.jp/valvallow/

2年くらい使ったけど、常々使い心地の悪さを感じていたのでBloggerへ移行します。

ついでに、投稿ソフトも導入してみます。（遅い）

Windows Live Writer

Bloggerでも問題なく使えるとの評判なので・・・。

【scheme】letrecで階乗

letrecで階乗。んー。letrecって名前付きletと何か違う？

参考
7. 繰り返し
 http://www.shido.info/lisp/scheme7.html
Y-Combinatorで階乗。
【Scheme】Y-Combinator（Yコンビネータ/不動点演算子）
http://ameblo.jp/valvallow/entry-10182574504.html
名前付きletで階乗。
【scheme】再帰だけでなくループできるのか
 http://ameblo.jp/valvallow/entry-10186037975.html

(define fact-letrec
(lambda (n)
    (letrec ((iter (lambda (counter result)
        (if (= counter 1)
        result
        (let ((m (- counter 1)))
          (iter m (* result m)))))))
     (iter n n))))

(fact-letrec 5);;=> 120

【scheme】再帰だけでなくループできるのか http://ameblo.jp/valvallow/entry-10186037975.html

名前付きlet

(define loop-fact
(lambda (n)
    (let loop ((count n)(result n))
        (if (= count 1)
          result
          (let ((m (- count 1)))
            (loop m (* result m)))))))

(loop-fact 5);;=> 120

【scheme】再帰だけでなくループできるのか

と、思いきや、結局letブロック内で再帰か。（ってことだよね？）

(define loop-fact
(lambda (n)
    (let loop ((count n)(result n))
      (if (= count 1)
        result
        (loop (- count 1) (* result (- count 1)))))))

(loop-fact 5);;=> 120

(- count 1)が冗長なのでletする。

;;(- count 1) => let => m
(define loop-fact
(lambda (n)
    (let loop ((count n)(result n))
      (if (= count 1)
        result
        (let ((m (- count 1)))
          (loop m (* result m)))))))

(loop-fact 5);;=> 120

名前つきletということなので、別にloopって名前でなくてもおｋ。

(define loop-fact
(lambda (n)
    (let l ((x n)(y n))
      (if (= x 1)
      y
      (let ((z (- x 1)))
        (l z (* y z)))))))

(loop-fact 5);;=> 120

【scheme】for-eachがあったのか

リストの各要素に対して関数を適用するfor-eachがあったなんてー。

こないだの悩み解決。

【scheme】こないだのlistで書き忘れた http://ameblo.jp/valvallow/entry-10185017551.html

リストの中身を全部出力したかっただけなんだけどな。こんなことになっちゃった。センスなさすぎﾜﾛﾀ系？

;;list
(define x (list 1 2 3))
;;display list
(define disp-list
(lambda (l)
    (if (not (null? l))
       (begin
         (display (car l))
         (newline)
         (disp-list (cdr l))))))
(disp-list x)
;;=> 1
;;=> 2
;;=> 3

こっちがfor-each使ったもの。

(define ls '(1 2 3 4 5))
ls

(for-each display ls);;=> 12345

(newline)

(for-each (lambda (s) (display s) (newline)) ls)
;;=> 1
;;=> 2
;;=> 3
;;=> 4
;;=> 5

【scheme】letはlambdaのシンタックスシュガー

(let ((a 1)(b 2))
(display a);;=> 1
(newline)
(display b));;=> 2

(newline)

((lambda (a b)
(display a)
(newline)
(display b)) 1 2)
;;=> 1
;;=> 2

【Scheme】問題1.9＠SICP

あけましておめでとうございます。

インクリメント関数、デクリメント関数

(define inc
(lambda (x) (+ x 1)))
(define dec
(lambda (x) (- x 1)))

こっちの方がしっくりくるけど取りあえず置いといて。

(define ++ inc)
(define -- dec)

(++ 1);;=> 2
(-- 1);;=> 0

SICPでは+関数として定義してあるけど、ちょっと判りづらいので「plus」にした。

(define plus
(lambda (a b)
    (if (zero? a)
      b
      (inc (plus (dec a) b)))))

実行結果（式展開）。再帰的。

;;recursive
(plus 4 5)
(inc (plus (dec 4) 5))
(inc (inc (plus (dec 3) 5)))
(inc (inc (inc (plus (dec 2) 5))))
(inc (inc (inc (inc (plus (dec 1) 5)))))
(inc (inc (inc (inc (plus 0 5))))
(inc (inc (inc (inc 5)))
(inc (inc (inc 6)))
(inc (inc 7))
(inc 8)
9

同じく+からplus2に変更。

(define plus2
(lambda (a b)
    (if (zero? a)
      b
      (plus2 (dec a)(inc b)))))

実行結果。反復的。

;;iterative
(plus2 4 5)
(plus2 (dec 4)(inc 5))
(plus2 (dec 3)(inc 6))
(plus2 (dec 2)(inc 7))
(plus2 (dec 1)(inc 8))
9

vallog