vallog: 2010/08

2010/08/30

ポール・グレアムがオススメする本

ポール・グレアム「起業のFAQ」 - らいおんの隠れ家

ベンチャーの起業家に私たちが推薦しているのはデール・カーネギーの「人を動かす」。仕事をする人は必ず読むべき本だ。1960年代より前の版を入手してほしい。カーネギーの死後、本は委員会に「改訂」され続け、その結果かえって悪くなってしまった。

有名な本ですね。読んでいません。個人的に「うさんくせぇー本だな・・・。」と思う本の一つだったので。。
ポール・グレアムがオススメしているとなると読みたくなる不思議。

しかし、一体どうやってそんな古書を・・・。。

2010/08/29

数学が嫌いな方、算数で挫折した方にオススメしたいです。

私も算数で躓いて、中高の数学はなんとかやり過ごして大学は文系に行ったクチです。10代前半に読んでいたら、人生が変わっただろうなと思います。おもしろいしわかりやすいし、楽しんで読めます。数学のおもしろさを感じることができます。

「学校の教科書はコレにした方が良いんじゃないか。」と @shunsuk さんがおっしゃっていましたが、私もそう思います。そうでなくても算数や数学を教える立場にある方には参考にして欲しい一冊だと思いました。

（下）も読みます。これは読みます。

2010/08/28

PAIP tree-search

実用 Common Lisp 6.4 ～
探索ツール。9LISP で紹介のため、取りあえずUP。gauche で書いてあります。

6.4.tree-search.scm at master from valvallow's PAIP - GitHub

