プログラミングの基礎 16.4 最初の完動プログラム

プログラミングの基礎で作ったメトロネットワーク最短路問題の解答．
ダイクストラ法を使い求める．
ここまでのメトロネットワーク最短路問題に関係する問題の解答すべてここに書いてある．

(* サポートページからダウンロードしたglobal_ekimei_listとglobal_ekikan_list *)
#use "metro.ml"

(* 目的：ekimei_t型のデータを受け取り，「路線名，駅名（かな）」を返す *)
(* hyoji : ekimei_t -> string *)
let hyoji ekimei = match ekimei with
    {kanji = kanji;
     kana = kana;
     romaji = romaji;
     shozoku = shozoku;}
    -> shozoku ^ "，" ^ kanji ^ "（" ^ kana ^ "）";;



(* hyoji test *)
print_string "hyouji test"
let test1 = hyoji {kanji = "茗荷谷"; kana = "みょうがだに";
                   romaji = "myogadani"; shozoku = "丸ノ内線"}
  = "丸ノ内線，茗荷谷（みょうがだに）"


(* 目的：ローマ字の駅名（文字列）と駅名リスト(ekimei_t list 型)を受け取り
   園駅の漢字表記を返す *)
(* romaji_to_kanji -> string -> ekimei_t list -> string *)
let rec romaji_to_kanji name lst = match lst with
    [] -> ""
  | {kanji = kanji; kana = kana; romaji = romaji; shozoku = shozoku} :: rest ->
     if name = romaji
     then kanji
     else romaji_to_kanji name rest

(* romaji_to_kanji test *)
let test1 = romaji_to_kanji "" [] = ""
let test2 = romaji_to_kanji "" global_ekimei_list = ""
let test3 = romaji_to_kanji "myogadani" [] = ""
let test4 = romaji_to_kanji "myogadani" global_ekimei_list = "茗荷谷"
let test5 = romaji_to_kanji "aoyamaicchome" global_ekimei_list = "青山一丁目"
let test6 = romaji_to_kanji "heiwadai" global_ekimei_list = "平和台"


(* 目的：漢字の駅名を２つと駅間リストを受け取ったら，駅間リストの中からその２駅間の距離を返す *)
(* get_ekikan_kyori : string -> string -> ekikan_t list -> float *)
let rec get_ekikan_kyori eki1 eki2 lst = match lst with
    [] -> infinity
  | {kiten = kiten; shuten = shuten; keiyu = keiyu; kyori = kyori; jikan = jikan} :: rest ->
     if eki1 = kiten && eki2 = shuten
     then kyori
     else if eki2 = kiten && eki1 = shuten
     then kyori
     else get_ekikan_kyori eki1 eki2 rest



(* get_ekikan_kyori test *)
let test1 = get_ekikan_kyori "錦糸町" "住吉" [] = infinity
let test2 = get_ekikan_kyori "錦糸町" "" global_ekikan_list = infinity
let test3 = get_ekikan_kyori "" "錦糸町" global_ekikan_list = infinity
let test4 = get_ekikan_kyori "横浜駅" "錦糸町" global_ekikan_list = infinity
let test5 = get_ekikan_kyori "大手町" "三越前" global_ekikan_list = 0.7
let test6 = get_ekikan_kyori "三越前" "大手町" global_ekikan_list = 0.7
let test7 = get_ekikan_kyori "霞ヶ関" "日比谷" global_ekikan_list = 1.2


(* 目的：ローマ字の駅名を２つ受け取り，その間の距離を調べ，つながっている場合は
   「A駅からB駅までのはｘｋｍです」と返し，繋がっていない場合は
   「A駅からB駅はつながっていません」と返す*)
let kyori_wo_hyoji r1 r2 =
  let k1 = romaji_to_kanji r1 global_ekimei_list in
  let k2 = romaji_to_kanji r2 global_ekimei_list in
  let not_exist = "という駅は存在しません" in
  if k1 = ""
  then r1 ^ not_exist
  else if k2 = ""
  then r2 ^ not_exist
  else let kyori = get_ekikan_kyori k1 k2 global_ekikan_list in
       if kyori = infinity
       then k1 ^ "駅と" ^ k2 ^ "駅はつながっていません"
       else k1 ^ "駅から" ^ k2 ^ "駅までは" ^ string_of_float kyori ^ "kmです"

