(define eどうやらSXPathで遊ぶときは、「真偽を返す関数」をsxml:xxxみたいな名前の関数に渡してコンバータを作り、それを要素に適用するというのが常套っぽい。いまは属性をもとに評価したいので、「真偽を返す関数」としては「lang属性の値が"ja"かどうかテストするプロシージャ」になるんだろうな。そして木全体をめぐりたいので、sxml:descendantで作ったコンバータをルートノードに適用すればよさそうだ。
'(*TOP*
(p (|@| (lang "ja"))
"こんにちはこんにちは"
(emph "日本語です"))
(p (|@| (lang "en"))
"hellohello"
(emph "I got english"))
(m (p (|@| (lang "ja"))
"あしたは休み")
(p (|@| (lang "en"))
"I can't work any more"))))
(use sxml.sxpath)実行結果
(use sxml.tools)
(define (f r n v)
((sxml:descendant
(lambda (e) (equal? "ja" (sxml:attr e 'lang))))
r))
(define q (sxpath `(,f)))
gosh> (q e)
((p (|@| (lang "ja")) "こんにちはこんにちは" (emph "日本語です"))
(p (|@| (lang "ja")) "あしたは休み"))
(define life一番上の階層のテキスト情報だけを抜きたい。
'(i (value "2007")
"年"
(ii (value "10")
"月"
(iii (en "9")
"日"))
(delimiter "/")
(value "2009")
"年"
(ii (value "1")
"月"
(iii (en "31")
"日"))
(iii (value "10")
"日")))
(use sxml.sxpath)
(define (text-self elem)
(sxml:string ((node-self (ntype?? '*any*)) elem)))
(text-self
(cons 'dummy
((sxml:child (sxml:invert (ntype-names?? '(ii iii)))) life)))
(use text.kakasi)これを kakasi-trial.scm とすると、
(kakasi-begin :JH :p)
(display (kakasi-convert "素子"))
(newline)
(kakasi-end)
$ gosh -V
Gauche scheme interpreter, version 0.8.10 [utf-8,pthreads]
$ gosh kakasi-trial.scm
{もとこ|そし}
;;; let designated pattern be highlightM-x highlight-regexp すると正規表現の入力を促されるので、そこで適切なパターンを指定すると、上の例のようにハイライトされる。そういえば解除するときのことは考えてなかった。あと、上の例ではなんとなく改行をまたいだマッチに成功してるけど、emacs の正規表現である以上、改行をまたいだパターンのマッチは期待通りにいかないと覚悟すべき。やっぱりこのエディタは、本当のところは文章のパワー編集には向かないんじゃないだろうか。
(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))
(use gauche.charconv)KAKASIがUTF-8を扱えないのが厄介だけど、それ以外はとても素直に Gauche で漢字かな変換ができる。
(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)))
gosh> (kanji->hira "素子")さて、この「素子」のようにユニークな読みを決定できない項目があると困っちゃうんだけど、「もとこ」か「そし」かの判断を機械的にすべきではなさそうだ
{もとこ|そし}
<p>↓
この素子を開発したのは素子さんです。
<indexterm><i1 sortas="そし">素子<i2>開発者</i2></i1></indexterm>
<indexterm><i1 sortas="もとこ">素子</i1></indexterm>
<indexterm><i1>開発者</i1></indexterm>
</p>
この素子を開発したのは素子さんです。\index{そし@素子!かいはつしゃ@開発者}\index{もとこ@素子}\index{かいはつしゃ@開発者}
/fib {0 1 2 index -1 1 {pop exch 1 index add} for} def%!これでページの左下に大きく「89」と印刷される。やっぱりPalatinoフォントの数字は美しい。
/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
%!
/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
/func {1 exch -1 1 {mul} for} defようするに、自分がしたい操作に必要な変数が、適切な数だけ適切な順番でスタックに積まれているようにすればいいらしい。そしてスタックというやつからは、直前に積んだものだけを取り出すことができる。GS> 5 funcまず 5 がスタックに積まれる。この 5 は「funcへの引数」のつもりなんだけど、スタックから見るとそんなつもりはなくて、ただ値が積まれただけ。次は func を積むんだけど、func は上記のように定義されているので、その定義の一番最初にある 1 がスタックに積まれる。この時点のスタックの状態はこんな感じ。
1func の定義によれば、次は exch だ。これは、それまでスタックの1番上にあった要素とその下の要素を入れ替える。つまり、スタックの状態はこうなる。
---
5
5さらに -1 と 1 を順番に積んで、スタックの状態はこうなる。
---
1
1ここで、本文が mul だけの for が登場する。for というオペレータは、スタックの値を 3つ消費し、それぞれの値を深いほうから順番に「繰り返しの最初」「繰り返しの更新」「繰り返しの終わり」として本文を繰り返す。ただし毎回の繰り返しでは、スタックの先頭に、そのターンにおける変数のようなものが積まれる。こう書くと複雑だけど、ようは最初に本文を実行するときには「5」が、2回目は「4」が、...、5回目は「1」がスタックの先頭に積まれるということ。つまり1回目の繰り返しのとき、スタックの状態はこう。
---
-1
---
5
---
1
5本文の mul は、このスタックから値を 2つ取り出して、それらの積をあらためてスタックに積む。したがってスタックの状態は、
---
1
52回目の繰り返しに際してスタックの先頭に「4」が積まれる。
4このスタックで mul を適用すると、
---
5
203回目の繰り返しに際してスタックの先頭に「3」が積まれる。
3mul を適用して
---
20
604回目の繰り返しに際してスタックの先頭に「2」が積まれる。
2mul を適用して
---
60
1205回目の繰り返しに際してスタックの先頭に「1」が積まれる。
1mul を適用して
---
120
120おしまい。こうして最後のスタックの値を取り出せば（そのためには == を使う）、5の階乗の値が得られる。
/func {dup 1 eq {1 mul} {dup 1 sub func mul} ifelse} def実行結果。GS> 10 func ==どうやら再帰的なオペレータの定義ができるらしい。はじめは、ふつうに for を使って解こうとしたんだけど、わかりませんでした。
3628800
GS> 20 func ==
2.43290202e+18
GS> 100 func ==
inf.0
(define (one rad)このプロシージャ one は、values や receive という組み込みの多値のしくみを使わなくても、つぎのように継続を表すプロシージャ cont を使って多値を模倣できる。
(receive (sin cos)
(sincos rad)
(+ (* sin sin) (* cos cos))))
(define (sincos rad)
(values
(sin rad) (cos rad)))
(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
/* Implementation of a recursive fibonachi machine in C.スタックの機能をでっちあげて、Figure5.12にあるSchemeっぽい式をもじどおり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;
}
k16@debian:~/play $ ./fib 24
answer = 46368
k16@debian:~/play $ ./fib 25
セグメンテーション違反です
(define (fib n)その下のレイヤでは上記のCのコードのようなレジスタへの代入とスタックへの出し入れだけの形（現代のコンピュータがかろうじて完璧に扱える形）に解くほぐせて、しかも動く、という話なんだよね。プログラミング言語っていうのは、もしかして、ここで手動で試してみたコードからコードへの変換みたいな処理を自動的に行うしくみのことなのか？
(if (< n 2)
n
(+ (fib (- n 1)) (fib (- n 2)))))
ボールはトンネルの真ん中まで落ちるあいだ、つねに一定の加速度で移動する。
つまり、どんどん速度が増える。
トンネルの真ん中付近を突っ切るときが最速で、そこから先は正反対の向きの加速度で移動する。
つまり、だんだんゆっくりになる。
そのうち前半の行程で得たエネルギーを使い果たし、反対側の地表付近で一瞬静止して、今度はもときた方向へ落ちていく。
以下繰り返し。
(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)))
(define (stripe? ls)ところでgroupとtransposeは、いつも使いたいときに一瞬探すんだけど見つからなくて、そのたびに下手な実装をしてる気がする。今回はこんなんで。
(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)))))))
(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)))
A | B | C |
(use srfi-1)あとは、先に定義した patch? を使ってストリームをフィルタリングすればいい。どの色もだいたい平等に塗られているかどうかを調べるプロシージャ egalite? も定義しておいて、ここであわせてフィルタリングする。
(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))))))))
これで (tiles 4 4 3) とかって実行すれば、塗り分けパターンを順次計算してくれるストリームが帰ってくる。はずなんだけど、実際には組み合わせが爆発しちゃう。16マスを3色に塗り分けようと思ったら 316 = 43,046,721 のパターンがありうるわけで、すべての塗り分けパターンからなるリストを作ったりすると巨大なリストになって身動きが取れなくなると思ってストリームを使ってみたんだけど、どのみち4x4=16マスの3色塗り分けを全部求めるのは無理だったもよう。
(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)))))))
gosh> (define s (tiles 4 3 3))最初に得られる結果を先の色定義（ 1：青、2：オレンジ、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>
(define (tile->html tile rownum)しかし、tilesの引数は順番を逆にするべきだったな。行と列がいれかわってて紛らわしいことこのうえない。
(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\"> </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)))