TSS rember1*

ネストした cond とか読みづらいですねー。

読みづらい、どころの問題じゃないです(苦笑)。
問題のコードはこれなんですけど。中でも「一番マシ」なのをピックアップしました。

; The Seasoned Schemer letrec, let
(define rember1*
  (lambda (a l)
    (letrec
        ((R (lambda (l)
              (cond
               ((null? l)(quote ()))
               ((atom? (car l))
                (cond
                 ((eq? (car l) a)(cdr l))
                 (else (cons (car l)
                             (R (cdr l))))))
               (else (let ((av (R (car l))))
                       (cond
                        ((eqlist? (car l) av)
                         (cons (car l)(R (cdr l))))
                        (else (cons av (cdr l))))))))))
      (R l))))
 
(rember1* 'salad '((Swedish rye)
                   (French (mustard salad turkey))
                   salad))
; -> ((Swedish rye) (French (mustard turkey)) salad)

もうあったまクラクラしてきますね(笑)。Schemeにある程度慣れていてもクラクラしてくるコードです。
The Little SchemerやThe Seasoned Schemerは「名著」の誉れが高いんですが「ホンマか?」と頭の中が疑念の嵐です、しょーじきなトコロ。ひっどいコードの垂れ流しとしか見えません。
僕は両書とも持ってないんで、意図がどこにあるのか、あるいは何か目的があってそこへ誘おうとしてるのか分からないんですが、いずれにせよ、このコードを見る以上「酷いコードが書かれてあるテキスト」だとしか思えません。

「リファクタリングせねば!」

とか思ったんですが、これがなかなか(苦笑)。一筋縄ではいかない。
valvallowさんが記述している通り、

ネストした list 内から最初に見つかったものを一つだけ取り除くって、一つだけって逆に難しいですね。

なんです。全くです(苦笑)。

しかしながら、テキストを鵜呑みにするんじゃなくって

「何とかリファクタリングして短いコードが書けないか?」

と考えるのは良い練習だと思います。
と言うのも、Schemeで実用的なプログラムを書くのは難しいですし、もしある目的を達成するコードが「短く書けない」のなら、そもそもSchemeなんて勉強する必要なんて無いんです。

コードを極限まで短くする方法を考える

のがSchemeの学習の唯一の価値です。ホントですよ。
(大体、短く書けなきゃSchemeはやたら括弧が多い妙ちきりんな言語なだけ、です。)

まず、例示のコードを見て気になるのは、letrecを用いている意味が全くない、って辺りです。
と言うのも、このコードは全く末尾再帰してないので、ローカル手続きを使ってる意味が無いんです。従って、まずはletrecを消去しちゃいましょう。ここは無駄な部分です。