(* kyori_wo_hyoji test *)
let test1 = kyori_wo_hyoji "otemachi" "hibiya" = "大手町駅と日比谷駅はつながっていません"
let test2 = kyori_wo_hyoji "" "kinsityo"  = "という駅は存在しません"
let test3 = kyori_wo_hyoji "yokohama" "kinsityo" = "yokohamaという駅は存在しません"
let test4 = kyori_wo_hyoji "otemachi" "mitsukoshimae" = "大手町駅から三越前駅までは0.7kmです"
let test5 = kyori_wo_hyoji "mitsukoshimae" "otemachi" = "三越前駅から大手町駅までは0.7kmです"
let test6 = kyori_wo_hyoji "kasumigaseki" "hibiya" = "霞ヶ関駅から日比谷駅までは1.2kmです"

type eki_t = {
  namae : string;               (* 駅名（漢字の文字列） *)
  saitan_kyori : float;         (* 最短距離（実数） *)
  temae_list : string list;     (* 駅名（漢字の文字列）のリスト *)
}

(* 目的：string型の駅名(漢字)とekimei_t list型を受け取り，
   ekimei_t listをeki_t listに変え，その際駅名と一致する駅についてはshokikaする *)
(* make_initial_eki_list : string -> ekimei_t list -> eki_t list *)
let make_initial_eki_list name lst =
  List.map (fun eki -> match eki with
    {kanji = k; kana = a; romaji = r; shozoku = s}
    -> if k = name
      then {namae = k; saitan_kyori = 0.; temae_list = [k]}
      else {namae = k; saitan_kyori = infinity; temae_list = []})
    lst;;

(* make_initial_eki_list test *)
let test1 = make_initial_eki_list "代々木上原" [{kanji="代々木上原"; kana="よよぎうえはら";
                                                 romaji="yoyogiuehara"; shozoku="千代田線"}]
  = [{namae = "代々木上原"; saitan_kyori = 0.; temae_list = ["代々木上原"]}];;
let test2 = make_initial_eki_list "明治神宮前" [{kanji="代々木公園"; kana="よよぎこうえん";
                                                romaji="yoyogikouen"; shozoku="千代田線"};
                                               {kanji="明治神宮前"; kana="めいじじんぐうまえ";
                                                romaji="meijijinguumae"; shozoku="千代田線"}]
  = [{namae = "代々木公園"; saitan_kyori = infinity; temae_list = []};
     {namae = "明治神宮前"; saitan_kyori = 0.; temae_list = ["明治神宮前"]}];;
let test3 = make_initial_eki_list "赤坂" [{kanji="表参道"; kana="おもてさんどう";
                                           romaji="omotesandou"; shozoku="千代田線"};
                                          {kanji="乃木坂"; kana="のぎざか";
                                           romaji="nogizaka"; shozoku="千代田線"};
                                          {kanji="赤坂"; kana="あかさか";
                                           romaji="akasaka"; shozoku="千代田線"}]
  = [{namae = "表参道"; saitan_kyori = infinity; temae_list = []};
     {namae = "乃木坂"; saitan_kyori = infinity; temae_list = []};
     {namae = "赤坂"; saitan_kyori = 0.; temae_list = ["赤坂"]}];;





(* 目的：ekimei_t型のレコードとekimei_t型のリストを受け取ったら，平仮名の昇順となる位置に
   ekimei_t型のレコードを挿入する．同じ駅がリストにあれば挿入しない．
   seiretsuのための補助関数*)
(* ekimei_isnert : -> ekimei_t -> ekimei_t list -> ekimei_t list *)
let rec ekimei_insert eki lst = match lst with
    [] -> [eki]
  | ({kanji = kanji; kana = kana; romaji = romaji; shozoku = shozoku;} as first) :: rest ->
     if kana = eki.kana
     then lst                   (* リストにあったほうが残る *)
     else if eki.kana < kana    (* 駅のkana < first のkana *)
     then eki :: lst
     else first :: ekimei_insert eki rest

(* test data *)
let yoyogiuehara_tiyodasen = {kanji="代々木上原"; kana="よよぎうえはら";
                              romaji="yoyogiuehara"; shozoku="千代田線"}
let otemachi_tiyodasen = {kanji="大手町"; kana="おおてまち";
                         romaji="otemachi"; shozoku="千代田線"}
