先週、2004年ごろには Gauche に KAKAI のライブラリがあったらしいとか書いたけど、sourceforge のページから今でもダウンロードできると shiro さんに教えていただいた。ありがとうございます。（そして、ろくに確認せず適当なことを書いていてすみません。）

しかもインストールしたら使えた。

(use text.kakasi)
(kakasi-begin :JH :p)
(display (kakasi-convert "素子"))
(newline)
(kakasi-end)

これを kakasi-trial.scm とすると、

$ gosh -V
Gauche scheme interpreter, version 0.8.10 [utf-8,pthreads]
$ gosh kakasi-trial.scm
{もとこ|そし}

［2010年6月3日 追記］改良版はこちら

emacs で、検索パターンをその後の編集中ずっとハイライトにしたい。インクリメンタルサーチの結果でもハイライトされるけど、あれだと編集をはじめるとハイライトが解除されてしまうので、使えない。
具体的には、作業中のバッファであるパターンを一時的にハイライトして、それを確認しながらを作業するための方法がほしい。こんな具合。



この例は、 ja タグで囲まれた部分をハイライトするようにしたところ。普段はハイライト不要なんだけど、たとえば「 ja にも en にも出てくる語を検索して周辺の文章を編集したいんだけど en 内にあるほうは無視してもいいや」といった作業に便利じゃない？

で、とりあえず作ってみた関数。

