teranishi
rubyから移ってきました。よろしくお願いします。
combinationsの高速化
util.combinationsのcombinationsを高速化してみました。 nが1の場合と、nがsetの長さと同じ場合を特殊処理して速度を稼いでいます。
(use srfi-1) (define (combinations set n) (define (rec set tail) (cond [(null? tail) (list set)] [(eq? (cdr set) tail) (map list set)] [else (fold-right (cut acons (car set) <> <>) (rec (cdr set) (cdr tail)) (rec (cdr set) tail))])) (cond [(not (positive? n)) (list '())] [(list-tail set n #f) => (pa$ rec set)] [else '()]))
- Shiro(2011/02/10 17:59:50 PST): む、これいいですね。頂きます。
;; util.combinations版 gosh> (time (length (combinations '(a b c d e f g h i j k l m n o p q r s t u) 10))) ;(time (length (combinations '(a b c d e f g h i j k l m n o p q r s t u ... ; real 6.351 ; user 6.310 ; sys 0.040 352716 ;; 高速版 gosh> (time (length (combinations. '(a b c d e f g h i j k l m n o p q r s t u) 10))) ;(time (length (combinations. '(a b c d e f g h i j k l m n o p q r s t ... ; real 1.235 ; user 1.210 ; sys 0.020 352716
Scheme:戻り値のスプライシング
今更ですが、戻り値のスプライシングを常に行う必要は無いのではないかと 思い、以下のようなものを作りました。
(define-syntax splice (syntax-rules () ((_ func (fcall ...)) (call-with-values (lambda () (fcall ...)) func)) ((_ func args ...) (splice-iter func () args ...)))) (define-syntax splice-iter (syntax-rules () ((_ func (quoted ...)) (apply func `(quoted ...))) ((_ func (quoted ...) (fcall ...) args ...) (splice-iter func (quoted ... ,@(receive lst (fcall ...) lst)) args ...)) ((_ func (quoted ...) arg args ...) (splice-iter func (quoted ... ,arg) args ...))))
使用例
gosh> (splice + (values 1 2 3)) 6 gosh> (splice + (values 1 2 3) (values 4 5 6)) 21
要するに、GaucheRefj:cutのようなインタフェースで、 先頭に splice をつけた時だけスプライシングしようということです。
既に誰かが同じような事を考えていたらすみません。
今日の一行 木の復元
また後出しですが、木の復元を。 木をたどる順番の変更を、評価順の入れ替えのみで行うようにした結果、 自分でも訳が分からないコードになってしまいました。 (2006/03/20 21:57:27 PST)
(use srfi-42) (define make-leaf values) (define make-branch list) (define (make-all-branch e left right) (list-ec (: l left) (: r right) (make-branch e l r))) (define (traverse-rev order lst) (let loop ((n (length lst))) (if (= n 1) (list (make-leaf (pop! lst))) (append-ec (:let lst-backup lst) (: pos 1 (- n 1) 2) (begin (set! lst lst-backup)) (case order ((pre) (let* ((e (pop! lst)) (left (loop pos)) (right (loop (- n pos 1)))) (make-all-branch e left right))) ((in) (let* ((left (loop pos)) (e (pop! lst)) (right (loop (- n pos 1)))) (make-all-branch e left right))) ((post) (let* ((left (loop pos)) (right (loop (- n pos 1))) (e (pop! lst))) (make-all-branch e left right))))))))
AA折れ線グラフ
ほとんどShiroさんのコードのパクリですが、せっかく作ったので貼っておきます。
zipperを使うことで、縦軸の最大、最小を調べずに済ませています。(2006/03/15 06:20:00 PST)
- fold-with-index の存在に気付いたので修正 (2006/03/16 00:43:34 PST)
- 最後がRだと表示されないバグに暫定対応(2006/03/16 09:00:29 PST)
(use srfi-1) (use gauche.sequence) (define (circular-zipper elt) (let1 lst (circular-list elt) (cons lst lst))) (define (prev zipper) (list* (cdar zipper) (caar zipper) (cdr zipper))) (define (next zipper) (acons (cadr zipper) (car zipper) (cddr zipper))) (define (modify proc zipper) (list* (car zipper) (proc (cadr zipper)) (cddr zipper))) (define (take-while-zipper pred zipper) (append-reverse! (take-while pred (cons (cadr zipper) (car zipper))) (take-while pred (cddr zipper)))) (define (graph input) (define (input->zipper input) (fold-with-index (lambda (index char zipper) (case char ((#\R) (prev (modify (pa$ acons index #\/) zipper))) ((#\F) (modify (pa$ acons index #\\ ) (next zipper))) ((#\C) (modify (pa$ acons index #\_) zipper)))) (circular-zipper '()) input)) (define (draw-row alist) (for-each (lambda (prev curr) (format #t "~v@a" (- (car curr) (car prev)) (cdr curr))) (acons -1 #f alist) alist) (newline)) (for-each (lambda (alist) (draw-row (reverse alist))) (take-while-zipper pair? (input->zipper input)))) (define (main args) (graph (cadr args)))
さらに IO Monad について
IO Monad がわかりづらいのは、通常の言語と制御の流れが逆になるからではないでしょうか。
通常の言語で、標準入力から文字を読む場合の流れは、こんな感じでしょう。
- ユーザプログラムで、文字を読み込む関数を呼ぶ
- システムが、標準入力から文字を拾ってくる
- 入力された文字が、関数の戻り値として返される
- ユーザプログラムで、戻り値を使用して計算を続ける
IO Monad を使うと、この流れが以下のようになります。
- ユーザプログラムから、文字を読み込むコマンドがシステムに戻り値として返される
- システムが、そのコマンドに従い、標準入力から文字を拾ってくる
- 入力された文字が、次の関数の引数として渡される
- ユーザプログラムで、渡された引数を使用して計算を続ける
この流れに近いのは、実は CGI なのかも知れません。
- CGI のプログラムから、データ入力用のHTMLがブラウザに返される
- ブラウザが、ユーザから入力を受けつける
- ユーザからの入力が、次の CGI にパラメータとして渡される
- CGI のプログラムで、その入力を受け取り、新たなページを生成する
・・・Schemeと関係ない話題で申し訳ないです。
IO Monad
IO Monad の Scheme での実装として、以下のようなものを考えました。
(define (ret x) `((*ret* ,x))) (define (mread) '((*read*))) (define (mwrite x) `((*write* ,x))) (define (>>= m f) (append m (list f))) (define (runIO cmds) (let ((cmd (car cmds)) (funcs (cdr cmds))) (let1 result (runCmd cmd) (if (null? funcs) 'done (let1 next-cmds ((car funcs) result) (runIO (append next-cmds (cdr funcs)))))))) (define (runCmd cmd) (case (car cmd) ((*ret*) (cadr cmd)) ((*read*) (read)) ((*write*) (write (cadr cmd))))) (define (inc x) (ret (+ x 1))) (define (sqr x) (ret (* x x))) (define hs-main (>>= (>>= (>>= (mread) inc) sqr) mwrite)) (runIO hs-main)
(mread が毎回同じ値を返す事と、hs-main 自体には副作用が無い事が表現できていると思います)
IO Monad を単なるアクションの組合せと見なせば、 そのアクションを動的にくみ上げていく感覚が分かりやすいのではないでしょうか。
(2005/05/26 20:17:33 PDT追記) これって単に、2chのHaskellスレの 501 を焼き直しただけですね。今ごろ気付きました。
(2005/11/09 19:17:02 PST) 私が IO Monad に対して持っているイメージを反映するように修正。 上のプログラムにおける IO Monad の実体はリストであり、先頭要素がアクション、 2番目以降の要素は前のアクションの結果を受け取ってアクションを返す関数になっている。
- Monadが未だ理解できてなくて迷走中ですが、Monadic Programmingが「イイ感じ」 なのってどんな場面なんでしょ?>みなさんcut-sea:2005/04/20 16:29:59 PDT
- こういうことは Haskell な方に聞いたほうがいいかも。
Scheme だと Monad を使わなくても何とかなってしまうので。
teranishi:2005/04/20 20:50:42 PDT
Monad Scheme での代替手段 Maybe Nothing を #f にして and-let* などを使う Error 例外処理 List call/cc を使った非決定性演算? IO 評価順が決まっているので必要なし State グローバル変数 Reader fluid-let Writer グローバル変数 Continuation call/cc
- IO Monad は単なるアクションなので、リスト上にアクション列を作っておけば、
リストの操作で実行順を制御できるのが面白いかもしれません。
例えば、カンマ区切りで出力したい場合に、
それぞれの要素を出力するアクションのリストに
カンマを出力するアクションを挟み込んで実行する、みたいなことができます。
・・・でも、これは Monad だから、というわけではないですね。
teranishi:2005/04/24 01:06:51 PDT
(use srfi-1) (use util.list) (define (ret x) (list '*ret* x)) (define (>>= m f) (list '*>>=* m f)) (define (mdisplay x) (list '*display* x)) (define (runIO cmd) (case (car cmd) ((*ret*) (cadr cmd)) ((*>>=*) (runIO ((caddr cmd) (runIO (cadr cmd))))) ((*display*) (display (cadr cmd))))) (define (>> m n) (>>= m (lambda (_) n))) (define (sequence_ lst) (fold-right >> (ret '()) lst)) (define hs-main (>> (sequence_ (intersperse (mdisplay ", ") (map mdisplay '(1 2 3 4 5)))) (mdisplay "\n"))) (runIO hs-main)
every*
引数の長さが異なる場合には #f を返す GaucheRefj:every が必要だが、 eq? との整合性が無いので GaucheRefj:list= が使えない場合に、 この関数が使えると思います。 (例えば、下の「式の比較」の「equal-expr-list?」)
この関数がライブラリに無いのは、あまり需要が無いからでしょうか。
(define (every* pred . args) (if (any null? args) (every null? args) (and (apply pred (map car args)) (apply every* pred (map cdr args)))))
Monad
haskell-jp MLのアーカイブをのぞいたら、cut-seaさんが訳した Monadic Programming in Schemeを見つけました。 面白かったので、最後の例のプログラムをGaucheで実装してみました。
(define-module Monad (extend util.match) (export-all) (define-macro (>> m1 m2) `(>>= ,m1 (lambda (,(gensym)) ,m2))) (define fail error) (define-macro (letM binding expr) (match binding (((pat initializer)) `(>>= ,initializer ,(if (symbol? pat) `(lambda (,pat) ,expr) `(match-lambda (,pat ,expr) (_ (fail "nomatch")))))))) (define-macro (letM* bindings expr) (match bindings ((binding) `(letM (,binding) ,expr)) ((binding rest ...) `(letM (,binding) (letM* ,rest ,expr))))) (define-macro (beginM . body) (match body ((expr) expr) ((expr rest ...) `(>> ,expr (beginM ,@rest))))) (define-macro (with-monad monad . body) `(let ((return (with-module ,monad return)) (>>= (with-module ,monad >>=)) (fail (with-module ,monad fail))) ,@body)) ) (define-module IO (extend Monad) (export return >>= read-int put-line runIO) (define *command-table* (make-hash-table 'eq?)) (define-syntax define-command (syntax-rules () ((_ (func args ...) body ...) (begin (hash-table-put! *command-table* 'func (lambda (args ...) body ...)) (define (func args ...) (list 'func args ...)))))) (define-command (return a) a) (define-command (>>= m f) (runIO (f (runIO m)))) (define-command (read-int) (read)) (define-command (put-line s) (display s) (newline)) (define (runIO cmd) (apply (hash-table-get *command-table* (car cmd)) (cdr cmd))) ) (define-module List (use srfi-1) (extend Monad) (export-all) (define (return a) (list a)) (define (>>= m f) (append-map f m)) (define (fail _) ()) ) (import List) (import IO) (use srfi-1) (define f (beginM (put-line "Enter a number: ") (letM* ((n (read-int)) (all-n (return (iota n 1))) (evens (return (with-monad List (letM* ((i all-n) (#t (return (even? i)))) (return i))))) ) (return evens)))) (define (main args) (runIO (letM ((r f)) (put-line (write-to-string r)))))
モジュールの依存関係がうまくいかなかったので、define-macro でごまかしてます。 そのため、>> などを個々のモナドで上書きする事ができなくなってしまいました。
- それぞれの具体的なモナドを class にして、>>= をジェネリック関数にする
というのはどうでしょう。--nobsun
- return がジェネリックでかけねぇ。orz
- 私も、最初は class で書こうとしましたが、return が書けない事に気づき挫折。
(戻り値の型で適用する関数を選択するなど、型推論なしには無理臭い)
次に、return や >>= をモジュールで定義して with-module で使い分けようとしましたが、 トップレベルで定義した関数が with-module 内で直接見えないので使いづらい。
結局、元のコードと同じく let を使う方法で妥協しました。
ruby の Mix-in みたいな事をやるには、どうすればいいのでしょう。
(2005/04/19 21:57:37 PDT) IO モナドが実際には Continuation モナドだったので、 もうすこし IO モナドっぽく書き換えました。
Shiro(2005/08/14 20:44:24 PDT) こんなん考えてみました→Scheme:ExplicitMonad
rxmatch-fold
webstealでこのパターンを使っていたので、regexp-replace-all のソースから 該当部分を引っ張ってきました。
(define (rxmatch-fold kons knil regexp str) (cond ((and (not (equal? str "")) (regexp str)) => (lambda (match) (when (= (rxmatch-start match) (rxmatch-end match)) (error "rxmatch-fold: matching zero-length string causes infinite loop:" rx)) (rxmatch-fold kons (kons match knil) regexp (rxmatch-after match)))) (else knil)))
一つの文字列に連続してある正規表現をマッチさせていく時、 regexp-replace-all のように結果を文字列として埋め込むのではなく、 単にマッチ結果を使いたいだけという状況は結構あるんじゃないでしょうか。
- 横道それちゃいますけど、こういう kons/knil を用いる抽象化って
知ってはいるのに、なかなか自分では出来なかったりします。
gosh> (rxmatch-fold cons '() #/def/i "abcdefghijklmnDEFGHI") (#<<regmatch> 0x81132a0> #<<regmatch> 0x81132b8>) gosh> (rxmatch-fold (lambda (m n) (+ n 1)) 0 #/def/i "abcdefghijklmnDEFGHIxyzdefDEF") 4 gosh> (rxmatch-fold (lambda (m n) #`",n,(m 0)") "" #/def/i "abcdefghijklmnDEFGHIxyzdefDEF") "defDEFdefDEF" gosh> (rxmatch-fold (lambda (m n) #`",n,(m 'before)") "" #/def/i "abcdefghijklmnDEFGHIxyzdefDEF") "abcghijklmnGHIxyz" gosh>
結果を蓄積する fold like な処理を見掛けたら、 一考するってクセをつけないとダメかな。cut-sea:2004/10/15 17:40:40 PDT
相対URIから絶対URIへの変換
webstealのソースを見ていて唐突に書きたくなったので。 しかし、rfc.uriモジュールにそれっぽいコメントがあるのに実体がないのが気になります。
(use srfi-11) (use srfi-13) (use file.util) (use rfc.uri) (define (uri-relative->absolute uri base) (let*-values (((scheme specific) (uri-scheme&specific uri)) ((authority path query fragment) (uri-decompose-hierarchical specific)) ((base-scheme base-specific) (uri-scheme&specific base)) ((base-authority base-path . _) (uri-decompose-hierarchical base-specific))) (if (or (and (string-null? path) (not (or scheme authority query))) scheme) uri (uri-compose :scheme base-scheme :authority (or authority base-authority) :path (if (or authority (string-prefix? "/" path)) path (simplify-path (string-append (string-trim-right base-path #[^/]) path))) :query query :fragment fragment))))
このコードですが、実際にRFC2396にある例を使ってテストすると、 いくつか引っかかります。
discrepancies found. Errors are: test //g: expects "http://g" => got "http://g/" test .: expects "http://a/b/c/" => got "http://a/b/c/." test ./g/.: expects "http://a/b/c/g/" => got "http://a/b/c/g/."
uri-composeがpathの前に'/'を補うのと、 simplify-pathが最後の'.'を除去しないのが原因のようです。
macroexpandの参照する環境
macroexpandが参照する環境は何でしょうか。with-moduleで影響を受けないようなので、カレントモジュールではないようですが・・・
gosh> (define push! list) push! gosh> (with-module gauche (macroexpand '(push! x 1))) (push! x 1) gosh> (select-module gauche) #<module gauche> gosh> (macroexpand '(push! x 1)) (#<id 0x113d60 gauche::set!> x (#<id 0x113d10 gauche::cons> 1 x))
- Shiro: 実行時のカレントモジュールです。macroexpandは手続きなので、 コンパイル時のモジュールを知ることができません (with-moduleはコンパイル時 のみに作用する構文なので、(with-module gauche (macroexpand '(push! x 1))) では macroexpand の名前解決にのみ影響を与えます。コンパイル後に、元の モジュール内にで、macroexpandの呼び出しが行われます)。
- コンパイル時の環境を考慮するものとして、%macroexpandという構文が
用意されています。
gosh> (with-module gauche (%macroexpand (push! a b))) (#<id 0x8137620 gauche::set!> a (#<id 0x81375d0 gauche::cons> b a))
%macroexpandはローカルな環境も考慮するので、let-syntax等による ローカルマクロも展開できます。 - コンパイル時と実行時のモジュールの分離はわかりにくくはあるのですが、
一致させようとすると実行に非常に大きなペナルティを伴うのです。 Gaucheのゴールは「スクリプトエンジン」ですので、バッチでスクリプトを がりがり実行する際に余分な負担となるものは入れない方針です。
- あ、でも、 macroexpandがオプショナルでモジュールを取るようにすることはできますね、 考えてみたら。
- teranishi: 分かりやすい説明、ありがとうございます。コンパイル時と実行時で使われるモジュールが異なる場合がある事を初めて知りました。
vectorの展開
ベクターがクォートなしでマクロ内に現れた場合、展開後にIdentifierが残ってしまいます。
gosh> (define-syntax foo (syntax-rules () ((_) #(a b)))) #<syntax foo> gosh> (foo) #(#<id 0xee270 user::a> #<id 0xee230 user::b>)
R5RSによると、ベクターはクォートなしで現れてはいけないらしいので、バグとは言い切れないかもしれませんが・・・
式の比較
2つの式のマクロをすべて展開し、変数の名前を変えて、等しくなるかを調べる関数。
マクロ展開のテストケースを書くのに使えると思います。
すでに同様のものを誰かが書いているような気がしますが・・・
- マクロの展開結果がリストにならない場合にエラーになるバグの修正(2004/12/20 13:16:44 PST)
- eq? なリストを比較すると必ず #t になってしまうバグの修正(2005/03/13 06:44:09 PST)
(define-module equal-expr (use srfi-1) (use util.match) (use util.list) (export equal-expr?)) (select-module equal-expr) (define equal-table (make-hash-table)) (define id? (any-pred symbol? identifier?)) (define (valid-args? args) (or (null? args) (id? args) (and (pair? args) (id? (car args)) (valid-args? (cdr args))))) (define (flatten tree) (let loop ((tree tree) (result ())) (cond ((null? tree) result) ((pair? tree) (loop (car tree) (loop (cdr tree) result))) (else (cons tree result))))) (define (macroexpand-unbound bound? expr) (if (or (not-pair? expr) (bound? (car expr))) expr (let ((expanded (macroexpand-1 expr))) (if (eq? expr expanded) expr (macroexpand-unbound bound? expanded))))) (define (collect-internal-define bound? body) (let loop ((tail body) (head ()) (local-bound ())) (if (null? tail) (values (reverse head) local-bound #f) (let ((expanded (macroexpand-unbound bound? (car tail)))) (if (or (not-pair? expanded) (pair? (car expanded)) (bound? (car expanded))) (values (append-reverse head tail) local-bound #t) (case (unwrap-syntax (car expanded)) ((define) (match (cdr expanded) ((or ((? id? var) _) (((? id? var) . _) _ ..1)) (loop (cdr tail) (cons expanded head) (cons var local-bound))))) ((begin) (receive (rest new-local-bound term?) (loop (cdr expanded) () local-bound) (let ((new-begin (cons (car expanded) rest))) (if term? (values (append-reverse head (cons new-begin (cdr tail))) new-local-bound #t) (loop (cdr tail) (cons new-begin head) new-local-bound))))) (else (values (append-reverse head tail) local-bound #t)))))))) (define (eq-unwrap? expr1 expr2) (eq? (unwrap-syntax expr1) (unwrap-syntax expr2))) (define (equal-unwrap? expr1 expr2) (equal? (unwrap-syntax expr1) (unwrap-syntax expr2))) (define (same-args-pattern? args1 args2) (or (and (not-pair? args1) (not-pair? args2) (eq? (null? args1) (null? args2))) (and (pair? args1) (pair? args2) (same-args-pattern? (cdr args1) (cdr args2))))) (define (%equal-expr? subst expr1 expr2) (cond ((and (id? expr1) (id? expr2)) (cond ((assq-ref subst expr1) => (pa$ eq? expr2)) (else (and (not (rassq expr2 subst)) (eq-unwrap? expr1 expr2))))) ((and (pair? expr1) (pair? expr2)) (let ((expanded1 (macroexpand-unbound (cut assq <> subst) expr1)) (expanded2 (macroexpand-unbound (cut rassq <> subst) expr2))) (cond ((and (pair? expanded1) (pair? expanded2) (id? (car expanded1)) (id? (car expanded2)) (not (assq (car expanded1) subst)) (not (rassq (car expanded2) subst)) (eq-unwrap? (car expanded1) (car expanded2)) (hash-table-get equal-table (unwrap-syntax (car expanded1)) #f)) => (cut <> subst (cdr expanded1) (cdr expanded2))) (else (equal-expr-list? subst expanded1 expanded2))))) (else (equal-unwrap? expr1 expr2)))) (define (every* pred . args) (if (any null? args) (every null? args) (and (apply pred (map car args)) (apply every* pred (map cdr args))))) (define (equal-expr-list? subst lst1 lst2) (every* (pa$ %equal-expr? subst) lst1 lst2)) (define (equal-expr-rest? subst rest1 rest2) (every* (pa$ equal-expr-list? subst) rest1 rest2)) (define (equal-expr-body? subst body1 body2) (receive (new-body1 vars1 _) (collect-internal-define (cut assq <> subst) body1) (receive (new-body2 vars2 _) (collect-internal-define (cut rassq <> subst) body2) (equal-expr-list? (fold acons subst vars1 vars2) new-body1 new-body2)))) (define equal-expr? (pa$ %equal-expr? ())) (hash-table-put! equal-table 'quote (lambda (subst rest1 rest2) (equal-unwrap? rest1 rest2))) (hash-table-put! equal-table 'quasiquote (lambda (subst rest1 rest2) (let loop ((depth 0) (expr1 (car rest1)) (expr2 (car rest2))) (cond ((or (not-pair? expr1) (not-pair? expr2)) (equal-unwrap? expr1 expr2)) ((and (id? (car expr1)) (id? (car expr2)) (eq-unwrap? (car expr1) (car expr2))) (case (unwrap-syntax (car expr1)) ((quasiquote) (loop (+ depth 1) (cadr expr1) (cadr expr2))) ((unquote unquote-splicing) (if (zero? depth) (%equal-expr? subst (cadr expr1) (cadr expr2)) (loop (- depth 1) (cadr expr1) (cadr expr2)))) (else (loop depth (cdr expr1) (cdr expr2))))) (else (and (loop depth (car expr1) (car expr2)) (loop depth (cdr expr1) (cdr expr2)))))))) (hash-table-put! equal-table 'cond (lambda (subst rest1 rest2) (match rest1 (((clause1 ..1) ..1) (match rest2 (((clause2 ..1) ..1) (equal-expr-rest? subst clause1 clause2))))))) (hash-table-put! equal-table 'case (lambda (subst rest1 rest2) (match rest1 ((key1 (datum1 rest1 ..1) ..1) (match rest2 ((key2 (datum2 rest2 ..1) ..1) (and (%equal-expr? subst key1 key2) (equal-unwrap? datum1 datum2) (equal-expr-rest? subst rest1 rest2)))))))) (hash-table-put! equal-table 'let (lambda (subst rest1 rest2) (match rest1 (((((? id? vars1) vals1) ...) body1 ...) (match rest2 (((((? id? vars2) vals2) ...) body2 ...) (and (equal-expr-list? subst vals1 vals2) (equal-expr-body? (fold acons subst vars1 vars2) body1 body2))) (_ #f))) (((? id? func1) (((? id? vars1) vals1) ...) body1 ..1) (match rest2 (((? id? func2) (((? id? vars2) vals2) ...) body2 ..1) (and (equal-expr-list? subst vals1 vals2) (equal-expr-body? (acons func1 func2 (fold acons subst vars1 vars2)) body1 body2))) (_ #f)))))) (hash-table-put! equal-table 'lambda (lambda (subst rest1 rest2) (match rest1 (((? valid-args? args1) body1 ..1) (match rest2 (((? valid-args? args2) body2 ..1) (and (same-args-pattern? args1 args2) (equal-expr-body? (fold acons subst (flatten args1) (flatten args2)) body1 body2)))))))) (hash-table-put! equal-table 'define (lambda (subst rest1 rest2) (match rest1 (((? id? var1) val1) (match rest2 (((? id? var2) val2) (and (%equal-expr? subst var1 var2) (%equal-expr? subst val1 val2))) (_ #f))) (((func1 . (? valid-args? args1)) body1 ..1) (match rest2 (((func2 . (? valid-args? args2)) body2 ..1) (and (same-args-pattern? args1 args2) (%equal-expr? subst func1 func2) (equal-expr-body? (fold acons subst (flatten args1) (flatten args2)) body1 body2))) (_ #f)))))) (hash-table-put! equal-table 'let* (lambda (subst rest1 rest2) (match rest1 (((((? id? vars1) vals1) ...) body1 ...) (match rest2 (((((? id? vars2) vals2) ...) body2 ...) (let loop ((subst subst) (vars1 vars1) (vars2 vars2) (vals1 vals1) (vals2 vals2)) (or (and (null? vars1) (null? vars2) (equal-expr-body? subst body1 body2)) (and (pair? vars1) (pair? vars2) (%equal-expr? subst (car vals1) (car vals2)) (loop (acons (car vars1) (car vars2) subst) (cdr vars1) (cdr vars2) (cdr vals1) (cdr vals2))))))))))) (hash-table-put! equal-table 'letrec (lambda (subst rest1 rest2) (match rest1 (((((? id? vars1) vals1) ...) body1 ...) (match rest2 (((((? id? vars2) vals2) ...) body2 ...) (let ((new-subst (fold acons subst vars1 vars2))) (and (equal-expr-list? new-subst vals1 vals2) (equal-expr-body? new-subst vals1 vals2))))))))) (hash-table-put! equal-table 'do (lambda (subst rest1 rest2) (match rest1 (((((? id? vars1) inits1 updates1 ...) ...) (test1 ..1) body1 ...) (match rest2 (((((? id? vars2) inits2 updates2 ...) ...) (test2 ..1) body2 ...) (let ((new-subst (fold acons subst vars1 vars2))) (and (equal-expr-list? subst inits1 inits2) (equal-expr-rest? new-subst updates1 updates2) (equal-expr-list? new-subst test1 test2) (equal-expr-body? new-subst body1 body2))))))))) (hash-table-put! equal-table 'receive (lambda (subst rest1 rest2) (match rest1 (((? valid-args? args1) expr1 body1 ..1) (match rest2 (((? valid-args? args2) expr2 body2 ..1) (and (same-args-pattern? args1 args2) (%equal-expr? subst expr1 expr2) (equal-expr-body? (fold acons subst (flatten args1) (flatten args2)) body1 body2)))))))) (provide "equal-expr")
使用例
gosh> (equal-expr? '(let ((val val)) (set! val (cdr val)) (car val)) '(pop! val)) #f gosh> (equal-expr? '(let ((x val)) (set! val (cdr x)) (car x)) '(pop! val)) #t
多値と一時変数
多値は便利なのですが、多値を使うために一時変数を使わざるを得ないのが個人的には面倒です。
一時変数は、同じ値が複数の場所で使われる場合や、式が複雑になりすぎて分割したい場合にしか必要性を感じないのに、多値が出てくるとそれだけで変数名を考えなければならなくなります。
もう少し、一時変数を介さずに使える多値の関数が欲しいですね。
使いどころが限られるものしか作れないかもしれませんが。
Scheme:多値の引数へのスプライシング
Scheme:戻り値のスプライシングのお試し実装に移ったようです。
多値のそれぞれの値に別の関数を適用する
多値のコードを組んでいると、cut-seaさんがScheme:多値の分配で書いているapply-val-to-funcsのように、多値のそれぞれに別の関数を適用したくなる事があります。
多値の一番目の値のみ加工して返したり、リスト構造を渡り歩いて多値を集めたりする場合です。
ただ、apply-val-to-funcsだと一引数に限定されるので、以下のようなものを考えてみました。(既出だったらすみません)
最新のコードはScheme:多値の分配にありますが、以下の議論で参照しているので一応古いコードを残しておきます。
(use srfi-11) (define-syntax call-each-values (syntax-rules () ((_ (func funcs ...) args ...) (call-each-values "gensym" () () (args ...) (funcs ...) (func funcs ...) (args ...))) ((_ "gensym" l (lr ...) () () (func ...) (args ...)) (call-each-values "bind" () (l lr ...) (l lr ...) (func ...) (args ...))) ((_ "gensym" l (lr ...) () (f g ...) (func ...) (args ...)) (call-each-values "gensym" () (l lr ...) (args ...) (g ...) (func ...) (args ...))) ((_ "gensym" (tr ...) (lr ...) (a b ...) (f ...) (func ...) (args ...)) (call-each-values "gensym" (t tr ...) (lr ...) (b ...) (f ...) (func ...) (args ...))) ((_ "bind" (b ...) (() ...) ((l ...) ...) (func ...) ()) (let-values (b ...) (values (func l ...) ...))) ((_ "bind" (b ...) ((v vr ...) ...) ((l ...) ...) (func ...) (arg args ...)) (call-each-values "bind" (((v ...) arg) b ...) ((vr ...) ...) ((l ...) ...) (func ...) (args ...)))))
使用例
(define (qr-list a b) (if (or (null? a) (null? b)) (values () ()) (call-each-values (cons cons) (quotient&remainder (car a) (car b)) (qr-list (cdr a) (cdr b))))) gosh> (qr-list '(10 9 8 7 6) '(5 4 3 2 1)) (2 2 2 3 6) (0 1 2 1 0)
見てくれが通常の再帰に近くなるし、一時変数を使う必要もありません。
- 私自身がマクロ使いこなせてないんでアレなんですが、
上記の "gensym" や "bind" って単なる目印ですよね?
この場合は実際に同じ文字列が使われる可能性もあるので、 (syntax-rules (gensym bind) ... などとするものなのかと思ったりします。cut-sea:2004/06/05 08:46:36 PDT - 目印に文字列を使う方法は、R5RSのletrecの実装例で使われていたので、それを真似してみました。
また、同じR5RSのcondの実装例で (syntax-rules (else =>) ... となっているので、syntax-rules直後の括弧内には、そのマクロ内でのみ意味を持つシンボルを入れるのかなと思っております。 - hira パターン内のシンボルはデフォルトでは変数名として機能しますが、括弧内に入れられたシンボルに関しては、シンボルのリテラルとして機能します。condの例で言うと'else'や'=>'は変数名ではなく、リテラルマッチとして機能することになります。私は四則演算マクロを実装する課程で'+-*/%^'をパターンマッチで区別しなければならなくなったとき、syntax-rules直後の括弧は伊達じゃないんだと気づきました。
- Shiro: "gensym"等の話は別ページにしてみます→Scheme:マクロ内でのループ