let otemachi_hanzoumonsen = {kanji="大手町"; kana="おおてまち";
                             romaji="otemachi"; shozoku="半蔵門線"}


(* test *)
let test1 = ekimei_insert otemachi_tiyodasen [] = [otemachi_tiyodasen]
let test2 = ekimei_insert otemachi_tiyodasen [otemachi_hanzoumonsen] = [otemachi_hanzoumonsen]
let test3 = ekimei_insert otemachi_tiyodasen [yoyogiuehara_tiyodasen]
    = [otemachi_tiyodasen; yoyogiuehara_tiyodasen]
let test4 = ekimei_insert yoyogiuehara_tiyodasen [otemachi_tiyodasen]
    = [otemachi_tiyodasen; yoyogiuehara_tiyodasen]


(* 目的：ekimei_t型のリストを受け取ったら，それを平仮名の順に整列し，
   さらに駅の重複を取り除いたekimei_t型のリストを返す *)
(* seiretsu : ekimei_t -> ekimei_t *)
let rec seiretsu lst = match lst with
    [] -> []
  | first :: rest -> ekimei_insert first (seiretsu rest)




let test1 = seiretsu [] = []
let test2 = [yoyogiuehara_tiyodasen]
  = [yoyogiuehara_tiyodasen]
let test3 = seiretsu [otemachi_tiyodasen; otemachi_hanzoumonsen]
  = [otemachi_hanzoumonsen]
let test4 = seiretsu [otemachi_tiyodasen; otemachi_hanzoumonsen; yoyogiuehara_tiyodasen]
  = [otemachi_hanzoumonsen; yoyogiuehara_tiyodasen]




let otemachi = {namae = "大手町"; saitan_kyori = 0.; temae_list = ["大手町"]}
let mitsukoshimae = {namae = "三越前"; saitan_kyori = infinity; temae_list = []}
let shibuya = {namae = "渋谷"; saitan_kyori = infinity; temae_list = []}
let aoyamaichome = {namae = "青山一丁目"; saitan_kyori = infinity; temae_list = []}



(* 目的：直前に確定した駅 p (eki_t型)と味覚手の役のリスト v (eki_t list型)を受け取り
   必要な更新処理を行った後の未確定の駅のリストを返す*)
(* koushin -> eki_t -> eki_t list -> ekikan_t list -> eki_t list *)
let koushin p v ekikan =
  List.map
    (fun q ->
      let kyori = get_ekikan_kyori p.namae q.namae ekikan in
      if kyori = infinity
      then q
      else let p_keiyu_q_kyori = p.saitan_kyori +. kyori in
           if  p_keiyu_q_kyori  < q.saitan_kyori
           then { namae = q.namae; saitan_kyori = p_keiyu_q_kyori;
                  temae_list =(q.namae) :: p.temae_list}
           else q)
    v;;


(* test data *)
let otemachi = {namae = "大手町"; saitan_kyori = 0.; temae_list = ["大手町"]}
let mitsukoshimae = {namae = "三越前"; saitan_kyori = infinity; temae_list = []}
let shibuya = {namae = "渋谷"; saitan_kyori = infinity; temae_list = []}
let aoyamaichome = {namae = "青山一丁目"; saitan_kyori = infinity; temae_list = []}
let nagatacho = {namae = "永田町"; saitan_kyori = infinity; temae_list = []}
let shinochanomizu = {namae = "新御茶ノ水"; saitan_kyori = infinity; temae_list = []}

(* koushin test *)
let koushin_test1 = koushin otemachi
  [mitsukoshimae; shibuya; shinochanomizu; aoyamaichome] global_ekikan_list
  =[{namae = "三越前"; saitan_kyori = 0.7;
     temae_list = ["三越前"; "大手町"]};
    {namae = "渋谷"; saitan_kyori = infinity; temae_list = []};
    {namae = "新御茶ノ水"; saitan_kyori = 1.3;
     temae_list = ["新御茶ノ水"; "大手町"]};
    {namae = "青山一丁目"; saitan_kyori = infinity; temae_list = []}];;



(* 目的：eki_t list型のリストを受け取り，「最短距離最小の駅」と
   「最短距離最小の駅以外からなるリスト」の組を返す *)