tree-search

	;; PAIP chapter.6 tree-search

	(use srfi-1)
	(use gauche.sequence)
	(use liv.debugs)

	(debug :search)
	;; (undebug :search)

	(define fail '())

	(define (tree-search states goal? successors combiner)
	;; (debug-indent :search 10 ";; Search: ~a" states)
	(dbg :search ";; Search: ~a" states)
	(cond ((null? states) fail)
	((goal? (car states))(car states))
	(else (tree-search (combiner (successors (car states))
	(cdr states))
	goal? successors combiner))))

	(define (tree-search states goal? successors combiner)
	(if (null? states)
	fail
	(let1 a (car states)
	(if (goal? a)
	a
	(tree-search (combiner (successors a)
	(cdr states))
	goal? successors combiner)))))

	(define (tree-search states goal? successors combiner)
	(if (null? states)
	fail
	(let rec ((states states))
	(dbg :search ";; Search: ~a" states)
	(let1 a (car states)
	(if (goal? a)
	a
	(rec (combiner (successors a)
	(cdr states))))))))

	;; successors
	(define (binary-tree x)
	(let1 x (* 2 x)
	(list x (+ 1 x))))

	(define (finite-binary-tree n)
	(lambda (x)
	(remove (pa$ < n)
	(binary-tree x))))

	;; cost function
	(define (diff num)
	(compose abs (cut - <> num)))

	(define (sorter cost-fn)
	(lambda (new old)
	(sort-by (append new old) cost-fn <)))

	(define (price-is-right price)
	(lambda (x)
	(if (> x price)
	(greatest-fixnum)
	(- price x))))

	;; goal?
	(define (is value)
	(pa$ equal? value))

	;; combiner
	(define (prepend x y)
	(append y x))

view raw tree-search.scm hosted with ❤ by GitHub

深さ優先


	(define (depth-first-search start goal? successors)
	(tree-search (list start) goal? successors append))

	;; (depth-first-search 1 (is 12) binary-tree)
	;; endless loop ...

	(depth-first-search 1 (is 12)(finite-binary-tree 15))
	;; Search: (1)
	;; Search: (2 3)
	;; Search: (4 5 3)
	;; Search: (8 9 5 3)
	;; Search: (9 5 3)
	;; Search: (5 3)
	;; Search: (10 11 3)
	;; Search: (11 3)
	;; Search: (3)
	;; Search: (6 7)
	;; Search: (12 13 7)12

view raw depth-first-search.scm hosted with ❤ by GitHub

幅優先

	(define (breadth-first-search start goal? successors)
	(tree-search (list start) goal? successors prepend))

	(breadth-first-search 1 (is 12) binary-tree)
	;; Search: (1)
	;; Search: (2 3)
	;; Search: (3 4 5)
	;; Search: (4 5 6 7)
	;; Search: (5 6 7 8 9)
	;; Search: (6 7 8 9 10 11)
	;; Search: (7 8 9 10 11 12 13)
	;; Search: (8 9 10 11 12 13 14 15)
	;; Search: (9 10 11 12 13 14 15 16 17)
	;; Search: (10 11 12 13 14 15 16 17 18 19)
	;; Search: (11 12 13 14 15 16 17 18 19 20 21)
	;; Search: (12 13 14 15 16 17 18 19 20 21 22 23)12

view raw breadth-first-search.scm hosted with ❤ by GitHub

最良優先探索


	(define (best-first-search start goal? successors const-fn)
	(tree-search (list start) goal? successors (sorter const-fn)))

	(best-first-search 1 (is 12) binary-tree (diff 12))
	;; Search: (1)
	;; Search: (3 2)
	;; Search: (7 6 2)
	;; Search: (14 15 6 2)
	;; Search: (15 6 2 28 29)
	;; Search: (6 2 28 29 30 31)
	;; Search: (12 13 2 28 29 30 31)12

	(best-first-search 1 (is 12) binary-tree (price-is-right 12))
	;; Search: (1)
	;; Search: (3 2)
	;; Search: (7 6 2)
	;; Search: (6 2 14 15)
	;; Search: (12 2 13 14 15)12

view raw best-first-search.scm hosted with ❤ by GitHub

ビーム探索

	(define (beam-search start goal? successors cost-fn beam-width)
	(tree-search (list start) goal? successors
	(lambda (old new)
	(let1 sorted ((sorter cost-fn) old new)
	(if (> beam-width (length sorted))
	sorted
	(subseq sorted 0 beam-width))))))

	(beam-search 1 (is 12) binary-tree (price-is-right 12) 2)
	;; Search: (1)
	;; Search: (3 2)
	;; Search: (7 6)
	;; Search: (6 14)
	;; Search: (12 13)12

view raw beam-search.scm hosted with ❤ by GitHub

実用 Common Lisp (IT Architects’Archive CLASSIC MODER)

2010/08/27

PAIP debug, dbg, dbug-indent

実用 Common Lisp の P.116 にあるデバッグ用のツールです。
すごく便利だったので、gauche で書いて使えるようにしてみました。

	;; debug tools
	;; PAIP(実用 Common Lisp) - P.116 - 4.10

	(define-module liv.debugs
	(use srfi-1)
	(use gauche.parameter)
	(export-all))

	(select-module liv.debugs)

	(define dbg-ids (make-parameter '()))

	;; (define (dbg id format-string . args)
	;; (when (member id (dbg-ids))
	;; (let1 port (current-error-port)
	;; (newline port)
	;; (apply format port format-string args))))
	(define dbg (cut debug-indent <> 0 <> <...>))

	(define (debug . ids)
	(dbg-ids (lset-union eq? ids (dbg-ids))))

	(define (undebug . ids)
	(dbg-ids (if (null? ids)
	'()
	(lset-difference eq? (dbg-ids) ids))))

	(define (debug-indent id indent format-string . args)
	(when (member id (dbg-ids))
	(let1 port (current-error-port)
	(newline port)
	;; (dotimes (i indent (display " " port)))
	(display (apply string-append (make-list indent " ")) port)
	(apply format port format-string args))))

	(provide "liv/debugs")

view raw debug.scm hosted with ❤ by GitHub

library の lib なら liv じゃなくて lib でしょう。valvallow の library ということで liv でいいかな、などと。

syntax-rules: mreverse (マクロ reverse, 反転）

syntax-rules による reverse です。syntax-rules でマクロを書く時に良く使われるテクニック（？）。

	;; macro reverse
	(define-syntax mreverse
	(syntax-rules ()
	((_ (arg ...))
	(mreverse "help" ()(arg ...)))
	((_ "help" (acc ...)())
	(acc ...))
	((_ "help" (acc ...)(arg x ...))
	(mreverse "help" (arg acc ...)(x ...)))))


	(mreverse (3 2 1 list))
	;; (1 2 3)

view raw mreverse1.scm hosted with ❤ by GitHub

helper を別途定義した場合。

	(define-syntax mreverse
	(syntax-rules ()
	((_ (arg ...))
	(mreverse-helper ()(arg ...)))))

	(define-syntax mreverse-helper
	(syntax-rules ()
	((_ (acc ...)())
	(acc ...))
	((_ (acc ...)(arg x ...))
	(mreverse-helper (arg acc ...)(x ...)))))

view raw mreverse2.scm hosted with ❤ by GitHub

Scheme:マクロ内でのループ

2010/08/26

syntax-rules: cut っぽい let

たまたま、試しにこういうアナフォリックマクロを書いていました。値を一時的に束縛したいけど、名前を付けたいわけではないことがよくある気がしたので。別に <> じゃなくて On Lisp の aif や aand みたいに it でも良いんですけども。

	(define-macro (& exp . body)
	`(let1 <> ,exp ,@body))

	(& 2
	(& (* <> 2)
	(list <> (+ 1 <>))))

view raw cet1.scm hosted with ❤ by GitHub

そこで、srfi-26 の cut っぽい let があったら便利そうだなぁ。。と思ったので、こちらも試しに書いてみました。みましたが・・・。（名前は、cut っぽい let -> cutlet -> cet と取りあえず）

	(define-syntax cet-helper
	(syntax-rules (cet <>)
	;; base
	((_ val (x ...)())
	(x ...))
	;; list
	((_ val (x ...)((nest ...) rest ...))
	(cet-helper val (x ... (cet-helper val ()(nest ...)))(rest ...)))
	((_ val (x ...)(<> rest ...))
	(cet-helper val (x ... val)(rest ...)))
	((_ val (x ...)(a rest ...))
	(cet-helper val (x ... a)(rest ...)))
	;; atom
	((_ val (x ...) <>)
	val)
	((_ val (x ...) a)
	a)))

	(define-syntax cet
	(syntax-rules ()
	((_ expr body ...)
	(let ((tmp expr))
	(cet-helper tmp () body ...)))))

	(cet (* 2 2)
	(list <> <> <> <>))
	;; (4 4 4 4)

	(cet 10 <>)
	;; 10

	(use srfi-1)
	(cet 10 (map list (iota <>)))
	;; ((0) (1) (2) (3) (4) (5) (6) (7) (8) (9))

	(cet (* 2 2)
	(apply + <> (list <> (+ 1 <>))))
	;; 13

	(cet 2
	(cet (* <> 2)
	(list <> (+ 1 <>))))
	;; error

view raw cet2.scm hosted with ❤ by GitHub

ネストした時ダメですね。。こういう時はどう扱ったら良いんでしょうか。わかりません。以下のように少し書き足してもみましたが・・・。動いたとしても、ここまでするなら一番最初のアナフォリックマクロで良いかなーと思いました。

	(define-syntax cet-helper
	(syntax-rules (cet <>)
	;; base
	((_ val (x ...)())
	(x ...))

	;; add
	((_ val (x ...)((cet exp b ...) rest ...))
	(cet-helper val (x ... (cet (cet-helper val () exp) b ...))(rest ...)))

	;; list
	((_ val (x ...)((nest ...) rest ...))
	(cet-helper val (x ... (cet-helper val ()(nest ...)))(rest ...)))
	((_ val (x ...)(<> rest ...))
	(cet-helper val (x ... val)(rest ...)))
	((_ val (x ...)(a rest ...))
	(cet-helper val (x ... a)(rest ...)))
	;; atom
	((_ val (x ...) <>)
	val)
	((_ val (x ...) a)
	a)))

	(cet 2
	(cet (* <> 2)
	(list <> (+ 1 <>))))
	;; error

view raw cet3.scm hosted with ❤ by GitHub

しかし、srfi のコードは美しいですねぇ。今回も大変勉強になりました。

追記

コメント欄が面白かったので。

cutの実装 - 初学者の箸置

2010/08/25

Gauche の $ （ドル）

コメント欄の Gauche の $

本当にLispはカッコが多い？ - 八発白中

$ の話をどこかで見たなー・・・と思ってググるもなかなか見つかりませんでした。Haskell 由来だった覚えがあったので「Gauche Haskell」でググったら出てきました。。

Gauche:$

gauche.experimental.app なんてものがあるんですね。ドキュメントにもない実験的な機能ということですか。$ もこれに含まれているようです。（Gauche もいずれリーダーマクロがつくっぽいところも期待）

似てるけど違うけど、これを思い出しました。

vallog: syntax-rules: across （Clojure の .. ぽいもの）

追記

$ と cut - 主題のない日記

Visual Stuidio (2008) での Emacs キーバインド

ツール -> オプション -> 環境 -> キーボード
キーボードマップスキームを Emacs に設定後、以下の設定を追加してみました。

キー	実行されるコマンド
C-c i	編集.選択範囲のフォーマット
C-h	編集.一語削除
M-;	編集.選択範囲のコメント
M-+	編集.選択範囲のコメントを解除
C-,	ウィンドウ.前のドキュメントウィンドウ
C-.	ウィンドウ.次のドキュメントウィンドウ

たったこれだけですが、追加したら結構良い感じになりました。

あとは
C-g を Emacs と同じようなキャンセルっぽい動作に
tab の入力を C-i に
補間候補のポップアップ内の選択も C-n, C-p にできたらもっと幸せなんですが・・・。

ところで、VS2010 では Emacs キーバインドがデフォルトでは提供されていないとか。

そういや、こういう噂はどうなったんでしょうね。

参考

sehm @ メモ: Visual Studio 2005 を emacs キーバインドに設定する

2010/08/24

グッド・ラボラトリー・プラクティス

vallog: 「足りない」という強迫観念

同じくただのメモ。

世界は分けてもわからない P.186 より。

実験室におけるよき習慣。ヒトは常に間違える。忘れる。混乱する。だから、それをしないよう注意するのではなく、それが起こらないための方法論を考えよ。あるいはミスが起こったとき、その被害が最小限にとどまるような仕組みを考えよ。それが君たちの仕事だ。

プログラマの仕事のことかと思いました。どの業界も似たようなものなんでしょうか。ソフトウェア業界にも似たような教訓があります。
それに福岡伸一さんの著書を読むと、ポスドクの社畜っぷりもなかなかであることがわかります。

そういえば、この世界は分けてもわからないには意外なことに、ゲームプログラマになる前に覚えておきたい技術の平山尚氏の名前が出てきます。

プログラマ、ＳＥ、ゲームプログラマについて - Yahoo!知恵袋

「足りない」という強迫観念

世界は分けてもわからない P.14 より。

私の身体が、あるいは私の精神が不調なのは、何かが不足しているからかもしれない・・・・・・この強迫観念から逃れんがための反動として、私たちは時として、不必要な物質の大量摂取を無自覚に行なってしまうのです。

↑を読んで↓を思い出しました。

vallog: 多くの情報を抱え込みたくなる理由

「過ぎたるは及ばざるが如し」「押し付けられた善意は悪意と同じ」ですか。

生物と無生物のあいだ (講談社現代新書) とできそこないの男たち (光文社新書) も以前読みました。次は動的平衡生命はなぜそこに宿るのかも読んでみたいです。

最近ようやく積読が増加から減少傾向に。。

2010/08/20

「Scheme」という名の由来

ここだけ引用してもアレですが。。

Scheme 過去◇現在◇未来

→ リンク切れてますね。代わり→ https://gist.github.com/legokichi/49342f7aeb22c898b17e6829d6975438

英語でPlannerはプランする何かです。Conniverはスニーキー(こそこそする、卑劣)なプランナーです。だから、もっとスニーキーなプランナーを何と呼ぼうか。そりゃ、スキーマー(陰謀家、策略家)だ。それで、Schemerとつけたのです。

残念ながら、我々は60年代に設計されたOSを使っていたので、すべてのファイル名は6文字以下でなければなりませんでした。それで、ファイル名SCHEMERは最初の6文字だけに切り捨てられました。

概略

MIT に Carl Hewitt と Gerry Sussman という聡明な二人が競い合ってプログラミング言語を実装していた。

Carl Hewitt が Planner というとても複雑なプログラミング言語を設計した。
Planner が複雑過ぎて実装できなかったため、Planner の小型版である Microplanner が実装された。
それでも複雑だったため、Gerry Sussman が Microplanner を改良した Conniver という言語を実装した。

一方 Carl Hewitt は、Conniver より良い Plasma という言語を実装した。
Plasma は Smalltalk などから影響を受けた、アクタモデルを採用したオブジェクト指向言語だった。Plasma にはコンティニュエーション（継続）の概念があった。

Plasma は難し過ぎて、Gerry Sussman と Guy L. Steele Jr には理解できなかった。
二人は、不要な機能を取り去ったとても小さな Plasma のインタプリタを Lisp で書いた。
Gerry Sussman はこのころレキシカルスコーピングに興味があったのでそれを採用した。

Scheme 過去◇現在◇未来

Sussmanと私は、小さなインタプリタを書きました。言語を理解するもっとも簡単な方法はそのインタプリタを書くことです。インタプリタを書くもっともよい言語はLispです。

Planner, Conniver ときたので、Schemer と名付けることにした。
OS の制限でファイル名が6文字までしか許されなかったので6文字以降を切り捨てた Scheme になった。

余談

Gerry Sussman は SICP の中の人ですね。

計算機プログラムの構造と解釈 - Wikipedia

Guy L. Steele Jr は Common Lisp や Java の仕様策定なんかもやった人ですね。

ガイ・スティール - Wikipedia

他

レキシカルスコープとダイナミックスコープ

scheme

レキシカルスコープ

Common Lisp

レキシカルスコープ
ダイナミックスコープ

Emacs Lisp

ダイナミックスコープ

という認識で良いかと思います。Clojure や Arc なんかもたぶんレキシカルスコープでしょう（たぶん）。
Common Lisp はスペシャル変数（だけ？）がダイナミックスコープですよね。

scheme にはダイナミックスコープな変数をエミュレートする fluid-let という変数束縛マクロがあったりします。

vallog: syntax-rules: fluid-let

で、なんと Emacs Lisp には lexical-let マクロという、レキシカルスコープな変数をエミュレートするマクロがあるらしいじゃないですか。（cl パッケージだけど）
ソース見てみたんですが、正直よくわかりませんでした。。

Emacs Lisp と lexical-let の場合。

(require 'cl)

(defvar a 100)
a
;; 100

(defvar b 200)
b
;; 200

(defun a+b ()
  (+ a b))

(a+b)
;; 300

(let ((a 1)(b 2))
  (values (a+b)(+ a b)))
;; (3 3)

(lexical-let ((a 1)(b 2))
  (values (a+b)(+ a b)))
;; (300 3)

ついでに、scheme と fluid-let の場合。

(use srfi-15)

(define a 100)
a
;; 100

(define b 200)
b
;; 200

(define (a+b)
  (+ a b))

(a+b)
;; 300

(let ((a 1)(b 2))
  (values (a+b) a b))
;; 300
;; 1
;; 2

(fluid-let ((a 1)(b 2))
  (values (a+b) a b))
;; 3
;; 1
;; 2

Scheme 以前の太古の Lisp は皆ダイナミックスコープだったらしいですね。こわい。
Common Lisp のスペシャル変数は便利だなぁ、と思っていました。でも Emacs Lisp のように原則ダイナミックスコープっていうのはどうなんだろう。すごく難しそうな気がするんですが、どうなんでしょう。。

2010/08/19

Emacs Lisp の mapcar

ハマった。。apply を疑ったり。。

mapcar が引数に取るリストは、単一なんですね。複数のリストを取るのは mapcar* だそうで。

GNU Emacs Lispリファレンスマニュアル: Mapping Functions

これは error

(apply 'mapcar 'cons '(("1" "2" "3")("a" "b" "c")))

複数のリストを取るのは mapcar*

(apply 'mapcar* 'cons '(("1" "2" "3")("a" "b" "c")))
(mapcar* 'cons '(1 2 3)'(a b c))
(mapcar* 'list '(1 2 3)'(a b c)'(10 20 30)'("a" "b" "c"))

fold-with-index

vallog: fold with index : fold/index

書かなくてもあった・・・

Gauche ユーザリファレンス: 9.19 gauche.sequence - シーケンスフレームワーク

2010/08/17

Project Euler お試し

追記

丸3年放置していましたが、2013/08/07辺りから再開しました。

valvallow/euler

Project Euler - valvallow

shunsuk さんの勧めで、取りあえず1問やってみました。こういう場合、勧めなのか薦めなのか。。

以下コード。

	;; 001

	;; http://projecteuler.net/index.php?section=problems&id=1
	;; If we list all the natural numbers below 10 that are multiples of 3 or 5, we get 3, 5, 6 and 9. The sum of these multiples is 23.
	;; Find the sum of all the multiples of 3 or 5 below 1000.

	;; http://odz.sakura.ne.jp/projecteuler/index.php?Problem%201
	;; 10未満の自然数のうち、3 もしくは 5 の倍数になっているものは 3, 5, 6, 9 の4つがあり、これらの合計は 23 になる。
	;; 同じようにして、1,000 未満の 3 か 5 の倍数になっている数字の合計を求めよ。


	(use srfi-1)

	(apply + (filter (lambda (e)
	(or (zero? (remainder e 3))
	(zero? (remainder e 5))))
	(iota 10)))
	;; 23


	(define (filter-sum pred ls)
	(apply + (filter pred ls)))

	(filter-sum (lambda (e)
	(or (zero? (remainder e 3))
	(zero? (remainder e 5))))
	(iota 1000))
	;; 233168


	(let1 f (compose zero? (pa$ remainder))
	(filter-sum (lambda (e)
	(or (f e 3)
	(f e 5)))
	(iota 1000)))


	(define (aliquant? n d)
	(zero? (remainder n d)))


	(filter-sum (lambda (e)
	(or (aliquant? e 3)
	(aliquant? e 5)))
	(iota 1000))
	;; 233168


	(define (aliquant-any? n d . ds)
	(any (lambda (d)
	(aliquant? n d))(cons d ds)))

	(filter-sum (cut aliquant-any? <> 3 5)
	(iota 1000))
	;; 233168

view raw 0001.scm hosted with ❤ by GitHub

いつものことですが、名前付けがどうもしっくりこないです。かと言って英語の勉強まで手を広げる気にもなれません。

Project Euler は数学色が強いと聞いていたので敬遠していましたが、取りあえず躓くまでやってみようと思います。
L-99 の方も滞っています。

vallog: L-99

そうえば Chrome がバージョンアップして Ctrl+b でブックマークバーが出なくなって戸惑いました。Ctrl+Shift+b になったんですね。

2010/08/13

syntax-rules:def-let* (slib)

syntax-rules でマクロを定義するマクロ def-let* がうまいこと動きませんでした。

vallog: syntax-rules: fluid-let*

これがその def-let*

	(define-syntax def-let*
	(syntax-rules ()
	((_ name let-macro-name)
	(define-syntax name
	(syntax-rules ()
	((_ ((var val)) body ...)
	(let-macro-name ((var val))
	body ...))
	((_ ((var val) x ...) body ...)
	(name ((var val))
	(name (x ...) body ...))))))))

	(def-let* my-fluid-let* fluid-let)

view raw def-let*.scm hosted with ❤ by GitHub

そこで、また教えて頂きました！ありがとうございます！

Twitter / SaitoAtsushi: @valvallow http://bit.ly/9 ...

Scheme:初心者の質問箱:log01

@valvallow http://bit.ly/9Bvqri

Twitter / SaitoAtsushi: @valvallow まず (use slib)(r ...

@valvallow まず (use slib)(require 'repl)(require 'syntax-case) とします。 slib 環境内で評価したい式全体を quote して macro:eval 手続きに渡せばよいです。

Twitter / SaitoAtsushi: @valvallow あるいは、 (repl:top ...

@valvallow あるいは、 (repl:top-level macro:eval) とすると slib の repl が開始されるのでここに式を入力してもよいです。

動きましたー！以下そのコード。仕組みがよくわかってませんが。。

	(use slib)
	(require 'repl)
	(require 'syntax-case)

	(macro:eval '(define-syntax def-let*
	(syntax-rules ()
	((_ name let-macro-name)
	(define-syntax name
	(syntax-rules ()
	((_ ((var val)) body (... ...))
	(let-macro-name ((var val))
	body (... ...)))
	((_ ((var val) x (... ...)) body (... ...))
	(name ((var val))
	(name (x (... ...)) body (... ...))))))))))

	(define a 1)
	(define b 2)
	(define c 3)
	(define (a+b+c)
	(+ a b c))

	(macro:eval '(def-let* my-fluid-let* fluid-let))
	(macro:eval '(begin
	(my-fluid-let* ((a 100)(b 200)(c (+ a b)))
	(print (a+b+c)))
	(print (a+b+c))))
	;; 600
	;; 6

view raw def-let*2.scm hosted with ❤ by GitHub

slib は今まで (use slib)(require 'trace) して trace, untrace くらいしか使ったことありませんでした。。slib って R5RS 準拠の pure scheme なライブラリなんですよね？srfi も良いですが、slib も読むと面白そうですね！

The SLIB Portable Scheme Library

2010/08/12

syntax-rules: fluid-let*

なんのことはありません。fluid-let を使って fluid-let* を書くわけですから、let を使って let* を書くのと変わりません。

;; fluid-let*

;; ;; example
;; (define-values (a b c)
;;   (values 1 2 3))

;; (define (a+b+c)
;;   (+ a b c))

;; (a+b+c)
;; ;; 6

;; (fluid-let* ((a 100)
;;              (b (* a 2))
;;              (c (+ a b)))
;;             (a+b+c))
;; ;; 600

つまり、以下のコードのようになります。

	;; fluid-let*

	;; ;; example
	;; (define-values (a b c)
	;; (values 1 2 3))

	;; (define (a+b+c)
	;; (+ a b c))

	;; (a+b+c)
	;; ;; 6

	;; (fluid-let* ((a 100)
	;; (b (* a 2))
	;; (c (+ a b)))
	;; (a+b+c))
	;; ;; 600

	(define-syntax fluid-let*
	(syntax-rules ()
	((_ ((var val)) body ...)
	(fluid-let ((var val))
	body ...))
	((_ ((var val) x ...) body ...)
	(fluid-let* ((var val))
	(fluid-let* (x ...) body ...)))))

	(fluid-let* ((a 100)
	(b (* a 2))
	(c (+ a b)))
	(a+b+c))
	;; 600
	(a+b+c)
	;; 6

view raw fluid-let*.scm hosted with ❤ by GitHub

そうなると、こういうのが欲しくなります。（このコードは動かないと思います。）

	(define-syntax def-let*
	(syntax-rules ()
	((_ name let-macro-name)
	(define-syntax name
	(syntax-rules ()
	((_ ((var val)) body ...)
	(let-macro-name ((var val))
	body ...))
	((_ ((var val) x ...) body ...)
	(name ((var val))
	(name (x ...) body ...))))))))

	(def-let* my-fluid-let* fluid-let)

view raw def-let*.scm hosted with ❤ by GitHub

syntax-rules でこういうの書くにはどうしたら良いんだろう。。たぶん、... のところがダメなんじゃないかとは思うのですが・・・。

vallog: syntax-rules: fluid-let

syntax-rules: fluid-let

fluid-let は dynamic scope をエミュレートするようなマクロです。

fluid-let は srfi にもあります。gauche などでは組み込みで用意されています。驚いたのは dynamic-wind が使われているところ。例えば body で脱出された場合などを考慮しているんですよね、きっと。なるほど～。

こういう動きです。

;; fluid-let

;; example
(define-values (a b)(values 1 2))

(define (a+b)
  (+ a b))

(a+b)
;; 3

(fluid-let ((a 100)(b 200))
  (a+b))
;; 300

;; fluid-let expand image
(let ((tempa a)(tempb b))
  (dynamic-wind
    (lambda ()
      (set! a 100)(set! b 200))
    (lambda ()
      (a+b))
    (lambda ()
      (set! a tempa)(set! b tempb))))
;; 300
(a+b)
;; 3

独習 Scheme 三週間 Teach Yourself Scheme in Fixnum Days に伝統的なマクロを用いた例が載っています。
fluid-let は syntax-rules では書けないかと思っていました。が、書けるようです。

当初、カンニングせずに自分で考えてみようと思いましたが、syntax-rules 内で一時的な変数を用意する方法がわかりませんでした。。そこで早速カンニングして写経してみました。

当然ですが、srfi のコードは美しいですねぇ・・・。

;; SRFI 15: Syntax for dynamic scoping - http://srfi.schemers.org/srfi-15/srfi-15.html
(define-syntax fluid-let
  (syntax-rules ()
    ((_ ((v1 e1) ...) b1 b2 ...)
     (fluid-let "temps" () ((v1 e1) ...) b1 b2 ...))
    ((_ "temps" (t ...) ((v1 e1) x ...) b1 b2 ...)
     (let ((temp e1))
       (fluid-let "temps" ((temp e1 v1) t ...) (x ...) b1 b2 ...)))
    ((_ "temps" ((t e v) ...) () b1 b2 ...)
     (let-syntax ((swap!
                   (syntax-rules ()
                     ((swap! a b)
                      (let ((tmp a))
                        (set! a b)
                        (set! b tmp))))))
       (dynamic-wind
         (lambda ()
           (swap! t v) ...)
         (lambda ()
           b1 b2 ...)
         (lambda ()
           (swap! t v) ...))))))

写経しつつ以下のように分解してみました。

	(define-syntax swap!
	(syntax-rules ()
	((_ a b)
	(let1 temp a
	(set! a b)
	(set! b temp)))))

	(define-syntax my-fluid-let
	(syntax-rules ()
	((_ ((var val) ...) body ...)
	(my-fluid-let-helper () ((var val) ...) body ...))))

	(define-syntax my-fluid-let-helper
	(syntax-rules ()
	((_ (t ...)((var val) x ...) body ...)
	(let1 temp val
	(my-fluid-let-helper (t ... (temp var))(x ...) body ...)))
	((_ ((temp var) ...)() body ...)
	(dynamic-wind
	(lambda ()
	(swap! temp var) ...)
	(lambda ()
	body ...)
	(lambda ()
	(swap! temp var) ...)))))


	(my-fluid-let ((a 100)(b 200))
	(a+b))
	;; 300
	(a+b)
	;; 3

view raw fluid-let1.scm hosted with ❤ by GitHub

上記の helper マクロを写経しているときに気づいたのですが、

(_ "temps" (t ...) ((v1 e1) x ...) b1 b2 ...)
     (let ((temp e1))
       (fluid-let "temps" ((temp e1 v1) t ...) (x ...) b1 b2 ...)))

この部分が素敵ですね！自分はこのテクニック（？）を知らなかったので、今まで以下のように書いていました。。

	(define-syntax my-fluid-let-helper
	(syntax-rules ()
	((_ (t ...)((var val)) body ...)
	(let1 temp val
	(my-fluid-let-helper ((temp val var) t ...)() body ...)))
	((_ (t ...)((var1 val1)(var2 val2) ...) body ...)
	(let ((temp1 val1))
	(my-fluid-let-helper ((temp1 val1 var1) t ...)((var2 val2) ...) body ...)))
	((_ ((t val var) ...)() body ...)
	(dynamic-wind
	(lambda ()
	(swap! t var) ...)
	(lambda ()
	body ...)
	(lambda ()
	(swap! t var) ...)))))

view raw fluid-let-bad-helper.scm hosted with ❤ by GitHub

ところで、文字列を使ったフラグ（？）によって、以下のように一つのマクロにまとめることができるわけです。

	(define-syntax my-fluid-let
	(syntax-rules ()
	((_ ((var val) ...) body ...)
	(my-fluid-let "temp" () ((var val) ...) body ...))
	((_ "temp" (t ...)((var val) x ...) body ...)
	(let1 temp val
	(my-fluid-let-helper (t ... (temp var))(x ...) body ...)))
	((_ "temp" ((temp var) ...)() body ...)
	(let-syntax ((swap! (syntax-rules ()
	((swap! a b)
	(let1 tmp a
	(set! a b)
	(set! b tmp))))))
	(dynamic-wind
	(lambda ()
	(swap! temp var) ...)
	(lambda ()
	body ...)
	(lambda ()
	(swap! temp var) ...))))))

	(a+b)
	;; 3
	(my-fluid-let ((a 100)(b 200))
	(a+b))
	;; 300
	(a+b)
	;; 3

view raw fluid-let3.scm hosted with ❤ by GitHub

でも、こういう風に書けたらもっとわかりやすい気がします。でも、確かダメなんですよね。。(... ...)とかドット対記法だと良いんでしたっけ？（その辺はまた今度・・・）

	(define-syntax my-fluid-let
	(syntax-rules ()
	((_ ((var val) ...) body ...)
	(let-syntax
	((swap! (syntax-rules ()
	((swap! a b)
	(let1 temp a
	(set! a b)
	(set! b temp))))))
	(letrec-syntax
	((helper (syntax-rules ()
	((helper (t ...)((var val) x ...) body ...)
	(let1 temp val
	(helper (t ... (temp var))(x ...) body ...)))
	((helper ((temp var) ...)() body ...)
	(dynamic-wind
	(lambda ()
	(swap! temp var) ...)
	(lambda ()
	body ...)
	(lambda ()
	(swap! temp var) ...))))))
	(helper () ((var val) ...) body ...))))))

view raw fluid-let2.scm hosted with ❤ by GitHub

参考

SRFI 15: Syntax for dynamic scoping

;; SRFI 15: Syntax for dynamic scoping - http://srfi.schemers.org/srfi-15/srfi-15.html
(define-syntax fluid-let
  (syntax-rules ()
    ((_ ((v1 e1) ...) b1 b2 ...)
     (fluid-let "temps" () ((v1 e1) ...) b1 b2 ...))
    ((_ "temps" (t ...) ((v1 e1) x ...) b1 b2 ...)
     (let ((temp e1))
       (fluid-let "temps" ((temp e1 v1) t ...) (x ...) b1 b2 ...)))
    ((_ "temps" ((t e v) ...) () b1 b2 ...)
     (let-syntax ((swap!
                   (syntax-rules ()
                     ((swap! a b)
                      (let ((tmp a))
                        (set! a b)
                        (set! b tmp))))))
       (dynamic-wind
         (lambda ()
           (swap! t v) ...)
         (lambda ()
           b1 b2 ...)
         (lambda ()
           (swap! t v) ...))))))

Identifier Syntax

;; Identifier Syntax - http://permalink.gmane.org/gmane.lisp.scheme.reports.wg1/148
(define-syntax fluid-let
  (syntax-rules ()
    ((fluid-let ("step") bind ((var val) . rest) body ...)
     (fluid-let ("step") ((var old new val) . bind) rest body ...))
    ((fluid-let ("step") ((var old new val) ...) () body ...)
     (let ((old var) ...
           (new val) ...)
       (dynamic-wind (lambda () (set! var new) ...)
                     (lambda () body ...)
                     (lambda () (set! var old) ...))))
    ((fluid-let ((var val) ...) body ...)
     (fluid-let ("step") () ((var val) ...) body ...))))

easyffi.scm

;; http://www-pu.informatik.uni-tuebingen.de/users/knauel/sw/fffi/easyffi.scm
(define-syntax fluid-let
  (syntax-rules ()
    ((fluid-let ((var1 expr1) (var2 expr2)) body ...)
     (let ((old-var1 var1)
           (old-var2 var2))
       (set! var1 expr1)
       (set! var2 expr2)
       (let ((res ((lambda () body ...))))
         (set! var1 old-var1)
         (set! var2 old-var2)
         res)))
    ((fluid-let ((var1 expr1)) body ...)
     (let ((old-var1 var1))
       (set! var1 expr1)
       (let ((res ((lambda () body ...))))
         (set! var1 old-var1)
         res)))))

Control Operations

;; Control Operations - http://www.scheme.com/tspl4/control.html
(define-syntax fluid-let
  (syntax-rules ()
    [(_ ((x e)) b1 b2 ...)
     (let ([y e])
       (let ([swap (lambda () (let ([t x]) (set! x y) (set! y t)))])
         (dynamic-wind swap (lambda () b1 b2 ...) swap)))]))

The Scheme Programming Language, 4th Edition

2010/08/11

Gauche の and-let* と On Lisp の aand

On Lisp --- アナフォリックマクロ

On Lisp の aand をそのまま scheme で以下のように書いてハマりました。。

	(define-macro (aif test-form then-form . else-form)
	`(let ((it ,test-form))
	(if it ,then-form ,@else-form)))

	(define-macro (aand . args)
	(cond ((null? args) #t)
	((null? (cdr args))(car args))
	(else `(aif ,(car args) (aand ,@(cdr args))))))

	(aand (string-scan "aaa.el" ".elc" 'after)
	(string=? it ""))
	;; #<undef>

	(macroexpand '(aand (string-scan "aaa.el" ".elc" 'after)
	(string=? it "") "not found"))
	(let ((it (string-scan "aaa.el" ".elc" 'after)))
	(if it
	(let ((it (string=? it "")))
	(if it
	"not found"))))

view raw aand-1.scm hosted with ❤ by GitHub

まともに使うにはこうでしょうか。。

	(define-macro (aand . args)
	(cond ((null? args))
	((null? (cdr args))(car args))
	(else `(if-let1 it ,(car args)
	(aand ,@(cdr args))
	#f))))

	(aand (string-scan "aaa.el" ".elc" 'after)
	(string=? it ""))
	;; #f

view raw aand-2.scm hosted with ❤ by GitHub

というか、gauche を使っているので、and-let* を使った方が無難なようです。。

Gauche ユーザリファレンス: 4.6 変数束縛

	(and-let* ((it (string-scan "aaa.el" ".elc" 'after))
	(it (string=? it "")))
	it)

view raw and-let*.scm hosted with ❤ by GitHub

2010/08/09

Emacs Windows SKK

メモ。

Emacs23.1 for windows

rubikitch さんの本買おう。

2010/08/08

(append '() 'a) ; -> a

Twitter / Yuji Okazawa: gauche で (append '() 1) を評 ...

gauche で (append '() 1) を評価した結果が 1 になるのはなんとなく納得いかないなぁ...

これを見て私もまんまと「え、なんでだろう？」と思いました。

shiro: R5RSでそう規定されてます RT: @yujiorama: gauche で (append '() 1) を評価した結果が 1 になるのはなんとなく納得いかないなぁ... http://bit.ly/atJY60

shiro: R5RSでそう規定されてます RT: @yujiorama: gauche で (append '() 1) を評価した結果が 1 になるのはなんとなく納得いかないなぁ... http://bit.ly/atJY60

で、実際 R5RS を見てみたら、そう書いてありました。そらそうですね。

shiro: appendは正式なリスト同士の演算じゃないんですね。むしろペアに対する演算の一種と考えた方がすっきりする。consやlist*の仲間。 http://bit.ly/9eMywh

shiro: appendは正式なリスト同士の演算じゃないんですね。むしろペアに対する演算の一種と考えた方がすっきりする。consやlist*の仲間。 http://bit.ly/9eMywh

Twitter / SaitoAtsushi: @valvallow いや、一貫してるでしょう。リ ...

@valvallow いや、一貫してるでしょう。リストの最後 (null) を次のリストに置き換えた形にするものと考えれば。

ここまで読んでもピンと来ませんでしたorz
下記のように append を自分で書いてみてようやくわかりました。。orz (append '() 'a) ; -> a なのは当然の結果ですね。

	(use srfi-1)

	(define (my-append ls1 ls2)
	(fold-right cons ls2 ls1))

	(my-append '(1 2 3)'(a b c))
	;; (1 2 3 a b c)
	(my-append '() 'a)n
	;; a
	(my-append '(1) 2)
	;; (1 . 2)


	(define (my-append ls1 ls2)
	(if (null? ls1)
	ls2
	(cons (car ls1)
	(my-append (cdr ls1) ls2))))

	(my-append '(1 2 3)'(a b c))
	;; (1 2 3 a b c)
	(my-append '() 'a)
	;; a
	(my-append '(1) 2)
	;; (1 . 2)

	(define (my-append ls1 ls2)
	(let rec ((ls (reverse ls1))(acc ls2))
	(if (null? ls)
	acc
	(rec (cdr ls)(cons (car ls) acc)))))

	(my-append '(1 2 3)'(a b c))
	;; (1 2 3 a b c)
	(my-append '() 'a)
	;; a
	(my-append '(1) 2)
	;; (1 . 2)


	(define (my-appends ls . lss)
	(fold (lambda (e acc)
	(my-append acc e)) '() (cons ls lss)))

	(my-append '(1 2 3)'(a b c))
	;; (1 2 3 a b c)
	(my-append '() 'a)
	;; a
	(my-append '(1) 2)
	;; (1 . 2)
	(my-appends '(1 2 3)'(4 5 6)'(7 8 9)'(10 11 12))
	;; (1 2 3 4 5 6 7 8 9 10 11 12)


	(define (my-appends ls . lss)
	(let rec ((ls (reverse (cons ls lss)))(acc '()))
	(if (null? ls)
	acc
	(rec (cdr ls)(my-append (car ls) acc)))))

	(my-append '(1 2 3)'(a b c))
	;; (1 2 3 a b c)
	(my-append '() 'a)
	;; a
	(my-append '(1) 2)
	;; (1 . 2)
	(my-appends '(1 2 3)'(4 5 6)'(7 8 9)'(10 11 12))
	;; (1 2 3 4 5 6 7 8 9 10 11 12)

view raw *scratch*.scm hosted with ❤ by GitHub

PAIP 3.1 「let*式と等価なlambda式を示せ」をマクロで・・・

掲題の通りの問題です。今さら手書きするのもあれなので、マクロ書いてエキスパンドすれば良いんじゃね？と思ってマクロ書きましたが、思ったよりエキスパンドしてくれませんでした・・・。

	;; PAIP excersise 3.1
	;; let*式と等価なラムダ式を示せ


	(define-syntax let*->lambda
	(syntax-rules ()
	((_ () body ...)
	(let ()
	body ...))
	((_ ((var val)) body ...)
	(let ((var val))
	body ...))
	((_ ((var1 val1)(var2 val2) ...) body ...)
	(let*->lambda ((var1 val1))
	(let*->lambda ((var2 val2) ...)
	body ...)))))

	(macroexpand '(let*->lambda ((a 10)(b a)(c (+ a b)))
	(print a b c)))
	;; (#<identifier user#let> ((a 10))
	;; (#<identifier user#let*->lambda> ((b a) (c (+ a b)))
	;; (print a b c)))


	(define-syntax let->lambda
	(syntax-rules ()
	((_ () body ...)
	((lambda ()
	body ...)))
	((_ ((var val)) body ...)
	((lambda (var)
	body ...) val))
	((_ ((var1 val1)(var2 val2) ...) body ...)
	(let->lambda ((var1 val1))
	(let->lambda ((var2 val2) ...)
	body ...)))))

	(macroexpand '(let->lambda ((a 10))
	(print a)))
	;; ((#<identifier user#lambda> (a)
	;; (print a)) 10)


	(define-syntax let*->lambda
	(syntax-rules ()
	((_ () body ...)
	(let->lambda ()
	body ...))
	((_ ((var val)) body ...)
	(let->lambda ((var val))
	body ...))
	((_ ((var1 val1)(var2 val2) ...) body ...)
	(let*->lambda ((var1 val1))
	(let*->lambda ((var2 val2) ...)
	body ...)))))

	(macroexpand '(let*->lambda ((a 10)(b a)(c (+ a b)))
	(print a b c)))

	;; ((#<identifier user#lambda> (a)
	;; (#<identifier user#let*->lambda> ((b a) (c (+ a b)))
	;; (print a b c))) 10)

view raw 3.1.scm hosted with ❤ by GitHub

PAIP Excersise 2.4

ほとんどさっき書いたやつでワロタ

vallog: PAIP 2.6

	(define (cross-product proc xls yls)
	(cross-combine xls yls proc))

	(define (combine-all xls yls)
	(cross-product append xls yls))

	(print (combine-all (map list '(a b c))(map list '(1 2 3))))
	;; ((a 1) (b 1) (c 1) (a 2) (b 2) (c 2) (a 3) (b 3) (c 3))

	(cross-product + '(1 2 3)'(10 20 30))
	;; (11 12 13 21 22 23 31 32 33)

	(cross-product list '(a b c d e f g h)'(1 2 3 4 5 6 7 8))
	;; ((a 1) (b 1) (c 1) (d 1) (e 1) (f 1) (g 1) (h 1)
	;; (a 2) (b 2) (c 2) (d 2) (e 2) (f 2) (g 2) (h 2)
	;; (a 3) (b 3) (c 3) (d 3) (e 3) (f 3) (g 3) (h 3)
	;; (a 4) (b 4) (c 4) (d 4) (e 4) (f 4) (g 4) (h 4)
	;; (a 5) (b 5) (c 5) (d 5) (e 5) (f 5) (g 5) (h 5)
	;; (a 6) (b 6) (c 6) (d 6) (e 6) (f 6) (g 6) (h 6)
	;; (a 7) (b 7) (c 7) (d 7) (e 7) (f 7) (g 7) (h 7)
	;; (a 8) (b 8) (c 8) (d 8) (e 8) (f 8) (g 8) (h 8))

view raw excesise-2.4.scm hosted with ❤ by GitHub

PAIP 2.6

どうもうまいこと書けない。。それに名前付けがいつも悪い。

	;; PAIP 2.6 P.41
	(define (combine-all xlis ylis)
	(mappend (lambda (y)
	(map (lambda (x)
	(append x y)) xlis))
	ylis))

	(print (combine-all (map list '(a b c))(map list '(1 2 3))))
	;; ((a 1) (b 1) (c 1) (a 2) (b 2) (c 2) (a 3) (b 3) (c 3))



	;; (cross-combine '(1 2 3)'(a b c))
	;; ((1 a) (2 a) (3 a) (1 b) (2 b) (3 b) (1 c) (2 c) (3 c))
	(define (cross-combine xlis ylis)
	(mappend (lambda (y)
	(map (lambda (x)
	(list x y)) xlis))
	ylis))


	;; (add-combine-elements (cross-combine '(1 2 3)'(a b c))
	;; '(100 200 300))
	;; ((1 a 100) (2 a 100) (3 a 100) (1 b 100) (2 b 100) (3 b 100) (1 c 100) (2 c 100) (3 c 100) (1 a 200) (2 a 200) (3 a 200) (1 b 200) (2 b 200) (3 b 200) (1 c 200) (2 c 200) (3 c 200) (1 a 300) (2 a 300) (3 a 300) (1 b 300) (2 b 300) (3 b 300) (1 c 300) (2 c 300) (3 c 300))
	(define (add-combine-elements comb elements)
	(mappend (lambda (c)
	(map (lambda (e)
	(append e (list c))) comb))
	elements))


	(define (cross-combine xls yls . opt)
	(let-optionals* opt ((kons list))
	(mappend (lambda (y)
	(map (lambda (x)
	(kons x y)) xls))
	yls)))


	(define (add-combine-elements comb elements)
	(cross-combine comb elements (lambda (e c)
	(append e (list c)))))


	(define (cross-combines ls1 ls2 . lss)
	(let rec ((lss lss)(comb (cross-combine ls1 ls2)))
	(if (null? lss)
	comb
	(rec (cdr lss)
	(add-combine-elements comb (car lss))))))


	;; (print (combine-all (map list '(a b c))(map list '(1 2 3))))
	;; ((a 1) (b 1) (c 1) (a 2) (b 2) (c 2) (a 3) (b 3) (c 3))
	(define (combine-all xlis ylis)
	(cross-combine xlis ylis append))


	(print (cross-combines '(a b c)'(1 2 3)'(100 200 300)))
	;; ((a 1 100) (b 1 100) (c 1 100)
	;; (a 2 100) (b 2 100) (c 2 100)
	;; (a 3 100) (b 3 100) (c 3 100)
	;; (a 1 200) (b 1 200) (c 1 200)
	;; (a 2 200) (b 2 200) (c 2 200)
	;; (a 3 200) (b 3 200) (c 3 200)
	;; (a 1 300) (b 1 300) (c 1 300)
	;; (a 2 300) (b 2 300) (c 2 300)
	;; (a 3 300) (b 3 300) (c 3 300))

	(print (cross-combines '(a b c)'(#f #t)'(1 2 3)'(100 200 300)))
	;; ((a #f 1 100) (b #f 1 100) (c #f 1 100)
	;; (a #t 1 100) (b #t 1 100) (c #t 1 100)
	;; (a #f 2 100) (b #f 2 100) (c #f 2 100)
	;; (a #t 2 100) (b #t 2 100) (c #t 2 100)
	;; (a #f 3 100) (b #f 3 100) (c #f 3 100)
	;; (a #t 3 100) (b #t 3 100) (c #t 3 100)
	;; (a #f 1 200) (b #f 1 200) (c #f 1 200)
	;; (a #t 1 200) (b #t 1 200) (c #t 1 200)
	;; (a #f 2 200) (b #f 2 200) (c #f 2 200)
	;; (a #t 2 200) (b #t 2 200) (c #t 2 200)
	;; (a #f 3 200) (b #f 3 200) (c #f 3 200)
	;; (a #t 3 200) (b #t 3 200) (c #t 3 200)
	;; (a #f 1 300) (b #f 1 300) (c #f 1 300)
	;; (a #t 1 300) (b #t 1 300) (c #t 1 300)
	;; (a #f 2 300) (b #f 2 300) (c #f 2 300)
	;; (a #t 2 300) (b #t 2 300) (c #t 2 300)
	;; (a #f 3 300) (b #f 3 300) (c #f 3 300)
	;; (a #t 3 300) (b #t 3 300) (c #t 3 300))

view raw 2.6.scm hosted with ❤ by GitHub

読むペースと書くペースが合わない。。どんどん先を読んで、後から書いて、2度読むことになってなんとも。。だがそれがいい。

2010/08/05

defmacro: def-related-closures

思いついたので書いた。後悔はしていない。必要ない気がする。

view raw def-related-closures.scm hosted with ❤ by GitHub

PAIP 2.2 でちょっとしたマクロ

PAIP（実用 Common Lisp (IT Architects’Archive CLASSIC MODER)）の当該箇所の本題とは無関係なのですが、マクロを書いたので晒しておきます。

以下コード。一番上が書籍に載っているもの。2, 3番目がマクロ。

	(use srfi-27)

	(define (sentence)
	(append (noun-phrase)(verb-phrase)))

	(define (noun-phrase)
	(append (Article)(Noun)))

	(define (verb-phrase)
	(append (Verb)(noun-phrase)))

	(define (Article)
	(one-of '(the a)))

	(define (Noun)
	(one-of '(man ball woman table)))

	(define (Verb)
	(one-of '(hit took saw liked)))

	(define (one-of set)
	(list (random-elt set)))

	(define (random-elt choices)
	(list-ref choices (random-integer (length choices))))

	(sentence)
	;; (a man liked a man)
	(sentence)
	;; (a table hit a ball)
	(sentence)
	;; (the woman took the woman)
	(sentence)
	;; (a table liked a table)
	(sentence)
	;; (the woman liked a table)

view raw PAIP-2.2-1.scm hosted with ❤ by GitHub

	(define-syntax def-phrase
	(syntax-rules ()
	((_ (name proc exp1 exp2 ...))
	(define (name)
	(proc exp1 exp2 ...)))
	((_ (name11 proc11 exp11 exp12 ...)
	(name21 proc21 exp21 exp22 ...) ...)
	(begin
	(def-phrase (name11 proc11 exp11 exp12 ...))
	(def-phrase (name21 proc21 exp21 exp22 ...) ...)))))

	(define-macro (def-choice name proc ls)
	(let ((varname (gensym)))
	(let ((varname (string->symbol #`",\|name\|s")))
	`(begin
	(define ,varname ,ls)
	(define (,name)
	(,proc ,varname))))))

	(define-syntax def-choices
	(syntax-rules ()
	((_ (name proc ls))
	(def-choice name proc ls))
	((_ (name1 proc1 ls1)(name2 proc2 ls2) ...)
	(begin
	(def-choices (name1 proc1 ls1))
	(def-choices (name2 proc2 ls2) ...)))))



	(define (one-of set)
	(list (random-elt set)))

	(define (random-elt choices)
	(list-ref choices (random-integer (length choices))))

	(def-phrase
	(sentence append (noun-phrase)(verb-phrase))
	(noun-phrase append (article)(noun))
	(verb-phrase append (verb)(noun-phrase)))

	(def-choices
	(article one-of '(the a))
	(noun one-of '(man ball woman table))
	(verb one-of '(hit took saw liked)))

	(sentence)
	;; (the man saw a table)
	(sentence)
	;; (a table liked the woman)
	(sentence)
	;; (the ball took a man)
	(sentence)
	;; (a table took the man)
	(sentence)
	;; (the man liked a table)



	(define (adj*)
	(if (= (random-integer 2) 0)
	'()
	(append (adj)(adj*))))

	(define (pp*)
	(if (random-elt '(#t #f))
	(append (pp)(pp*))
	'()))

	(def-phrase
	(noun-phrase append (article)(adj)(noun)(pp))
	(pp append (prep)(noun-phrase)))

	(def-choices
	(adj one-of '(big little blue green adiabatic))
	(prep one-of '(to in by with on)))

	(sentence)
	;; (a little blue little table took a adiabatic blue blue blue big table in the adiabatic little table in the little table on the green blue little table)
	(sentence)
	;; (a green woman took a little woman)
	(sentence)
	;; (the man by a little adiabatic man by the woman in the green ball hit the blue ball)

view raw PAIP-2.2-2.scm hosted with ❤ by GitHub

	(define-macro (def-choice name proc ls)
	(let ((varname (gensym))
	(valname (gensym)))
	(let1 varname (string->symbol #`",\|name\|s")
	`(begin
	(define-values (,name ,(string->symbol #`"push-,\|varname\|!"))
	(let1 ,varname ,ls
	(values (lambda ()
	(,proc ,varname))
	(lambda (,valname)
	(push! ,varname ,valname)))))))))

	(def-choice adj one-of '(big))
	(def-choice prep one-of '(to))

	(sentence)
	;; (the big man to the ball to a big big big big big woman to a big woman to the table to a big big man to a big big big table to a big big man to the table to the big man to a ball to a table to a man saw a big big big big woman)
	(sentence)
	;; (the big big ball to a man took a big man)


	(push-adjs! 'little)
	;; (little big)
	(push-adjs! 'blue)
	;; (blue little big)
	(push-adjs! 'red)
	;; (red blue little big)

	(sentence)
	;; (the blue man to the big table liked the little little table to the big little big big blue little table)
	(sentence)
	;; (a red little woman hit the red table to a table to the ball to the blue ball)


	(push-preps! 'by)
	;; (by to)
	(push-preps! 'in)
	;; (in by to)
	(push-preps! 'with)
	;; (with in by to)
	(push-preps! 'on)
	;; (on with in by to)


	(sentence)
	;; (the table saw a little ball)
	(sentence)
	;; (the big table to the little man saw a little ball on the big table in the ball)
	(sentence)
	;; (a little table hit the woman with a table with the red little woman by the red big ball to a ball by the red big big ball with the red table on the big blue red red ball)

view raw PAIP-2.2-3.scm hosted with ❤ by GitHub

私は On Lisp も LET OVER LAMBDA Edition 1.0 も読んだわけですが、"読んだ"だけで書けるようになったわけではありません。どうやら。書かないと書けるようにはならないでしょうね。両書籍も書きながら再読しないといけませんね。

ちなみに書籍は Common Lisp ですが、今のところ Scheme（Gauche）で書いています。
この分厚い書籍を携帯したり、電車の中で読むには勇気が要りますね。。今日から実行していますが。。

2010/08/04

「LISPにはscanlに該当する関数ってあるんでしょうか？」

指名ktkr!!力不足ですが、せっかくですので。

Haskellのscanl関数でフィボナッチ。 - このブログは証明できない。

ところで、LISPにはscanlに該当する関数ってあるんでしょうか？ > valvallowさん

正直わかりません、知りません、すみません。。Haskell 読めませんが、fold っぽいですね。取りあえず確認がてら同じようなものをでっち上げてみます。遅延評価でもなく Gauche 依存ですけれども。以下コード。

	;; Prelude> scanl (+) 0 []
	;; [0]
	;; Prelude> scanl (+) 0 [1]
	;; [0,1]
	;; Prelude> scanl (+) 0 [1,2]
	;; [0,1,3]
	;; Prelude> scanl (+) 0 [1..10]
	;; [0,1,3,6,10,15,21,28,36,45,55]

	;; (scanl + 0 '())
	;; (0)
	;; (scanl + 0 '(1))
	;; (0 1)
	;; (scanl + 0 '(1 2))
	;; (0 1 3)
	;; (scanl + 0 (iota 10 1))
	;; (0 1 3 6 10 15 21 28 36 45 55)

	(use srfi-1)
	(use srfi-8)
	(use gauche.collection)

	(define (scanl proc seed ls)
	(receive (n l)
	(fold2 (lambda (ele acc-n acc-l)
	(let1 n (proc ele acc-n)
	(values n (cons n acc-l))))
	seed (cons seed '()) ls)
	(reverse l)))

	(scanl + 0 '())
	;; (0)
	(scanl + 0 '(1))
	;; (0 1)
	(scanl + 0 '(1 2))
	;; (0 1 3)
	(scanl + 0 (iota 10 1))
	;; (0 1 3 6 10 15 21 28 36 45 55)

view raw scanl.scm hosted with ❤ by GitHub

非常にカッコ悪いですね・・・。なんでこんなに難しそうになるわけ・・・。

素直に named-let で書いた方がよかったみたいです。

	(define (scanl p s ls)
	(let rec ((ls (cons s ls))(accn s)(accl '()))
	(if (null? ls)
	(reverse accl)
	(let1 n (p (car ls) accn)
	(rec (cdr ls) n (cons n accl))))))

	(scanl + 0 '())
	;; (0)
	(scanl + 0 '(1))
	;; (0 1)
	(scanl + 0 '(1 2))
	;; (0 1 3)
	(scanl + 0 (iota 10 1))
	;; (0 1 3 6 10 15 21 28 36 45 55)

view raw scanl2.scm hosted with ❤ by GitHub

きっと R5RS の範囲の Scheme にはないんじゃないでしょうか。たぶん R6RS にも。srfi か Common Lisp にはあるかも？教えてエロい人！

追記

そうか。fold2 で書くにしても、こうすれば receive 取れて少しマシか。

	(use srfi-1)
	(use srfi-8)
	(use gauche.collection)

	(define (scanl proc seed ls)
	(reverse
	(fold2 (lambda (ele acc-l acc-n)
	(let1 n (proc ele acc-n)
	(values (cons n acc-l) n)))
	(cons seed '()) seed ls)))

	(scanl + 0 '())
	;; (0)
	(scanl + 0 '(1))
	;; (0 1)
	(scanl + 0 '(1 2))
	;; (0 1 3)
	(scanl + 0 (iota 10 1))
	;; (0 1 3 6 10 15 21 28 36 45 55)

view raw scanl3.scm hosted with ❤ by GitHub

追記2

毎度のことながら教えていただきました！

Twitter / SaitoAtsushi: @valvallow (use gauche.col ...

@valvallow (use gauche.collection)(define (scanl f x xs)(values-ref (map-accum (^(a acc)(let1 z (f a acc) (values z z))) x xs) 0))

なるほど、map-accum ですかー！ちょっと写経。

	;; https://twitter.com/SaitoAtsushi/statuses/20302777187

	(use gauche.collection)
	(define (scanl f s ls)
	(values-ref (map-accum (lambda (e acc)
	(let1 n (f e acc)
	(values n n))) s (cons s ls)) 0))
	(scanl + 0 '())
	;; (0)
	(scanl + 0 '(1))
	;; (0 1)
	(scanl + 0 '(1 2))
	;; (0 1 3)
	(scanl + 0 (iota 10 1))
	;; (0 1 3 6 10 15 21 28 36 45 55)

view raw scanl4.scm hosted with ❤ by GitHub

values-ref ってのもあるのか。

Gauche ユーザリファレンス: 9.3 gauche.collection - コレクションフレームワーク

追記3

Clojure で書いてる人がいらっしゃる。

Clojureでscanl - maoeのブログ

追記4

遅延評価だとこんな感じ？いや、良くわかりませんが・・・。

	(use util.stream)

	(define (scanl p s ls)
	(let rec ((ls (stream-cons s (list->stream ls)))
	(accn s)
	(accl (list->stream '())))
	(if (stream-null? ls)
	(stream-reverse accl)
	(let1 n (p (stream-car ls) accn)
	(rec (stream-cdr ls) n (stream-cons n accl))))))

	(stream->list (stream-take (scanl + 0 '()) 1))
	;; (0)
	(stream->list (stream-take (scanl + 0 '(1)) 2))
	;; (0 1)
	(stream->list (stream-take (scanl + 0 '(1 2)) 3))
	;; (0 1 3)
	(stream->list (stream-take-while (pa$ > 1000)
	(scanl + 0 (iota 1000 1))))
	;; (0 1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136 153 171 190 210 231 253 276 300 325 351 378 406 435 465 496 528 561 595 630 666 703 741 780 820 861 903 946 990)
	(stream->list (stream-filter (lambda (n)
	(and (< 5000 n)
	(< n 10000)))
	(scanl + 0 (iota 10000 1))))
	;; (5050 5151 5253 5356 5460 5565 5671 5778 5886 5995 6105 6216 6328 6441 6555 6670 6786 6903 7021 7140 7260 7381 7503 7626 7750 7875 8001 8128 8256 8385 8515 8646 8778 8911 9045 9180 9316 9453 9591 9730 9870)

view raw scanl5.scm hosted with ❤ by GitHub

Gauche ユーザリファレンス: 11.53 util.stream - ストリームライブラリ

追記5

また教えていただきました！ですが、マニュアル見ても iterator->stream がよくわかりません。。

@valvallow (use srfi-1)(use util.stream)(define(scanl f x xs)(iterator->stream(lambda(n e)(until(null? xs)(n x)(set! x(f x(pop! xs))))(e))))

@valvallow (use srfi-1)(use util.stream)(define(scanl f x xs)(iterator->stream(lambda(n e)(until(null? xs)(n x)(set! x(f x(pop! xs))))(e))))

せっかくなので、インデント付けて gist に貼っつけました。

	;; @valvallow (use srfi-1)(use util.stream)(define(scanl f x xs)(iterator->stream(lambda(n e)(until(null? xs)(n x)(set! x(f x(pop! xs))))(e)))) - https://twitter.com/SaitoAtsushi/statuses/20372687335

	(use srfi-1)
	(use util.stream)
	(define (scanl f x xs)
	(iterator->stream (lambda (n e)
	(until (null? xs)
	(n x)
	(set! x (f x (pop! xs))))
	(e))))

view raw scanl6.scm hosted with ❤ by GitHub

登録: 投稿 (Atom)

	(define-macro (def-related-closures var-binds . proc-binds)
	`(define-values ,(map car proc-binds)
	(let ,var-binds
	(values ,@(map cadr proc-binds)))))

	(def-related-closures ((count 0)(step 1))
	(inc (lambda ()
	(set! count (+ count step))))
	(dec (lambda ()
	(set! count (- count step))))
	(reset (lambda ()
	(set! count 0))))

	(map (lambda (e)
	(e))
	(list inc inc inc dec reset dec dec reset))
	;; (1 2 3 2 0 -1 -2 0)