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で返すというものです.

 例えば, 座標のリスト[p₁ p₂ ... p₈]があるときに互いに衝突していないかを判定するためには, p₁と[p₂ ... p₈], p₂と[p₃ ... p₈], p₃と[p₄ ... p₈]と判定していくため, 上記のような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相当)を定義する話. 

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

Parsing Karva notation in haskell

Karva Notation and K-Expressions

 今日, 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

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

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

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

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

Clojureでダイクストラ法

ダイクストラ法 - Wikipedia

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

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 = aⁿbⁿ, 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

のようにして使います.

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' → "二" | ... | "九"
B₁₀ → A' "十" A | A' "十" | "十" A | A

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

B₁₀₀  → A' "百" B₁₀ | A' "百" | "百" B₁₀ | B₁₀
B₁₀₀₀ → A' "千" B₁₀₀ | A' "千" | "千" B₁₀₀ | B₁₀₀

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

C_m → B₁₀₀₀ "万" B₁₀₀₀ | B₁₀₀₀ "万" | B₁₀₀₀
C_o → B₁₀₀₀ "億" C_m | B₁₀₀₀ "億" | C_m

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

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

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

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

Top   → C_m  | "零"
C_m    → B₁₀₀₀ "万" B₁₀₀₀ | B₁₀₀₀ "万" | B₁₀₀₀
C_o    → B₁₀₀₀ "億" C_m | B₁₀₀₀ "億" | C_m
B₁₀₀₀  → A' "千" B₁₀₀ | A' "千" | "千" B₁₀₀ | B₁₀₀
B₁₀₀  → A' "百" B₁₀ | A' "百" | "百" B₁₀ | B₁₀
B₁₀   → 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関数は, それぞれパラメータを与えて, B_1000, B_100, B₁₀を解析する関数へ変化します. 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#

Clojureで8Queen問題

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

エイト・クイーン(Wikipeida.ja)

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

(x₁ - x₂) = (y₁ - y₂)
(x₁ - x₂) = (y₂ - y₁)

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

 これを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で表示してくれます.

手作業でプログラム運算

• 関数プログラミング入門 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, 間違っていたので一部修正.