(* saitan_wo_bunri : eki_t list -> eki_t * eki_t list *)
let saitan_wo_bunri eki_list =
  List.fold_right
    (fun first rest_saitan ->
      let (minimum, lst) = rest_saitan in
      if minimum.namae = ""
      then (first, lst)
      else if first.saitan_kyori <= minimum.saitan_kyori
      then (first, minimum :: lst)
      else (minimum, first :: lst))
    eki_list
    ({namae = ""; saitan_kyori = infinity; temae_list = []}, [])


let test1 = saitan_wo_bunri [{namae = "三越前"; saitan_kyori = 0.7;
                              temae_list = ["三越前"; "大手町"]};
                             {namae = "渋谷"; saitan_kyori = 0.3; temae_list = ["渋谷"]};
                             {namae = "新御茶ノ水"; saitan_kyori = 1.3;
                              temae_list = ["新御茶ノ水"; "大手町"]};
                             {namae = "青山一丁目"; saitan_kyori = infinity;
                              temae_list = []}]
  =({namae = "渋谷"; saitan_kyori = 0.3; temae_list = ["渋谷"]},
    [{namae = "三越前"; saitan_kyori = 0.7;
     temae_list = ["三越前"; "大手町"]};
     {namae = "新御茶ノ水"; saitan_kyori = 1.3;
      temae_list = ["新御茶ノ水"; "大手町"]};
     {namae = "青山一丁目"; saitan_kyori = infinity; temae_list = []}]);;


(* 目的：eki_t list型の未確定の駅のリストとekikan_t list型の駅間のリストを受け取り
   ダイクストラのアルゴリズムにしたがって各駅について
   最短距離と最短経路が正しく入ったリストを返す *)
(* dijkstra_main : eki_t list -> ekikan_t list -> eki_t list *)
let rec dijkstra_main  eki_list ekikan = match eki_list with
    [] -> []
  | first :: rest -> match (saitan_wo_bunri eki_list) with
    (saitan1, []) -> [saitan1]
    | (saitan2, rest) -> saitan2 :: (dijkstra_main (koushin saitan2 rest ekikan) ekikan) ;;



(* test_data *)
let otemachi = {namae = "大手町"; saitan_kyori = 1.7; temae_list = ["神保町"]};;
let mitsukoshimae = {namae = "三越前"; saitan_kyori = infinity; temae_list = []};;
let suitenguumae = {namae = "水天宮前"; saitan_kyori = infinity; temae_list = []};;
let kiyosumishirakawa = {namae = "清澄白河"; saitan_kyori = infinity; temae_list = []};;
let sumiyoshi = {namae = "住吉"; saitan_kyori = infinity; temae_list = []};;

let dijkstra_test1 = dijkstra_main [otemachi; mitsukoshimae; suitenguumae;
                                    kiyosumishirakawa; sumiyoshi]
  global_ekikan_list
  = [{namae = "大手町"; saitan_kyori = 1.7; temae_list = ["神保町"]};
     {namae = "三越前"; saitan_kyori = 2.4;
      temae_list = ["三越前"; "神保町"]};
     {namae = "水天宮前"; saitan_kyori = 3.7;
      temae_list = ["水天宮前"; "三越前"; "神保町"]};
     {namae = "清澄白河"; saitan_kyori = 5.4;
      temae_list = ["清澄白河"; "水天宮前"; "三越前"; "神保町"]};
     {namae = "住吉"; saitan_kyori = 7.30000000000000071;
      temae_list =
         ["住吉"; "清澄白河"; "水天宮前"; "三越前"; "神保町"]}];;

(* 目的：始点の駅名（ローマ字の文字列）と終点の駅名（ローマ字の文字列）を受け取り
   seiretsuを使ってglobal_ekimei_list の重複を取り除き，
   romaji_to_kanji を使って始点と終点の漢字表記を求め
   make_initial_eki_listを使って駅のリストを作り，
   dijkstra_mainを使って各駅までの最短路を確定し，
   その中空終点の駅のレコード(eki_t型)を返す*)
(* dijkstra : string -> string -> eki_t *)
let dijkstra siten shuten =
  let sorted_ekimei_list = seiretsu global_ekimei_list in
  let siten_kanji = romaji_to_kanji siten sorted_ekimei_list in
  let shuten_kanji = romaji_to_kanji shuten sorted_ekimei_list in
  let initialized_list = make_initial_eki_list siten_kanji sorted_ekimei_list in
  let saitan_list = dijkstra_main initialized_list global_ekikan_list in
  let rec serch item lst = match lst with
      [] -> {namae = ""; saitan_kyori = infinity; temae_list = []}
    | first :: rest ->
       if first.namae = item
       then first
       else serch item rest
  in serch shuten_kanji saitan_list;;