(define (rember1* a l)
  (cond
   ((null? l) '())
   ;; atom? は標準手続きじゃないので、not pair? に置き換える。
   ((not (pair? (car l)))
    (cond
     ((eq? (car l) a) (cdr l))
     (else (cons (car l) (rember1* a (cdr l))))))
   (else (let ((av (rember1* a (car l))))
    (cond
     ;; eqlist?も標準手続きではない。
     ;; リスト同士の等価判定はequal?で充分。
     ((equal? (car l) av)
      (cons (car l) (rember1* a (cdr l))))
     (else (cons av (cdr l))))))))

それで、このコードを扱ってる章では、valvallowさんの記述によると、

letを使って局所変数を纏めよう

と言うのが狙いのようなんですが、だったらどうしてこんなに中途半端なのか。コード中に現れる(car l)や(cdr l)こそ局所変数で纏めるべきなんですよ。これが素のままで記述されているので、ネストだらけになって見づらいんです。

(define (rember1* a l)
  (if (null? l)
      '()
      (let ((x (car l)) (y (cdr l)))
 (if (not (pair? x))
     (if (eq? x a)
  y
  (cons x (rember1* a y)))
     (let ((av (rember1* a x)))
       (if (equal? x av)
    (cons x (rember1* a y))
    (cons av y)))))))

valvallowさんが仰ってる通り、

分岐が2つなら if 使おうよ。

って事なんで、condも全部ifに置き換えます。
ちょっとは見通し良くなったかな?

次は個人的趣味なんですが、あんまnot～ってのは好きじゃないんですよね。元々分岐が二つである以上、論理的には「pair?であるか、そうじゃないか」ってだけです。つまり、分岐二つの枝の順序は取り替えて良い。

(define (rember1* a l)
  (if (null? l)
      '()
      (let ((x (car l)) (y (cdr l)))
 (if (pair? x)
     (let ((av (rember1* a x)))
       (if (equal? x av)
    (cons x (rember1* a y))
    (cons av y)))
     (if (eq? x a)
  y
  (cons x (rember1* a y)))))))

だいぶ整理されて見やすくなっては来ました。だけど依然としてifのネストはウザいです。ウザいですね。
一つの考え方ですが、例えば(pair? x)以降のifのカタマリに着目してみましょうか。
Lisp系言語の素晴らしいトコは、文がないと言う辺りです。実際文がある言語ではif～then～elseは制御構文なんで、基本的に手続きの引数につっこめません。必ず手続きの外側に置く必然性が出てきます。
一方、全てが式であるLispではその辺融通無碍です。
どう言う事かと言うと、この部分ではどっちにせよ動作は

(cons 何とか1 何とか2)

が求められてるんですね。フォーマットとしては特に差異がないんです。
つまり、次のように書き換えてしまう事が可能です。

(define (rember1* a l)
  (if (null? l)
      '()
      (let ((x (car l)) (y (cdr l)))
 (if (pair? x)
     (let ((av (rember1* a x)))
       ;; 述語の判定結果を it に束縛してしまう。
       (let ((it (equal? x av)))
  ;; it を利用して cons の引数を交換してしまう。
  (cons (if it x av) (if it (rember1* a y) y))))
     (if (eq? x a)
  y
  (cons x (rember1* a y)))))))

これは荒技に見えるかもしれませんが、結構Lisp系ではオーソドックスな手だと思います。これでネストが減ったように見えて(実際見えるだけ、ですが)若干コードがフラットになった印象を受けます。
そして、

(cons 何とか1 何とか2)

が(let ((x (car l)) (y (cdr l)))...以下の主作業であり、また「引数交換」だけで書けるのなら、最後の枝も纏めてしまえるのでは、と言う野望が生まれますね。そして恐らくそれは正しいんです。
ちょっと整理してみましょうか。

1. (eq? x a)が成り立った時点で、xは(Schemeの仕様上そう言う定義は無いが)アトムである事が決定している。-> つまりこれは独立して括り出せる。


2. 残りはpair? => #tかアトムであるけどeq? => #fじゃないか、の二つの枝である。


3. (cons 何とか1 何とか2)の中身が部分的に重複しているパターンが多い

の3点が分かりますね。実際そうなんです。
1番目を考慮すると、コードは取りあえず次のように書けば良いのが分かります。

(define (rember1* a l)
  (if (null? l)
      '()
      (let ((x (car l)) (y (cdr l)))
 (if (eq? x a)
     y
     ...)

これで1番目は綺麗に処理されます。あとはpair?の中身のパターンわけをどうするのか、って事なんですけど……。並べて見てみますか。

(cons (if it x av) (if it (rember1* a y) y))
(cons x (rember1* a y))

第一引数に着目します。候補の引数の中身はxかavの二種類の可能性しかない、って事がお分かりでしょう。当たり前ですよね。
そして、もう一つ重要なのは、xがpair? => #t「だからこそ」再帰でrember1*を噛ます必要性があるのであって、そうじゃなければそんな事する必要がない、のです。そして、再帰噛ました結果とxが等価であるかどうかは第一引数に付いてはロジック上丸っきり関係がありません。その判定が必要なのは第二引数の方なのです。
従って、第一引数は一つのシンボルavで表現して、avはSchemeの有難いif式を利用して束縛します。

(define (rember1* a l)
  (if (null? l)
      '()
      (let ((x (car l)) (y (cdr l)))
 (if (eq? x a)
     y
     ;; av を次のような条件式で束縛する。
     (let ((av (if (pair? x) (rember1* a x) x)))
       ...)

これでxがpair? => #tだったらavは(rember1* a x)に束縛されるし、そうじゃなかったらxに束縛されます。
これにより、ここのletの本体は

(cons av ...)

と書ける事が決定しました。他に何も必要がないのです。こう言う大技が繰り出せるのも、Schemeが文を持たないお陰です。有難や有難や。
ではconsの第二引数はどうなんでしょうか?これは(equal? x av) => #fの「時だけ」yである必要があり、デフォルトでは(rember1* a y)である、ってのが条件なんです。
従って、完成コードは、

(define (rember1* a l)
  (if (null? l)
      '()
      (let ((x (car l)) (y (cdr l)))
 (if (eq? x a)
     y
     (let ((av (if (pair? x) (rember1* a x) x)))
       (cons av (if (equal? x av) (rember1* a y) y)))))))

となりました。随分とスッキリしたでしょ?ネストが減ったように見えて、結構フラットな印象になったと思います。また、コードの「意味」も追いやすくなったんじゃないかな、と思います。

call/ccの冒険～その2

call/ccの意味の分からないトコは、「無くてもいいじゃん?」って思えるケースがしばしば見受けられるトコです。
この原因の主たるところは、Schemeは明示的にreturnを使うようにはなっていない為じゃないのか、とかちょっと思うんです。
割に、C言語や、その派生モデルの言語の方がcall/ccの意図がつかみ易いのでは、と時々思います。
いずれにせよ、R5RSに以下のように記述されている通り、

call-with-current-continuation の平凡な用途は，ループまたは手続き本体からの構造化された非局所的脱出である。

call/ccの取りあえずの目的は脱出なんです。いわゆるcall/ccの「すげえ機能」と言う一種の誤解は、この「脱出をどう実現してるのか」から出てきた言わば副産物なんですよね。
従って、call/ccで脱出にこだわるのは、call/ccの機能を知る為の第一歩なんじゃないか、と思います。

ところで。ANSI Common LispとSchemeには次のような違いがあります。
ANSI Common Lispの場合、

CL-USER> (car '())
NIL
CL-USER> (cdr '())
NIL
CL-USER> 

となります。
これは、たまにプログラミングに於いてバグになるんですが、上手くすれば非常に便利なんですよね。コードを書く量が劇的に減ります。
実はこれはInterlispと言うLispから受け継いだらしいんですが、はじめは「何て手抜きな事を」と感じる事もなきにしもあらず。しかし、数学的には正しい結果でもあるんです。

空集合の部分集合は空集合自身のみである。

いいですね。魅力的です。
ただし、Schemeは数学的に見てヘンな結果になります。端的に言うとエラーを返す。

> (car '())
car: expects argument of type ; given ()

 === context ===
/usr/lib/plt/collects/scheme/private/misc.ss:74:7

> (cdr '())
cdr: expects argument of type ; given ()

 === context ===
/usr/lib/plt/collects/scheme/private/misc.ss:74:7

> 

ここで、Scheme上でANSI Common Lispのような働きをするextended-carとextended-cdrを書いてみましょう。それぞれxcar、xcdrとします。
恐らく、オーソドックスにSchemeでこれらを書くと、次のようなコードになるでしょう。

(define (xcar lst)
  (if (null? lst)
      lst
      (car lst)))

(define (xcdr lst)
  (if (null? lst)
      lst
      (cdr lst)))

何にも問題ありませんね。至極単純なコードです。実行結果は以下の通り。

> (xcar '())
()
> (xcar '(1 2 3 4 5))
1
> (xcdr '())
()
> (xcdr '(1 2 3 4 5))
(2 3 4 5)
> 

敢えてこれをcall/ccを用いて記述してみましょう。コードは次のようになります。

(define (xcar lst)
  (call/cc
   (lambda (return)
     (car (if (null? lst)
       (return lst)
       lst)))))

(define (xcdr lst)
  (call/cc
   (lambda (return)
     (cdr (if (null? lst)
       (return lst)
       lst)))))

これが脱出です。
考え方としては、要するに普通のcar/cdrなんですが、lstが空リストだった場合エラーになるんで、その条件の場合、car/cdrが作り出す筈の「計算結果を捨てて」空リストを持って脱出するわけです。
これは普通の手続き型言語で考えたらお馴染みでしょう。簡単です。
ただし、

1. call/ccを使わないでも書けるコードなのに、call/ccを使う必然性が見当たらない。


2. 単に構文的にはreturnがあれば済む話なんじゃないか。


3. そもそも、単に脱出する為だけに(call/cc (lambda (hoge) ...))って大掛かりさは何なんだ。

と言う不満があるでしょう。全くもってその通りです。
僕は1番目にずーっと引っかかってたんですよね。call/ccを使わなくても記述可能な場合が多い、んです。他でもっと簡易な代替手段があるのに、それでも敢えてcall/ccを使わなきゃならない理由は何なんだ、と。全くもって意味不明でした。
手続き型言語をやってる人は2番3番は思うでしょう。実際ANSI Common Lispにはreturnとかreturn-fromと言う構文があるんで、call/ccの煩雑さは際立ちます。単に脱出するだけだったらもっと簡易な脱出構文を用意しとけばいいのです。抽象化の失敗の薫りがしますね。
しかし、call/ccの練習、つまり、「慣れ」を考えるなら、敢えて上記のように「call/ccを使わなくても」書ける手続きをcall/ccを使って記述しなおすのは良いと思います。少なくと上の例のように「括弧の中と外が」ひっくり返るような形になるでしょう。文字通りひっくり返るんです。ここ、重要ですよ。

実は、この手の処理の場合、独立した手続きにするより、何かの組み込みとしてcall/ccを使った方が有用性が際立ちます。特に空リストのcarを取ったり、とかcdrを取ってエラーになる、と言うのは、ロジック自体は間違ってないトコでの「Scheme特有の性質」に足を掬われたりするんで、効果は絶大です。

ところで、ANSI Common Lispにはeveryと言う関数が定義されています。述語とシーケンスを引数に取り、シーケンスの全要素が述語を満たすかどうか判定します。
使用例は以下の通り。

CL-USER> (every #'characterp "abc")
T
CL-USER> (every #'oddp '(1 3 5))
T
CL-USER> (every #'> '(1 3 5) '(0 2 4))
T
CL-USER> 

これをSchemeで定義してみます。もちろんオーソドックスには再帰で繰り返し構造を記述して…と言うのが手の一つですが、メンド臭いんで、高階手続きを使って以下のようなコードをでっち上げます。

(define (every pred . arg)
  (not (member #f
        (apply map pred
        (map (lambda (x)
        (cond ((string? x) (string->list x))
       ((vector? x) (vector->list x))
       (else x))) arg)))))

ポイントがいくつかあります。

1. レストパラメータ以降の引数は全て一つのリストに纏められる。


2. Schemeでリストに変換可能なデータ型(シーケンス)はR5RS範疇では文字列とベクタである。


3. 写像手続きmapは結果をリストとして返す。


4. 高階手続きapplyは最後の引数がリストであれば、何を適用しても良い。


5. 手続きmemberは第一引数が第二引数のリストに含まれてるか調べる。


6. Schemeでは空リストも含み、論理的にはリストは#tである。

繰り返しを地道に書くのはメンド臭いです。メンド臭いからこそ写像手続き、あるいは高階手続きが存在します。
論理的には上のような流れで、極めて簡単にSchemeでeveryが実装出来ます。動作も完璧ですよね。

> (every char? "abc")
#t
> (every odd? '(1 3 5))
#t
> (every > '(1 3 5) '(0 2 4))
#t
> 

ってなワケで完成しました。ロジックも穴がありません。
「動けば良い」のならこれでよい。でも、この富豪の時代ではあまり気にならないんですが(正直気にならない)このコードは実は「効率性」から言うと問題があるんです。
上のコードでは手続きmemberを用いて与えられたリスト(apply以降の計算結果)に#fが含まれるかどうか見ています。問題は「1個でも#fが見つかれば、everyと言う定義に反する」って部分なんです。
つまり、計算途中に#fが見つかればそれで既に論理的には結果は明らかに#fなんです。そして、それ以降が#tだろうが#fだろうがどーでも良いのです。しかし、上のコードは律儀に最後までリストを走査します。
もうちょっと細かくapply以降の動作を見てみましょう。

(define (engine-of-every pred . arg)
  (apply map pred
  (map (lambda (x)
  (cond ((string? x) (string->list x))
        ((vector? x) (vector->list x))
        (else x))) arg)))

;; 実行例
> (engine-of-every odd? '(1 2 3 4 5))
(#t #f #t #f #t)
> (engine-of-every > '(1 2 5) '(0 3 4))
(#t #f #t)
> 

上の実行例を見ても分かると思いますが、1つ目の例で言うとリストの2個目の要素が#fだと分かった以上、それ以降の計算は無意味です。2つ目の例でもそうですね。その時点で計算を終わらせればそれでいいのです。
こう言う場合、強制的に計算を終了させるのがcall/ccの役目で、それこそが「脱出」です。call/ccを用いればもうちょっと計算効率が上がります。

(define (engine-of-every pred . arg)
  (call/cc
   (lambda (return)
     (apply map
     (lambda x   ;ここはR5RS参照
       (or (apply pred x)
    (return #f)))  ;脱出
     (map (lambda (y)
     (cond ((string? y) (string->list y))
    ((vector? y) (vector->list y))
    (else y))) arg)))))

;; 実行例
> (engine-of-every char? "abc")
(#t #t #t)
> (engine-of-every odd? '(1 2 3 4 5))
#f
> (engine-of-every > '(1 3 5) '(0 2 4))
(#t #t #t)
> (engine-of-every > '(1 2 5) '(0 3 4))
#f
> 

実はもう殆ど完成してますね。論理的には(#t #t #t)だろうと他のリストだろうと#tです。そして、一個でも#fが見つかった時には即座に計算を終了して#fを持って脱出してます。
このように、結構高階手続きとcall/ccは相性が良いです。高階手続きを設計する際は「call/ccを使う余地が無いか?」考えてみるのが一興でしょう。
なお、上のengine-of-everyで唯一注釈が必要なのは、R5RSに記述されている次のラムダ式の記法でしょう。

<変数>: 手続きは任意個数の引数をとる。手続きが呼び出される時には，実引数の列が，一つの新しく割り付けられたリストへと変換され，そしてそのリストが<変数> の束縛に格納される。

((lambda x x) 3 4 5 6) =⇒ (3 4 5 6)

一種、ラムダ式のレストパラメータと言っても良いのですが、ラムダ式の仮引数が括弧で囲まれてない場合、与えられた引数はリストとして纏められる、と言うルールがあります。あまり有名ではないのですが、覚えておいて損はないでしょう。

実は前回のコードの継続2と言うのは単にこの脱出を行っています。
もう一回コードを再録してみます。見比べてみてください。

(define (sum n)
  (let ((tag #f))   ;タグを設定
    (let ((count 1) (result 1))  ;初期条件
      (call/cc
       (lambda (body)
  ;; 継続1。bodyはここのcall/ccの「外側」をクロージャとして表現したもの。
  ;; 具体的には上部のletから末尾までが範囲となっている。
  ;; (正確にはλ式。つまり、letの束縛された数値は捕捉対象外である。)
  ;; tagはそのまた外側なので継続1には捕捉されない。
  (set! tag body)))   ;そのbodyをtagに代入している。
      (call/cc
       (lambda (return)
  ;; 継続2。ここの継続は継続1内に捕捉されている事に注意。
  ;; 継続1の「外側」に存在しているからである。
  ;; 条件を満たした場合、継続2はresultを持って計算を脱出する。
  (and (= count n) (return result)) 
  (set! count (+ 1 count)) ;手続的計算
  (set! result (+ count result))
  ;; tagへ飛ぶ。tagは事実上一引数関数になってるのでダミー引数'()を渡してる。
  (tag '()))))))

call/ccの冒険～その1

プログラミング言語に於ける抽象化、と言うのはどう言う意味でしょうか。
抽象……。まあ、一般用語で言うと「ボンヤリとして良く分からない曖昧模糊」と言う印象があるのでは。
例えば、キャバ嬢が言う

「あのお客さんの話って抽象的で良く分かんないのよね～～。」

みたいな感じが用法でしょうか。まあ、確かにキャバ嬢相手に抽象論をするお客さんはサイテーだと思います(笑)。気をつけましょう(笑)。分かりやすい話をせんと。

とまあ、実際問題、一般生活の感覚で言うと、「抽象性＝難解」と言うニュアンスが含まれますね。「抽象的な話はどーでもいいんだ!具体的な話をしろ!」みたいに怒られる事もしばしばです。

それはさておき。

僕はフォーマルでは全くCS(Computer Science)を学んだ事が無いわけなんですけれども。
一応、僕の感覚から言うと「プログラミング言語の抽象化」と言うのは「プログラミング言語を分かりやすくする」と言うのと同義です。一般文脈の「抽象」とは丸で逆ですね。
この抽象、ってのはどのレベルから見て抽象なのか?と言うと、我々人間側から見て、ではないと思います。コンピュータハードウェアから見て、って事でしょう。逆に言うと、ハードウェアレベルでの「具体」と言うのは0と1とで構成されたバイナリ世界の事です。そして人間の思考様式に近いレベルになればなるほど「抽象」レベルが上がってくるわけです。

プログラミング言語の進化、と言うのは必ずしもCOBOL的な話ではなくって、「人間の思考形式に近づいてくる」と同義だと思います。如何に人間に分かりやすいレベルまであげてくるのか。当然ですよね。そうじゃないと「使い辛い」と言う事だから、です。
考えてみると、プログラミング言語ってのは元々「分かり辛い」ものなんです。いまだに人間が「使いやすい」ツールにはなってない。なってないからこそ他人が書いたコードは読みづらい(笑)。書くのも大変。だから色々な小手先の改良を加えられてきてる。それらはみんな「抽象化」です。

ところで、プログラミング言語設計上での色んな試み、つまり、「人間になるべく分かりやすい」設計をしよう、と頑張ってきた歴史があるわけですけど。当然人間が作るものなんで、抽象度が明後日の方向に行っちゃってるものがある。
こう言うのは「難解なものを理解したい」と言う挑戦欲は刺激しますが、一方、ツールの開発、って観点から見ると単に「失敗した」って場合もあるとは思うんですよね。「人間に分かりやすく」しようとして設計したのにそうじゃない。こう言う場合は責められるのは学んでる側じゃない。あくまで、「設計が」責められないとならないんです。本来ならね。

Schemeで悪名高いcall/cc。これは本当に悩ましいです。ある意味抽象化の失敗例としては顕著な例じゃないか、とも思えます。これを理解するのに非常に苦しみます。何だか良く分からん。
ここでは仕様書に明言されてる「脱出」に焦点を絞ってcall/ccに付いて考えてみたいと思います。

ではここで非常につまんない例題を考えてみます。

1からnまでのすべての整数を足し合わせる手続きsumを定義せよ。

多分Schemeを勉強した人では鼻歌まじりに次のようなコードを書き上げるでしょう。

(define (sum n)
  (let loop ((count 1) (result 0))
    (if (> count n)
 result
 (loop (+ 1 count) (+ count result)))))

letrec使う人もいるでしょうし、あるいはinternal defineを使う人もいるやもしれません。
いずれにせよ、基本的な繰り返しの問題ですし、Schemeでは当然の如く「再帰」で記述している筈です。基本、これ以外に手がない。
Schemeの場合は何でも再帰、って皮肉られてたりしますし、繰り返し構文であるdoで書いたとしても、結局内部では再帰に変換されてしまう。繰り返し専用の制御構造ってのが存在しないのです。

表向きは。

実は、call/ccを使うと、Schemeでも無理くり反復を行う事が出来るんです。極めて手続き型言語的発想で。
次がそのコードです。

(define (sum n)
  (let ((tag #f))
    (let ((count 1) (result 1))
      (call/cc
       (lambda (body)
  (set! tag body)))
      (call/cc
       (lambda (return)
  (and (= count n) (return result))
  (set! count (+ 1 count))
  (set! result (+ count result))
  (tag '()))))))

多分、これ見たとき

「何じゃこりゃ!汚ねえ!」

とか思うと思います(笑)。書いた僕でさえそう思うんですから(笑)。
しかし、これは手続き型言語で言う「反復」なんです。Schemeの繰り返しなのに全く再帰の「さ」の字も出てきてません。嘘みたいでしょうが、ホントです。
しかも、これはキチンと動きます。

> (sum 5)
15
> 

上記のコードは、ぶっちゃけた話、構造化プログラミング以前のgoto文での反復を行っています。つまり、call/ccは古典的なgoto文である、と言うのを、それこそ抽象論じゃなく、具体的に説明しているコードです。
なお、ポイントを二つ挙げると、

1. 一つの手続きに何個でもcall/ccはぶち込んでよい。


2. call/ccによる脱出とは単純にgotoの事である。

と言う事が見て取れます。

コメント付きで上のコードを再録してみますか。

(define (sum n)
  (let ((tag #f))   ;タグを設定
    (let ((count 1) (result 1))  ;初期条件
      (call/cc
       (lambda (body)
  ;; 継続1。bodyはここのcall/ccの「外側」をクロージャとして表現したもの。
  ;; 具体的には上部のletから末尾までが範囲となっている。
  ;; (正確にはλ式。つまり、letの束縛された数値は捕捉対象外である。)
  ;; tagはそのまた外側なので継続1には捕捉されない。
  (set! tag body)))   ;そのbodyをtagに代入している。
      (call/cc
       (lambda (return)
  ;; 継続2。ここの継続は継続1内に捕捉されている事に注意。
  ;; 継続1の「外側」に存在しているからである。
  ;; 条件を満たした場合、継続2はresultを持って計算を脱出する。
  (and (= count n) (return result)) 
  (set! count (+ 1 count)) ;手続的計算
  (set! result (+ count result))
  ;; tagへ飛ぶ。tagは事実上一引数関数になってるのでダミー引数'()を渡してる。
  (tag '()))))))

一応コメントで解説試みてみたんですけど。詳細は次回(があれば)説明してみますか。
ただ、敢えて言うと、これは全く「関数型」のプログラミングではないです。
そして、call/ccの本質は「関数型言語の要素ではない」って部分なんです。Schemeの機能の中ではあらゆる意味で異質な存在だと思います。
上のコードを理解する為の一つヒントを言うと、(call/cc (lambda ...))と言う形式に惑わされない、って事でしょうかね。Fortran的な意味で言っても(もっとも僕はFortran知りませんが)、単なるgotoなんです。それがcall/ccの「正体」です。

再帰結果は束縛可能

あんま語られないんですけど、例えばこう言うコードがあるとします。

(define (multirember a lat)
  (cond ((null? lat) '())
        ((eq? a (car lat))(multirember a (cdr lat)))
        (else (cons (car lat)
                    (multirember a (cdr lat))))))

これは非常に綺麗なコードです。
実行結果は次のようになりますね。

> (multirember 'a '(a b c d a b c d))
(b c d b c d)
> 

ところで、もう一度上のコードを見てみます。

(define (multirember a lat)
  (cond ((null? lat) '())
        ((eq? a (car lat)) (multirember a (cdr lat))) ;1
        (else (cons (car lat)
                    (multirember a (cdr lat)))))) ;2

まず特徴として、

1. 分岐の木が

   cond

   により3本に分かれている。



2. (multirember a (cdr lat))

   と言うのは実は書くと長い。

の二つがあります。
実は、この2番目が再帰のポイントなんで、「記述を重複するな」と言う言い方には無理があるんですけど、要するに記述のショートカットが出来るか否か、ってのがポイントではあるんです。
んで、実は、あまり知られてないんですが、再帰結果ってのは変数に束縛出来て使いまわしが可能なんです。
コード的には次のようになりますね。

(define (multirember a lat)          
  (if (null? lat)           
      '()
      ;; (car lat)も二回出てくるんでショートフォームitとして束縛
      (let ((it (car lat))
     ;; 再帰部分もrecurと言う変数に束縛してしまう。
     (recur (multirember a (cdr lat))))
 (if (eq? a it)   ;itの使いまわし
     recur   ;recurの使いまわし
     (cons it recur)))))        ;itとrecurの使いまわし

これでも全く同じように動作します。

> (multirember 'a '(a b c d a b c d))
(b c d b c d)
> 

まあ、実際はあんま関係ないんですが、一応理論上は後者の方が若干効率が良い筈です。
と言うのも、Lisp系言語ほどコーディングスタイルが字面通り効率を表す言語は無いんじゃないか、と思われるから、です。
前者だと、例えば

(car lat)

が一々書かれていると、ホントにその場で計算される為、その計算が文字通り二回行われます。反面、2番目のコードだと、再帰に付き1回しか計算されず、その結果は即時、変数itに束縛され「使いまわされ」ます。従って若干効率が上がるんです。
再帰部分も同じですね。結局「結果」が欲しいだけですし、その計算自体は全く同じ、なんで、実はコード内に律儀に2回書く必要はないのです。

この様に、分岐が3段階以上に分かれて、かつ、再帰部分のコード自体は「全く同じ」場合は、試しに局所変数として束縛しちゃうのがお薦めです。

注:ちなみにcall/ccを用いて、

(define (multirember a lat)
  (call/cc
   (lambda (k)
     (let ((it (car (if (null? lat)
   (k '())
   lat)))
    (recur (multirember a (cdr lat))))
       (if (eq? a it)
    recur
    (cons it recur))))))

と言う書き方も可能です。
元々、'()的な記述が必要なのは、Schemeが述語に関して#t、#fを返す、と言うメンド臭い仕様になってるから、ですが、上記の方法だと、一応コード本体の分岐の木は二本で済みます。
ANSI Common Lispだと、

(defun multirember (a lat)
  (and lat
      (let ((it (car lat))
     (recur (multirember a (cdr lat))))
 (if (eq a it)
     recur
     (cons it recur)))))

ともうちょっとシンプルに書けますね。

幸せになれる結婚年齢が分かるプログラム

#! /usr/bin/env mzscheme
#lang scheme

(define (marrage-year)
  (display "貴女が幸せになれる結婚年齢を導き出すお手伝いをさせて頂きます\n")
  (first-step))

(define (first-step)
  (display "お好きな二桁の数字を入力してください : ")
  (let ((num (read)))
    (cond ((or (not (integer? num)) (< num 10) (> num 99))
    (display "入力値が違います。\n")
    (first-step))
   (else
    (second-step num)))))

(define (second-step num)
  (for-each display (list "入力された数値は " num " です。\n"))
  (let ((b (modulo num 10)))
    (let ((a (/ (- num b) 10)))
      (let ((ans (+ a b)))
 (display "一の位と十の位を足した数を入力してください : ")
 (let ((n (read)))
   (cond ((not (eqv? n ans))
   (display "計算が間違っています。\n")
   (second-step num))
  ((> n 9)
   (display "もう一度一の位と十の位を足します。\n")
   (second-step n))
  (else
   (third-step n))))))))

(define (third-step num)
  (for-each display (list "入力された数値は " num " です。\n"))
  (let ((ans (* num 9)))
    (display "出てきた答えに9をかけて入力してください。 : ")
    (let ((n (read)))
      (cond ((not (eqv? n ans))
      (display "入力値が間違っています。\n")
      (third-step num))
     (else
      (fourth-step n))))))

(define (fourth-step num)
  (for-each display (list "入力された数値は " num " です。\n"))
  (let ((b (modulo num 10)))
    (let ((a (/ (- num b) 10)))
      (let ((ans (+ a b)))
 (display "出てきた答えの一の位と十の位を足してください。 : ")
 (let ((n (read)))
   (cond ((not (eqv? n ans))
   (display "計算が間違っています。\n")
   (fourth-step num))
  (else
   (fifth-step n))))))))

(define (fifth-step num)
  (for-each display (list "入力された数値は " num " です。\n"))
  (display "出てきた答えに今までの男性経験人数を足して入力して下さい。 : ")
  (let ((n (read)))
    (cond ((or (not (integer? n)) (negative? n) (< n num))
    (display "入力値が間違っています。\n")
    (fifth-step num))
   (else
    (for-each display (list "貴女の男性経験数は " (- n 9) " 人です。\n"))))))

(marrage-year)

Project Lizardry ～その1～

#!/usr/bin/env mzscheme
#lang scheme/base

(require srfi/1)

;; データ
(define *gilgamesh-tavern-data* '())

(define *party* '())

;; キャラクター基本
(define *character-base*
  '(('foe . #f)
    ('level . #f)
    ('性格 . #f)
    ('職業 . #f)
    ('種族 . #f)
    ('E.P. . #f)
    ('Next . #f)
    ('Gold . #f)
    ('Marks . #f)
    ('Age . #f)
    ('A.C. . #f)
    ('Rip . #f)
    ('力 . #f)
    ('知恵 . #f)
    ('信仰心 . #f)
    ('生命力 . #f)
    ('素早さ . #f)
    ('運の強さ . #f)
    ('H.P.numerator . #f)
    ('H.P.denominator . #f)
    ('状態 . #f)
    ('Mage 0 0 0 0 0 0 0 0 0)
    ('Priest 0 0 0 0 0 0 0 0 0)
    ('持ち物 . '())))

(define *race* '((人間 ((力 . 8)
                        (知恵 . 8)
                        (信仰心 . 5)
                        (生命力 . 8)
                        (素早さ . 8)
                        (運の強さ . 9)))
                 (エルフ ((力 . 7)
                          (知恵 . 10)
                          (信仰心 . 10)
                          (生命力 . 6)
                          (素早さ . 9)
                          (運の強さ . 6)))
                 (ドワーフ ((力 . 10)
                            (知恵 . 7)
                            (信仰心 . 10)
                            (生命力 . 10)
                            (素早さ . 5)
                            (運の強さ . 6)))
                 (ノーム ((力 . 7)
                          (知恵 . 7)
                          (信仰心 . 10)
                          (生命力 . 8)
                          (素早さ . 10)
                          (運の強さ . 7)))
                 (ホビット ((力 . 5)
                            (知恵 . 7)
                            (信仰心 . 7)
                            (生命力 . 6)
                            (素早さ . 10)
                            (運の強さ . 15)))))

;; テキスト部分
(define *top-page-text*
  "\t Lizardry\n\n      Proving Grounds\n\t    of\n     the Let Over Lambda\n\n\tWelcome to\n  the world of Lizardry\n\n\t1. START\n\t2. READ STORY\n")

(define *story-text*
  '("昔々あるところにラムダ王国と言う平和な国があった。ラムダ王国の平和はラムダ騎士団によって守られていた。\n\nラムダ騎士団のリーダーは紫導師と呼ばれるハッカーだった。ラムダ騎士団は紫導師の指導の下、日々鍛錬を重ねていた。\n\nそんなある日、城壁のそばに転がっていた古びたSymbolicsの中に迷宮を作って住み着く邪悪なニシキヘビが、紫導師の寝室に忍び込み、熟睡中の紫導師の耳元で悪魔の言葉を大阪弁で囁いた。\n\n「今更マクロなんて流行りまへんがな。時代は豊富な組み込みライブラリでっせ、旦那。」\n\nこの言葉は呪詛となり、あろう事か紫導師はニシキヘビと共に電脳迷宮の奥深くへと消えて行った。\n\n"
    "紫導師の突然の失踪は即ラムダ騎士団の弱体化に繋がった。リーダーを失ったラムダ騎士団はもはや烏合の衆と成り果て、ラムダ王国は存亡の危機へと陥った。\n\n事態を重く見たラムダ国王はラムダ騎士団の立て直しを図り、世界に散らばった逸材を発掘するため、ある召集を行った。\n\n「我らが偉大な王、ラムダ国王の召集である。皆の者、心して聞くように。元主席ハッカー紫が、ニシキヘビの陰謀に嵌り連れ去られてしまった。ニシキヘビは勝手に町外れに転がっている中古のSymbolicsの電脳世界に迷宮を掘り、モンスターを離して立てこもっておるのだ。かの悪逆非道のニシキヘビを成敗し、紫導師を救い出すのだ!さすれば、ラムダの騎士の称号とラムダ騎士団への入隊、更には多額の賞金が贈られるであろう!ポール・グレアムも実はそうやって金を稼いだのだがそれは内緒にしててね!!」\n\nこの召集に、ラムダ王国だけではなく、各地からあらゆる種族のハッカー達が集まった。金に困る者、己の腕を磨こうとする者たちが次々に名乗りをあげる。ラムダの騎士の名誉と一攫千金を夢見て・・・。\n\n"))

(define *castle-text*
  "\t        キャッスル:\n\n\t1. ギルガメッシュないとの酒場\n\t2. ハッカーの宿\n\t3. ボッタクル商店\n\t4. カント寺院\n\t5. 街外れに行く\n")

(define *gilgamesh-tavern-text*
  "\t        キャッスル:\n\n\t1. 仲間に入れる\n\t2. 仲間から外す\n\t3. 調べる\n\t4. ゴールドの山分け\n\t5. 外へ出る\n")

(define *edge-of-town-text*
  "\t        街外れ:\n\n\t1. 迷宮に入る\n\t2. 冒険の再開\n\t3. 訓練場に行く\n\t4. ゲームの中断\n\t5. 城に戻る\n")

(define *leave-game-text*
  "\tお疲れ様でした。\nこの状態でゲームを終了します。\n\n\tAで冒険を再開します\n")

;; マクロ
(define-syntax character-making
  (syntax-rules ()
    ((_ name alist)
     (define name
       (alist-copy alist)))))

;; 実行部分

(define (top-page scenario)
  (display scenario)
  (newline)
  (display "コマンド? >> ")
  (let ((key (read)))
    (case key
      ((1) (castle *castle-text*))
      ((2) (story-reader *story-text*))
      (else (top-page scenario)))))

(define (story-reader scenario)
  (do ((ls scenario (cdr ls))
       (key #f (read)))
      ((null? ls) (top-page *top-page-text*))
    (display (car ls))))

(define (castle scenario)
  (display scenario)
  (newline)
  (display "コマンド? >> ")
  (let ((key (read)))
    (case key
      ((1) (gilgamesh-tavern *gilgamesh-tavern-text*))
      ((2) (adventurer-inn))
      ((3) (boltac-trading-post))
      ((4) (temple-of-cant))
      ((5) (edge-of-town *edge-of-town-text*))
      (else (castle scenario)))))

(define (gilgamesh-tavern scenario)
  (display scenario)
  (newline)
  (display "コマンド? >> ")
  (let ((key (read)))
    (case key
      ((1) (add-character))
      ((2) (remove-character))
      ((3) (inspect-character))
      ((4) (divvy-gold))
      ((5) (castle *castle-text*))
      (else (gilgamesh-tavern scenario)))))

(define (add-character) (display "工事中\n"))
(define (remove-character) (display "工事中\n"))
(define (inspect-character) (display "工事中\n"))
(define (divvy-gold) (display "工事中\n"))

(define (adventurer-inn)
  (display "工事中\n"))

(define (boltac-trading-post)
  (display "工事中\n"))

(define (temple-of-cant)
  (display "工事中"))

(define (edge-of-town scenario)
  (display scenario)
  (newline)
  (display "コマンド? >> ")
  (let ((key (read)))
    (case key
      ((1) (maze))
      ((2) (restart-an-out-party))
      ((3) (training-grounds))
      ((4) (leave-game *leave-game-text*))
      ((5) (castle *castle-text*))
      (else (edge-of-town scenario)))))

(define (maze) (display "工事中\n"))
(define (restart-an-out-party) (display "工事中\n"))
(define (training-grounds) (display "工事中\n"))

(define (leave-game scenario)
  (display scenario)
  (newline)
  (display "コマンド? >> ")
  (let ((key (read)))
    (if (eqv? key 'a)
        (edge-of-town *edge-of-town-text*)
        (exit))))

(define (inheritance key datum)
  (lambda (alist)
    (let ((ls (alist-delete key (alist-copy alist))))
      (alist-cons key datum alist))))

(top-page *top-page-text*)

MoeMacsってこう言う感じかこの野郎。

イメージとしてはこう言う感じなんですかね。イメージだけ、ですけれども。


Twittering-modeはこんな感じになっている。