;;; let designated pattern be highlight
(defun highlight-regexp (re)
  (interactive "sRegexp: \n")
  (make-face 'my-highlight-face)
  (set-face-foreground 'my-highlight-face "black")
  (set-face-background 'my-highlight-face "yellow")
  (defvar my-highlight-face 'my-highlight-face)
  (setq font-lock-keywords (list (list re 0 my-highlight-face t)))
  (font-lock-fontify-buffer))

M-x highlight-regexp すると正規表現の入力を促されるので、そこで適切なパターンを指定すると、上の例のようにハイライトされる。そういえば解除するときのことは考えてなかった。あと、上の例ではなんとなく改行をまたいだマッチに成功してるけど、emacs の正規表現である以上、改行をまたいだパターンのマッチは期待通りにいかないと覚悟すべき。やっぱりこのエディタは、本当のところは文章のパワー編集には向かないんじゃないだろうか。

まあ問題はあるけど、ここまではよかった。

実はいま c さんに、「xyzzy で同じことがしたい」と脅されている。xyzzy は普段使ってないから、色の付け方とかわからんのですよ……。
Windows なら EmEditorとかで GUI のメニューから同じようなことができるから、とりあえずそっちでいいんじゃないかなあ。だめ？

昨日、Gauche には KAKAI のライブラリとかないとか書いたけど、2004年ごろにはあったらしい。

cさんに「索引の読み仮名をひらがなで明示的に指定するのは前時代すぎてあほみたいだ。休み明けまでに何とかしとけ」と恫喝されたので、彼女が休みのあいだに急いで対策することにした。

まあ、実際の cさんはそんなひどい言い方をする人ではなく、ちょうかわいいんだけど、たしかに LaTeX ベースで本を作っていると索引のふりがな入力がうっとうしい。労力の問題だけでなく、原稿にひらがなが氾濫して読みにくくなるという意味でもうっとうしい。

漢字かな変換にはKAKASIを使うのが常套なんだろうな。Gauche には Ruby とちがって KAKASI のライブラリはないけれど、ほとんどジョーカーみたいな c-wrapper がある。
これで libkakasi.h に宣言されているCの関数が Gauche から使える。

(use gauche.charconv)
(use c-wrapper)
(c-load-library "/usr/lib/libkakasi.so.2.1.0")
(c-include "/usr/include/libkakasi.h")

(define (kanji->hira str)
  (let ((base-ces "utf-8")
        (kakasi-ces "iso2022jp"))
    (kakasi_getopt_argv 3 '("kakasi" "-JH" "-p"))
    (ces-convert
      (x->string (kakasi_do (ces-convert str base-ces kakasi-ces)))
      kakasi-ces base-ces)))

KAKASIがUTF-8を扱えないのが厄介だけど、それ以外はとても素直に Gauche で漢字かな変換ができる。

gosh> (kanji->hira "素子")
{もとこ|そし}

さて、この「素子」のようにユニークな読みを決定できない項目があると困っちゃうんだけど、「もとこ」か「そし」かの判断を機械的にすべきではなさそうだ
（「この素子を開発したのは素子さんです」問題）。だから、こういうのだけは人力であらかじめ指定しておくのが最適な対応だと思うのですが、それでかまわないでしょうか？＞ cさん
こんなふうにマークアップ原稿がLaTeXへと変換されるようにします。

<p>
  この素子を開発したのは素子さんです。
    <indexterm><i1 sortas="そし">素子<i2>開発者</i2></i1></indexterm>
    <indexterm><i1 sortas="もとこ">素子</i1></indexterm>
    <indexterm><i1>開発者</i1></indexterm>
</p>

↓

この素子を開発したのは素子さんです。\index{そし@素子!かいはつしゃ@開発者}\index{もとこ@素子}\index{かいはつしゃ@開発者}

---

参考：
今日の一行::ひらかなのインデックス の cut-sea さんの解
ごとけんさんの ruby-kakasi の kakasi.c

もう、PostScriptでフィボナッチ数列くらいなら昼休みにコーヒー飲みながらでも考えられる。

/fib {0 1 2 index -1 1 {pop exch 1 index add} for} def

ただ、せっかく PostScript なので、結果を印刷とかもしたい。印刷には show オペレータを使うわけだけど、show は文字列（string）しかとれない。fib オペレータが返すのは数値（integer）なので、文字列の型に変換する必要がある。

PostScript で型を文字列に変換するには、=string cvs とすればいいようだ。

%!
/fib {0 1 2 index -1 1 {pop exch 1 index add} for} def
/Palatino-Linotype findfont 300 scalefont setfont
10 10 moveto
11 fib == =string cvs show

これでページの左下に大きく「89」と印刷される。やっぱりPalatinoフォントの数字は美しい。



さらにグラフなど描いてみる。

%!
/fib {0 1 2 index -1 1 {pop exch 1 index add} for} def
20 setlinewidth

1 1 21 { % for
    /i exch def
    /x 27 i mul def

    0 setgray
    /Palatino-Linotype findfont 10 scalefont setfont
    10 x 5 sub exch moveto
    i fib == =string cvs show

    /r {rand i mod 21 div} def
    r r r setrgbcolor
    newpath
        x 30 moveto
        i fib == 10 div 30 add x exch lineto
        stroke
} for

showpage

PostScript で階乗のつづき。こんどは for 文で。

/func {1 exch -1 1 {mul} for} def

ようするに、自分がしたい操作に必要な変数が、適切な数だけ適切な順番でスタックに積まれているようにすればいいらしい。そしてスタックというやつからは、直前に積んだものだけを取り出すことができる。

たとえば上記で定義した階乗のオペランド func を以下のように呼び出すと、

GS> 5 func

まず 5 がスタックに積まれる。この 5 は「funcへの引数」のつもりなんだけど、スタックから見るとそんなつもりはなくて、ただ値が積まれただけ。次は func を積むんだけど、func は上記のように定義されているので、その定義の一番最初にある 1 がスタックに積まれる。この時点のスタックの状態はこんな感じ。

 1 
---
 5 

func の定義によれば、次は exch だ。これは、それまでスタックの1番上にあった要素とその下の要素を入れ替える。つまり、スタックの状態はこうなる。

 5
---
 1

さらに -1 と 1 を順番に積んで、スタックの状態はこうなる。

 1 
---
-1
---
 5
---
 1

ここで、本文が mul だけの for が登場する。for というオペレータは、スタックの値を 3つ消費し、それぞれの値を深いほうから順番に「繰り返しの最初」「繰り返しの更新」「繰り返しの終わり」として本文を繰り返す。ただし毎回の繰り返しでは、スタックの先頭に、そのターンにおける変数のようなものが積まれる。こう書くと複雑だけど、ようは最初に本文を実行するときには「5」が、2回目は「4」が、...、5回目は「1」がスタックの先頭に積まれるということ。つまり1回目の繰り返しのとき、スタックの状態はこう。

 5
---
 1

本文の mul は、このスタックから値を 2つ取り出して、それらの積をあらためてスタックに積む。したがってスタックの状態は、

5

2回目の繰り返しに際してスタックの先頭に「4」が積まれる。

 4 
---
 5

このスタックで mul を適用すると、

 20

3回目の繰り返しに際してスタックの先頭に「3」が積まれる。

 3 
---
 20

mul を適用して

 60

4回目の繰り返しに際してスタックの先頭に「2」が積まれる。

 2 
---
 60

mul を適用して

120

5回目の繰り返しに際してスタックの先頭に「1」が積まれる。

 1 
---
120

mul を適用して

120

おしまい。こうして最後のスタックの値を取り出せば（そのためには == を使う）、5の階乗の値が得られる。

たぶん用語の使い方はいいかげん。はやく教科書こないかな。

PostScript が意外におもしろいので真剣に勉強してみようと思う。教科書は、Web で PDF が全部公開されている "Thinking in PostScript" に決めた。書籍はもうとっくに絶版らしい。でも物理的な本が手もとにないとつらいんだよなあ。Amazon マーケットプレイスにも出品されているけどバカみたいに高額なので（6000円以上）、US の同様のサービスに注文した（600円くらい）。まだ届かない。出荷された気配もない。もう待ちきれないよう。

というわけで、試行錯誤しながら階乗を考えてみた。

 /func {dup 1 eq {1 mul} {dup 1 sub func mul} ifelse} def

実行結果。

GS> 10 func ==
3628800
GS> 20 func ==
2.43290202e+18
GS> 100 func ==
inf.0

どうやら再帰的なオペレータの定義ができるらしい。はじめは、ふつうに for を使って解こうとしたんだけど、わかりませんでした。

ところで Emacs の ps-mode は GS のビューワーと連動して出力結果がリアルタイムで見られてすごい。便利すぎ。ただしお絵描きを始めると日付が変わるようだ。

Schemeの多値の正体は継続

SICPでは「多値」を表立って使うことはない。ただ、5.2.2で2種類のリストをやりとりするときに2変数のプロシージャを使った一見するとトリッキーな処理が登場して、これが実は多値なんだよという種明かしを脚注4でやっている。さらに、そのトリッキーな2変数プロシージャのことを継続（continuation）と呼ぶと説明している。

多値も継続だったのか。

噛みしめるために小さな例を考えてみた。つぎのプロシージャ one は、プロシージャ sincos が返す 2 値を受け取り、その 2 乗和を返す。sincos は引数の角度に対する sin の値と cos の値を返すので、プロシージャ one は引数にどんな数値を指定しても実数の 1 を返す。

(define (one rad)
  (receive (sin cos)
      (sincos rad)
    (+ (* sin sin) (* cos cos))))

(define (sincos rad)
  (values
    (sin rad) (cos rad)))

このプロシージャ one は、values や receive という組み込みの多値のしくみを使わなくても、つぎのように継続を表すプロシージャ cont を使って多値を模倣できる。

(define (one rad)
  (sincos
    rad
    (lambda (sine cosine)
      (+ (* sine sine) (* cosine cosine)))))

(define (sincos rad cont)
  (cont (sin rad) (cos rad)))

いちおう実行結果。

gosh>(one 123456)
1.0
gosh>(one -9876)
1.0

まとめ

計算の一部または全部をどうにかしたい場合があって（よその関数に渡したいとか、ちょっと保留しておきたいとか）、そのときの定石は「プロシージャでくるんでしまえ」。で、そういうプロシージャのことを「継続」（continuation）と呼ぶ。

ついやってしまった。

Functional Programming IAT
関数型指数（潜在的な関数型プログラミングの嗜好度）をはかる IAT
http://dame.dyndns.org/misc/fpiat/


「あなたの関数型指数は 0.62331761674765 です。正が関数型、負が手続き型です。」

でも、設問では"Lisp"（Schemeではない）が関数型言語とされているんだけど、それはどうなの？

練習問題を放置したままだったSICPの第5章をぽちぽち再開。こうやって再読してみると、すっかりどんな話だったか忘れてる。やっぱり手を動かさないで本を読んでいるだけじゃなんにも身につかない。編集という、まさに読んでいるだけの職業に自分が従事している現実を呪うのはこういう瞬間だ。ただの逆ギレだけど。

というわけで第5章の練習問題に着手しはじめた。ところがすぐに困っちゃったのは、この章の内容がGauche（などのSchemeインタプリタ）で式を実行すれば確かめられる話じゃないこと。とくに5.2節でレジスタマシンのシミュレータをSchemeで作るまでは、紙と鉛筆でデータの流れを図示したりしながら、脳内レジスタマシンを妄想して読み進めるしかない。「レジスタマシンの動作を手でシミュレートしろ」といった問題を考えるのは楽しいんだけど、どうにも「わかった気になっているだけかも」という懸念がぬぐえないのが気持ち悪い。どうでもいいけど、専門書や専門雑誌の編集者を楽しく長く続けていくのに求められる最強のスキルは、「わかった気になったところで留まっていられる」ことだとおもう。前々から気がついてはいたけれど、最近になってひどく実感するようになった。こういう感情をわざわざ書きとめているということは、そういうことだ。ここまでどうでもいい話。

この気持ち悪さはレジスタマシンがあれば解決する。かといって5.2節でシミュレータを作るまで待ってられないし（経験上、1問でも練習問題をぬかすと最後まで練習問題に手をつけずに読了する。帰納法で証明できたらかっこいいかもね）、そもそもSchemeでシミュレートするっていうのも気持ちが悪い。最初にこの章を読んだときは「これは教科書として画期的なアイデアだ」と思ったけど、実際はめんどくささのランクをひとつ繰り上げているだけなような気もする。

アセンブリというわけにもいかないので、Cで書いてみることにした。たとえばフィボナッチ数列の第n項を求めるレジスタマシンのコントローラ（原書512ページのFigure5.12）。

/* Implementation of a recursive fibonachi machine in C.
   (Figure 5.12 of "SICP")
   2007/6/17
   k16.shikano@gmail.com
*/ 

#include <stdio.h>
#include <stdlib.h>
#define STACKSIZE 100

void fibloop();
void afterfib1();
void afterfib2();
void fibdone();
void immediate();
void rtc(int);

void initstack();
void save(int);
int restore();

int cont = 0;
int val;
int n;

main(int argc, char *argv[])
{ 
  initstack();
  n = atol(argv[1]);

  fibloop();
}

void fibloop()
{
  while(n >= 2)
    {
      save(cont);
      cont = 1;
      save(n);
      n = n - 1;
    }
  immediate();
}  

void afterfib1()
{
  n = restore();
  cont = restore();
  n = n - 2;
  save(cont);
  cont = 2;
  save(val);
  fibloop();
}

void afterfib2()
{
  n = val;
  val = restore();
  cont = restore();
  val = val + n;
  rtc(cont);
}

void immediate()
{
  val = n;
  rtc(cont);
}

void fibdone()
{
  printf("answer = %d\n", val);
  exit(1);
}


/* return to continue */
void rtc(int c)
{
  switch(c)
    {
    case 0: fibdone();
    case 1: afterfib1();
    case 2: afterfib2();
    }
}


/* naive stack implementation */
int stack[STACKSIZE];
int *pstack;
int *pinit;

void initstack()
{
  pstack=stack;
  pinit=pstack;
}

void save(int val)
{
  if (pstack > pinit+STACKSIZE){
    perror("Reached Stack End");
    exit(1);
  }

  *pstack=val;
  ++pstack;
}

int restore()
{
  if (pstack == pinit){
    perror("Reached Stack Head");
    exit(1);
  }

  --pstack;
  return *pstack;
}

スタックの機能をでっちあげて、Figure5.12にあるSchemeっぽい式をもじどおりCに置き換えただけ。コンパイルして実行すると（想定内のセグメンテーション違反はおこすけど）あっさりうごく。

k16@debian:~/play $ ./fib 24
answer = 46368
k16@debian:~/play $ ./fib 25
セグメンテーション違反です

これは、Cでフィボナッチを書きました、という話ではなく、これまでSchemeというレイヤでプログラミングしているときに再帰関数だと思っていたコレが、

(define (fib n)
        (if (< n 2)
            n
            (+ (fib (- n 1)) (fib (- n 2)))))

その下のレイヤでは上記のCのコードのようなレジスタへの代入とスタックへの出し入れだけの形（現代のコンピュータがかろうじて完璧に扱える形）に解くほぐせて、しかも動く、という話なんだよね。プログラミング言語っていうのは、もしかして、ここで手動で試してみたコードからコードへの変換みたいな処理を自動的に行うしくみのことなのか？

なんだかこの本を読みはじめたときのようなわくわく感が。

地球の裏側までトンネルを掘ってボールを落としたらどうなるかという話題になった。空気がなくて、他の天体の重力の影響を無視できて、トンネルが地球の重心を通る直線で、トンネルの壁が重力によって押しつぶされなくて、なんかほかにもいろいろ条件を満たすなら、ボールは反対側の地表付近まで届く。トンネルの途中でぴたっと止まっちゃうことはない。力学は昔も今もさっぱり自信がないんだけど、その理由を文章で説明するとしたらこんな感じになると思う。

ボールはトンネルの真ん中まで落ちるあいだ、つねに一定の加速度で移動する。
つまり、どんどん速度が増える。
トンネルの真ん中付近を突っ切るときが最速で、そこから先は正反対の向きの加速度で移動する。
つまり、だんだんゆっくりになる。
そのうち前半の行程で得たエネルギーを使い果たし、反対側の地表付近で一瞬静止して、今度はもときた方向へ落ちていく。
以下繰り返し。

で、こういう問題を考えるときは「地球の中心に全質量が集中している」と見たてることになっているわけだけど、その理由を説明するのがむずい。この場合の「見たて」は、たとえば数学で「0.99999… = 1」とか規定するのと違って、そう考えると議論に都合がいいからという性質だけのものじゃなく、もっと本質的な話だったはず（もちろん、どんな理学的な説明だって「そのほうが都合がいいから」って言い方はできるんだろうけど……）。で、昼休みにWikipediaを見てみたら、あっさり証明がのっていた。（読んではいない）

Shell theorem
http://en.wikipedia.org/wiki/Newton%27s_sphere_theorem

もしボールがトンネルを移動している最中に球に地球が真っ二つに割れたら？という話も出たけど、それまでにボールが得ている運動エネルギーと変化した周囲の重力から得るエネルギーとが均衡するように動くとしか……（実際には地球を真っ二つに割ることになった外因からのエネルギーがいちばん大きく影響するんじゃない？）

パズル「グリッド色分け問題」少し改良版

「組合せ最適化」をぱらぱらめくったけど安直な方法が見つけられなかったので、オクトーバーフェストに行ってビールをのみながらほげほげ考えていたら、行ごとに組み合わせを求めつつ枝刈りして、それを枝刈りしながら列に集めれば、ずいぶんメモリを省略できるはずだと思いついた。実際これはうまくいって、4x4程度なら瞬時に計算できる。

たとえば10番目に得られた結果。10番目であることに特に意味はない。

(use srfi-1)
(use util.stream)

(define (line-colorings width colors pred)
  (cond ((= 1 width)
         (apply stream (zip (iota colors colors -1))))
        ((= 0 colors)
         stream-null)
        (else
         (let R ((top colors))
           (if (= 0 top)
               stream-null
               (stream-append
                (stream-filter
                 pred
                 (stream-map (cut cons top <>)
                             (line-colorings (- width 1) colors pred)))
                (R (- top 1))))))))

;; (stream of lists) -> (stream of lists)
(define (grid-colorings hight rows patterns pred)
  (cond ((= 1 hight)
         patterns)
        ((stream-null? patterns)
         stream-null)
        (else
         (let R ((top (stream-car patterns))
                 (rest (stream-cdr patterns)))
           (stream-append
            (stream-filter
             pred
             (stream-map (cut append top <>)
                         (grid-colorings (- hight 1) rows patterns pred)))
            (if (stream-null? rest)
                stream-null
                (R (stream-car rest) (stream-cdr rest))))))))

(define (tiles lines rows colors)
  (stream-filter 
   (cut egalite? <> (quotient (* lines rows) colors) colors)
   (grid-colorings lines rows 
     (line-colorings rows colors 
       (cut stripe? <>))
     (cut staggered? <> rows))))


;;;; predicates
; Doesn't the list contain adjacent cells with same color?
(define (stripe? ls)
  (cond ((null? ls)
         #t)
        ((null? (cdr ls))
         #t)
        (else
         (let ((v (car ls))
               (w (cadr ls)))
           (and (not (= v w))
                (stripe? (cdr ls)))))))

; Doesn't the list contain vertically adjucent cells with same color?
(define (staggered? ls rows)
  (let R ((rows (transpose ls rows)))
    (if (null? rows)
        #t
        (and (stripe? (car rows))
             (R (cdr rows))))))

; Does each color appear at least n times?
(define (egalite? ls n c)
  (let R ((c c) (ls ls))
    (cond ((= c 0) #t)
          ((< (length ls) n) #f)
          (else
           (receive (the-colors rest)
               (partition (cut = c <>) ls)
             (and (>= (length the-colors) n)
                  (R (- c 1) rest)))))))



;;;; some list utils
(define (group ls n)
  (receive (front end)
      (split-at ls n)
    (if (null? end)
        (list ls)
        (cons front (group end n)))))
(define (transpose ls rows)
  (apply zip (group ls rows)))

パズル「グリッド色分け問題」をSchemeで解く

自宅のトイレにはディック・ブルーナのポスターがもう何年も張ってある。全体がグリッドに仕切られていて、そのひとつひとつに彼の代表作から抜き出した絵が並べられてるんだけど、そのうちの1枚に描かれているテーブルクロスの柄が気になってしょうがない。



どうしてこのテーブルクロスは、きちんと格子が塗り分けられていないんだろう。左下で青いマスが横に並んじゃっているのがどうにも気持ち悪い。行列の成分でいうと33と34の2つ。もしスプーンがおかれてなかったら境界が識別できないじゃないか。4x4のグリッドを3色で塗り分けるパターンなんていくらもあるだろうに。

というわけでパターンを求めてみる。

戦略は、まず塗り分けのパターンをすべて求めて（つまり隣同士が同じ色に塗られるパターンを含む）、そのうちで3色をちゃんと使ってうまく塗り分けられているものを取り出す。

「3色をちゃんと使ってうまく塗り分けられている」はどう評価しよう？　
とりあえず、どの色も少なくとも5回（16÷3）は使われていて、隣同士が違う色になっていればよしとしよう。（デザイン上のよしあしを評価するとしたら何を考えたらいい？）

4x4のグリッドを塗り分けるパターンは、長さ16のリストであらわすことにする。使う色は1,2,3という数値で表す。つまり、リストの各要素には、各マスの色を意味する1,2,3のいずれかの数値がはいる。これをグリッドの左上→右下という順番で並べる。たとえば以下のような塗り分けは、(1 3 2 3 3 2 1 2 1 3 2 1 3 2 1 3) というリストであらわすことにする。（ 1：青、2：オレンジ、3：緑）



隣同士が別の色で塗り分けられているかどうかは、ベタに縦横の関係を調べる patch? というプロシージャを定義して、それで済ませることにする。

(define (stripe? ls)
  (cond ((null? ls)
         #t)
        ((null? (cdr ls))
         #t)
        (else
         (let ((v (car ls))
               (w (cadr ls)))
           (and (not (= v w))
                (stripe? (cdr ls)))))))
(define (patch? ls n m)
  (and (let L ((lines (group ls n)))
         (if (null? lines)
             #t
             (and (stripe? (car lines))
                  (L (cdr lines)))))
       (let R ((rows (transpose ls n)))
         (if (null? rows)
             #t
             (and (stripe? (car rows))
                  (R (cdr rows)))))))

ところでgroupとtransposeは、いつも使いたいときに一瞬探すんだけど見つからなくて、そのたびに下手な実装をしてる気がする。今回はこんなんで。

(define (group ls n)
  (receive (front end)
      (split-at ls n)
    (if (null? end)
        (list ls)
        (cons front (group end n)))))
(define (transpose ls rows)
  (apply zip (group ls rows)))

塗り分けパターンをすべて求めるにはどうしたらいいか。

たとえば、3つのマスを3色で塗り分けるやり方をすべて求めることを考えてみよう。以下のようなマスA,B,Cを緑黒赤の3色で塗り分けるパターンをすべて求めたい。

A

B

C

いま、都合よく R という関数があって、これを使うと2マスを3色で塗り分けパターンが全部求められるとしよう。R を使えば、以下の 3つの結果をよせ集めることで、3マスの塗り分けパターンを求めることができる。

1. Aを緑に塗って、BとCは R に従って塗り分ける全パターン
2. Aを黒に塗って、BとCは R に従って塗り分ける全パターン
3. Aを赤に塗って、BとCは R に従って塗り分ける全パターン

ようするに、うしろの塗り分け方さえ全部求まってれば、先頭の色だけとっかえひっかえした結果をよせ集めることで、全体の塗り分けがすべて得られる。



このアイデアをストリームを使ってダイレクトにコードにするとこんな感じ。Scheme だと簡単すぎ。

(use srfi-1)
(use util.stream)

(define (gen-colorings width colors)
  (cond ((= 1 width)
         (apply stream (zip (iota colors colors -1))))
        ((= 0 colors)
         stream-null)
        (else
         (let R ((top colors))
           (if (= 0 top)
               stream-null
               (stream-append
                 (stream-map (cut cons top <>)
                             (gen-colorings (- width 1) colors))
                 (R (- top 1))))))))

あとは、先に定義した patch? を使ってストリームをフィルタリングすればいい。どの色もだいたい平等に塗られているかどうかを調べるプロシージャ egalite? も定義しておいて、ここであわせてフィルタリングする。

(define (tiles n m c)
  (stream-filter 
   (lambda (tone)
     (and 
      (egalite? tone n c) 
      (patch? tone n m))
   (gen-colorings (* n m) c)))

(define (egalite? ls n c)
  (let R ((c c) (ls ls))
    (cond ((= c 0) #t)
          ((< (length ls) n) #f)
          (else
           (receive (the-colors rest)
               (partition (cut = c <>) ls)
             (and (>= (length the-colors) n)
                  (R (- c 1) rest)))))))

これで (tiles 4 4 3) とかって実行すれば、塗り分けパターンを順次計算してくれるストリームが帰ってくる。はずなんだけど、実際には組み合わせが爆発しちゃう。16マスを3色に塗り分けようと思ったら 3¹⁶ = 43,046,721 のパターンがありうるわけで、すべての塗り分けパターンからなるリストを作ったりすると巨大なリストになって身動きが取れなくなると思ってストリームを使ってみたんだけど、どのみち4x4=16マスの3色塗り分けを全部求めるのは無理だったもよう。
しかたがないので、問題を1行小さくして 3x4 の横長のテーブルクロスの3色塗り分けを求めてお茶を濁すことにした。

gosh> (define s (tiles 4 3 3))
s
gosh> (stream->ref s 1)
(3 2 1 3 2 1 3 2 1 2 1 3)
gosh> (stream-ref s 2)
(3 2 1 3 2 1 2 1 3 2 1 3)
gosh> (stream-ref s 3)
(3 2 1 2 1 3 2 1 3 2 1 3)
gosh> 

最初に得られる結果を先の色定義（ 1：青、2：オレンジ、3：緑）で塗り分けると、こうなる。



ついでに、このHTMLテーブルを描くのにでっちあげた補助関数。

(define (tile->html tile rownum)
  (define (num->color n)
    (cond
     ((= 1 n) "blue")
     ((= 2 n) "orange")
     ((= 3 n) "green")
     (else    "black")
     ))
  (define (line->str line)
    (string-append 
     "<tr>\n  "
     (apply string-append 
       (map (lambda (cell)
              (string-append "<td style=\"background-color:" 
            (num->color cell) 
       "\"><div style=\"width:1em\">&nbsp;</div></td>"))
                               line))
     "\n</tr>\n"))
  (define (lines->str lines)
    (string-append "<table>\n" 
                   (apply string-append (map (cut line->str <>) lines))
                   "</table>\n"))
  (lines->str (group tile rownum)))

しかし、tilesの引数は順番を逆にするべきだったな。行と列がいれかわってて紛らわしいことこのうえない。

XMLっぽい構造をパースする

指定した範囲の内側でだけ、テキストのパターン置換をしたい。つまり、こういうことがしたい。

gosh> str
"<title>
  <en>Introduction</en>
  <ja>は じ め に</ja>
</title>
<p>
  <en>
    Here we'll discuss about english
      <footnote>
        <p class="footnote">
          Or, any language you speak as a native tongue.
        </p>
      </footnote>
    .
  </en>
  <ja>
    ここでは日本語
      <footnote>
        <p class="footnote">
          で な く て も、母 国 語 な ら な ん で も い い。
        </p>
      </footnote>
    について説明しよう。
  </ja>
</p>"

gosh> (regexp-replace-all-among-all 'ja #/\b\s\b/ str "")
"<title>
  <en>Introduction</en>
  <ja>はじめに</ja>
</title>
<p>
  <en>
    Here we'll discuss about english
      <footnote>
        <p class="footnote">
          Or, any language you speak as a native tongue.
        </p>
      </footnote>
    .
  </en>
  <ja>
    ここでは日本語
      <footnote>
        <p class="footnote">
          でなくても、母国語ならなんでもいい。
        </p>
      </footnote>
    について説明しよう。
  </ja>
</p>"

先日のような邪道な試行錯誤をしたり、再帰下降パーザについて少し勉強したりした結果、地道にパーズするのがいちばんだということがよく分かった。PerlやJaveなら優れたXML処理のライブラリを使うべきなのかもしれないね。

置換をほどこしたい領域（上の例では<ja>...</ja>の部分）を取り出すことから考えよう。その前に、XMLっぽいテキストを構成するパーツを先頭から順番に取り出してくれるプロシージャ read-xml があると仮定する。read-xml を一回呼ぶと、「<title>」や「<p class="footnote">」のようなタグ、もしくは、タグの前後の本文を、テキストの先頭から順番にゲットできる。こんな感じ。

(with-input-from-string "aaa<p>bbb</p>ccc"
  (lambda ()
    (read-xml) ; ⇒ aaa
    (read-xml) ; ⇒ <p>
    (read-xml) ; ⇒ bbb
    (read-xml) ; ⇒ </p>
    (read-xml) ; ⇒ ccc
  ))

この read-xml でひとつずつパーツを取り出してチェックしていく。探している領域を開始するタグ（いまの例では<ja>）が取り出せたら、終了を表すタグ（いまの例では</ja>）が現れるまで次々にパーツをつないでいくことで、ほしい領域が取り出せる。領域がネストしている可能性もあるので、開始タグの数もチェックしておくようにする。ざっくり書くとこんな感じ。利便性を考えて、領域の前後の文字列も返すようにした。

(define (xml-maximal-region tagname)
  (define (xmltag? e)
    (and (> (string-length e) 1)
         (char=? #\< (string-ref e 0))))
  (define (tag->name e)
      (string-trim-right
       (x->string (string-drop e 1))
       #\>))
  (define (start-tag? e)
    (and (xmltag? e)
         (equal? (x->string tagname)
                 (tag->name e))))
  (define (end-tag? e)
    (and (xmltag? e)
         (equal? (x->string tagname)
                 (string-drop (tag->name e) 1))))
  (define (rest-xml)
    (let R ((next (read-xml)))
      (if (string-null? next)
          ""
          (string-append next (R (read-xml))))))
  (define (in-region e body c before)
    (cond ((string-null? e)
           (error "Premature end of input -- GET-XMLTAGGED-MAXIMAL-REGION"))
          ((end-tag? e)
           (if (= 0 c)
               (values before (string-append body e) (rest-xml))
               (in-region (read-xml) (string-append body e) (- c 1) before)))
          ((start-tag? e)
           (in-region (read-xml) (string-append body e) (+ c 1) before))
          (else
           (in-region (read-xml) (string-append body e) c before))))
  (define (out-region e body before)
    (cond ((string-null? e)
           (values before "" ""))
          ((start-tag? e)
           (in-region (read-xml) e 0 before))
          (else
           (out-region (read-xml) body (string-append before e)))))
  (out-region (read-xml) "" ""))

この xml-maximal-region を使えば、求めるプロシージャ regexp-replace-all-among-all が簡単に定義できる。

(define (regexp-replace-all-among-all region-declaration rx str sub)
  (with-input-from-string str
    (lambda ()
      (receive (before region after)
           (xml-maximal-region region-declaration)
        (string-append before
                       (regexp-replace-all rx region sub)
                       (if (string-null? after)
                           after
                           (regexp-replace-all-among-all region-declaration rx after sub)))))))

あとは read-xml を書けばいい。むずかしいところはないけど面倒。長いので、全体とあわせて下記を参照。

replace-among.scm


References

---

「なんでも再帰」Shiro Kawai（2003/1）
http://www.shiro.dreamhost.com/scheme/docs/tailcall-j.html

『Perl & XML』：Erik T. Ray,Jason McIntosh（2002/11）
http://www.amazon.co.jp/dp/4873111064

二分木が描きたい。

Scheme を使っていると木を使うことが多い（Scheme に限らないけど）。教科書なんかには整形された木の絵がよく出てくるけど。あれはみんなどうやって描いているんだろう。きっと PostScript のコマンドを生成したりして描いているに違いない。そこで、再帰下降パーザの例としてありがちな四則演算を表す木を描くのに挑戦してみた。

arithmetic-culc-tree.scm

$ gosh arithmetic-culc-tree -tree ps
1*2+3*((4+5)-7)/(8+9)
%!
<< /PageSize [460.0 350.0] >> setpagedevice
newpath
175.0 297.0 moveto
85.0 270.0 lineto
175.0 297.0 moveto
265.0 270.0 lineto
...(以下略)

convert で png に変換した結果。

もうちょっと見ための改善の余地がありそうだけどもうつかれた。

Gaucheの単体テストで、副作用により標準出力に書き出す処理（displayとか）の動作をテストしたい。つまり、こんな単体テストをしたい。

(test* "display test"
       "foobar string"
       (display "foobar string"))

もちろんこれは失敗する。関数 test は equal? で第2引数と第3引数を比較するだけだから。オプション引数を与えて比較に使うプロシージャを変更することもできるけど、そもそも上記のような display のテストでは第3引数を評価した値が # でしかないので、テストの意味をなさない。

display の動作を脳内シミュレートすると、こんなふうに出力ポートを曲げればうまくいきそう。

(test* "display test"
       "foobar string"
       (with-output-to-string (lambda () (display "foobar string"))))

どうやらうまくいく。あとはこんなマクロをでっちあげておけばうれしい。

(define-syntax test-with-output*
  (syntax-rules ()
    ((_ e1 e2 e3)
     (test* e1 e2 (with-output-to-string (lambda () e3))))
    ((_ e1 e2 e3 e4)
     (test* e1 e2 (with-output-to-string (lambda () e3)) e4))))

結果。

gosh >(test-with-output* "display test"
                   "foobar string"
                   (display "foobar string"))
test global conversion 2, expects "foobar string" ==> ok
#<undef>

文字列を螺旋にそって描く。これに似ているけど、もっと単純に、ASCIIのみからなる文字列を同心円状の渦巻に沿って出力する。交差はさせない。(できない)

howm wiki - spiral.el
http://howm.sourceforge.jp/cgi-bin/hiki/hiki.cgi?SpiralDotEl

昨日定義した関数たちを改良して、

• 螺旋のパラメータを指定できるようにする
• state の列に真偽値ではなく各文字を対応させる（同じ座標の state を飛ばす処理も必要）

ようにする。

;; num -> direction -> type -> [state]
(define (make-spiral-states length start-x start-y start-direction l-or-r)
  (define (make-spiral-series total)
    (let* ((most (floor (/ (- (sqrt (+ 1 (* 8 (- total 1)))) 1) 2)))
           (lmost (iota (- most 1) 2 1))
           (rest (- total (fold + 1 lmost))))
      (append (list 2) lmost (if (zero? rest) '() (list rest)))))
  (let ((series (make-spiral-series length))
        (init-state (make-state start-x start-y start-direction))
        (turn (if (equal? l-or-r 'left) turn-left turn-right)))
    (scanf init-state (concatenate (map (lambda (n) (append (keep-moving n) (list turn))) series)))))

;; [state] -> [codes]
(define (normalize states)
  (let R ((ps '()) (codes (map car states)))
    (cond ((null? codes)
           ps)
          ((member (car codes) ps)
           (R ps (cdr codes)))
          (else
           (R (cons (car codes) ps) (cdr codes))))))

;; [codes] -> [state]
(define (stick-char codes chars)
  (map (cut list <> <>) codes chars))

;; [state] -> [[char]]
(define (bitmap ps)
  (define (range xs)
    (list-ec (: i (apply min xs) (+ (apply max xs) 1)) i))
  (define (corresponding-char code ps)
    (cond ((null? ps) " ")
          ((equal? code (caar ps)) (cadar ps))
          (else (corresponding-char code (cdr ps)))))
  (let ((codes (map car ps)))
    (list-ec (: x (range (map car codes)))
             (list-ec (: y (range (map cadr codes)))
                      (corresponding-char (list x y) ps)))))

;; [[char]] -> string
(define (picture bitmap)
  (string-join 
   (map (lambda (line) (string-join (map x->string line) "" 'strict-infix)) 
        bitmap)
   "\n" 'strict-infix))


(define (display-spiral string)
  (let ((length (string-length string)))
    (display 
     (picture
      (bitmap
       (stick-char
        (normalize (make-spiral-states length 0 0 2 'left))
        (string->list (string-join (string-split string #[\s]) "+" 'strict-infix))))))
    (newline)
    (values)))

実行例（サンプルの文字列は Gauche のトップページから引用）

gosh> (display-spiral "Gauche is an R5RS Scheme implementation developed to be a handy script interpreter,
which allows programmers and system administrators to write small to large scripts for their daily chores.
Quick startup, built-in system interface, native multilingual support are some of my goals.")

                Gauche+
                      i
nterpreter,+which+all s
i                   o +
+ all+to+large+scri w a
t m               p s n
p s ,+built-in+sy t + +
i + p           s s p R
r e u ingual+su t + r 5
c t t l       p e f o R
s i r i +my+g p m o g S
+ r a t f   o o + r r +
y w t l o   a r i + a S
d + s u + .sl t n t m c
n o + m e     + t h m h
a t k + mos+era e e e e
h + c e         r i r m
+ s i vitan+,ecaf r s e
a r u             + + +
+ o Q+.serohc+yliad a i
e t                 n m
b artsinimda+metsys+d p
+                     l
ot+depoleved+noitatneme

スクリプトの全体→ spiral-string.scm

R.バード『関数プログラミング』の亀の子図形問題、Scheme版

『関数プログラミング』（R. バード,P.ワドラー著/武市 正人訳）に亀の子図形の例題がある。その一筆書きバージョンを Gauche で書くとこんな感じ。

;; state -> state
(define (move state)
  (match state
    (`((,x ,y) 0) (make-state (- x 1) y 0))    ;; N
    (`((,x ,y) 1) (make-state x (- y 1) 1))    ;; W
    (`((,x ,y) 2) (make-state (+ x 1) y 2))    ;; S
    (`((,x ,y) 3) (make-state x (+ y 1) 3))    ;; E
    ))

;; state -> state
(define (turn-left state)
  (let-state state
      (x y d)
    (make-state x y (remainder (+ d 1) 4))))

ただし、

(define (make-state x y d)
  (list (list x y) d))

(define-syntax let-state
  (syntax-rules ()
    ((_ e1 (e2 e3 e4) e5 ...)
     (let ((e2 (caar e1))
           (e3 (cadar e1))
           (e4 (cadr e1)))
       e5 ...))))

とする。

この move と turn-left（および同様に定義した turn-right）を使って「鉛筆の軌跡」をつくり、それを適当な大きさのビットマップに対応させれば、結果として絵が描ける。そのためのプロシージャは、たとえば以下のように定義すればいい。

;; [state] -> [[boole]]
(define (bitmap-by-truth-value ps)
  (define (range xs)
    (list-ec (: i (apply min xs) (+ (apply max xs) 1)) i))
  (define (orlist ls)
    (cond ((null? ls) #f)
          ((car ls) #t)
          (else
           (orlist (cdr ls)))))
  (define (in? x xs)
    (orlist (map (cut equal? <> x) xs)))
  (let ((codes (map car ps)))
    (list-ec (: x (range (map car codes)))
             (list-ec (: y (range (map cadr codes)))
                      (in? (list x y) codes)))))

;; [[boole]] -> string
(define (picture-with-numbermark bitmap)
  (string-join
   (map (lambda (y)
          (string-join (map (lambda (x) (if x "#" " ")) y) "" 'strict-infix))
        bitmap)
   "\n" 'strict-infix))

（ちなみにコード中にコメントで示している型は厳密なものではなく、コードを書くときの便宜的なものです。）

教科書には正方形を描く例がある。でもそれは面白くない。簡単な応用として螺旋模様を描いてみよう。

(define (make-simple-spiral-states length)
  (define (make-spiral-series total)
    (let* ((most (floor (/ (- (sqrt (+ 1 (* 8 (- total 1)))) 1) 2)))
           (lmost (iota (- most 1) 2 1))
           (rest (- total (fold + 1 lmost))))
      (append (list 2) lmost (if (zero? rest) '() (list rest)))))
  (let ((series (make-spiral-series length))
        (init-state (make-state 0 0 0)))
    (scanf init-state (concatenate (map (lambda (n) (append (keep-moving n) (list turn-left))) series)))))

keep-moving と scanf は以下のような関数。

;; num -> (state -> [state])
(define (keep-moving n)
  (list-tabulate n (lambda (i) move)))

;; (alpha -> beta) -> gamma -> [alpha -> beta]
(define (scanf init procs)
  (if (null? procs)
      '()
      (let ((value ((car procs) init)))
        (cons value
              (scanf value (cdr procs))))))

実行するとこんな感じ。

gosh> (display (picture-with-numbermark (bitmap-by-truth-value (make-simple-spiral-states 55))))
###########
          #
  ####### #
  #     # #
  # ### # #
  # # # # #
  # #   # #
  # ##### #
  #       #
  ##########<undef>

（srfi-1 と srfi-42 と util.match が必要）

数学的帰納法は超限帰納法により証明します。超限帰納法は整列集合の性質から導かれます。たしかに大学の集合論の授業でこれを最初に知ったときはびっくりした。

うすうす感じてたんだけど、どうやら僕の生き方は「むかつき駆動」らしい。一方、人生というのは基本的に前進するほど問題が増えるので、むかつく→対応→別なことにむかつく→対応→……。


たぶん「むかつき駆動」はハッカーの定義なんかにも重なるんだと思う。でも僕はもちろんハッカーではない。むかつくポイントが彼らとは異なると思われるから。たとえば、計算機に仕事をさせられていることにむかつくことはなくて、計算機を使えていない自分にむかつく。よく言えば客観的だけど、ええかっこしいなのかもしれない。だとしたらむかつく。でもええかっこしいかもしれない自分にむかついて誤った対応（自分の外面に無頓着になるとか）をすると女の子に嫌われそうなのでやっぱりむかつく。むかー☆