(* test *)
(* サポートページからのコピペ *)
let test1 = dijkstra "shibuya" "gokokuji" =
  {namae = "護国寺"; saitan_kyori = 9.8;
   temae_list =
     ["護国寺"; "江戸川橋"; "飯田橋"; "市ヶ谷"; "麹町"; "永田町";
      "青山一丁目"; "表参道"; "渋谷"]}
let test2 = dijkstra "myogadani" "meguro" =
  {namae = "目黒"; saitan_kyori = 12.7000000000000028;
   temae_list =
     ["目黒"; "白金台"; "白金高輪"; "麻布十番"; "六本木一丁目"; "溜池山王";
      "永田町"; "麹町"; "市ヶ谷"; "飯田橋"; "後楽園"; "茗荷谷"]}

OCamlの無名関数は再帰を定義できない？

わたろーです．
今プログラミングの基礎 (Computer Science Library)を読んでいます．
これはOCamlとデザインレシピでプログラミングの基礎を学ぶという内容なのですが，
名前のない関数という節で気になる文章がありました．
14.4 名前のない関数 p145

名前のない関数で定義できるのは再帰をしていない関数だけです．

OCamlはラムダ計算を元にしていると思っていたので驚きました．
Yコンビネータ使って再帰出来ないのって思ったので試してみました．
Yコンビネータは計算機プログラムの構造と解釈 第2版p233 問題4.21に載っていたものを使います．

;;; SICP
;;; 階乗計算
(lambda (n)
  ((lambda (fact)
     (fact fact n))
   (lambda (ft k)
     (if (= k 1)
         1
         (* k (ft ft (- k 1)))))))

実行すると

gosh> ((lambda (n)
         ((lambda (fact)
            (fact fact n))
          (lambda (ft k)
            (if (= k 1)
                1
                (* k (ft ft (- k 1)))))))
       5)
120

　
これをOCamlで書いてみます．

# (fun n->
  (fun fact ->
    fact fact n)
    (fun ft k ->
      if k = 1
      then 1
      else k * (ft ft (k - 1)))) 5;;
            Characters 33-37:
      fact fact n)
           ^^^^
Error: This expression has type 'a -> 'b -> 'c
       but an expression was expected of type 'a
       The type variable 'a occurs inside 'a -> 'b -> 'c

エラーですね．
型が解決されていないのでしょうか．
ググッてみると -rectypesを使ってインタプリタを起動すれば出来るようです．

不動点演算子ふたたび - sumiiの日記

# (fun n->
    (fun fact ->
      fact fact n)
      (fun ft k ->
        if k = 1
        then 1
        else k * (ft ft (k - 1)))) 5;;

            - : int = 120

おお，動いた．
再帰型っていうのが必要になるわけなんですね．
まだまだわからないことだらけですが，型もおもしろそうです．
この辺探すのに行き着いたこのページのTaPLのまとめがすごくおもしろそうです．

mint.hateblo.jp

おもしろそう．読みたい．すごく読みたい． でもまだ自分には厳しそう．

その前にプログラミング言語の基礎概念 (ライブラリ情報学コア・テキスト)を読みたい．
しかしその時間を作れるか．
そろそろお仕事探しのために動かないといけないかもって思ってきています．
勉強だけしていたい．

プログラミング初心者がSICP(計算機プログラムの構造と解釈)を読んでみた

読む前の状態と動機

• 読み始めた時点でプログラミング歴約１年
• もうひとつのscheme入門でプログラミングに入門するも，高階関数で挫折．
• Ruby本二冊，Rails Tutorialを二周．
• 他読み始めたけど途中で飽きた本が何冊か．
• 仕事（非IT)が忙しく，プログラミング始めて一年でこれくらいしか出来なかった．
• 基本的なところがしっくりこない．
• でもコード書くのは楽しいし，出来ればそれを仕事にしたいので基礎を身に着けたい．
• 無職になって時間もあるから基礎を身につけるためにSICPを読もう．
  　

読むための準備

• Scheme手習いとプログラミングGaucheを読んでからSICPにとりかかった．
• メインで読んだのは2版の和田訳．読んでわからない時は原著や1版の元吉訳に当たる．
• 後半になると真鍋訳が登場したためこちらにも助けられた．
  　
  　

  SICPを読む過程で得たもの

