2014/12/31

ClojureでunfoldとHylomorphism

unfold

 unfoldは, fold(reduce)の双対として定義される関数で, リストを生成する一種のジェネレータのような働きをするものです. 畳み込み関数に対応する, 要素を展開する関数とみなすことができます. Clojureだとiterateが一番近い関数でしょう.
user> (take 10 (iterate (partial + 2) 0))
(0 2 4 6 8 10 12 14 16 18)
 Haskellでは, foldが二種類あり, foldrとfoldlで, 右から畳み込みと左から畳み込みに対応しています. Clojureのreduceは, foldlに相当します. そして, foldr/foldlそれぞれにunfoldr/unfoldlが定義できますが, 以下の文章では, foldlを前提に話を進めます. (Haskellのfoldとunfoldrについてはここで書いています.)

 unfoldlをClojureで書くとしたら以下のような感じになると思います.
(defn unfoldl [pred g h start]
   (map g (take-while #(not (pred %)) (iterate h start))))
 計算を始めるオブジェクトと繰り返し適用するh, 生成したリストにmapをかけるためのgと, リストを終わらせる条件式predからなります. map gがtake-whileよりも後の処理になるのも重要な点です.

Hylomorphism

 Hylomorphismとは, (代数的データ型へ)一般化されたfoldとunfoldの合成のことで, リストにおけるfoldlとunfoldlについて,

hylol f e p g h = foldl f e . unfoldl p g h

と書ける関数です. (太字部分 2015/01/08追記) unfoldlで生成したリストをfoldlで畳み込むような計算になります. map/reduceならぬ, generate(リスト生成)/map/reduceの処理が一つにまとまりました. Clojureだと次のようになります.
(defn hylol1
  "hylol f e p g h = foldl f e . unfoldl p g h"
  [f init pred g h start]
  (reduce f init (unfoldl pred g h start)))
 これだけだと, 抽象的な関数を組み合わせたまた別の抽象的なだけの関数といった印象しか残りません. しかし, Hylomorphismは, これを別のリストを使わないコードへ書き直すことができるのです.
(defn hylol2
  [f e p g h b]
  (if (p b)
    e
    (f (g b) (hylol2 f e p g h (h b)))))
 これが, HylomorphismLの別の実装です.

 foldlとunfoldlを組み合わせると当然, unfoldlで生成されたリストが, foldlにおいて, 畳み込まれてしまうため, 結果的に, 最終的な計算結果(戻り値)に不要なリストを計算途中で生成する必要が出てきてしまいます. しかし, 上記の2番目の実装では, リストを生成する様子がありません.

 Hylomorphismの変換では, foldとunfoldの合成関数を, これと同等の意味を持つ「リストを生成しないプログラム」へ書き換えることでプログラムを高速化します. この辺はmap分配則と同じような感じですね.

 例えば, 1〜100の和を計算するようなプログラムについて, foldl/unfoldlを使って,
(defn sum-from1to [n]
  (reduce + 0 (unfoldl (partial = 0) identity dec n)))
 と書けるわけですが, これをHylomorphismで書きなおしてみると, hylol2の実装を使って,
user> (hylol2 + 0 (partial = 0) identity dec 10)
55
と書けます. これをhylol2の実装へ展開すると,
(defn hylol2-sum
  [b]
  (if ((partial = 0) b)
    0
    (+ (identity b) (hylol2-sum (dec b)))))
 のように書きなおすことができて, foldl/unfoldlを使った場合に比べて素直な書き方になっていることがわかるかと思います.

 ある意味では, Hylomorphismの変換とは, リストを使って抽象化した処理を, 素朴な再帰関数に書き戻す手法だとみなすことができます.

Hylomorphismの変換例

 さて, Hylomorphismの変換に関する一番の関心事は, 本当に高速化するのかという点と, 具体的にプログラムへ適用できるのかという点です. というわけで, 以下は, 8Queen問題のプログラムでHylomorphismを使ってみたケースです.

 前に書いた記事の8Queen問題の解法では, バックトラックにより計算していましたが, 今回は, 素朴な総当り法を使います.

 8Queen問題の解とは, 究極的には, 1〜8の数字の並び, だとみなすことができます. 例えば, x座標を固定した場合, 鳩の巣論法的に, 各x座標(= 1, 2, ... 8)には必ず一つQueenが入っている必要があるからです. というわけで, x座標の情報は不要になり, 順序を持ったy座標列が, 解となります.

 というわけで, このプログラムでは, y座標のpermutationを与え, そこから, xy座標の組を計算し, その座標列が正しいかどうかを判定し, 正しければ解を返します. 以下がコードです.
(use 'clojure.math.combinatorics)

;; unfoldl & hylomorphism
(defn unfoldl [pred g h start]
   (map g (take-while #(not (pred %)) (iterate h start))))

(defn hylol2
  [f e p g h b]
  (if (p b)
    e
    (f (g b) (hylol2 f e p g h (h b)))))

;; 8 queen
(defn conflict? [x y others]
  (and (not (empty? others))
       (let [x1 (ffirst others) y1 (second (first others))]
         (or (= x x1) (= y y1)
             (= (- x x1) (- y y1)) (= (- x x1) (- y1 y))
             (conflict? x y (rest others))))))

(defn not-conflict? [ls]
  (let [xy (first ls) others (rest ls)]
    (not (conflict? (first xy) (second xy) others))))

(defn andf
  ([a] a)
  ([a b] (and a b)))

(defn correct-answer? [arrangement]
  (reduce andf
    (map not-conflict?
      (take-while first (iterate rest arrangement)))))

(defn correct-answer?-v2 [arrangement]
  (hylol2 andf true #(not (first %)) not-conflict? rest arrangement))

(defn check-and-cons [checker yss]
  (let [arrangement (map list (range 8) yss)]
    (if (checker arrangement) arrangement [])))

(defn get-correct-answers [permutations checker]
  (filter first (map (partial check-and-cons checker) permutations)))

(def perm (doall (permutations (range 8))))

(def correct-answers
  (get-correct-answers perm correct-answer?))

(def correct-answers-v2
  (get-correct-answers perm correct-answer?-v2))
 実行時間を計測してみると, 確かに高速化されていることがわかります. correct-answersの方が, foldl/unfoldl(に相当するもの)を使った場合で, correct-answers-v2がhylol2によりプログラム変換を行ったケースです.
user> (time (count correct-answers))
"Elapsed time: 733.504269 msecs"
92
user> (time (count correct-answers-v2))
"Elapsed time: 592.678338 msecs"
92
 上記の結果を見た場合, それ以外の部分でボトルネックになっている部分もありそうですが, Hylomorphismの変換により, 一応, 高速化ができていることが観察できました.

 さて, 問題のプログラム変換は以下の部分で行っています. correct-answer?が, 素朴なfoldl/unfoldlで, correct-answer?-v2がリストを生成しないHylomorphismを使ったコードになります. correct-answer?の方にunfoldlというキーワードは見当たりませんが, map/take-while/iterateの組み合わせがそれに相当します.
(defn correct-answer? [arrangement]
  (reduce andf
    (map not-conflict?
      (take-while first (iterate rest arrangement)))))

(defn correct-answer?-v2 [arrangement]
  (hylol2 andf true #(not (first %)) not-conflict? rest arrangement))
 ここでは, [[1 2] [3 4] ...]のようなQueenの位置を表すリスト(arrangement)を受け取り, そこから, 部分リストを生成し(iterate/take-while), 各部分リストの「先頭の要素」と「他の要素」が衝突しないか(互いが取り合える位置にいないか)をチェックして(map not-conflict?), 矛盾しているケースがないかどうかをandf(andの関数版)で確認し(reduce), その答えの正解/不正解をboolで返すというものです.

 例えば, 座標のリスト[p1 p2 ... p8]があるときに互いに衝突していないかを判定するためには, p1と[p2 ... p8], p2と[p3 ... p8], p3と[p4 ... p8]と判定していくため, 上記のようなrestをiterateする実装になっています.

 reduce, map. take-while, iterateが一堂に会しているので, 図らずともHylomorphismの変換が簡単にできました.

 Hylomorphismの変換から得られる教訓(?)は, プログラム中に, ジェネレータによるリスト生成を行う部分があり, その先で, reduce(畳み込み関数)がそのリストを畳もうと待ち構えているとき, そのコードは, リストを使わないコードへ書き換えることができるかもしれない, ということです. そして, 書き換えたコードは, 余分な(本来の計算結果に不要な)データ構造の生成が不要になることで, 高速化できる筈だという結論です.

参考文献
  • 関数プログラミングの楽しみ, Jeremy Gibbons & Oege de Moor(編集), 山下 伸夫 (翻訳), オーム社, 2010/6/23
    • ifphの続編(?), この記事の内容は本書のhylomorphismのセクションを元にかかれています.
  • 構成的アルゴリズム論
    • hyloだけでなく, map分配則などプログラム運算の様々な規則が紹介されています. チュートリアル.
  • Anamorphic Adventure in Clojure - Matlux
    • Clojureで, Anamorphism(unfold相当)を定義する話. 

2014/12/30

Karva Notationという木構造を表す記法



 今日, hylomorphismについて調べていたらKarva Notationという記法に出会った. 上がhylomorphismについてググっていたときに出てきた記事で, 下がKarva Notationの説明の記事.

 一見すると, ポーランド記法のような書き方で, 演算子と識別子(変数?)を並べただけの書き方に見えますが, 例題の木構造とKarva Notationを見比べてみると, ポーランド記法とは全く別物です.

 こんな感じの木構造に対して,
     +
   ┏━┓
   a   *
     ┏━┓
     /   d
  ┏━┓
  b   c

 S式では,

 (+ a (* (/ b c) d))

と書くところを, Karva Notationは,

 + a * / d b c

 と表すようなのです. ポーランド記法だと, + a * / b c d になります.

 この記法では [深さ0の要素(=木構造のトップ)] [深さ1の要素] ... ... [深さnの要素] の順で各深さのレベルにおいて, それぞれ左から要素を記述していくという書き方です.
 上記の例では,

 [(木構造トップの) +] [(深さ1の) a (と) *]  [(深さ2の) / (と) d]  [(深さ3の) b (と) c]

 で, + a * / d b c となるわけです.

 こんな不思議な(可読性の低い)記法が, 何に使われるのかと思ったら, 遺伝的プログラミングでした.


 遺伝的プログラミングは, Wikipediaにもあるように, 遺伝的アルゴリズムをプログラミングへ発展させたもので, プログラムを意味する遺伝子どうしを掛け合わせたり, 突然変異させたりして, プログラム(もしくは関数)を進化させて, 解を得るという手法です. プログラムを木構造(抽象構文木)として表現し, この木構造を遺伝子として扱うことで, プログラムどうしを交叉(遺伝子どうしの配合)させます.

 そして, 普通, プログラム(関数)の遺伝子の表現は, S式など用いて行うわけですが, 上記のような Karva Notationによるプログラムの表現でも遺伝的プログラミングができる, ということのようです.

 そう考えると, なかなか面白い記法ですね. SGAで使われるような0/1の遺伝子の表現と同じような単なる記号列なので, SGAと同じような文字列の1点交叉や2点交叉ができてしまいます.

参考文献
Gene Expression Programming: A New Adaptive Algorithm for Solving Problems

2014/12/26

Clojureでダイクストラ法


 ダイクストラ法, 与えられたグラフにおいて, ある頂点からそれ以外の各頂点への最短のパス(ルート)を求めるアルゴリズムの一つです.

  1. グラフの頂点を, 到達済み頂点のグループと, 未到達頂点のグループへ分割します. 到達済み頂点のグループの初期値は, 開始頂点1つからなるグループで, 未到達の頂点グループの初期値は, それ以外の頂点すべてを含んだグループになります.
  2. 「到達済み頂点のグループのうち, どれかの頂点」(=vn)との間に「最も短い辺を持つ未到達の頂点」(=vm)を到達済み頂点のグループへ追加する. また, この辺を新しいルートとする. (開始点から新しく追加されたvmまでのパスは, 「開始点~vnまでのパス + 新しく追加された辺」となります.)
  3. 未到達頂点のグループに要素がなければアルゴリズム終了. 未到達頂点のグループに要素があれば, 2へ.

 日本語で書くとこんな感じで, 未到達の頂点が1つづつ減っていって, すべての頂点へのルートが決定します.

 なんとなく階層的クラスタリングに似ている気もしますが. 以下のような感じでダイクストラ法の実行結果が得られます. a~jがグラフ中の各点で隣の数字が開始点からの最短距離で, 赤線が開始点からの各点へのルートを表します. 黒線は, グラフに含まれているが, 最短ルートには含まれない辺. 例えば, c→jのルートは, c → d → a → j となります.

 以下の図において, 各点は, (x,y)座標が与えられており, 各点間の距離(=辺の長さ)は二乗距離で定義されます. (つまり, 視覚的な距離と, 頂点間の距離(辺の長さ)がおおよそ対応しています.)
 ナイーブなダイクストラ法の実装が以下のコードです. ダイクストラ法本体の実装より, グラフと実行結果可視化のコードの方がなぜか, 分量が多いですが.
(use '[clojure.core.match :only (match)]
     '[clojure.math.numeric-tower :as math])

;;---------------------------------------------------------------
;; find path

(defn mean-square [x1 x2 y1 y2]
  (math/sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2)))))

(defn get-weights [routes points-with-coord]
  (defn get-distance
    [point-A point-B]
    (let [a (get points-with-coord point-A)
          b (get points-with-coord point-B)]
      (mean-square (first a) (first b) (second a) (second b))))
  (->> routes
       (map #(get-distance (first %) (second %)))
       (interleave routes)
       (apply hash-map)))

(defn get-neighbors [routes]
  (->> (concat (map reverse routes) routes)
       (map vec)
       sort
       (group-by first)
       (map (fn [x] (list (first x) (map second (second x)))))
       (reduce concat)
       (apply hash-map)))

(defn find-path [start routes vs weights]

  (defn length [u v]
    (weights (sort (list u v))))

  (defn get-dist [x dp]
    (get-in dp [x :dist]))

  (defn find-nearest [xs dp]
    (->> (map (fn [x] [(get-dist x dp) x]) xs)
         sort first second))

  (defn short-route? [u v dp]
    (< (+ (length u v) (get-dist u dp)) (get-dist v dp)))

  (defn set-shorter [u v dp]
    (assoc-in dp [v] {:dist (+ (get-dist u dp) (length u v)) :prev u}))

  (defn update-at [u dp v]
    (if (short-route? u v dp) (set-shorter u v dp) dp))

  (let [distance-previous-data
        (->> vs
             (map #(list % {:dist Double/POSITIVE_INFINITY :prev nil}))
             (apply concat) (apply hash-map)
             (#(assoc-in % [start] {:dist 0 :prev nil})))]
   (loop [q vs dp distance-previous-data]
      (if (empty? q)
        dp
        (let [u (find-nearest q dp)
              new (reduce (partial update-at u) dp (u (get-neighbors routes)))]
          (recur (remove #(= u %) q) new))))))

;;---------------------------------------------------------------
(def spwc ;;sample-points-with-coord
  {:a [20 80] :b [35 20] :c [80 40] :d [60 100] :e [70 10]
   :f [10 60] :g [120 80] :h [20 35] :i [110 20] :j [0 120]})

(def sample-routes
  (let [routes
        [[:j :f] [:j :a] [:f :a] [:f :h]
         [:a :d] [:d :g] [:g :c] [:c :d]
         [:g :i] [:c :i] [:c :e] [:e :i]
         [:a :h] [:h :b] [:b :e] [:b :c]]]
    (map sort routes)))

;; samples
;; (find-path :j sample-routes (keys spwc) (get-weights sample-routes spwc))
;; (find-path :c sample-routes (keys spwc) (get-weights sample-routes spwc))

;;---------------------------------------------------------------
;; graph plot

(import (javax.swing JFrame))
(import (java.awt Color))
(import (java.awt Graphics))
(import (java.awt Graphics2D))
(import (java.awt Font))

(def radius 8)

(defn x-extend [x]
  (+ (* (- x radius) 3) 50))

(defn y-extend [y]
  (+ (- (* (- y radius) 3)) 400))

(defn vertex->str [key]
  (apply str (rest (str key))))

;; (plot-graph spwc sample-routes)
(defn plot-graph [points route-pairs answer]
  (let [window-size 450
        font  (Font.  "Monospace" Font/BOLD 14)
        frame (JFrame. "Route")
        get-x #(+ radius (x-extend (first %1)))   ;; for draw-line
        get-y #(+ radius (y-extend (second %1)))] ;; for draw-line

    (doto frame
      (.setSize window-size window-size)
      (.setVisible true)
      (.setResizable false))
    (Thread/sleep 100) ;; wait for the generateion of Window

    (def graphics (.. frame (getGraphics)))

    (defn plot-point [name]
      (let [coord (name points)
            r (* radius 2)
            x-pos (x-extend (first  coord))
            y-pos (y-extend (second coord))]

        (doto (cast Graphics2D graphics)
          (.setColor (Color. 255 100 100))
          (.fillOval x-pos y-pos r r)
          (.setColor (Color. 100 190 190))
          (.drawOval x-pos y-pos r r)
          (.setColor Color/blue)
          (.setFont font)
          (.drawString
           (->> answer name :dist round (str (vertex->str name) "="))
           (+ x-pos 20) (+ y-pos 10)))))

    (defn draw-line [point-a point-b]
      (let [a (point-a points) b (point-b points)]
        (if (or (= point-b (:prev (point-a answer)))  ;; from b to a
                (= point-a (:prev (point-b answer)))) ;; from a to b
          (.setColor graphics Color/red)
          (.setColor graphics Color/black))
        (.drawLine graphics (get-x a) (get-y a) (get-x b) (get-y b))))

    ;; draw background
    (doto graphics
      (.setColor Color/white)
      (.fillRect 0 0 window-size window-size))

    ;; draw route
    (doall (map draw-line (map first route-pairs) (map second route-pairs)))

    ;; draw points
    (doall (map plot-point (keys points)))

    (println "done!")))

;;---------------------------------------------------------------
;; execution example
(def from-a (find-path :a sample-routes (keys spwc) (get-weights sample-routes spwc)))
(def from-c (find-path :c sample-routes (keys spwc) (get-weights sample-routes spwc)))
(def from-e (find-path :e sample-routes (keys spwc) (get-weights sample-routes spwc)))
 こんな感じになりました. find-path関数で, 最短ルートとその距離を求めます. find-pathの一番目の引数は, 開始点. get-weights関数は, 各辺の重み(=距離)を計算しています. plot-graphでSwingにより, グラフを表示します.

 以下のように実行します.
user> (load-file "find-path.clj")
#'user/from-e
user> (plot-graph spwc sample-routes from-e)
done!
nil
user> (plot-graph spwc sample-routes from-a)
done!
nil
というわけで実行結果. 開始点をaとすると,
となり, 開始点をeとすると,

こんな感じ.

青空文庫のルビ取り(Clojure)と1重, 2重の括弧を認識する正規表現

 青空文庫のテキストファイルは, ルビが振ってあるため, 何か自然言語的な処理をする前段階として, ルビや本文に関係ないテキストのトリミングの作業が必要になります. この手のトリミングのプログラムはネット上にいくつかありますが, この記事もいくつかあるうちの一つです.

 正規表現では基本的に括弧は扱えないわけですが, 別に全く認識できないというわけではなくて, 任意のn回ネストした括弧が認識できないというだけです. つまり, {w | w = anbn, n ∊自然数}みたいな言語のクラスが認識できません.

  "((( ... ((( ))) ... )))"みたいな言語や"(( ... ) ( ... ))"のような言語(いずれも左右の括弧が正しく対応している場合). しかし, 1回ネストしているとか, 2回ネストしているとか, 有限回ネストしている括弧だけの認識なら, 必ずしも不可能ではありません. しかも, かなりイディオム的に記述可能です.

 Clojure(Java)の正規表現でルビ部分を認識する正規表現は,

《[^》]*》

 と書けます. 最初に開く括弧(《)を認識し, 閉じ括弧以外([^》]*)の文字からなる文字列を受け付けて, 閉じ括弧(》)が来たら, 括弧全体を認識するといった感じ.

 余談ですが, 二回ネストしている括弧を認識する場合は, 以下のような感じになります.

《([^《^》]|(《[^》]*》))*》

 一重の括弧を認識する正規表現の中にもう一つ別の括弧を認識する正規表現(青い部分)が入っている感じです. 外側の開閉括弧間の文字列は, ([^《^》]|(《[^》]*》))*で認識します. 三重括弧の場合は, [^》]*の中を拡張して, ([^《^》]|(《[^》]*》))*で書き換えれば, 三重括弧が認識できる要領になります.

 こんな感じで, スタックに積むように, 正規表現を伸ばしていけば, 有限回ネストする括弧の認識を正規表現で書くことができます.

 以下が実行例. 括弧(《》)の部分をparに書き換えます. 上から順に, 1重の括弧の認識, 1重の括弧の失敗例, 2重括弧の認識, 3重括弧の認識例です.
user> (clojure.string/replace "《some》 text 《》 here"  #"(《[^》]*》)" "par")
"par text par here"
user> (clojure.string/replace "《《text》》 《》"  #"《[^》]*》" "par")
"par》 par"
user> (clojure.string/replace "《《text》 abc 《text》》 《text》 《》"  #"《([^《^》]|(《([^《^》]|(《[^》]*》))*》))*》" "[]")
"[] [] []"
user> (clojure.string/replace "《《text》 abc 《text》》 《《text》 abc 《text《》》》 《text》 《》"  #"《([^《^》]|(《([^《^》]|(《[^》]*》))*》))*》" "[]")
"[] [] [] []"
 というわけで, 青空文庫のテキストからルビとコメント[#……], バー(|), 本文と関係ない部分を取り除くプログラム.
(use '[leiningen.exec :only (deps)])

(def top-bar
  (re-pattern (apply str (take 55 (cycle "-")))))

(defn remove-top&bot [text]
  (first (clojure.string/split (nth (clojure.string/split text top-bar) 2)
                               #"\n\r\n\r\n\r\n")))
(defn remove-pars [text]
  (clojure.string/replace text #"||(《[^》]*》)|([[^]]*])" ""))

(defn file-in-out [trim-fn file-name]
  (let [target-text (slurp file-name :encoding "shift-jis")
        new-file-name (str file-name ".rr.txt")]
    (println (trim-fn target-text))))

(file-in-out #(remove-pars (remove-top&bot %)) (second *command-line-args*))
 shift-jisなのでslurpで, エンコードの指定をする必要があります. また, 本文に関係ない部分のテキストもカットしてあります.
C:\aozora>lein exec removepars.clj 夏目漱石//道草.txt > 道草nopar.txt
のようにして使います.

2014/12/19

GaucheのPeg(Parser Expression Grammar)で漢数字の構文解析

※注意(2017/02/28) :本文中の表記には本来ドルマークが表示されるべき箇所で、ドルマークが表示されていません。また、不適切なイタリック体になっている箇所があります。いずれ修正しますが、とりあえず、今の所は修正していませんのでご注意ください。申し訳ありません。m(_ _)m

 構文解析は, HaskellのParsecや, trampoline, OpenNPLを今まで使ってきましたが, 今回はGaucheのPegを使って構文解析してみようと思います.

 Pegとは, Parser Expression Grammarの略で, 従来のパーサジェネレータ等に対して, 近年(Wikipediaには2002年の論文へのリンクが貼ってありますが...)登場した新しいタイプの形式言語で構文解析などに用いられます. 従来のCFG(文脈自由言語)に対して, 曖昧さが無く, 文法をそのまま再帰的下向き構文解析として用いることができるそうです. 理由は, 強欲な(Greedy)先読みを行うためで, 読み込めるまで優先順位の高い規則を使って読み込み, 失敗したらバックトラックにより戻ります. また, Greedyなために左再帰を用いた記述はできません.

 GaucheでのPegは, パーサコンビネータとして実装されています. 使い方は次のように使えます.
gosh> (use parser.peg)
#<undef>
gosh> (peg-parse-string ($or ($s "1")  ($s "2")) "2")
"2"
gosh> (peg-parse-string ($seq ($s "L") ($or ($s "L(1)")  ($s "R"))) "LR")
"R"
gosh> (peg-parse-string ($seq ($s "L") ($or ($s "L(1)")  ($s "R"))) "Peg")
*** PARSE-ERROR: expecting L at 0, but got #\P
Stack Trace:
_______________________________________
  0  (eval expr env)
        At line 179 of "c:\\Program Files (x86)\\Gauche\\share\\gauche-0.9\\0.9.4\\lib/gauche/interactive.scm"
 高階関数の組み合わせにより文法を定義し, peg-parse-stringへ文法を定義した高階関数とターゲットとなる文字列を渡すと, 構文解析結果(最後にパースされた文字列?)が帰ってきます. エラー処理を何もしなかった場合, 上記のようにreplのトップにエラーが出力されました.
 $sとは引数に与えた文字列をパースせよという意味です. それに対して, $orは, 引数に与えられた各要素について, 先頭から順に調べて行って, どれか一つにマッチしたらOKという意味でしょう.

もう少し, 返される文字列を工夫したいという場合は, $doと$returnが使えます.
gosh> (peg-parse-string ($do [word ($or ($s "a") ($s "b"))] ($return word)) "b")
"b"
もう少し, 返される文字列を加工したいという場合は, rope->stringが使えます.
gosh> (peg-parse-string ($do [word ($or ($s "a") ($s "b"))] ($return (string-append "the answer is " (rope->string word)))) "b")
"the answer is b"
 $do構文中では, 変数wordに解析結果(呼び出した関数から返される値)をバインドし, $returnでその文法が返す値を決めることができますが, 変数wordから文字列を取り出すには, rope->stringという関数に一回通す必要があります.

 見た感じHaskellのParsecによく似ていますが, Comparision of parser generators - Wikipeida によれば, Parsecは, Deterministic CFGのリストにあり, アルゴリズムは, LL+Backtrackingと書かれているため, Pegとはまた別物のようです.

 さて, 本題ですが, 漢数字の表記("一億千七百六十五万四千二百二十一"みたいなの)をパースして, 読みやすいアラビア数字の表記に変換します.

 漢数字の表記で特徴的なのは, 千の位まででひと塊になること, 一万単位で新しい位に名前が付くことで, 一万, 一億, 一兆, ...etcといった感じになることです.

10未満を表す漢数字は当然, 次のようになります.

A → "一" | "二" | ... | "九"

 0は入りません. 次に100未満を表す文法は, 以下のように記述できます.

A' → "二" | ... | "九"
B10 → A' "十" A | A' "十" | "十" A | A

 十の前後に漢数字が入ってくるケース, 九十九などか, 1の位が記述されない九十, 単体の十, 十の位が記されない九など. 基本的にこれ以降の位でも同様のことが起きます. 得に紛らわしいのは, "二十"と書いても, "一十"とは書かないことで, 2~9までの漢数字を表すA'が別途必要になります. 100と1000の位は以下.

B100  → A' "百" B10 | A' "百" | "百" B10 | B10
B1000 → A' "千" B100 | A' "千" | "千" B100 | B100

 こんな感じで, ただし, 百と千の後ろはそれぞれ, 百未満の数字, 千未満の数字を表す非終端記号が入ってきます. 前述したように, 一万を超えると, 千の位まででひと塊で, 一千万など位を表す漢数字の前に1~9999までの漢数字が入ってきます.

Cm → B1000 "万" B1000 | B1000 "万" | B1000
Co → B1000 "億" Cm | B1000 "億" | Cm

 億以降は同じことの繰り返しになるので, 省略します.

 似たような構造が続くので, もう少し簡潔に書けそうな気がしますが, 一つ間違えれば, 九十九十九みたいな文字を認識してしまうので, 各位の判定には注意が必要になります. 必ず億の次に万が来るように.

 ただし, 細かい話をすれば, 一千万と言っても, 千万とは言わないとか, 億千万とはいうけど, この時の億千万とは, 多分, 一億一千万のことではないとか...

 というわけで以上のCFGをまとめると以下の様になります.

Top   → Cm  | "零"
Cm    → B1000 "万" B1000 | B1000 "万" | B1000
Co    → B1000 "億" Cm | B1000 "億" | Cm
B1000  → A' "千" B100 | A' "千" | "千" B100 | B100
B100  → A' "百" B10 | A' "百" | "百" B10 | B10
B10   → A' "十" A | A' "十" | "十" A | A
A'   → "二" | ... | "九"
A    → "一" | "二" | ... | "九"

 似たようなタイプ別に, A, B, C,とその添字でまとめています. このくくりは実装で関数としてまとめる単位別にA, B, Cとなっています.

 おそらく, この漢数字による数値表現は, CFGを使わなくても, 正規表現(有限状態オートマトン)で十分認識可能だとは思われますが, 今回は一応, Schemeの数値型へ変換するということで, Pegを使っています.

 以下がそのコードです. 実際に構文解析のスタート地点となるのは, parse-cc-numで, それ以降のコードはすべてテスト用のコードです. parse-Adは, 上記のCFGのA'に相当します. parse-B関数は, それぞれパラメータを与えて, B1000, B100, B10を解析する関数へ変化します. parse-C関数も同じ. コード中のnnは, Natural Numberの略で, ccはChinease Characterの略です
(use parser.peg)           ;; for parser
(use gauche.generator)     ;; for test
(use srfi-1)
(use data.random)          ;; for test

;; target characters :: 零一二三四五六七八九十百千万億
(define cc-0-9
  (string->list "零一二三四五六七八九"))

;; from chinease character number format to natural number (integer type)

(define cc-num->nn
  (let ((corresp (apply hash-table (cons 'eq? (zip cc-0-9 (iota 10))))))
    (lambda (cc-num)
      (car (ref corresp cc-num)))))

(define parse-Ad
  ($do [c ($or ($s "二") ($s "三") ($s "四") ($s "五")
               ($s "六") ($s "七") ($s "八") ($s "九"))]
       ($return (cc-num->nn (car (string->list (rope->string c)))))))

(define parse-A
  ($do ($or ($do [v ($c #\一)] ($return 1))
            parse-Ad)))

(define parse-B
  (lambda (head middle tail value)
    ($or
     ($try ($do [v10 head] [temp middle] [v1 tail]  ($return (+ (* v10 value) v1))))
     ($try ($do            [temp middle] [v1 tail]  ($return (+ value v1))))
     ($try ($do [v10 head] [temp middle]            ($return (* v10 value))))
     ($try ($do                          [v1 tail]  ($return v1)))
     ($try ($do            [temp middle]            ($return value))))))

(define parse-B10
  (parse-B parse-Ad ($s "十") parse-A 10))

(define parse-B100
  (parse-B parse-Ad ($s "百") parse-B10 100))

(define parse-B1000
  (parse-B parse-A ($s "千") parse-B100 1000))

(define parse-C
  (lambda (head middle tail value)
    ($or
     ($try ($do [v10 head] [temp middle] [v1 tail] ($return (+ (* v10 value) v1))))
     ($try ($do [v10 head] [temp middle]           ($return (* v10 value))))
     ($try ($do                          [v1 tail] ($return v1))))))

(define parse-Cm
  (parse-C parse-B1000 ($s "万") parse-B1000 10000))

(define parse-Co
  (parse-C parse-B1000 ($s "億") parse-Cm 100000000))

(define parse-top
  ($or ($do [temp ($s "零")] ($return 0))
       ($try parse-Co)
       ($return "faild to parse")))

(define (parse-cc-num cc-num)
  (peg-parse-string parse-top cc-num))

;; from natural number (integer type) to chinease character number format

(define nn-num->4unit-list
  (let ()

    (define char->number
      (let ((zero (char->integer #\0)))
        (lambda (c)
          (- (char->integer c) zero))))

    (define num->cc-num
      (let ((corresp (apply hash-table (cons 'eq? (zip (iota 10) cc-0-9)))))
        (lambda (num)
          (string (car (ref corresp num))))))

    (define (each-unit value unit)
      (cond
       ((= value 0) "")
       ((and (= value 1) (or (equal? unit "百") (equal? unit "十"))) unit)
       (else (string-append (num->cc-num value) unit))))

    (define zeros (circular-list 0))

    (define lim 12) ;; 0 ~ 9999,9999,9999 (maximum length of string is 12)

    (define unit '("千" "百" "十" ""))

    (define 3units (append unit unit unit)) ;; (千 ~) 億 (千 ~) 万 (千 ~) 一

    ;; nn-num->4unit-list
    (lambda (nn-num) ;; natural number (supposed to be integer type)
      (let* ((nn-nlist (map char->number (string->list (number->string nn-num))))
             (rest (- lim (length nn-nlist))))
        (if (< rest 0)
            (map each-unit (take zeros lim) 3units)
            (map each-unit (append (take zeros rest) nn-nlist) 3units))))))

(define 4unit-list->cc-num
  (let ()

    (define (take&concat ls index)
      (apply string-append (take-right (take ls (* index 4)) 4)))

    (define (wipe-out-blanks unit-str cc-unit-name)
      (if (equal? unit-str "") ""
          (string-append unit-str cc-unit-name)))

    ;; 4unit-list->cc-num
    (lambda (4unit-list)
      (string-append
       (wipe-out-blanks (take&concat 4unit-list 1) "億")  ;; oku
       (wipe-out-blanks (take&concat 4unit-list 2) "万")  ;; man
       (wipe-out-blanks (take&concat 4unit-list 3) "")))));; ichi

(define (nn->cc-num n)
  (4unit-list->cc-num (nn-num->4unit-list n)))

;; test

;; int -> int
(define id
  (lambda (x)
    (parse-cc-num (nn->cc-num x))))

(define (do-test n) ;; n = the number of repeat
  (call/cc
   (lambda (cc)
     (map (lambda (value)
            (if (not (= value (id value)))
                (cc (format "fail to parse ~D" value))))
          (generator->list (integers-between$ 0 1000000000000) n))
     (display "all tests passed"))))
parse-B, parse-C関数にある$tryの部分は, 強欲な読み込みの裏返しで, 読み込みが失敗した時に, $tryの位置まで戻ってくることを指しているようで, Javaのtry-catchのようなものでしょうか.
 nn->cc-numは, ちょうど解析器の(おおよその)逆関数になっていて, 数値を入力として受け取り, 漢数字を返します. 若干不十分なところはありますが(例えば, 入力1000について, 千ではなく, 一千と返してしまいます).

gosh> (nn->cc-num 1000)
"一千"
gosh> (nn->cc-num 1290123139)
"十二億九千十二万三千百三十九"
gosh> (nn->cc-num 1290000009)
"十二億九千万九"
というわけでParserを実際に動かしてみると, こんな感じに認識してくれることがわかります.
gosh> (parse-cc-num "十二億九千十二万三千百三十九")
1290123139
gosh> (parse-cc-num "十二億九千万九")
1290000009
gosh> (do-test 1000)
all tests passed#

2014/12/12

Clojureで8Queen問題

8Queen問題とは, 有名ですが, 以下のような問題です.


 チェスのクイーンの動きは, 飛車 + 角行で, 縦横の重複(飛車の動きの判定)は容易ですが, (X軸かY軸が重複していればいいだけなので) ナナメの判定にはどう実装しようか戸惑います. 斜めにコマを取られるケースの実装が厄介に感じられますが, 実際は結構で, 斜め筋が重複している場合の判定は, 2つのクイーンQ1(x1, y1), Q2(x2, y2)について, 次のようになります. どちらか一つの式が成立したら斜めで重複していることになります.

(x1 - x2) = (y1 - y2)
(x1 - x2) = (y2 - y1)

 上の式は, 右上から左下への斜め筋が, (1,1), (2,2), (3,3) ... とかなので. 下の式は, 左上から右下へがその逆なので,  y1y2が反転します.

 これをClojureで, 実装するとこんな感じになりました. 実際に問題を解いているのは28行目までで, 他は文字列の出力関係です.

 conflict?ですでに置いたクイーンとの衝突を判定します. put-a-queenは, 次に置く一手を決めます. 引数の(x, y)以上の位置から探索を始めて, others(他のクイーンの座標[x y]のリスト)と重複しないような位置を返します. そのような場所がない場合は, falseを返します.

 solveは, バックトラックによって探索します. solveは, (x, y) = (0, 0), others = []から始めて, 可能な解をすべて計算します. 1行あたり1クイーンなので, 上から順に各行にQueenをputしていきます. xの初期位置が7を超えたら探索終わり. 左上から探索を始めてput-a-queenを何度も呼び出して, 矛盾しない解を探し続ける(solve関数内の末尾のrecur2つ). 解が見つかればputが成功したのだと考えて, その次の行の値を探しに行く. 解が見つからない場合, 前回putが失敗だったと考え, 一つ前の行のputを取り消して, そこから右へ向かって検索を行う.
 一つ解を求めたら, その解が失敗だったものと見なしてバックトラックを行い, solveを再び始めます(solve関数内のconsのあたり) .
(use '[leiningen.exec :only (deps)]) ; lein exec

;; slove the 8 queen problem
(defn conflict? [x y others]
  (and (not (empty? others))
       (let [x1 (ffirst others) y1 (second (first others))]
         (or (= x x1) (= y y1)
             (= (- x x1) (- y y1)) (= (- x x1) (- y1 y))
             (conflict? x y (rest others))))))

(defn put-a-queen [x y others]
  (cond
   (< 7 x) false
   (not (conflict? x y others)) [x y]
   :else (put-a-queen (inc x) y others)))

(defn solve [x1 y1 answer1]
  (loop [x x1 y y1 answer answer1]
    (let [rests (rest answer)]
      (cond
       (and (< 7 x) (= 0 y))
       nil
       (< 7 y)
       (cons answer (solve (inc (ffirst answer)) (dec y) rests))
       :else
       (if-let [xy (put-a-queen x y answer)]
         (recur 0 (inc y) (cons xy answer))
         (recur (inc (ffirst answer)) (dec y) rests))))))

;; make the list of solutions
(def solutions (solve 0 0 []))

;; show the results
(defn queen-str [xs]
  (let [dots #(take % (cycle "."))
        astr (partial apply str)]
    (map (fn [i] (astr (astr (dots i)) "Q" (dots (- 7 i))))
         (map second (sort xs)))))

(defn add-left [xs ys]
  (map str xs ys))

(defn spaces [width] ;; the list of space
  (cycle (apply str (take width (cycle " ")))))

(defn add-leftside-margin [width xs]
  (let [height (count xs)]
    (add-left (take height (spaces width)) xs)))

(defn gen-string [n xs]
  (->> (range n)
       (map (fn [x ns] (add-leftside-margin 10 x)) xs)
       (reduce add-left)))

(defn display-1-line [xs]
  (doall (map println xs))
  (println ""))

(defn display-all [given-list per]
  (loop [xs (partition-all per given-list)]
    (if (not (empty? xs))
      (do (display-1-line (gen-string per (map queen-str (first xs))))
          (recur (rest xs))))))

(display-all solutions 8)
 display-allで, 1列あたり8つの解を表示しています. 8-Queenの解の総数は, 92個あるそうですが, 次のような感じになりました.
u@mint ~/Dropbox/clj/8queen $ lein exec 8queen.clj
 Q....... Q....... Q....... Q....... .....Q.. ...Q.... ....Q... ..Q.....
 ......Q. ......Q. .....Q.. ....Q... Q....... Q....... Q....... Q.......
 ....Q... ...Q.... .......Q .......Q ....Q... ....Q... .......Q ......Q.
 .......Q .....Q.. ..Q..... .....Q.. .Q...... .......Q ...Q.... ....Q...
 .Q...... .......Q ......Q. ..Q..... .......Q .Q...... .Q...... .......Q
 ...Q.... .Q...... ...Q.... ......Q. ..Q..... ......Q. ......Q. .Q......
 .....Q.. ....Q... .Q...... .Q...... ......Q. ..Q..... ..Q..... ...Q....
 ..Q..... ..Q..... ....Q... ...Q.... ...Q.... .....Q.. .....Q.. .....Q..

 ....Q... ......Q. ....Q... ...Q.... .Q...... ....Q... .......Q ...Q....
 Q....... Q....... Q....... Q....... .....Q.. ..Q..... ..Q..... .....Q..
 ...Q.... ..Q..... .......Q ....Q... Q....... Q....... Q....... Q.......
 .....Q.. .......Q .....Q.. .......Q ......Q. ......Q. .....Q.. ....Q...
 .......Q .....Q.. ..Q..... .....Q.. ...Q.... .Q...... .Q...... .Q......
 .Q...... ...Q.... ......Q. ..Q..... .......Q .......Q ....Q... .......Q
 ......Q. .Q...... .Q...... ......Q. ..Q..... .....Q.. ......Q. ..Q.....
 ..Q..... ....Q... ...Q.... .Q...... ....Q... ...Q.... ...Q.... ......Q.

 ....Q... .....Q.. ....Q... .....Q.. ...Q.... .......Q ...Q.... ...Q....
 ......Q. ..Q..... ..Q..... ..Q..... .......Q ...Q.... .......Q ......Q.
 Q....... Q....... Q....... Q....... Q....... Q....... Q....... Q.......
 ...Q.... .......Q .....Q.. .......Q ..Q..... ..Q..... ....Q... .......Q
 .Q...... ...Q.... .......Q ....Q... .....Q.. .....Q.. ......Q. ....Q...
 .......Q .Q...... .Q...... .Q...... .Q...... .Q...... .Q...... .Q......
 .....Q.. ......Q. ...Q.... ...Q.... ......Q. ......Q. .....Q.. .....Q..
 ..Q..... ....Q... ......Q. ......Q. ....Q... ....Q... ..Q..... ..Q.....

 .....Q.. .....Q.. ......Q. ....Q... .Q...... .Q...... .....Q.. ......Q.
 ...Q.... ..Q..... ..Q..... ......Q. ....Q... .......Q .Q...... .Q......
 Q....... Q....... Q....... Q....... ......Q. .....Q.. ......Q. ...Q....
 ....Q... ......Q. .....Q.. ..Q..... Q....... Q....... Q....... Q.......
 .......Q ....Q... .......Q .......Q ..Q..... ..Q..... ..Q..... .......Q
 .Q...... .......Q ....Q... .....Q.. .......Q ....Q... ....Q... ....Q...
 ......Q. .Q...... .Q...... ...Q.... .....Q.. ......Q. .......Q ..Q.....
 ..Q..... ...Q.... ...Q.... .Q...... ...Q.... ...Q.... ...Q.... .....Q..

 .......Q ....Q... .....Q.. ....Q... ..Q..... .....Q.. ....Q... ..Q.....
 .Q...... .Q...... .Q...... .Q...... ....Q... ...Q.... .......Q .....Q..
 ...Q.... .......Q ......Q. .....Q.. ......Q. ......Q. ...Q.... .......Q
 Q....... Q....... Q....... Q....... Q....... Q....... Q....... Q.......
 ......Q. ...Q.... ...Q.... ......Q. ...Q.... .......Q ......Q. ....Q...
 ....Q... ......Q. .......Q ...Q.... .Q...... .Q...... .Q...... ......Q.
 ..Q..... ..Q..... ....Q... .......Q .......Q ....Q... .....Q.. .Q......
 .....Q.. .....Q.. ..Q..... ..Q..... .....Q.. ..Q..... ..Q..... ...Q....

 ......Q. .....Q.. ....Q... ..Q..... ..Q..... ....Q... .Q...... .Q......
 ....Q... ...Q.... .......Q .....Q.. .....Q.. ......Q. .....Q.. ....Q...
 ..Q..... ......Q. ...Q.... ...Q.... .......Q ...Q.... .......Q ......Q.
 Q....... Q....... Q....... Q....... Q....... Q....... ..Q..... ...Q....
 .....Q.. ..Q..... ..Q..... .......Q ...Q.... ..Q..... Q....... Q.......
 .......Q ....Q... .....Q.. ....Q... ......Q. .......Q ...Q.... .......Q
 .Q...... .Q...... .Q...... ......Q. ....Q... .....Q.. ......Q. .....Q..
 ...Q.... .......Q ......Q. .Q...... .Q...... .Q...... ....Q... ..Q.....

 .Q...... ......Q. .......Q ...Q.... ...Q.... ..Q..... ..Q..... .....Q..
 ......Q. .Q...... .Q...... .Q...... .Q...... .....Q.. ....Q... .......Q
 ....Q... .....Q.. ....Q... .......Q ......Q. .Q...... .Q...... .Q......
 .......Q ..Q..... ..Q..... .....Q.. ....Q... ......Q. .......Q ...Q....
 Q....... Q....... Q....... Q....... Q....... Q....... Q....... Q.......
 ...Q.... ...Q.... ......Q. ..Q..... .......Q ...Q.... ......Q. ......Q.
 .....Q.. .......Q ...Q.... ....Q... .....Q.. .......Q ...Q.... ....Q...
 ..Q..... ....Q... .....Q.. ......Q. ..Q..... ....Q... .....Q.. ..Q.....

 ..Q..... ..Q..... .....Q.. .....Q.. .....Q.. ...Q.... ...Q.... ...Q....
 .......Q ....Q... ..Q..... ..Q..... ..Q..... .......Q ......Q. .....Q..
 ...Q.... .......Q ......Q. ....Q... ....Q... ....Q... ....Q... .......Q
 ......Q. ...Q.... ...Q.... ......Q. .......Q ..Q..... ..Q..... ..Q.....
 Q....... Q....... Q....... Q....... Q....... Q....... Q....... Q.......
 .....Q.. ......Q. .......Q ...Q.... ...Q.... ......Q. .....Q.. ......Q.
 .Q...... .Q...... .Q...... .Q...... .Q...... .Q...... .......Q ....Q...
 ....Q... .....Q.. ....Q... .......Q ......Q. .....Q.. .Q...... .Q......

 .Q...... ...Q.... ...Q.... ..Q..... ..Q..... ..Q..... ....Q... ....Q...
 ...Q.... .Q...... .Q...... ......Q. .....Q.. .....Q.. ......Q. ......Q.
 .....Q.. ....Q... .......Q .Q...... .Q...... .Q...... .Q...... .Q......
 .......Q .......Q ....Q... .......Q ....Q... ......Q. .....Q.. .....Q..
 ..Q..... .....Q.. ......Q. ....Q... .......Q ....Q... ..Q..... ..Q.....
 Q....... Q....... Q....... Q....... Q....... Q....... Q....... Q.......
 ......Q. ..Q..... ..Q..... ...Q.... ......Q. .......Q ...Q.... .......Q
 ....Q... ......Q. .....Q.. .....Q.. ...Q.... ...Q.... .......Q ...Q....

 ......Q. ......Q. ....Q... ..Q..... ......Q. ...Q.... ...Q.... ....Q...
 ...Q.... ...Q.... ......Q. .....Q.. ..Q..... ......Q. .....Q.. ..Q.....
 .Q...... .Q...... .Q...... .......Q .......Q ....Q... .......Q .......Q
 ....Q... .......Q ...Q.... .Q...... .Q...... .Q...... .Q...... ...Q....
 .......Q .....Q.. .......Q ...Q.... ....Q... .....Q.. ......Q. ......Q.
 Q....... Q....... Q....... Q....... Q....... Q....... Q....... Q.......
 ..Q..... ..Q..... ..Q..... ......Q. .....Q.. ..Q..... ..Q..... .....Q..
 .....Q.. ....Q... .....Q.. ....Q... ...Q.... .......Q ....Q... .Q......

 .Q...... ...Q.... ....Q... ..Q..... .....Q.. .....Q.. .....Q.. ...Q....
 ......Q. .Q...... .Q...... ......Q. ...Q.... ..Q..... ..Q..... ......Q.
 ..Q..... ......Q. ...Q.... .Q...... .Q...... ......Q. ......Q. ..Q.....
 .....Q.. ..Q..... .....Q.. .......Q .......Q .Q...... .Q...... .......Q
 .......Q .....Q.. .......Q .....Q.. ....Q... ...Q.... .......Q .Q......
 ....Q... .......Q ..Q..... ...Q.... ......Q. .......Q ....Q... ....Q...
 Q....... Q....... Q....... Q....... Q....... Q....... Q....... Q.......
 ...Q.... ....Q... ......Q. ....Q... ..Q..... ....Q... ...Q.... .....Q..

 ...Q.... ....Q... ..Q..... ..Q.....
 .Q...... .Q...... ....Q... .....Q..
 ......Q. ...Q.... .Q...... ...Q....
 ..Q..... ......Q. .......Q .Q......
 .....Q.. ..Q..... .....Q.. .......Q
 .......Q .......Q ...Q.... ....Q...
 ....Q... .....Q.. ......Q. ......Q.
 Q....... Q....... Q....... Q.......
んー.

Java/ClojureのSwingでWindows/Linux風のUIにする

 SwingのGUIを各OS固有のGUIに変更するコードです. どこで見つけたのか忘れたのですが, 常用しています. SwingのデフォルトのUIは, 変なグラデーションのボタンなど, あまり好ましい見た目ではないと思う人も多いかと思いますが, GUIを出現させる前に以下のコードを実行すると, OS固有のGUIを表示してくれます.

Java版
try {
  UIManager.setLookAndFeel(UIManager.getSystemLookAndFeelClassName());
} catch (ClassNotFoundException | InstantiationException
        | IllegalAccessException | UnsupportedLookAndFeelException e) {
  e.printStackTrace();
}
JavaのversionができればClojureも似たようなものですが, コピペ用に.
Clojure版
(javax.swing.UIManager/setLookAndFeel
  (javax.swing.UIManager/getSystemLookAndFeelClassName))
プログラム・サンプル
package lookandfeel;
import javax.swing.*;

public class LookAndFeel {
  public static void main(String args[]){

    JOptionPane.showMessageDialog(null, "Swing GUI");
    
    try {
      UIManager.setLookAndFeel(UIManager.getSystemLookAndFeelClassName());
    } catch (ClassNotFoundException | InstantiationException
        | IllegalAccessException | UnsupportedLookAndFeelException e) {
      e.printStackTrace();
    }

    JOptionPane.showMessageDialog(null, "Windows GUI");
  }

}
以下, 実行結果.

 まず, Windowsで実行すると...
WindowsでのSwing
Windows風GUI

 同じコードをLinuxMintで実行してみても...
LinuxMintでのSwing

LinuxMint風GUI
と, こんな感じで, Mint風のGUIで表示してくれます.

2014/12/08

手作業でプログラム運算

  • 関数プログラミング入門 Haskellで学ぶ原理と技法, Richard Bird(著) / 山下伸夫(訳), 2012
 p368の練習問題12.1.3
zipp . pair (map f, map g) = map (pair (f, g))という法則は両辺を同じ結果に単純化することで証明できるか. 証明はzipp . unzip . map (pair (f, g))という式を2つの本質的に異なる方法(1つはzipp . unzip = idという法則を使い, もう1つはunzipの定義を使うことで単純化することで可能になる. 詳細を示せ.
 プログラム運算を実感するために, 上記の問題をやってみたいと思います. zippは, カリー化されてないzip関数.
 各関数の定義.
pair (f, g) x = (f x, g x)
zipp = uncurry zip
uncurry f xy = f (fst xy) (snd xy)
unzip = pair (map fst, map snd)

 早速, 変換を始めてみると,
zipp . unzip . map (pair (f, g))
{- zipp . unzip = idより -}
= map (pair (f, g))
= 右辺

{- unzipの定義から, -}
zipp . unzip . map (pair (f, g))
= zipp . pair (map fst, map snd) . map (pair (f, g))  --(1)

{- ここで, -}
pair (map fst, map snd) . map (pair (f, g))
{- pair (f, g) . h = pair (f . h, g . h) だから -}
= pair (map fst . (map (pair (f, g))), map snd . (map (pair (f, g))))
{- map分配則(map f . map g = map (f . g))から -}
= pair (map (fst . (pair (f, g))), map (snd . (pair (f, g))))
{- fst . pair (f, g) = fなどから -}
= pair (map f, map g)

{- なので, -}
zipp . unzip . map (pair (f, g))
= zipp . pair (map f, map g)
= 左辺

 左辺の変換は, ポイントフリーだとわかりにくいので, リストxsを使って考えると,
pair (map fst, map snd) (map (pair (f, g)) xs)
= (map fst (map (pair (f, g)) xs), (map snd (map (pair (f, g)) xs))
{- point freeで書き直すと -}
= (map fst . map (pair (f, g)) xs), ((map snd . map (pair (f, g)) xs))
{- map分配則から -}
= (map (fst . pair (f, g)) xs), map (snd . pair (f ,g)) xs)
{- fst .pair (f ,g) = f などから -
= (map f xs, map g xs)
= pair (map f, map g) xs
{- のように変形できるので, -}
unzip . map (pair (f, g))
= pair (map f, map g)

と考えることも可能.

というわけで, zipp . pair (map f, map g) = map (pair (f, g))が成立.

まとめると,
zipp . pair (map f, map g)
{- fst . pair (f, g) = fなどから -}
= zipp . pair (map (fst . (pair (f, g))), map (snd . (pair (f, g))))
{- map分配則(map f . map g = map (f . g))から -}
= zipp . pair (map fst . (map (pair (f, g))), map snd . (map (pair (f, g))))
{- pair (f, g) . h = pair (f . h, g . h) だから -}
= zipp . pair (map fst, map snd) . map (pair (f, g))
{- unzipの定義から-}
= zipp . unzip . map (pair (f, g))
{- zipp . unzip = idより -}
= map (pair (f, g))

2014/12/11, 間違っていたので一部修正.

2014/11/28

map分配則

 プログラム運算は, プログラムの変形なので, そのための変換規則というのがありますが, そのうちの一つに, map分配則というものがあります.

 map分配則は, 次のような規則です.

map (f . g) = map f . map g

 両辺とも意味的には同じなのですが, 片方の式が実行時間が短くなります.
 さてどちらでしょうか.
 高速化(等)のためのプログラム変換なので, 上記の式の片方がプログラム中に登場した時もう片方へ書き換えることで, 高速化を図るというテクニックです.

 実行時間は 左辺 > 右辺 左辺 < 右辺となります. つまり, 上の等式の右辺のような式を見つけた時, 左辺に変換可能であり, かつ, 左辺に変換することで高速化します.

 理由は簡単で, 右辺 map f . map g は, リストを生成を二回行いますが, 左辺 map (f . g)は, mapの回数が一回なので新しいリストを一回生成するに留まります. 右辺はほとんど, 二度ループを行っているようなものですね.

 等式ついては例えば, 次のように証明できます.

mapの定義は次のものとし,
map f [] = []
map f (x:xs) = f x : map f xs

また, 合成関数は次のように定義します.
(f . g) x = f (g x)

この時, 数学的帰納法により等式の証明を試みると
i) 空リストについて, mapの定義より,
map (f . g) [] = []であり,
(map f . map g) []
= map f (map g [])
= map f [] = []で空リストについて成立するので,  成立します.

ii) あるリストxsについて, map (f . g) xs  = (map f . map g) xs が成立すると仮定する.
xsに1つ要素をconsしたリスト(x:xs)について,
map (f . g) x:xs
= (f . g) x : map (f . g) xs
= f (g x) : map (f . g) xs
= {ここで仮定より} f (g x) : (map f . map g) xs    ......①
(map f . map g) (x:xs)
= {合成関数の定義より} map f (map g (x:xs))
= map f (g x : map g xs)
= f (g x) : map f (map g xs)
= {合成関数の定義から} f (g x) : (map f . map g) xs
= {①より} map (f . g) x:xs
より, 与えられたリストがx:xsの時にも map (f . g) = map f . map gが成立.

 というわけで数学的帰納法によりmap分配速が成立する. この辺までは高校レベルの数学に登場する数学的帰納法を知っていれば, 理解できます.
※) Haskellの記法なので, 関数適用がcons演算子や関数合成の演算子よりも優先順位が高いことに注意.

 map分配則は直感的に理解できるもので, わざわざ証明するまでもないようなものですが, もう少し複雑な規則なら上記の手法を用いることで, バグを含まない健全さを手に入れることができるかもしれません.

 さて, 問題はホントに速いのかということですが, 実際にやってみました.

こんなプログラムを用意して,
import Data.Time

gettime ls = do
  start <- getCurrentTime
  print $ sum ls
  end <- getCurrentTime
  print $ "elapsed time : " ++  (show $ diffUTCTime end start)

f = (20 *)
g = (1 +)
ghci上で実際に次のように計測してみたところ,
*Main> gettime $ (map f . map g) [1..10000000]
1000000300000000
"elapsed time : 7.2572358s"
*Main> gettime $ map (f . g) [1..10000000]
1000000300000000
"elapsed time : 5.2496645s"
map (f . g)の方が高速であることが分かるかと思います.

2014/11/20

Clojure×OpenNLPに教わる英文法

 先日, 英文を読んでいたら, 文法的によくわからない一文が, むむむむ.

We remove all artificial constructs from our experiments and instead focus on running the GA the way a practitioner might.

 で, そんな時に, Google翻訳(etc)に通すのも一興ですが, 現代の機械翻訳の限界を鑑みると, 少し頼りなく感じます. そして, 構文的な繋がりだけをヒントとして表示してくれないかな, と思ってみたりします. そこで, 構文解析です.

 調べてみると, ClojureからOpenNLPが使えるようで, (OpenNLPはJavaで書かれた自然言語処理ライブラリ)少し調べてみたところ, 構文解析木を吐いてくれるモジュールclojure-opennlpがあったので, これを使って構文的な繋がりを括弧で括ってみたいと思います.

 モジュールのインストールとreplからの簡単な実行は,


に詳しいですが, 構文解析器を起動するまでの手順をピックアップすると,
  1. profile.cljの:pluginへ [clojure-opennlp "0.3.2"]を追加.
  2. OpenNLP Tool Modelsから, "en-parser-chunking.bin"をダウンロード.
  3. replを起動して, (use 'opennlp.treebank)でclojure-opennlpのパーサのライブラリをインポート.
  4. make-treebank-parserでパーサを生成.
 これで英文の構文解析ができるようになります.

 profile.cljは, ~/.leinか, Windowsなら, C:\Users\<ユーザ名>\.lein\あたりにあるleiningenの設定ファイルで, :pluginsのリストへ[clojure-opennlp "0.3.2"]を追加すると, leinの起動時に勝手にインストールしてくれます.

 replは適当な場所で起動して, こんな感じで使えます.
user> (use 'opennlp.treebank)
nil
user> (def parser (make-treebank-parser "en-parser-chunking.bin"))
#'user/parser
user> (parser ["This is a pen"])
["(TOP (S (NP (DT This)) (VP (VBZ is) (NP (DT a) (NN pen)))))"]
user> (parser ["This is a pen" "The dog is running"])
 "en-parser-chunking.bin"のところは, ダウンロードしたファイルの相対パスor絶対パスです. ダウンロードしたフォルダか保存したフォルダでreplを起動してしまうのが手っ取り早いですが.
 構文解析木は文字列として出力されるようですが, NPやSなど品詞が横に付随していています. 構文解析なので当然, 形態素解析も内包しています. 名詞だけ取り出すような作業の時にはこのような品詞付きの解析木は重宝しますが, 今回は文法的なつながりだけを見たいので, DTとかNNとかが除去された状態にしたいのでmake-treeを使います.
user> (make-tree (first (parser ["This is a pen"])))
{:tag TOP, :chunk ({:tag S, :chunk ({:tag NP, :chunk ({:tag DT, :chunk ("This")})} {:tag VP, :chunk ({:tag VBZ, :chunk ("is")} {:tag NP, :chunk ({:tag DT, :chunk ("a")} {:tag NN, :chunk ("pen")})})})})}
 Clojureの内部構造にparseされたのであとは適当なフィルターを作ればOKですね.
(use 'opennlp.treebank) ;; [clojure-opennlp "0.3.2"]

(def treebank-parser
  (make-treebank-parser "en-parser-chunking.bin"))

(defn get-chunks [tree]
  (cond
   (string? tree) tree
   (seq?    tree) (map get-chunks tree)
   (map?    tree) (get-chunks (:chunk tree))
   :else          "error"))

(defn simplify [tree]
  (cond
   (string? tree)       (symbol tree)
   (not (seq? tree))    "error"
   (empty? (rest tree)) (simplify (first tree))
   :else                (map simplify tree)))

(defn parse-en [en-text] ;; (parse-en "let me out of here !")
  (->> [en-text]
       treebank-parser first make-tree
       get-chunks
       simplify))
のようなプログラムを作成し, 括弧の関係のみが残るようにフィルタリングした結果,
user> (load-file "filter.clj")
#'user/parse-en
user> (parse-en "We remove all artificial constructs from our experiments and instead focus on running the GA the way a practitioner might .")
(We ((remove (all artificial constructs) (from (our experiments))) and (instead focus (on (running (the GA) ((the way) (a practitioner might)))))) .)
 となり, 少しは読みやすくなったかな. といった感じです.
 なお, 上記の括弧の文法的な正しさは保証できませんのであしからず.

 clojure-opennlpを弄っていて気づいたのですが, このmake-treeで生成された構文解析木を使えば, 自作の機械翻訳器ができますね. 生成されたシンタックスのパターンに沿って日本語のルールを記述していってパターンマッチすれば......

2014/11/17

Haskellのフクロウ ((.)$(.))

 Haskellのポイントフリー記法により, いくつか新発見があったようなのですが, そのうちの一つがHaskellのフクロウ・コンビネータなのだそうで.


 次のコンビネータがそれなのですが, たしかに見ようによってはフクロウの顔に見えなくもないです.
*Main> :t ((.)$(.))
((.)$(.)) :: (a -> b -> c) -> a -> (a1 -> b) -> a1 -> c
 で, 試しに型を見てみると次のような感じ.
*Main> :t ((.)$(.))
((.)$(.)) :: (a -> b -> c) -> a -> (a1 -> b) -> a1 -> c
*Main> :t ((.)(.))
((.)(.)) :: (a -> b -> c) -> a -> (a1 -> b) -> a1 -> c
*Main> :t (.)(.)
(.)(.) :: (a -> b -> c) -> a -> (a1 -> b) -> a1 -> c
 ドルマークはgroup expressionと呼ばれ, 括弧と同等のもので, $から行末, またはその前の閉じ括弧の一つ手前までを括弧でくくる演算子です. なので, フクロウコンビネータのドル記号は実は不要(あってもなくても意味は同じ)で, さらに, 外側を囲っている括弧も(上記の例では)不要(Haskellでは, applyの優先順位が一番高いため)なので, 最終的に「フクロウ」は「見下ろす目玉」まで簡略化できました. ドット記号は, 関数合成の演算子なので, これ以上小さくすることはできません.
 しかし, こんなコンビネータどこで使うんだと思っていたのですが, pointfulに書くと,
f a b c d = a b (c d)
なのだそうで, 意外と使えるかもしれないですね. mapでは引数を二つとりますが, たいてい, 二番目の引数は, ごちゃごちゃしていますから.
*Owl> ((.)$(.)) map (* 2) reverse [1..10]
[20,18,16,14,12,10,8,6,4,2]
のように使えます.

 フクロウ・コンビネータは意味的には((.)(.))の目玉二つに相当するわけですが目玉の数を増やすと様々なコンビネータが作れます.
((.))                   :: (b -> c) -> (a -> b) -> a -> c
((.)(.))                :: (a -> b -> c) -> a -> (a1 -> b) -> a1 -> c
((.)(.)(.))             :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c
((.)(.)(.)(.))          :: (a -> a1 -> b -> c) -> a -> a1 -> (a2 -> b) -> a2 -> c
((.)(.)(.)(.)(.))       :: (b1 -> c) -> (b -> b1) -> (a -> b) -> a -> c
((.)(.)(.)(.)(.)(.))    :: (b -> b1 -> c) -> (a -> b) -> a -> (a1 -> b1) -> a1 -> c
((.)(.)(.)(.)(.)(.)(.)) :: (a -> b -> c) -> a -> (a1 -> a2 -> b) -> a1 -> a2 -> c
((.)(.)(.)(.)(.)(.)(.)(.)):: (b -> c) -> (a -> a1 -> a2 -> b) -> a -> a1 -> a2 -> c
目玉(合成関数)の数を増やしても, 生成される関数の型に一貫性がないように見えます.
 replで試してみると以下のようになります. 二番目はフクロウ・コンビネータの使い方と同じです.
*Owl> ((.)) reverse tail [1..10]
[10,9,8,7,6,5,4,3,2]
*Owl> ((.)(.)) map (* 2) reverse [1..10]
[20,18,16,14,12,10,8,6,4,2]
*Owl> ((.)(.)(.)) reverse map (* 2) [1..10]
[20,18,16,14,12,10,8,6,4,2]
*Owl> ((.)(.)(.)(.)) foldl (+) 0 tail [1..10]
54
*Owl> ((.)(.)(.)(.)(.)) reverse reverse reverse [1..10]
[10,9,8,7,6,5,4,3,2,1]
*Owl> ((.)(.)(.)(.)(.)(.)) map (+) 2 reverse [1..10]
[12,11,10,9,8,7,6,5,4,3]
 こんな感じで5つ「目」までは使えそうです. 使う関数の名前と組み合わせによっては, 括弧で直接囲うよりも見やすくなるかもしれません. とはいえ, 素直に書いた方が手っ取り早くて安全なのは言うまでもないですが.
 mapとfilterを繰り返し使いたい時と, foldlで組み合わせたい時は, 次のように書けます.

*Owl> ((.)$(.).(.)) map (+ 2) filter (< 3) [1..10]
[3,4]
*Owl> ((.)$(.)$(.).(.)) foldl (+) 0 map (* 3) [1..10]
165

2014/11/04

Haskellのポイント・フリー記法とコンビネータで暗号入門

  暗号化するターゲットは, 記号列なので, Haskellのリスト操作関数がよく似合います. 昔の情報理論の授業資料が出てきたので, Haskellのコンビネータとポイント・フリー記法で遊ぶネタに用いました. 有名どころの暗号化手法について, シーザー暗号, アフィン暗号, ヴィジュネル暗号, ポリュビオス暗号, ワンタイムパッド, フェイステル暗号(ブロック暗号), RSA暗号(公開鍵暗号)についてそれぞれ書きました.

(2014/11/16追記)今見ると, 結構pointfulな書き方が多いですね. もう少しタイトルを考えるべきでした.

注意

  • アルファベットの総数は, プログラム上では, 空白等の記号も用いたいのと簡単のため, 128にしていますが, これだと統計的にかなり偏りが出てしまうため, 暗号としては, あまりよくない(解読されやすい)ことに注意.
  • 実装では, 一部XORの代わりにシーザーシフト(シーザー暗号の変換)を使っています. これは, 文字列をbit列に変換するのが面倒だったので, 代用しているものです.
  • 間違ってたらごめんなさい.

シーザー暗号

 定番の暗号です. ジュリアス・シーザーが用いたと言われるもので, 鍵n(=1〜26 : アルファベットの総数以下)についてアルファベット順をnづつシフトして(ずらして)記述することで暗号化します. つまり, 鍵nは, シフト数を表します.

 例えば, 平文"cat"について鍵n=3を使うと, c→d→e→f, a→b→c→d, t→u→v→wで, "fdw"という暗号文ができます. 復号は, これを逆方向に3づつシフトすると, 元の平文が生成される仕組みです. zなどは, アルファベット順の末尾と先頭をつなげて, z→a→b→cとシフトします.

 鍵空間はアルファベットの総数(=26)で, 26通りなので, 総当り法で簡単に解けるものですが, 原始的ながら, 鍵と暗号化/復号化のアルゴリズムがあるという点は以降に紹介する暗号化手法と共通しています.

 Haskellでは, 一旦数値化して, 数値を足したあと, mod 128で繰り返します.
module Ceaser where
import Data.Char

ceaser key = chr . flip mod 128 . (key +) . ord

encrypt :: Int -> String -> String
encrypt key = map $ ceaser key

decrypt :: Int -> String -> String
decrypt key = map $ ceaser (- key)
 シーザーシフト(ceaser関数)は, ポイント・フリー(dot記号による関数合成)で書いています. flipは, 引数の順序を入れ替える関数で, flip f b a = apply f a bの意味です. ポイントフリー記法には欠かせません. (key +)は, 加算演算子の部分適用で一引数関数になっていて, Haskellの便利なところでもあります.

 ポイントフリーは右から処理が行われていきます. ceaser関数は, key::Intとc::Charを受け取り, ordでInt型へ変換した後, シーザーシフト(key +)を行い, mod 128で剰余を求め, 最後にchrでChar型へ変換した値を返すというふうに読みます.

 encryptとdecryptは, 暗号化/復号化の関数で, 鍵とそれぞれ平文/暗号文の2つを受け取る関数ですが, map関数への部分適用でクロージャが生成されるため, 引数は明示的には, 1つだけ記述しています. encrypt/decryptの第二引数はそのままmapの第二引数となります.

 $記号(演算子)は, HaskellにおいてGrouping Expression と呼ばれ, 括弧と同じ役割を果たします(syntax in Haskell). $演算子から文末までを括弧でくくるのと同等の意味を表します.

実行結果は以下のとおり.
Prelude> :load ceaser
[1 of 1] Compiling Ceaser           ( ceaser.hs, interpreted )
Ok, modules loaded: Ceaser.
*Ceaser> encrypt 10 "hello world!"
"rovvy*\SOHy|vn+"
*Ceaser> decrypt 10 "rovvy*\SOHy|vn+"
"hello world!"
*Ceaser> decrypt 11 (encrypt 11 "hello world!")
"hello world!"

アフィン暗号

 シーザー暗号の鍵空間がアルファベットの総数以下だったのに対し, アフィン暗号では, 2つの数値のペア(a, b)を暗号のキーにします.
 アフィン暗号のコンセプトは, ある平文のi番目の文字を表すpiに対し,

di = a * pi + b

で暗号化します. この暗号文の文字diに対して,

pi = ( di - b ) / a

で復号化できるというものです.

 加算と乗算に対応する減算と除算を行えば元の文字(値)が出現するという仕組みですが, 実際の暗号化はmod 128が入ってくるので, 暗号化と復号化はそれぞれ, 次のようになります.

di = a * pi + b (mod 128)

pi = (( di - b ) * N * 128) / a (mod 128)

 ただし, Nは, mod (( di - b ) * N * 128) a == 0となるような自然数です. また, 暗号化のためのキー(a, b)のうちaは, アルファベット総数(ここでは, 128)と素な数(gcd(a, 128) == 1)である必要があります.
module Affine where
import Data.List
import Data.Char

numeric op = chr . flip mod 128 . op . ord

encrypt :: (Int, Int) -> String -> String
encrypt (a, b) = map $ numeric $ (b +) . (a *)

decrypt :: (Int, Int) -> String -> String
decrypt (a, b) = map $ numeric $ flip div a . head . op
  where
  op c = [x | n <- [0..],let x = (c - b) + 128 * n, (mod x a) == 0] 
 リスト内包記法を使っているため, 前述した条件を満たすnを求める部分が, ジェネレータとlet式とフィルターがひとつにまとめて記述されていて, 簡潔にかけました. (b +) . (a *)のポイント・フリー記法は明らかにやり過ぎな感じですが, 面白いのでこのままにしました. decrypt のコードも極端すぎて読みにくいですね. とはいえ, 今回はこの記法で遊ぶのが目的の一部なのでこんな感じにしました.

 次のような実行になります.
*Affine> encrypt (7, 100) "affine cipher"
"\v..Cf'D\EMCt<'\STX"
*Affine> decrypt (7, 100) "\v..Cf'D\EMCt<'\STX"
"affine cipher"
 タプルのfstの要素が7というのが重要なところで, 今回はmod 128なので, 偶数だと復号に失敗します.

ヴィジュネル暗号

 シーザー暗号を周期的に切り替える手法が, ヴィジュネル暗号です. シフト数のリスト(s0, s1, ..., sn)を用意し, a番目の文字にシフト数s(i (mod n))を使い, a+1番目の文字にシフト数 s(i+1 (mod n))を使うという手法で, 周期的に切り替えることで, 符号化の難易度を高めます.

 例えば, 鍵に相当するシフト数のリスト[2, 3]について, 平文"doggy"は, シフト数2でd→e→f, シフト数3のo→p→q→r, でこれを残りの平文の文字列に対しても周期的に用いて, g→h→i, g→h→i→j, y→z→aで, 暗号文"frija"が完成します.

 暗号を解読するとき, 鍵の周期とシフト数を調べる必要があるため, 解読が難しくなります."鍵の周期の長さ" ≧ "暗号化する平文の長さ"となると, 後述するワンタイムパッドと同等になります.

  次がそのコードなのですが, 随分あっさりしてます.
module Vigenere where
import Data.List
import Data.Char

ceaser key = chr . (flip mod 128) . (key +) . ord

encrypt :: [Int] -> String -> String
encrypt keys = zipWith ceaser $ cycle keys

decrypt :: [Int] -> String -> String
decrypt keys = zipWith ceaser $ cycle $ map (0 -) keys
 周期的にシーザーシフトが変化する部分の書き方を悩んだのですが, cycleを使い, zipWithで抱き合わせてシーザーシフトさせれば上手く行きました.

 以下がその実行結果.
*Vigenere> encrypt [10, 21, 32] "cipher : Vige ne re"
"m~\DLErz\DC2*O@`~\ao5\SOo5\DC2o"
*Vigenere> decrypt [10, 21, 32] "m~\DLErz\DC2*O@`~\ao5\SOo5\DC2o"
"cipher : Vige ne re"
*Vigenere> decrypt [10, 20, 32] "m~\DLErz\DC2*O@`~\ao5\SOo5\DC2o"
"cjphfr ; Vjge!ne!re"
二回目の復号化ではわざと間違った鍵を渡していますが, 周期的に失敗していることがわかります.

ポリュビオス暗号

 アルファベットA〜Zについてそれぞれ重複しないようにランダムに別のアルファベットを割り当てます. 例えば, AにXを, BにNを, CにGを......というふうにそれぞれの割り当てを表にしたものが, 鍵となります. ポリュビオス暗号では, この表にしたがって, 文字を変換していきます. というわけでアルファベット26文字からなる文の鍵空間は, 26!になります.
 以下がHaskellのコード.
module Polybius where
import Data.List
import Data.Char
import System.Random

shuffle ls = do
  indices <- decRandInts $ (length ls)
  return $ snd $ foldl fetch (ls, []) indices
  where
  randInt :: Int -> IO Int
  randInt n = getStdRandom $ randomR (0, n - 1)
  decRandInts size = mapM randInt $ reverse [1..size]
  fetch (rest, new) i = let item = rest !! i
                        in (delete item rest, item:new)

generateKey = shuffle ([0..127]::[Int])

convert op = chr . (flip mod 128) . op . ord

encrypt :: [Int] -> String -> String
encrypt key = map $ convert (key !!)

decrypt :: [Int] -> String -> String
decrypt key = map $ convert (\x-> head $ findIndices (x ==) key)
 ヴィジュネル暗号に対して, プログラムがいきなり長くなったように感じますが, 暗号化/復号化の部分のコードサイズは, ヴィジュネル暗号とほぼ同じです. 鍵生成にコードが費やされているのですが, 原因は, shuffle関数にあります. リストの要素をランダムに並び替えるだけの関数ですがかなり行数を消費しています. HaskellにはClojureのshuffleに相当する関数がないようで, 困ったところです.

  generateKeyで適当な鍵を生成できます.

  以下が実行例.
*Polybius> key <- generateKey
*Polybius> key
[34,2,38,11,92,112,82,28,42,103,31,59,40,76,123,90,23,19,81,89,83,61,25,66,50,104,27,78,67,68,98,24,101,13,114,9,72,46,69,75,77,87,71,17,51,16,5,60,121,126,6,7,12,113,73,106,26,109,41,105,37,54,120,85,1,58,22,115,44,15,52,29,74,124,33,117,118,116,21,110,125,18,53,64,49,96,0,3,8,79,102,108,30,48,47,100,65,99,94,93,39,4,32,36,20,62,107,91,88,80,45,10,127,35,111,84,14,70,57,119,86,95,43,97,55,63,122,56]
*Polybius> encrypt key "Hello World, Polybius!!"
"J\EOTXX\ne\ETX\noX'3e}\nX_^>FT\r\r"
*Polybius> decrypt key "J\EOTXX\ne\ETX\noX'3e}\nX_^>FT\r\r"
"Hello World, Polybius!!"

ワンタイムパッド

 絶対に解読できない暗号といえば, これです. 解読が不可能(困難ではない)な割にアルゴリズムはものすごく簡単です. 暗号文は2進数としますが, ある平文に対して, その暗号文の同じ長さのランダムな二進数列が鍵になります. 平文と鍵についてXOR (排他的論理和)をとれば, 暗号文が完成します. 復号化は, やはり, 暗号文と鍵のXORでもとの平文が得られます.

  分かりやすさのために, XORの代わりにシーザー暗号を用いると, 長さnの平文P=(p1...pn)と同じ長さのシフト数のリストS=(s1...sn)を用意し, pi番目についてsi番目のシフト数でシフトするという操作と考えることもできます.  この手法は全数探索で解読することができません. 数学的にもちゃんと証明されているようですが, 直感的には, 鍵空間について全数探索を試みると, その長さで存在しうる可能なすべての平文が出現するからだと理解できます. これは, 鍵空間が大きすぎる(NP困難など)といった問題とは全き別の事柄です. 任意の鍵Sで出現した文字列が元の暗号化された平文なのかを判定できません(統計的にはもちろん直感的にもです).

  例えば, 平文"dog"について鍵[1,2,3]で暗号化すると, d→e, o→p→q, g→h→i→jで, 暗号文"eqj"ができます. これについて全数探索した時, mod 26で考えると, 鍵空間は26^3ですが, それぞれについて調べていると, 例えば鍵[2, 16, 16]についても調べます. この結果は, 平文"cat"です. また別の鍵[13, 12, 6]は平文"red"を与えますが, 果たして, 暗号の使用者がどの平文を暗号化したのか解読者の知る術は鍵のコードを直接知る以外にありません.

  というわけで, 次のHaskellのコードはシーザーシフトを用いて作られたOne Time Padのコードです.
module Onetimepad where
import Data.Char
import System.Random

randInt :: a -> IO Int
randInt n = getStdRandom $ randomR (0, 128)

generateKey ls = mapM randInt ls

ceaser key = chr . flip mod 128 . (key +) . ord

encrypt :: [Int] -> String -> String
encrypt = zipWith ceaser

decrypt :: [Int] -> String -> String
decrypt = zipWith (\k-> ceaser (- k))
 基本的にヴィジュネル暗号に近いですが, もともとのシーザー暗号を少し拡張した程度といった感じもします. ceaser関数は, シーザー暗号で使われていたものと同じものです. ポリュビオス暗号同様, 自分で鍵を作るのが大変なので, generateKey関数で平文の長さに応じた鍵が作れるようになっています.

  実行してみると次のようになります.
*Onetimepad> key <- generateKey "One Time Pad !!"
*Onetimepad> key
[102,9,52,106,31,47,21,63,52,9,36,99,80,32,41]
*Onetimepad> encrypt key "One Time Pad !!"
"5w\EM\ns\CAN\STX$TY\ENQGpAJ"
*Onetimepad> decrypt key "5w\EM\ns\CAN\STX$TY\ENQGpAJ"
"One Time Pad !!"
*Onetimepad> decrypt (98:(tail key)) "5w\EM\ns\CAN\STX$TY\ENQGpAJ"
"Sne Time Pad !!"
 ここからは少しややこしくなります....

フェイステル暗号(∈ブロック暗号)

  ワンタイムパッドは強力ですが, 鍵のサイズが物理的に持ち運ぶ必要があるなど難点があります. 解読が難しくかつ, 鍵のサイズがそこまで大きくない暗号が必要です. 軍隊のような物理的に巨大な鍵が使用できる場合を除けば, 現代で用いられている暗号は,ブロック暗号と公開鍵暗号が主流なのだそうです.  ブロック暗号は, 暗号化する平文をブロック単位に分割して, 各ブロックごとに暗号化する手法で, そのうちの一つがフェイステル暗号です.

  最初にF関数という非線形変換を行う関数を用意しておきます. この関数は, 鍵knと平文を引数にとり, 何らかの変換を行った値を返すような関数です. 平文を2つL, Rに分割します. 片方Lに, F関数を適用した後の値とRとで, XORを取り, これをR'とします. 次にR'にF関数を適用した値とLとでXORを取り, これをL'とします. そして再び片方Lに, ...... という処理をn回繰り返し, 2つの平文をくっつければ, 暗号文が出来上がります. 復号化はこの逆の処理です. F関数は非線形変換ならなんでも良いようですが, 暗号の強度はF関数の設計に依存するそうです.

以下がその実装.
module Feistel where
import Data.Char
import System.Random

generateKey n = mapM randInt [1..n]
  where
  randInt :: a -> IO Int
  randInt n = getStdRandom $ randomR (0, 128)

feistel d f key ls = rounding key l0 r0
  where
  (l0, r0) = flip splitAt ls $ div (length ls) 2
  cshift   = zipWith (\x y -> mod (d x y) 128)
  rounding [] l r     = r ++ l
  rounding (k:ks) l r = rounding ks r $ cshift l $ map (f k) r

f :: Int -> Int -> Int
f a x = a * x ^ 2

encrypt :: [Int] -> String -> String
encrypt key = map chr . feistel (+) f key . map ord

decrypt :: [Int] -> String -> String
decrypt key = map chr . feistel (-) f (reverse key)  . map ord
 暗号化/復号化の時の左右入れ替えの処理について上手く書けなかったので, 普通の関数定義として書いています. 一見すると複雑そうなアルゴリズムなので, 手間取るかと思っていたのですが, 案外簡単に実装できます. 暗号化と符号化の処理は全く逆の処理なので, プラスをマイナスに, 鍵を表すリストをひっくり返すだけでかけてしまいました.

 本来は, F関数へ通したあとの処理は, XORなのですが, ワンタイムパッドなど前述の例と同じように(そして, 同様の理由から)シーザーシフトを使っています.

 f関数にはシンプルな二次関数を使っています. 鍵を表すIntのリストはn回目のラウンドにおけるF関数の二次の係数です.

 以下がその実行例. 平文の文字数が奇数個の場合について考えていないので, 一回目の暗号化/復号化では, 最後の一文字が切れてしまっています.
*Feistel> key <- generateKey 10
*Feistel> key
[71,44,84,62,39,115,42,47,19,8]
*Feistel> encrypt key "Feistel Structure"
"\SOH@^oA@sR5\ESC{Hs\ESC\v\\"
*Feistel> decrypt key "\SOH@^oA@sR5\ESC{Hs\ESC\v\\"
"Feistel Structur"
*Feistel> encrypt key "Feistel Structure !!"
"\"\ETB\ENQHs\SOc [?\"\SUB>iS\ETB+ @k"
*Feistel> decrypt key "\"\ETB\ENQHs\SOc [?\"\SUB>iS\ETB+ @k"
"Feistel Structure !!"

RSA暗号(∈公開鍵暗号)

 モダンな暗号といえば, やはり公開鍵暗号でしょう. 復号鍵と暗号鍵が別々に存在し, 暗号鍵が公開できるという点が公開鍵暗号の素晴らしいところです. 公開鍵暗号系は, RSA暗号やElGamal暗号などあるようですが, ここではとりあえずRSA暗号を実装しました.

  私が知る中で, 公開鍵暗号の概念について最もわかりやすい解説は,
妻に公開鍵暗号を教えてみた - 西尾泰和のはてなダイアリー
です. あとは, Wikipediaなんかに色々書いてあります.

 要領としては, 適当に大きな素数p, qを選び, p-1とq-1の最小公倍数(least common multiple)を l とします(l = lcm (p-1, q-1)). 次に, 素数p, qの積を n とします(n = p * q). n 以下の l と素な自然数eを用意し(gcd(e,l) = 1, e ≦ n), (e, N)のペアを公開鍵とします. mod l の時に, e^ (-1)となるようなdを求めます(e * d (mod l) == 1). (d, N)のペアが秘密鍵です.  暗号化/復号化にはそれぞれ,
m = c^e (mod n)
c = m^d (mod n)
 を計算すれば, それぞれの値が求まります. m = m^(e*d) (mod n)のとき, e*d = 1なので, 復号化できるということのようです.
module RSA where
import Data.Char
import System.Random
import Data.Numbers.Primes -- cabal install primes

randInt :: Int -> IO Int
randInt n = getStdRandom $ randomR (100, n)

generateKeyPair a b = ((e , n), (d , n))
  where
  p = fromIntegral $ primes !! a
  q = fromIntegral $ primes !! b
  n = p * q
  l = lcm (p - 1) (q - 1)
  e = head [e | e <- [3..], gcd e l == 1]
  d = head [d | d <- [3..], mod (d * e) l == 1]

generateKey =
  do a <- randInt 200
     b <- randInt 200
     return $ generateKeyPair a b

encrypt :: Integral a => (a, a) -> String -> [a]
encrypt (e, n) = map $ (\m-> m ^ e `mod` n) . fromIntegral . ord

decrypt :: Integral a => (a, a) -> [a] -> String
decrypt (d, n) = map $ chr . fromIntegral . (\c-> c ^ d `mod` n)
 ポリュビオス暗号と同じく, 鍵生成にコードが費やされています.  HaskellのData.Numbers.Primesライブラリを使用しているので, 上記のプログラムの実行には, これをinstallする必要があります. installは, cabalから
cabal install primes
で使用できるようになりました. Data.Nubers.Primesで使用可能になる素数列primesは, [Int]型で, n番目の要素を取り出すときは, インデックスで指定して値を取得します.

 プログラム自体は, かなりシンプルですが, Intではなく, Integralを使うところがポイントです. べき乗は巨大な数になりやすいため, 通常のInt型では対応できません. HaskellのIntの範囲が大体, "at least the range [-2^29 .. 2^29-1]"(Data.Int, Hackage)なのに対して, Integralはほぼ上限なしの整数値を表現できます. きちんと, 型指定しないとInt型に勝手に読み替えられるのでその辺も注意が必要ですが, 一旦Integralを指定した後は楽ですね. 何も考えなくていいので. 

 素数のサイズは, 一般にセキュリティパラメータkに対して, k/2ビットの素数と決められているようですが, 上記の実装は適当で, そこそこ大きな素数(2から数えて, 100~200番目くらいの素数)を2つランダムに生成するように指定しました.  RSA暗号の難点の一つは暗号化/復号化に時間がかかることですが, 上記の実装でもその欠点をあますところなく再現しています. 

 実行してみると以下のようになります.
Prelude> :load rsa
[1 of 1] Compiling RSA              ( rsa.hs, interpreted )
Ok, modules loaded: RSA.
*RSA> keys <- generateKey
*RSA> keys
((7,662153),(35383,662153))
*RSA> encrypt (fst keys) "Hello RSA World!!"
[202542,581327,594739,594739,111395,619198,288526,9701,6174,619198,289750,111395,53605,594739,543959,289438,289438]
*RSA> decrypt (snd keys) [202542,581327,594739,594739,111395,619198,288526,9701,6174,619198,289750,111395,53605,594739,543959,289438,289438]
"Hello RSA World!!"
 以上です. Lispで書くのと違い, Haskellでプログラムを使うとなかなかカッコがつきませんね.

2014/10/09

ClojureでSGA(遺伝的アルゴリズム)を使って巡回セールスマン問題

 SGA (Simple Genetic Alogrithm, 単純遺伝的アルゴリズム)は, 最適化問題などに用いられる遺伝的アルゴリズムのシンプルなversionです.

 巡回セールスマン問題といえば, xy空間上などに適当に散布している各点を通るような最も最短の経路を求める問題です. 下図の実行結果の各ノードを結ぶ線が巡回経路になります. 組み合わせが爆発するので, (点の数が極端に小さい場合を除き)総当り法では解けず, 一般には何らかの最適化アルゴリズムを使って近似解を導くわけですが, そのうちの一つが遺伝的アルゴリズムというわけです.




SGA(単純GA)

SGAの仕組みは(Wikipediaに詳しい説明がありますが)基本的に,

 個体の初期集団の生成 → 選択 → 交叉(交配) → 突然変異 → 選択(2回目) → 交叉(2回目) → 突然変異(2回目) →...

と続いていく処理です.

 「個体の初期集団」とは解の集合で, これは最初はランダムにいくつか生成.

 選択のフェーズでは, 生成された解から次世代を担う解を選択. スコアの高いものが残る確率が高くなるように選びます. 初期集団の個体と同じ数を揃えます(選択の重複や選択したもののコピーも有). 選択方法には, ルーレット選択や, ランキング選択, トーナメント選択などいくつか種類があります.

 交叉のフェーズでは, 2つの個体(解)を選び, その解のそれぞれの部分列をお互いに入れ替え,新しい解を生成します. これも, 一点交叉, 二点交叉などいくつか種類があります.

 突然変異のフェーズでは, 一定確率で, 個体の集合の一部を適当に書き換えます. 書き換える確率は問題によって異なります.

 上記の3ステップで, 解の2世代目が生成されます. これをn回繰り返して, 1, 2, ... ... ,n世代目と解の集合がより洗練されたものになっていくという仕組み.

 繰り返しの上限などを決めておき, 適当なところで止めて, その時の世代(解の集合)の中でもっともスコアの高い解が最終的な計算結果です.

 初期集団をどれくらい作るのか, 何回繰り返すのか, 選択方式など各種パラメータは, 計算量や生成される最適解とにらめっこしながら実装者が試行錯誤しながら決めていくもののようです.

 特に優れた解は, 選択/交叉/突然変異のプロセスを飛ばして, 次世代に残したり(エリート抽出)しますが, 今回の実装ではしてません.

Grefenstetteらの手法

今回は巡回セールスマン問題を扱うので, 解は各ノードのリストとなります. 最終的な解は以下のようなデータ構造です.
[:a :f :e :g :d :h :c :b]
 交叉とは例えば, 二つの個体, 01000111 と 11101101について, [010][00111] と[111][01101]に分割して, [010][01101] と [111][00111] の二つの新しい個体を生成する作業なのです. 末尾の5bitを入れ替えました. 何bitのところで交叉させるかは, ランダムに決めます.

 これで新しい解が生成されるわけですが, これを上記のノードのリストに直接適用しようとすると不都合が生じかねません. 解がbit列で表現されているときは, まだいいのですが. 上記のような重複しない要素の順列が解になる場合 abdc と cdab について解の中央で交叉させると, [ab][ab]と[cd][dc]という全く意味を成さない解が生成されてしまいます.

 これについて, いろいろ試行錯誤ができるのですが, Grefenstetteらの手法(特に呼び名がないのでこう呼びますが)では, ノードのリストを次のような数値列にエンコードします.

 エンコードされた解が(x0, x1, ..., xn)のとき x0は, 全ノードのソートされた列P(例えば (a, b, c, ...))の x0番目の要素を表し, x1は, x0番目の要素が取り除かれた後のP'のx1番目の要素を表します.

 xiは, x0からx(i-1)を取り除く作業が終わった後の, 全ノードの(整列された)列P''のxi番目の要素を表すことになります.

 例えば, P = (a, b, c, d)があったときに, (3, 1, 2, 1)は, (c, a, d, b)を表すわけですが, 必ずソートされたすべての要素を含む列Pを参照するので, 要素が重複することはありません.
 先頭の3は, Pの3番目cを表し, その次に来る1は, P' = (a, b, d)の1番目aを表し, 2は, P''=(b, d)の2番目dを表し, 最後の1は, P'''=(b)の1番目bを表します.

 したがって, 交叉しても, 解として意味を成さない解は生成されません (この手法はこの手法でGA的に別の問題がありますが, ここでは割愛します). これにより, 交叉可能なデータへエンコードできるわけです.

 この手法は, (著) 棟朝 雅晴, 遺伝的アルゴリズム -その理論と先端的手法-, 森北出版, 2008に説明があります.

Clojureのコード

 今回はClojureでの実装が簡単そうな, 一点交叉, トーナメント選択で, 突然変異する確率は, 0.2%に設定してあります.


 上半分は簡単なプロファイラ. 適当な使いやすい実行時間計測のためのプロファイラがなかったので自作. Clojureは, こういうのが簡単に作れるところがいいですね.

 中央部がSGAの実装.
 find-opt-pathがSGAの本体です. メインルーチンは, find-opt-path関数の下から数行の部分です. 選択(selection), 交叉(crossover), 突然変異(mutation)の実装はそれぞれ, 見やすいので, map/reduceで楽して書いています. 実行時間に影響がありそうですが.

 実行(計算)結果の可視化は, Clojureなので, Awtを使えば簡単に表示できます. Y軸を反転させて, 座標系を拡大し, 原点を下にもってきて, 線を描くだけです.

 適当にreplにロードすれば使えます.
user> (load-file "find-opt-path.clj")
find-opt-path関数に, ターゲットの座標の情報と, ループ数, 個体群のサイズを指定して実行.
user> (find-opt-path sample-points-with-coord 200 200)
(:a :f :j :d :g :i :c :e :b :h)
 (最適化されているはずの)記号列を出力します. もちろん, 実行毎によって結果は変化しますが, 大体似たような結果になることが多いです.

 実行結果の可視化は, plot-graphとfind-opt-pathを組み合わせて実行します.
user> (plot-graph sample-points-with-coord (find-opt-path sample-points-with-coord 200 200))

表示結果はこんな感じ.

気になる実行時間ですが,
user> (time (find-opt-path sample-points-with-coord 200 200))
"Elapsed time: 1849.978839 msecs"
user> (print-exec-time)
:crossover : call= 200 ,elapsed-time= 1651.9376810000003
:mutation : call= 200 ,elapsed-time= 0.5620599999999997
:selection : call= 200 ,elapsed-time= 3.0204269999999958
nil
となります. これは実行環境により, 変化するものの, かなり遅いですね. 相当時間がかかっていますが, ほとんどcrossover(交叉)が実行時間のほとんどを占めています. 上記のケースは各関数の時間計測時に, doallを使わずにlazyに実行した場合.

* :  letfnやletを使うべきところで, defn/defを使っていたので, 一部リファクタリングを行い, Gistのコードは, 2015/02/19に差し替えました.


 書いている途中で気がついたのですが, 上記のプログラムは大体, パラメータさえ決まってしまえば, 使うメモリ空間は一定でほとんどin-placeアルゴリズムなわけです. ところが, 関数型言語風に書いたため, ひたすらconsingばかりしています. ちょっと効率悪いかなと.

 例えば, 突然変異は, 個体を表す数値を少し書き換えればよいのですが, ばらして, (変異させるbitを)選んで, 再構成して, という処理で, 無駄な部分がいくつかあります. 特に実行時間の長かった交叉(crossover)は, リストの再構成にconcatを多用していて, 破壊的な処理に書き直したくなりました.

 というわけでClojureは, こういうガリガリ回す数値計算に向いていないのか, と思ったのですが, これはどうやら間違いでした.

 make-arrayを使えばJavaの配列が使えて, それなりに早いようです.
Java の配列を利用してメモリと時間の壁を突破する. (tnoda-clojure)

 というわけでやり直し.

2014/09/15

Emacsのnext-buffer/previous-bufferで*(アスタリスク)を含むbufferを飛ばす

 Emacsでbufferを移動する際にnext-bufferとprevious-bufferを使っているのですが, アスタリスクの入ったbuffer(*scratch*や*Completions*, *Message* ,*auto-install ...etc)が頻繁に表示されます. 鬱陶しいなと思っていたのですが, そのまま放置していました.
 アスタリスクを飛ばすnext/previous-bufferは書いてみると結構そのまんまでした.

(defun asterisked? (buf-name)
  (= 42 (car (string-to-list buf-name))))

(defun move-to-scratch ()
  (interactive)
  (let ((current-buffer-name (buffer-name)))
    (next-buffer)
    (while (and (not (string= "*scratch*" (buffer-name)))
                (not (string= current-buffer-name (buffer-name))))
      (next-buffer))))

(defun next-buffer-with-skip* ()
  (interactive)
  (let ((current-buffer-name (buffer-name)))
    (next-buffer)
    (while (and (asterisked? (buffer-name))
                (not (string= current-buffer-name (buffer-name))))
      (next-buffer))))

(defun previous-buffer-with-skip* ()
  (interactive)
  (let ((current-buffer-name (buffer-name)))
    (previous-buffer)
    (while (and (asterisked? (buffer-name))
                (not (string= current-buffer-name (buffer-name))))
      (previous-buffer))))
 こんな感じ.
 これに, 以下のように適当なキーバインドを割り当てればOKです.
(global-set-key "\C-z\C-e" 'previous-buffer-with-skip*)
(global-set-key "\C-z\C-a" 'next-buffer-with-skip*)
 私の環境では, C-zはunsetしているので\C-z\C-eと\C-z\C-aに割り当てていますが, "\C-z\C-e"と"\C-z\C-a"の部分には, 任意の適当なキーを割り当てられます.
 また, このままだと, *scratch*へ移動できないことがあるので, scratchへ移動するため, move-to-scratchを書いています. M-x move-to-scratchで, *scratch*バッファへ移動できます. shell/eshellへは, それぞれ, M-x shellや, M-x eshellで移動できます. これらは, global-set-keyなどでキーバインドしても移動できます.

 使ってみると, 結構快適です.

2014/09/02

On Lispを読んだ.

 Paul Graham(著), 野田 開(訳), On Lisp, オーム社, 2007を読んだ.

 今更感がありますが, 普段使う言語は大抵, Scheme(Gauche)/Clojureなので, Common Lispについてはあまり興味がありませんでした. 本書は, 大学の図書館で, 斜め読みした程度でした(どちらかといえば, Let Over Lambdaの方が好きでした)が, 今回はちゃんと読みました(コードはまだ動かしてないです).
 主な目的は, 主にマクロの部分です. 本書の7章から24(25?)章がマクロの説明にあてられています. 特に読みたかったのは, ATNを使ったパーサの章と継続の章, 汎変数のあたりです.
 というわけで, 以下の文章は, その時の感想です.


 1章から6章までは, 主にCommon Lisp入門といった内容で, 簡単にCLの使い方について説明されています.
 7章からいよいよ, マクロの話です. これを使うシチュエーションについて本書では, 7種類くらい挙がってますが, 私は, マクロの主な用途は,
  • 評価順序(回数, 条件など)の操作
  • 副作用
を使うときの2種類でいいのではないかと思います.(※あくまでも個人の感想です)

 大半のマクロは, 展開されるS式を短くDRYに書くためのものです. 関数で書くこととマクロで書くことによる記述の大きな違いは, 与えられた式が関数評価の順序で計算される(ノーマルフォーム)か, 与えられた式が特殊な評価順序で処理される(スペシャルフォーム)かの違いです. つまり, 特殊な評価順序で処理されることを目的とする部分が重要だと考えました.
 単純に冗長な記述を縮約するだけなら, 関数にまとめて書けばいので, この1点目の目的は, かなり大きいと思います.
 例えば, Lispのマクロで, yaccのようなパーサジェネレータ(マクロによる展開)を書くことはできると思われますが, パーサコンビネータ(関数合成による構文解析器生成)でもOKで, わざわざマクロで書く必要はないかもしれません. このような単純に展開する操作だけならば, 関数でも代用できるはずです (高速化や最適化のためには, インライン展開などの方法も考えられます).

 2つ目のマクロの用途が「副作用」だというのは, コンテクスト(環境の操作), 継続や例外(withマクロ系)など, これも関数では扱えないパターンを, 簡略化や集約するときの使い方のことです. これは「副作用」とひとまとめにすることができます. 副作用も基本的に関数では扱えない部分で, 代表格は, letやmatchとか, その派生系ですが, マクロ需要の重要な位置を占めていると思います.

 というわけで, 基本的に, マクロはDSL(Domain Specific Language)なので, DSLについて方法論の説明がOn Lispの内容の大半を占めているようにも読めました. 本書では, DSLは「埋め込み言語」と書かれています(ドメイン特化言語の方が一般的な訳語だとは思いましたが).

 (Common)Lisp内部でマクロとしてDSLを書く利点は, DSLをLisp本体のコードと一緒にコンパイルできるという点があると書かれていました.
 例えば, C言語においてDSLを書きたい場合, それ用のインタプリタ/コンパイラ(または変換器?)の実装が必要になりますが, Lispではその必要がありません. Common Lispの最適化やGCのインフラの恩恵をそのまま受けられるということでしょう.
 このあたりは, 今まで意識してきませんでしたが, Lisp特有のメリットだと思いました.

 9章では, 「変数捕縛」というタイトルですが, ひたすらマクロ展開における変数の重複の回避について説明するという内容です. 例えば, Common Lispの準クォートなどによる素朴なマクロ展開では, 変数名が重複してしまうケースがあります. 例えば, 以下の例.

`(funcall #'list ,a ,b)
というマクロ展開があるとします. labelsが関数名listへ別の関数を束縛した時, labelsの内側でこのマクロを展開すると,
(labels ((list (x y) y)) `(funcall #'list ,[aに相当する式] ,[bに相当する式]))
という式に広げられ, この内側のlistは, 直前で束縛された関数listです. これは本来の展開の意図と異なります.
(funcall #'list 1 2 3) ;; => (1 2 3)
(labels ((list (x y z) y)) (funcall #'list 1 2 3)) ;; =>2
くらい違います.

 Common Lispが長年, 衛生的マクロを導入したなかったことを考えると, 実用上問題はないように思っていました. 著者自身が「病的」とまで語るほど, 名前の衝突を避けるために1セクション割いていることを考えると, Schemeの衛生的マクロや, Clojureにおける, 準クォートでの名前空間付きの準クォートは妥当な戦略なのかなと思いました.

 「汎変数」はGeneralized Variableの訳語で, 同じPaul Grahamが著者のANSI Common Lispでは, 一般化変数と訳されていました. これは, マクロによるシンタックスシュガーです. (変数の破壊は好きではないので通常のsetq/set!もふくめて)使ったことがないのですが, Gaucheにもあるようです.

 consを徹底的に排除するような記述が多く, 関数型言語とは程遠い印象を持ちます. consは, 参照透過なリストを作るために常用される手段なので, 関数型プログラミングには欠かせない仕組みだと思っていたのですが.

 Schemeは割と関数型言語寄りな書き方が多いような印象がありますし, Clojureは, よく「関数型言語」と呼ばれます(変数を破壊するようなことは基本的になくて, STMなどが使われます). Lisp系の言語は, 副作用は排除しがちなのだと思っていたのですが, On Lispでは割と破壊的代入が常用されていて驚きました.

 全体的に速度(やその最適化)を意識した内容になっていて, 少し意外でした.
 Scheme(Gauche)やClojure関連の話題で, 速度やそのチューンナップを意識した話はあまり聞かないような気がします. 私が寡聞なだけかもしれませんが.
 HaskellにはCalculational Programmingというのがあり, 高速化に関してもかなり抽象的な印象があります. 一方,  Common Lispにおける高速化はそれと真逆で, どちらかといえば, consを使わない(動的メモリ確保を減らす)とか, マクロによりインライン展開などの効果に由来するものが多かった印象です.

 私が特にCommon Lispいいな, と思ったのは, リードマクロの部分です. 本書では17章にあたります. これは, プログラム中の文字数を効果的に削減できるものだと思います. 例えば, リードマクロにより,
#[1..10] ;; => (1 2 3 4 5 6 7 8 9 10)
みたいな展開をするマクロが書けるんですね. Clojureでも使えないか探してみたところ, Clojureのリーダマクロ(記事後半部の「ディスパッチマクロの拡張」)のページを発見. これは遊んでみる必要があります...

 18章は「分配」と不思議なタイトルですが, これはよくあるmatchマクロのことでした. HaskellやOCamlでいうところのパターンマッチを実行するマクロですね.

 20章でいよいよ「継続」の話題に入るわけですが, ここでマクロ展開される継続は, CPS変換ではなく, グローバル変数の書き換えで継続を捕縛していました. Schemeの第一級の継続と比較すると見劣りしますが, 驚くべきことに, この実装が次の2つの章, 21章「マルチプロセス」と22章「非決定性」で実際に用いられた上に, 23章におけるATNパーサや25章のProlog実装につながります.

そういえば, web上に資料は上がっていたんですね.
On Lisp (Paul Graham著,野田 開 訳)

(2015/02/09 : 一部修正)

2014/08/29

Lispの仕様書, リファレンスマニュアル

(LISP 1.5 PRIMER (BY (CLARK WEISSMAN)) (1967)
http://www.softwarepreservation.org/projects/LISP/book/Weismann_LISP1.5_Primer_1967.pdf

LISP 1.5 Programmer's Manual 2nd ed, 15th printing (1985)
http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf

Mac Lisp Reference Manual (1974.08.04)
http://www.softwarepreservation.org/projects/LISP/MIT/Moon-MACLISP_Reference_Manual-Apr_08_1974.pdf

Franz Lisp Manual (1983)

Lisp Machine Manual 6th ed (Zeta Lisp) (1984.06)
http://common-lisp.net/project/bknr/static/lmman/frontpage.html

Common Lisp HyperSpec
http://www.lispworks.com/documentation/HyperSpec/Front/index.htm

R5RS〜R7RS, SRFI
http://scheme-reports.org/

R4RS(Revised 4 Report on the Algorithmic Language Scheme) (1991)
http://people.csail.mit.edu/jaffer/r4rs_toc.html

R5RS(Revised 5 Report on the Algorithmic Language Scheme) (1998)
http://www.schemers.org/Documents/Standards/R5RS/

R6RS(Revised 6 Report on the Algorithmic Language Scheme) (2007)
http://www.r6rs.org/

R7RS(Revised 7 Report on the Algorithmic Language Scheme) (2013)
http://trac.sacrideo.us/wg/wiki/R7RSHomePage

その他, LispといえばEmacs Lisp, Clojure, Arcなど.

#'(function)とfuncall (Common Lisp)

 Lisp-1を使う私にとって, Common Lispの最大の謎は, funcallと#'です. Lisp-2の名前空間の仕組みさえわかってしまえば, あとはGauche(Scheme)とほとんど同じというのが, Common Lispへの私の勝手な印象です(間違っているかもしれませんが..).
 Schemeから入ると, この辺がよくわからなくなります.

 #'の正しい呼び方は, "function"です. #'は, その見た目のとおり, functionマクロのリーダマクロでした. functionは, レキシカルクロージャを生成するためのものみたいですね. (Common Lispにおけるlambdaのあれこれ(ありえるえりあ))
 しかし, 普通にlambdaと書くだけではクロージャを作らないのかというと, そういうわけでもないようです. 現代におけるCommon Lispのlambdaは, #'(lambda ...)を表すマクロなので, lambdaと書けば, #'(lambda ...)と書いたのと同じだということです. Common Lispで普段使われるlambdaは, 普通のクロージャになるのでしょうか.

 関数呼び出しの最左の式(要素?)は, ラムダ抽象か, 関数を束縛した変数である必要があります.

((lambda (x y z ...)) B C ...) ; => ○
((x y z ...) B C ...)          ; (x y z ...)がlambda式でない何か=> ×
(A B C ...)                    ; この時, Aは特殊形式 => ○
(A B C ...)                    ; 関数の名前空間にAの値(関数)が束縛されている => ○
(A B C ...)                    ; 関数の名前空間にAの値(関数)が束縛されていない => ×
 上記の○と×は, 文法的かつ変数の束縛している内容について考えた場合, 正しい記述か間違っているかという意味です. Schemeでは上から二番目の(x y z...)も問題ないのですが, Common LispではNG. Common Lispでは,  funcallは, この時(or こういった書き方をしたい時)に, 呼ばれる関数のようです. また, 最下段のケースでも, 変数の名前空間でのAに関数が束縛されている時も, funcallが使えます.

 これで, なぜfuncallをするのかという謎と, #'の使い所の謎が解けました. lambda抽象に対する#'は不要で, defunで定義した関数について, クロージャを作りたいときに, #'fなどと書けば良いことになります. funcallは, クロージャが渡された時, applyするために使うものとなります.

 funcallが必要になるのは, Lisp-2の名前空間が原因のようで, 例えば, (A B C ...)のような関数適用があった時に, 関数の名前空間におけるAが表す値(関数)と変数の名前空間におけるAが表す値(関数/クロージャを1stクラスオブジェクトとして扱えるため)を区別するためにあるようですね.

2014/08/23

Haskell風のリスト内包記法をClojureで

Clojureのリスト内包記法は, forですが, この記法は少し読みにくいように感じます.

例えば, Haskellなら
[(x, y) | x <- [1..10], y <- [2..11], odd (x * y)]
と書けるところをClojureは,
(for [x (range 1 11), y (range 2 12), :when (odd? (* x y))] [x y])
と書きます.

 どのあたりが気に入らないのかというと, 真っ先に目につくのが:whenです. Haskellは注釈なしに条件を付加しています. whenのような注釈は, Haskellに必要ありません.

 :when以外にも気に入らないところがあります. generatorです. Haskellは, 例のx<-[1..10]というかなり直感的な表記ですが, Clojureは, rangeと束縛する変数を併置するという書き方で, かなり形式張った印象があります. Clojureでも, x <- [(exp1)..(exp2)]のようにかければいいかなと思いました. 一番理想的なのは, e ∈ [1..10]ですが.

 このような注釈が必要になるのは, 動的型付け言語であるClojureでは仕方がないのかもしれないです. Haskellの場合, odd (x * y)の式は, 構文を読み込んだ後の型推論のフェーズで, 式がboolを返す式であることを認識します. 一方で, Clojureは, 構文を読んだ時点で任意の関数fが, 例えば, (f (* x y))と書かれているとして, それが条件を表すとは認識できない(というか, 決定できない)と思ったのですが...

Haskell Report 98のリスト内包記法 によれば, 次のように定義されます.
[e | True ]     = [e]
[e | q    ]     = [ e | q, True ]
[e | b, Q ]     = if b then [  e | Q ] else []
[e | p <- l, Q ]= let ok p = [  e | Q ]
                      ok _ = []
                      in concatMap ok l
[e | let decls, Q ] = let decls in [  e | Q ]
 Haskellの内包記法は, letとfilter, generatorが使えます. letは, リスト内包記法内で一時的に束縛される変数を定義する式です.<-で記述される式は, generatorと呼ばれます. generatorから生成された変数列にかけるのがfilterです. 3行目のbがfilterに相当します.

 Haskellのリスト内包記法の定義をよく見ると, 型注釈から, 式をフィルターの条件式かどうかを判定しているわけではなく, 構文的に条件式だと見ているようです. つまり, 処理系から見て, リスト内包記法の構文を読む時, :whenの注釈は必要ないのかもしれません.

 :whenは, 意味的に必要なのではなくて, 分かりやすさのために存在していると見た方がよさそうです.

 Clojureのリスト内包記法がこのような表記になっている原因は, この記法のイメージの根底にあるが, for-each構文だからでしょう. 構文の名前もforと書かれています. Pythonのリスト内包記法もforが使われていました. 一方で, Haskellの記法は, 数学で用いられる集合の内包的記法を忠実に文法に落とし込んだ印象があります.

 いずれにせよ, 上記のような特徴からClojureのリスト内包記法は直感的ではないと思いました.

 というわけで, Haskell風のリスト内包記法の構文をClojureでも使えるようにします. ここで重要なのは, すべてHaskell化するのではないということです. S式は残します. 例えば, こんな感じ.
[(x, y) | x <- (range 1 11), y <- (range 2 12), (odd? (* x y))] 
 S式でコードが書けないのは, 本末転倒です. 最初からHaskellを使えばいいだけなので.

 次のようなマクロを作りました.
user=> (lc [x | x <- (range 10), (odd? x)])
(1 3 5 7 9)
user=> (lc [[x,y] | x <- (range 10), (odd? x), let y = (* x 3)])
([1 3] [3 9] [5 15] [7 21] [9 27])
 lcはHaskell風の内包記法をとり, Clojureのforへ変換します. 表記が違うだけで, 機能的にはforそのものです.
 以下がソースコード. core.matchマクロを使っているので, 使用の際には, project.cljやleinのprofileにmatchマクロを追加する必要があります.

(use '[clojure.core.match :only (match)])

(defn throw-exception [message]
  #((throw (Exception. (str message %)))))

(defn malformed-let-in-lc [s-exp]
  ((throw-exception "malformed let in list comprehension : ") s-exp))

(defn malformed-generator-in-lc [s-exp]
  ((throw-exception "malformed generator in list comprehension : ") s-exp))

(defn malformed-lc [s-exp]
  ((throw-exception "malformed list comprehension : ") s-exp))

(defn lc-tail->for [tail-exps converted]
  (let [top (first tail-exps)]
    (cond
     (empty? tail-exps) converted
     ;; let
     (= top 'let)
      (match tail-exps
             ['let var-name '= exp & rest-of-tail]
             (lc-tail->for
              rest-of-tail
              (concat converted [:let [var-name exp]]))
             a (malformed-let-in-lc a))
     ;; generator
     (and (symbol? top) (= '<- (second tail-exps)))
      (match tail-exps
             [var-name '<- generator & rest-of-tail]
             (lc-tail->for
              rest-of-tail
              (concat converted [var-name generator]))
             a (malformed-generator-in-lc a))
     ;; filter
     (list? top)
      (lc-tail->for
       (vec (rest tail-exps))
       (concat converted [:when top]))
     :else
      (malformed-lc tail-exps))))

(defmacro lc [exp]
  (match exp
         [an-element '| & list-comprehension-tail]
         `(for ~(vec (lc-tail->for list-comprehension-tail []))
            ~an-element)
         a (malformed-lc a)))
 例えば, ラマヌジャン数も求まります. (以下のS式のexpは別途用意が必要)
user=> (lc [[left [x,y,z,w]] | x <- (range 1 20),
                               y <- (range 1 20),
                               z <- (range 1 20),
                               w <- (range 1 20),
                               let left = (+ (exp x 3) (exp y 3)),
                               let right = (+ (exp z 3) (exp w 3)),
                               (= left right) (not= x y) (not= y z)
                               (not= z w) (not= x z) (not= x w) (not= y w)])
([1729 [1 12 9 10]] [1729 [1 12 10 9]] [4104 [2 16 9 15]] [4104 [2 16 15 9]] [1729 [9 10 1 12]] [1729 [9 10 12 1]] [4104 [9 15 2 16]] [4104 [9 15 16 2]] [1729 [10 9 1 12]] [1729 [10 9 12 1]] [1729 [12 1 9 10]] [1729 [12 1 10 9]] [4104 [15 9 2 16]] [4104 [15 9 16 2]] [4104 [16 2 9 15]] [4104 [16 2 15 9]])

 元のClojureのforよりは見やすくなったと信じています. 特に空白を表すカンマが適当なところで, 区切りを明確に表現して丁度いい感じになりました. しかし, lcが邪魔ですね.

 リードマクロで#[x| ...]のように記述できれば理想的なのですが, Clojureにはリードマクロを自由に追加することはできません. (追記, 2014/10/06 :  Clojureのリーダマクロ 最近のversionでは追加されたようです.) Clojure本体のコードを弄ることで, リードマクロを拡張することはできるようなのですが, それは少しやりすぎな感じがします.

2014/08/18

syntax-rulesの書き方のコツのようなもの(Scheme)

 Scheme(R5RS)のマクロであるsyntax-rulesは, Lispの伝統的なマクロとは書き方や雰囲気も全く違います. 伝統的なマクロがないSchemeは, どこか言語として(Lispとして), 物足りない感じがしました.  しかし, そんな私も最近は, 折にふれて, ちょっとした作業でsyntax-rulesマクロを使うようにしたところ, Hygenicマクロへの抵抗感が薄れてきました. 使い慣れたついでの, Hygenicマクロの書き方のコツのようなもののメモです.

再帰的な関数の書き方

 どこで読んだのか覚えていないのですが, 関数型言語でプログラムを書くコツは,if(cond)式について, 特殊なケースから順に書いていくことだそうです.
 例えば,  フィボナッチ数を計算する関数は, 再帰呼び出しを用いて書く場合,
(define (fib n)
    ... ...
という形で最初に関数名と引数の数とその値の型について考えます. ここでは, nは整数(integer)です.
 次に, 特殊なケースについて, n = 0の時と, n = 1について考えます.
(define (fib n)
  (cond
    ((= n 0) 1)
    ((= n 1) 1)
    ... ...
それぞれ以上のように書けることは, 明らかです. 関数型言語を覚えたての頃は, 任意のnのケースについて考えるのが大変なのですが, フィボナッチ数はその性質から, fib(n - 1)とfib(n - 2)の和だということを考えると, 残りのプログラムが書けて, 
(define (fib n)
  (cond
    ((= n 0) 1)
    ((= n 1) 1)
    (else (fib (- n 1)) (fib (- n 2)))))
という感じで, プログラムを書いていきます.
 これだと, nに負の値を与えられた場合が問題になるので, throw-exceptionに継続をバインドして, 次のように書いてもいいかもしれません.
(define (fib n)
  (cond
    ((< 0 n) (throw-exception "wrong argument"))
    ((= n 0) 1)
    ((= n 1) 1)
    (else (fib (- n 1)) (fib (- n 2)))))
 これは, 普段プログラミングを行うときに自然にやっていることですが, 関数型言語風の書き方を始めたばかりの頃は, 再帰呼び出しでの書き方が分からず, 混乱した時に, このアドバイスに従い, 整理して, 書いていました. この方法論は, かなり(私には)有用で, 大抵のケースで, このアドバイスが応用できました.
 上記は数値の例ですが, 例えば, リスト処理や文字列の処理でも同じような考え方でコードを書いたのを覚えています.

syntax-rulesマクロの書き方

 この方法論は, syntax-rulesマクロを書くときにも応用できます. マクロの引数が1つ与えられている場合について考えるのです.
 次のようなフォームを反転させるマクロを実装してみます. 例えば, (1 2 3 4 5 6)が与えられるとそれを反転した(6 5 4 3 2 1)が, S式として展開されるようなマクロです. 実用性はさておき, syntax-rulesの柔軟性を調べるためには十分だと思います.
 実行結果は次のようになります.
gosh> (macro-list-reverse (1 2 3 4 5 6))
*** ERROR: invalid application: (6 5 4 3 2 1)
Stack Trace:
_______________________________________
gosh> (macro-list-reverse (1 2 3 4 5 +))
15
 これは, Schemeにおけるreverse関数をパターンマッチにより実装するのとさほど変わりません. ところで, 一般に, reverse関数は, cons関数と再帰呼び出しのために, 2つ引数をとります.  (reverse (1 2 3) ()) → (reverse (2 3) (1)) → (reverse (3) (2 1)) → (reverse () (3 2 1)) というふうに末尾再帰を繰り返すので, 2つの引数を想定します.
(define-syntax macro-list-reverse
  (syntax-rules ()
    ((_ () ())
     ... ...
 次に特殊なケースについて考えます. 1つ目の引数が空リストの場合です. 2つ目の引数には, 反転されたリストが入っているので, そのリストを返せばよく,
(define-syntax macro-list-reverse
  (syntax-rules ()
    ((_ () ())
     ())
    ((_ () (xs ...))
     (xs ...))
     ... ...
と書けます. (xs ...)は, 何らかのリストを意味しています. これがそのまま, 展開した結果として返されます.
最後に, 一般的なケースについて考えると, 左の先頭を右の先頭へ移す処理なので, (x xs ...)と分解して, 左の(ys ...)に(x ys ...)と加えて, 次のように書けます.
(define-syntax macro-list-reverse
  (syntax-rules ()
    ((_ () ())
     ())
    ((_ () (xs ...))
     (xs ...))
    ((_ (x) (xs ...))
     (x xs ...))
    ((_ (x xs ...) (ys ...))
     (macro-list-reverse (xs ...) (x ys ...)))))
 これで, 与えられた要素が反転するマクロができますが, 初期値の空リストが冗長なので, パターンマッチでそのケースについて追加します.
(define-syntax macro-list-reverse
  (syntax-rules ()
    ((_ (xs ...))
     (macro-list-reverse (xs ...) ()))
    ((_ () ())
     ())
    ((_ () (xs ...))
     (xs ...))
    ((_ (x) (xs ...))
     (x xs ...))
    ((_ (x xs ...) (ys ...))
     (macro-list-reverse (xs ...) (x ys ...)))))
 というわけで, 最初のmacro-list-reverseが完成します.

 パターンマッチが分岐の役割を果たし, 再帰的展開が普通の関数における再帰呼び出しに相当するため, Schemeにおける関数と遜色ない程度の計算力を持ったマクロがかけるようです.

2014/08/08

shift/reset(限定継続)をSchemeのメタ循環インタプリタに実装

 Schemeのメタ循環インタプリタに, shift/reset(限定継続)の機能を付け加えよう. という話です.
最初からすべてを実装するのは大変なので, 3つのversionを作ります.Schemeの処理系はGaucheを想定しています.
  • interp1 : 普通のSchemeで作成した(Schemeのsubsetを解釈する)メタ循環インタプリタ
  • interp2 : カリー化されたSchemeのメタ循環インタプリタ
  • interp3 : Abstrcting Control(論文)のSemanticsに基づいたインタプリタ

shift/resetの評価器

 次の一連の式は, shift/resetを実行可能な評価関数の定義です. 論文(Abstracting Control)のセクション1, Extended Continuation-Passing Styleの後半部分に登場する評価器(evaluator)です.
 一番先頭の行は, 評価器(インタプリタ)の型で, 式と環境, 継続とメタ継続(限定継続)を引数にとり, 計算結果を返すものです. 上から順に変数, 組み込み関数(オペレータ)の適用, 関数適用, ラムダ抽象, if(条件分岐), call/cc, shift, resetを表します.
 基本的に, ラムダ計算にcall/cc, shift/reset, ifと定数/プリミティブ関数を拡張したプログラムになります.

Eval :: Exp -> Env -> Cont -> MCont -> Ans
Eval[x]ρκγ      = κ (ρ[x]) γ
Eval[π E]ρκγ    = Eval[E] ρ (λνγ'. κ (π ν) γ') γ
Eval[E1 E2]ρκγ   = Eval[E1] ρ (λfγ'. Eval[E2] ρ (λaγ". f a κ γ") γ') γ
Eval[λx. E]ρκγ  = κ (λνκ'γ'. Eval[E] ρ[x := ν] κ' γ') γ
Eval[E1 → E2 | E3]ρκγ
                = Eval[E1] ρ (λbγ'. b → Eval[E2]ρκγ' | Eval[E3]ρκγ') γ
Eval[εk. E]ρκγ  = Eval[E] ρ[k := (λνκ'γ'. κ ν γ')] κ γ
Eval[ξk. E]ρκγ  = Eval[E] ρ[k := (λνκ'γ'. κ ν (λw. κ' w γ'))] (λxγ". γ" x) γ
Eval[{E}]ρκγ    = Eval[E] ρ (λxγ'. γ' x) (λν.κνγ)
 ρ[x] は, 環境ρから変数xに相当する値を返す処理を意味しています.
 E1→E2|E3は, Schemeにおける (if E1 E2 E3)を表します.
 ρ[x:=ν]は, 環境ρ中のxをνに置き換えることの表現です.

 Eval[x]ρκγ = ...は例えば, 評価関数が式x(変数)と, 環境ρ, 継続κ, メタ継続γを引数として受け取った時, 右側の式を返すという風に読みます.

 全体的に限定継続付きの継続渡しスタイルになっていて, ある評価ステップで計算しきれなかった計算(=残りの計算)は, 次以降のステップで継続として記述されます. 定数/変数項やラムダ抽象のステップでは, これ以上計算できないので, 継続にその式(定数やラムダ抽象など)を関数適用します. それ以外のステップは, 基本的に残りの計算を継続で表現して, 式(プログラム)の解釈を進めます.

 最終的な目標

 次のような実装を実現することです.
gosh> (interp3 '(reset (+ 1 (shift (c) (c 10)))))
11
gosh> (interp3 '(reset (+ 1 (shift (c) (c (c 10))))))
12
gosh> (interp3 '(reset (+ 1 (shift (c) 10))))
10
 一番目の実行では, 限定継続が1回実行されて11を返しますが, 二回目は, 2回実行されて12を返します. 最後の実行では, 残りの計算が切り捨てられて10を返しています.


interp1(メタ循環インタプリタの実装)

 interp1では, 簡単なラムダ抽象とその関数適用, ifによる分岐, プリミティブの演算の実行が可能な処理系を作成します.

 文法は以下のようなものを受け付けます.
exp := const | var | (exp exp ...) | (lambda (var ...) exp) | (if exp exp exp)

interp1の実装は次のようになります.

 環境(変数を表すシンボルとその値のペアからなるリスト)から変数名を探し, それに該当する値を返すのがlookup関数, extend*は, 環境を拡張する関数でインタプリタでは共に定番の補助関数となっています. initial-envは, プリミティブの演算(関数)が含まれている環境. eval1がインタプリタ. interp1は例外の機構を付け加えたインタプリタです(interp2以降では, もう少し複雑な使われ方をします).
 サンプルプログラムとして, 階乗を計算するプログラムとフィボナッチ数を計算するプログラムを作成しました. ループは不動点コンビネータで記述します.
 評価関数は, schemeのmatchマクロの都合上, 最初に(lambda, ifなどの)スペシャルフォームを持ってきて, 次に関数適用, 定数/変数といった順に並べる必要がありました.
 ラムダ抽象を評価した結果の値は, レキシカルクロージャ(ラムダ抽象と環境のペア)です.
 エラーが発生するポイントとしては, 探している変数が見つからないlookup関数(8行目), 間違った関数適用の形式(46行目), 想定されていないプログラムのフォーマット(54行目)などがあります. このようなケースでは, continuationを使って, 脱出します.

 実行結果は, こんな感じです.
gosh> (interp1 factorial-p)
93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000
gosh> (interp1 fib-p)
144
gosh> (interp1 '((lambda (x y) (+ x (* y y))) 7 12))
151

interp2(カリー化)

 基本的に動作(計算結果, 機能など)については, interp1とほぼ同じですが, 内部的に式をカリー化したインタプリタを作成します. interp2では, プログラムとなる式を受け取ると, 内部的にカリー化して, カリー化された式を受け付けるインタプリタによりプログラムを計算します.
 また, これに伴い, プリミティブの関数もカリー化します.
 カリー化が必要なのは, 冒頭の説明にあるshift/resetの評価器がカリー化されたλ式をターゲットプログラムとしているからです.

 interp2の動作とinterp1の動作の違いは, 例えば, 次のプログラムを解釈できるか否かだと言えます.

gosh> (interp2 '((lambda (x) (x 2)) (+ 4)))
6
gosh> (interp1 '((lambda (x) (x 2)) (+ 4)))
4"# error :: malformed lambda"

 interp1では, +関数のカリー化に失敗しています(ラムダ抽象で包み込む必要があります)が, interp2では, その必要がありません (Haskell likeなスタイルになっているようにも見えます).

interp2の実装は以下のとおり.

 実行結果は,前述のケース以外では, interp1と同じです.
 プリミティブ関数をカリー化するcurryマクロとそれに関連するcurry*, curry-primitives-2などのマクロが登場しています. これは, プリミティブの関数fを, (lambda (x) (lambda (y) (f x y)))と書き直すことで, カリー化するマクロです. カリー化されたことで, eval2インタプリタでは, 関数適用が必ず関数と引数のペアになりました(今までは, 関数と引数の割合は一対多でした).
 curry-s-expは, 普通のS式を引数にとって, カリー化されたS式を返します.


interp3(素朴なshift/resetの実装)

 interp2まで完成すると, いよいよ, shift/resetが実装できるようになります. shift/resetの評価器は, 継続渡しスタイルで記述されます.
 この素朴な実装のメリットは, 上記の評価器をそのまま書けば, shift/resetの実装として正しく動いてくれるところです. ただし, matchマクロにあうように, スペシャルフォームから順に実装する必要があります.

ターゲット言語の文法は, 機能を追加したので, 次のようになります.
exp := const | var | (exp exp ...) | (lambda (var ...) exp) | (if exp exp exp)
             | (call/cc (var) exp) | (shift (var) exp) | (reset exp)

interp3の実装はこのようになります.


 normal2->cps2は, 2引数をとるプリミティブの関数を限定継続付きの継続渡しスタイルへ変換するマクロです. add-transform-cps-2で, その処理をすべてのプリミティブ関数に実行します.
 eval3では, インタプリタ上の例外処理をきれいに扱うため, factory関数を作り, eval3をその関数が生成するクロージャとすることで, 評価器の定義をそのまま記述できるようにしました. 基本的に書き方は, 冒頭で書いた定義と(順番が違う以外は, )ほぼ同じです.
 カリー化するプログラム(curry-s-exp)も, 文法の拡張部分について, 修正をほどこします.
 eval3へ最初に渡す継続は, (λx m. x)で, xに式全体の計算結果が渡されるので, それを返すようにします.
 サンプルプログラムとして, factorial-pでcall/ccとshift/resetを使ったものを作成しました.

 interp3の実行結果は次のようになるはずです.
gosh> (interp3 normal-p)
3628801
gosh> (interp3 shift-exception-p)
101
gosh> (interp3 call/cc-exception-p)
"call/cc exception"
 normal-pでは, 例外を返さない範囲内の引数が与えられたので, 普通にfactorialを計算します. shift-exception-pでは, factorial関数に50より上の値が渡されたので限定継続を使って, resetの外側へ脱出しています. 負の値を渡した場合は, 継続によってcall/ccの外へジャンプします.

 紛らわしいのですが, call/ccは, 継続を束縛した変数cを呼び出すことで例外のように式の外側へジャンプしますが, shift/resetは, 限定継続を束縛した変数cを呼び出さないことで式(reset)の外側へ脱出します.

 以上で, メタ循環インタプリタに限定継続(と継続)の機能を実装することができるようになりました.

 この投稿では, 素朴な(お試しの)実装について書きましたが, 本格的な言語に実用的な実装するには, Stackなどによる実装にする必要があります(遅いです).