• 括弧が気にならなくなった
• S式のほうが読みやすいのになんで中置記法のほうがメジャーなの？
• 再帰的プロセスと反復的プロセス
• 第一級手続き
• 抽象の壁
• メッセージパッシング
• 型によるディスパッチと強制型変換
• イベントドリヴン
• 制約の拡散
• 破壊的代入が怖くなった
• ストリーム
• 遅延評価
• 超循環評価器の実装を通して評価戦略を理解した．
• レジスタマシンのシミュレータによって低レベルで何が行われているのか理解した．
• コンパイラとインタプリタの効率の違い
  　

  感想

  ４ヶ月半近くかかった．
  SICPは基礎と聞いていたけど，やっぱり基礎でした．
  今の段階で読んでおいてよかった．
  問題全部解くつもりはなかったけど，だんだんと自力で解きたくなってきたため結局ほとんど自力で解いていた．
  解けないと悔しい．
  問題やってみて思うのは，時間がめちゃくちゃかかるけど解かないと理解できなかった．
  特に４章からは本文のコードを動かすにもデバッグが大変で，問題解くにもデバッグが大変．
  でもそのデバッグを通して何度もコードや本文を読むことでそこで何をしているのか理解していけた．
  最後はソースがコメントだらけになった．
  C言語でやる問題が２問残っているのでCを勉強してから解きたい．
  プログラミング楽しい！にプログラミング言語おもしろい！も追加された．
  プログラミング初心者からプログラミング初級者へレベルアップできた・・・はず．
  　
  これから読む人にはScheme手習いを読んでおくことを勧めたい．
  読みにくいし後半急激に難しくなるけど，そこで継続を渡すことを覚えておくと楽になる．
  デバッグ方法も覚えておかないと４章から辛いので
  Gauche使うならプログラミングGaucheにも一通り目を通しておいたほうがいい．
  　
  かなり苦しんだけど，それでも楽しい・おもしろいのほうが勝ってる．
  まだ半年は生きていけそうなのでまだまだ勉強してコード書く仕事につけるように頑張ります．
  とりあえずプログラミングの基礎 (Computer Science Library)でMLとデザインレシピに触れてからK&Rを読もうと思ってます．

計算機プログラムの構造と解釈 第2版

Scheme手習い

プログラミングGauche

SICP 問題 5.50

4.1節の超循環評価器を5.5で作った翻訳系でコンパイルする．
　

問題5.50 – SICP（計算機プログラムの構造と解釈）その302 : Serendip - Webデザイン・プログラミング

http://himoiku.cocolog-nifty.com/blog/2008/07/sicp550_f385.html

ここを参考にしました．
まずここに書いてるmapがバグるっていうのがわからないところからスタート．
エラーメッセージを見ても原因がmapだとは気づかず，
この２つのブログを参考にしながら修正するも，翻訳系がダメなのかインタプリタがダメなのかもなかなかわからず．
　
三日間いろいろなバグに出会いながら最後まで残ったのが２つ．
一つ目はどこかで環境の保護がされていないために，再帰のベースケースから戻ってきても環境が回復されずその後の計算がおかしくなるバグ．
二つ目はレキシカルアドレッシングで翻訳時環境から得たアドレスが狂うバグ．
一つ目は最終的にソースをenvで検索してpreservingまたはmake-instruction-sequenceでenvが足らないところがないか探しました．
レキシカルアドレッシングの実装時に，作ったcompile-variablesとcompile-assignmentのmake-instruction-sequenceのneededにenvが入っていないためでした． 二つ目の原因は内部定義でした．
翻訳時環境が拡張されるのはcompile-lambda-bodyだけなので，内部定義でフレームが拡張されず，
find-variableが指すアドレスがこのシンボルがない時の環境でのアドレスなので実行時環境では違うものを指してしまいバグっていました．
これの解決策として，scan-out-definesでmake-letを使い内部定義を全てletに吐き出し，
それをlet->combinationでlambdaに変換することで解決しました．
根本的な解決ではないですが，とりあえず，コンパイルについては問題なく動きます．
　
以下はテスト． 翻訳系のREPLのEC-COMPからdriver-loopを呼び出し，
翻訳系でコンパイルしたインタプリタのREPL，MC-Evalに入っています．

;;;EC-COMP input:
(driver-loop)


;;; MC-Eval input:
(define (map proc lst)
  (if (null? lst)
      '()
      (cons (proc (car lst))
            (map proc (cdr lst)))))

;;; MC-Eval value:
ok

;;; MC-Eval input:
(map car '((1 2) (3 4) (5 6)))

;;; MC-Eval value:
(1 3 5)

;;; MC-Eval input:
(define (fact n)
  (let iter ((count 1) (product 1))
    (if (< n count)
        product
        (iter (+ 1 count) (* count product)))))

;;; MC-Eval value:
ok

;;; MC-Eval input:
(fact 5)

;;; MC-Eval value:
120

;;; MC-Eval input:
(define (factorial n)
  (if (< n 2)
      n
      (* (factorial (- n 1))
         n)))

;;; MC-Eval value:
ok

;;; MC-Eval input:
(factorial 5)

;;; MC-Eval value:
120

;;; MC-Eval input:
(define (fact n)
  (define (iter count product)
    (if (< n count)
        product
        (iter (+ 1 count) (* count product))))
  (iter 1 1))

;;; MC-Eval value:
ok

;;; MC-Eval input:
(fact 5)

;;; MC-Eval value:
120

SICP 問題 5.49

compileとassembleを機械計算として持ち，REPLを行うレジスタ計算機を設計する．
　
はじめ，assembleを命令列の上でやる方法がわからずに，compile-and-assembleという手続きを作り，
それを機械演算として登録してRCEPLを実装したが，

問題5.49 – SICP（計算機プログラムの構造と解釈）その301 : Serendip - Webデザイン・プログラミング

ここでそれをうまく回避していたので真似た．

(load "./eval.scm")
(load "./compiler.scm")
(load "./register-machine-simulator.scm")
(load "./eceval.scm")

(define (rcepl) RCEPL)

(define rcepl-proc
  (append eceval-procedure
          (list (list 'compile compile))
          (list (list 'assemble assemble))
          (list (list 'rcepl rcepl))
          (list (list 'statements statements))))

(define RCEPL
  (make-machine
   rcepl-proc
   '((assign machine (op rcepl)) ;直接RCEPLを指せないので
     read-compile-execute-print-loop
     (perform (op initialize-stack))
     (perform (op prompt-for-input) (const ";;;EC-COMP input:"))
     (assign exp (op read))
     (assign env (op get-global-environment))
     (assign continue (label print-result))
     (goto (label read-compile-execute))

     print-result
     (perform (op print-stack-statistics))
     (perform (op announce-output) (const ";;;EC-COMP value":))
     (perform (op user-print) (reg val))
     (goto (label read-compile-execute-print-loop))

     read-compile-execute
     (assign val (op compile) (reg exp) (const val) (const return) (const ()))
     (assign exp (op statements) (reg val))
     (assign val (op assemble) (reg exp) (reg machine))
     (goto (reg val)))))

(define (start-rcepl)
  (set! the-global-environment (setup-environment))
  (start RCEPL))

　
test

gosh> (start-rcepl)


;;;EC-COMP input:
      (define (factorial n)
        (if (< n 2)
            n
            (* (factorial (- n 1)) n)))

(total-pushes = 0 maximum-depth = 0)
;;;EC-COMP value
ok

;;;EC-COMP input:
(factorial 20)

(total-pushes = 78 maximum-depth = 40)
;;;EC-COMP value
2432902008176640000

SICP 問題 5.48

ECEVALのrepl上でコンパイル出来るようにする．
これで動くかなって思ったら動いた．
ただトレースした命令列を見ると，
apply-dispatchからprimitive-procedureにジャンプせずに先頭に戻っている．
なぜそうなるのかわからない．

;; 環境を拡張してprimitive-procedureとしてcompile-and-run を登録
(define (setup-environment-with-compile)
  (extend-environment
   (list 'compile-and-run)
   (list (list 'primitive compile-and-run))
   (setup-environment)))

;; setup-environment-with-compileの環境からecevalに入るようにする
(define (compile-and-go expression)
  (let ((instructions
         (assemble (statements
                    (compile expression 'val 'return '()))
                   eceval)))
    (set! the-global-environment (setup-environment-with-compile))
    (set-register-contents! eceval 'val instructions)
    (set-register-contents! eceval 'flag true)
    (start eceval)))

; ; and-goとは違い環境の初期設定はいらない．
(define (compile-and-run expression)
  (let ((instructions
         (assemble (statements
                    (compile expression 'val 'return '()))
                   eceval)))
    (set-register-contents! eceval 'val instructions)
    (set-register-contents! eceval 'flag true)
    (start eceval)))

;; 環境をwith-compileのほうにしてflagをfalseにしてからecevalに入る．
(define (start-eceval)
  (set! the-global-environment (setup-environment-with-compile))
  (set-register-contents! eceval 'flag false)
  (start eceval))

SICP 問題 5.47

コンパイルした手続きから積極制御評価器で定義した手続きを使えるようにする．

(define (compile-procedure-call target linkage)
  (let ((primitive-branch (make-label 'primitive-branch))
        (compiled-branch (make-label 'compiled-branch))
        (compound-branch (make-label 'compound-branch)) ;; compound-branchの作成
        (after-call (make-label 'after-call)))
    (let ((compiled-linkage
           (if (eq? linkage 'next) after-call linkage)))
      (append-instruction-sequences
       (make-instruction-sequence
        '(proc) '()
        `((test (op primitive-procedure?) (reg proc))
          (branch (label ,primitive-branch))))
       ;; compiled-branchへの分岐を追加
       (make-instruction-sequence
        '(proc) '()
        `((test (op compiled-procedure?) (reg proc))
          (branch (label ,compiled-branch))))
       ;; primitiveでもcompiledでもなかったらcompoundとして処理．
       (parallel-instruction-sequences
        (append-instruction-sequences
         compound-branch
         ;; compiledと同じようにcompound-proc-applで命令を作る
         (compound-proc-appl target compiled-linkage))
        (parallel-instruction-sequences
            (append-instruction-sequences
             compiled-branch
             (compile-proc-appl target compiled-linkage))
            (append-instruction-sequences
             primitive-branch
             (end-with-linkage
              linkage
              (make-instruction-sequence
               '(proc argl) (list target)
               `((assign ,target
                         (op apply-primitive-procedure)
                         (reg proc)
                         (reg argl))))))))
       after-call))))

;; ほとんどcompile-proc-applと同じで，continueをセーブしてからcompappにジャンプする．
;; compappには(label procedure-apply)が入っている．
(define (compound-proc-appl target linkage)
  (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
         (make-instruction-sequence
          '() all-regs
          `((assign continue (label ,linkage))
            (save continue)
            (goto (reg compapp)))))
        ((and (not (eq? target 'val))
              (not (eq? linkage 'return)))
         (let ((proc-return (make-label 'proc-return)))
           (make-instruction-sequence
            '(proc) all-regs
            `((assign continue (label ,proc-return))
              (save continue)
              (goto (reg compapp))
              ,proc-return
              (assign ,target (reg val))
              (goto (label ,linkage))))))
        ((and (eq? target 'val) (eq? linkage 'return))
         (make-instruction-sequence
          '(proc continue) all-regs
          `((save continue)
            (goto (reg compapp)))))
        ((and (not (eq? target 'val)) (eq? linkage 'return))
         (error "return linkage, target not val -- COMPILE" target))))

;; ec-evalの命令の先頭でcompappを初期化する．
   '((assign compapp (label compound-apply)) ;追加
     (branch (label external-entry))
     read-eval-print-loop
     (perform (op initialize-stack))

　
test

gosh> (compile-and-go
       '(begin
          (define (f x) (+ (g x) 1))
          (define (g x) (+ x 10))))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(f 1)

(total-pushes = 7 maximum-depth = 3)
;;; EC-Eval value:
12

;;; EC-Eval input:
(define (g x) (+ x 20))

(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(f 1)

(total-pushes = 16 maximum-depth = 7)
;;; EC-Eval value:
22

gosh> (compile-and-go
       '(define (f x) (* (g x) 2)))

(total-pushes = 0 maximum-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(define (g x) (+ x 1))

(total-pushes = 3 maximum-depth = 3)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(g 1)

(total-pushes = 13 maximum-depth = 5)
;;; EC-Eval value:
2

;;; EC-Eval input:
(f 1)

(total-pushes = 16 maximum-depth = 7)
;;; EC-Eval value:
4

コンパイルした定義の上書き，コンパイルしていない定義へのアクセスの両方がうまくいっている．