2010/05/31

遅延評価はマクロで、多値は継続とマクロで実装できるんですって

そういえば、伝統的マクロなら継続も実装できるんでしたっけ?
;; delay, force
;; Control Operations http://www.scheme.com/tspl4/control.html#./control:h7
;; (define delay (with-module gauche delay))
;; (define force (with-module gauche force))
(define-syntax let/
(syntax-rules ()
((_ val (var ...) body ...)
(let ((v val))
(let ((var v) ...)
body ...)))))
(define-syntax my-delay
(syntax-rules ()
((_ expr)
(make-promise (lambda ()
expr)))))
(define (make-promise p)
(let/ #f (val set?)
(lambda ()
(unless set?
(let ((x (p)))
(unless set?
(set! val x)
(set! set? #t))))
val)))
(define (force promise)
(promise))
(define (stream-car s)
(car (my-force s)))
(define (stream-cdr s)
(cdr (my-force s)))
(define counters
(let next ((n 1))
(my-delay (cons n (next (+ n 1))))))
(stream-car counters)
; -> 1
(stream-car (stream-cdr counters))
; -> 2
(define (stream-add s1 s2)
(my-delay (cons
(+ (stream-car s1)
(stream-car s2))
(stream-add (stream-cdr s1)
(stream-cdr s2)))))
(define even-counters
(stream-add counters counters))
(stream-car even-counters)
; -> 2
(stream-car (stream-cdr even-counters))
; -> 4

;; values
;; 多値を学ぶ - ひげぽん OSとか作っちゃうかMona- http://d.hatena.ne.jp/higepon/20080608/1212937386
(define (values . things)
(call-with-current-continuation
(lambda (cont) (apply cont things))))
view raw values.scm hosted with ❤ by GitHub


The Scheme Programming Language, 4th Edition

syntax-rules: allf

便利そうだったので。
こうかなー。
;; On Lisp --- 汎変数 http://www.komaba.utmc.or.jp/~flatline/onlispjhtml/generalizedVariables.html
(use srfi-17)
(define-syntax allf
(syntax-rules ()
((_ val arg1 arg2 ...)
(let ((v val))
(set! arg1 v)
(set! arg2 v)...))))
(let ((prints (lambda args
(for-each print args))))
(let/ #f (a b c d)
(prints a b c d)
(allf #t a b c d)
(prints a b c d)))
;; #f
;; #f
;; #f
;; #f
;; #t
;; #t
;; #t
;; #t
;; #<undef>
view raw allf.scm hosted with ❤ by GitHub


On Lisp

熊本市内の本屋さんに「実用 Common Lisp」がなかった

今日、私の知る限りで最も品揃えの良い熊本市内の本屋さん2件を回ってみましたが、実用 Common Lisp (IT Architects’Archive CLASSIC MODER) は置いてませんでした・・・orz

「私の知る限り」なんて言わなくても、熊本市内で品揃えの良い2件と言ったら、三年坂のツタヤとダイエーのキクヤですね、はい。

ついでに、プログラミング言語SCHEMEビューティフルコード を立ち読んだら、欲しくなりました・・・。

後者は、scheme の syntax-case が載っている25章だけでも良いので欲しいなー。などと Twitter でつぶやいたら、PDF(英語)を教えて頂きました!ありがとうございます!

前者は、英語版が Web 上に公開されているので、チラ見してみます。

Web 上には、無料で読めるものが他にもたくさんあるしなー・・・。実用 Common Lisp (IT Architects’Archive CLASSIC MODER) は、また今度で良いかなー・・・。いや、立ち読んでみたいだけだったんだ。


ビューティフルコード実用 Common Lisp (IT Architects’Archive CLASSIC MODER)プログラミング言語SCHEMEThe Scheme Programming Language, 4th Edition

syntax-rules: let/

(let ((a #f)(b #f)(c #f)) (list a b c)) を (let #f (a b c) (list a b c)) と書ける的な。
良い名前が思い浮かびませんでした。当初 lump-init-let としていましたが、長いのでボツ。(let-with init-value ... というような意味合いを込めて、let/ ・・・。
;; let/
(define-syntax let/
(syntax-rules ()
((_ val (var ...) body ...)
(let ((var val) ...)
body ...))
((_ (var ...) body ...)
(let/ #f (var ...) body ...))))
(let/ '() (a b c d e)
(for-each print
(list a b c d)))
;; ()
;; ()
;; ()
;; ()
;; #<undef>
(let/ (a b c d)
(for-each print
(list a b c d)))
; -> *** ERROR: unbound variable: b
(macroexpand '(let/ (a b c d)
(for-each print
(list a b c d))))
;; (#<identifier user#let>
;; ((for-each #0=(a b c d))
;; (print #0#) ((list a b c d) #0#)))
(define-syntax let/
(syntax-rules ()
((_ val (var ...) body ...)
(let ((var val) ...)
body ...))))
(let/ ((lambda ()
(print "hoge")
#f))
(a b c d)
(for-each print (list a b c d)))
;; hoge
;; hoge
;; hoge
;; hoge
;; #f
;; #f
;; #f
;; #f
;; #<undef>
(define-syntax let/
(syntax-rules ()
((_ val (var ...) body ...)
(let ((v val))
(let ((var v) ...)
body ...)))))
(let/ ((lambda ()
(print "hoge")
#f))
(a b c d)
(for-each print (list a b c d)))
;; hoge
;; #f
;; #f
;; #f
;; #f
;; #<undef>
view raw let-slash.scm hosted with ❤ by GitHub



プログラミング言語SCHEME

syntax-rules: define-syntax-rule, define-syntax-rules

こんなのもありかなー、とか。

;; define-syntax-rule
(define-syntax define-syntax-rule
(syntax-rules ()
((_ (name (literal ...) arg ...)(body ...))
(define-syntax name
(syntax-rules (literal ...)
((_ arg ...)
(body ...)))))
((_ (name arg ...)(body ...))
(define-syntax-rule (name () arg ...)(body ...)))))
(define a '(1 2 3))
a
; -> (1 2 3)
(define-syntax-rule (null! x)
(set! x '()))
(null! a)
; -> ()
a
; -> ()
(macroexpand '(define-syntax-rule (null! x)
(set! x '())))
;; (#<identifier user#define-syntax> null!
;; (#<identifier user#syntax-rules> ()
;; ((#<identifier user#_> x)
;; (set! x '()))))
(define-syntax-rule (lets (<- in) var <- init in body ...)
(let ((var init))
body ...))
(lets i <- 10
in (print i)(print (* i i)))
;; 10
;; 100
;; #<undef>
(macroexpand '(define-syntax-rule (lets (<- in) var <- init in body ...)
(let ((var init))
body ...)))
;; (#<identifier user#define-syntax> lets
;; (#<identifier user#syntax-rules> (<- in)
;; ((#<identifier user#_> var <- init in body |...|)
;; (let ((var init)) body |...|))))


こんなのもありかなーとか。
(define-syntax define-syntax-rules
(syntax-rules ()
((_ (name literal ...)
((arg1 ...) body1 ...)
((arg2 ...) body2 ...) ...)
(define-syntax name
(syntax-rules (literal ...)
((_ arg1 ...) body1 ...)
((_ arg2 ...) body2 ...) ...)))))
(define-syntax-rules (implications =>)
(((pred => body ...) ...)
(begin
(when pred
body ...) ...)))
(let ((x 0)(y 0)(hoge "hello")(false #f))
(implications ((zero? x) => (display x)(newline))
((number? y) => (format #t "~a is number." y))
(false => (print hoge))
(#t => (print "world !"))))
;; 0
;; 0 is number.world !
;; #<undef>
(define-syntax-rules (hoge)
(()
(display "hoge"))
((arg1)
(format #t "hoge - ~a" arg1))
((arg1 arg2)
(format #t "hoge - ~a - ~a" arg1 arg2))
((arg1 arg2 arg3)
(format #t "hoge - ~a - ~a - ~a" arg1 arg2 arg3))
((arg1 arg2 arg3 arg4)
(format #t "hoge - ~a - ~a - ~a - ~a" arg1 arg2 arg3 arg4)))
(hoge in 1)
; -> hoge - 1#<undef>
(hoge 1 2)
; -> hoge - 1 - 2#<undef>
(hoge 1 2 3)
; -> hoge - 1 - 2 - 3#<undef>
(hoge 1 2 3 4)
; -> hoge - 1 - 2 - 3 - 4#<undef>


define-syntax-rules がそうなら、define-syntax-rule もこうかなーとか。
(define-syntax define-syntax-rule
(syntax-rules ()
((_ (name literal ...)((arg ...) body ...))
(define-syntax name
(syntax-rules (literal ...)
((_ arg ...)
body ...))))))
(define a '(1 2 3))
a
; -> (1 2 3)
(define-syntax-rule (null!)
((x)(set! x '())))
(null! a)
; -> ()
a
; -> ()
(macroexpand '(define-syntax-rule (null!)
((x)(set! x '()))))
;; (#<identifier user#define-syntax> null!
;; (#<identifier user#syntax-rules> ()
;; ((#<identifier user#_> x)
;; (set! x '()))))
(define-syntax-rule (lets <- in)
((var <- init in body ...)
(let ((var init))
body ...)))
(lets i <- 10
in (print i)(print (* i i)))
;; 10
;; 100
;; #<undef>
(macroexpand '(define-syntax-rule (lets <- in)
((var <- init in body ...)
(let ((var init))
body ...))))
;; (#<identifier user#define-syntax> lets
;; (#<identifier user#syntax-rules> (<- in)
;; ((#<identifier user#_> var <- init in body |...|)
;; (let ((var init)) body |...|))))


結局このくらいが丁度良いのかも。
(define-syntax define-syntax-rule
(syntax-rules ()
((_ (name arg ...) body ...)
(define-syntax name
(syntax-rules ()
((_ arg ...)
body ...))))))


プログラミングGauche

2010/05/29

syntax-rules: lets

Oleg さんって The Reasoned Schemer とか SXML の方ですよね。comp.lang.scheme もでしたっけ?
syntax-rules の引数ってこういうことなのか。

;; lets
;; http://okmij.org/ftp/papers/Macros-talk.pdf
;; (lets i <- (+ 1 4)
;; in (+ i 37))
;; ; -> 42
(define-syntax lets
(syntax-rules (<- in)
((_ var <- init in body ...)
(let ((var init))
body ...))))
(lets i <- (+ 1 4)
in (+ i 37))
; -> 42
view raw lets.scm hosted with ❤ by GitHub



プログラミングGaucheThe Reasoned Schemer

2010/05/28

Emacs view-mode がステキ便利

ソースコードはもちろんですが、テキストファイルなどを Emacs で読む機会が多いです。
つい先日も、Twitter で見かけたテキストファイルをダウンロードして、Emacs で読んでいました。
実は、C-x C-q (読み取り専用)なども知らなかったため、C-n C-p で読んでいる時に文章中に n や p が紛れ込むこともしばしばです。これはテキストファイルに限らずプログラムを書いている時もそうで、わりと困っていました。

そこで、こういうものを見かけたので、試してみたら便利も便利。。。
  1. emacsでコードリーディングをするときはvi-modeがおすすめ - goinger的日記
  2. view-mode - とりあえず暇だったし何となく始めたブログ
  3. Ctrl+中指か薬指を使うキー操作が多いEmacsで指の負担を軽くする方法 - (rubikitch loves (Emacs Ruby CUI))
特に、3の rubikitch さんところで紹介されている key-chord.el と view-mode のコンボがすごく便利でした。

例えば、.emacs はよく編集しますが、編集を始めるまでに眺める時間の方が長かったりします。この際、view-mode をデフォにしてみました。
(global-set-key [f7] '(lambda ()
(interactive)
(find-file "~/.emacs")
(view-mode)))

どうせなので、ファイルを開いたときはデフォルトで view-mode にすることにしました。しばらくこの状態で試してみます。
(add-hook 'find-file-hook
'(lambda ()
(interactive)
(view-mode)))


設定は、rubikitch さんのところから頂きました。
キーバインドは好みで以下のように変更しました。メモがてらさらしておきます。
;; view-mode
(setq view-read-only t)
(defvar pager-keybind
`( ;; vi-like
;; ("h" . backward-word)
;; ("l" . forward-word)
;; ("j" . next-window-line)
;; ("k" . previous-window-line)
("h" . backward-char)
("l" . forward-char)
("j" . next-line)
("k" . previous-line)
;; (";" . gene-word)
("b" . scroll-down)
(" " . scroll-up)
;; w3m-like
;; ("m" . gene-word)
;; ("i" . win-delete-current-window-and-squeeze)
("w" . forward-word)
("e" . backward-word)
;; ("(" . point-undo)
;; (")" . point-redo)
;; ("J" . ,(lambda () (interactive) (scroll-up 1)))
;; ("K" . ,(lambda () (interactive) (scroll-down 1)))
("n" . ,(lambda () (interactive) (scroll-up 1)))
("p" . ,(lambda () (interactive) (scroll-down 1)))
;; bm-easy
;; ("." . bm-toggle)
;; ("[" . bm-previous)
;; ("]" . bm-next)
;; langhelp-like
;; ("c" . scroll-other-window-down)
;; ("v" . scroll-other-window)
))
(defun define-many-keys (keymap key-table &optional includes)
(let (key cmd)
(dolist (key-cmd key-table)
(setq key (car key-cmd)
cmd (cdr key-cmd))
(if (or (not includes) (member key includes))
(define-key keymap key cmd))))
keymap)
(defun view-mode-hook0 ()
(define-many-keys view-mode-map pager-keybind)
(hl-line-mode 1)
(define-key view-mode-map " " 'scroll-up))
(add-hook 'view-mode-hook 'view-mode-hook0)
(defadvice find-file
(around find-file-switch-to-view-file (file &optional wild) activate)
(if (and (not (file-writable-p file))
(not (file-directory-p file)))
(view-file file)
ad-do-it))
(defvar view-mode-force-exit nil)
(defmacro do-not-exit-view-mode-unless-writable-advice (f)
`(defadvice ,f (around do-not-exit-view-mode-unless-writable activate)
(if (and (buffer-file-name)
(not view-mode-force-exit)
(not (file-writable-p (buffer-file-name))))
(message "File is unwritable, so stay in view-mode.")
ad-do-it)))
(do-not-exit-view-mode-unless-writable-advice view-mode-exit)
(do-not-exit-view-mode-unless-writable-advice view-mode-disable)
(require 'key-chord)
(setq key-chord-two-keys-delay 0.04)
(key-chord-mode 1)
(key-chord-define-global "jk" 'view-mode)


入門 GNU Emacs 第3版

quack-find-file

Emacsでschemeを書く時に、quack.elを使っています。quack.elを使っていると、C-x C-f(つまり find-file)がquack-find-fileになります。
これを解除したかったので、以下のように.emacs に書き加えました。

(setq quack-remap-find-file-bindings-p nil)

(load "quack")
(setq quack-pretty-lambda-p t)
(setq quack-remap-find-file-bindings-p nil)
(custom-set-variables
'(quack-default-program scheme-program-name)
'(quack-fontify-style (quote plt))
'(quack-pretty-lambda-p t)
'(quack-programs (quote ("ironscheme.console.exe" "'scheme-program-name" "bigloo" "csi" "csi -hygienic" "gauche" "gosh" "gsi" "gsi ~~/syntax-case.scm -" "guile" "kawa" "mit-scheme" "mred -z" "mzscheme" "mzscheme -M
errortrace" "mzscheme3m" "mzschemecgc" "rs" "scheme" "scheme-program-name" "scheme48" "scsh" "sisc" "stklos" "sxi")))
'(quack-run-scheme-always-prompts-p t)
'(quack-smart-open-paren-p nil))
view raw quack.emacs hosted with ❤ by GitHub


入門 GNU Emacs 第3版

2010/05/27

「そのプロセスにおいて、Schemeを使うことに関する多くの勘を やしなうだろう。」

数nの階乗を計算するが、手続きの最終行で自身に再帰できるようにするた めに名前"fact"が必要であるように思える。しかし、我々はそれは必要でない ことを理解し、そのプロセスにおいて、Schemeを使うことに関する多くの勘を やしなうだろう。

これが本当かどうかは置いといて、みんなもっと Y Combinator で遊ぼうよー!

 計算論 計算可能性とラムダ計算 (コンピュータサイエンス大学講座)The Little Schemer, 4th EditionThe Seasoned Schemer

Yコンビネータ 継続編

fixed point of call/cc だそうです。
タイトルに Y Combinator と入れましたが、正確にはそうではないようです。

すごくおもしろそうだったのでプリントアウトして頑張って読んでます。印刷したら10ページありました。まだ3ページくらいしか読んでないので、残りを読んでみます。

で、一見してもよくわかりません。よくわからないので、いじくり回してみました。先日ノーマルな Y Combinator でやったことの、逆過程のようなことをやりました。
結果、理解できてないのですが、なんとなく雰囲気がつかめた気がします。気がするだけかもしれません。
以下コード。
;; call/cc fixed point
;; http://okmij.org/ftp/Scheme/callcc-fixpoint.txt
;; varargs Y-combinator
(define y
(lambda (c)
((lambda (f)
(f f))
(lambda (g)
(c (lambda x
(apply (g g) x)))))))
;; fact
((y (lambda (f)
(lambda (n)
(if (zero? n)
1
(* n (f (- n 1))))))) 5)
; -> 120
;; Y-Combinator via call/cc
(define (y/cc f)
((lambda (u)
(u (lambda (x)
(lambda (n)
((f (u x)) n)))))
(call/cc (call/cc (lambda (x)
x)))))
;; fact
((y/cc (lambda (f)
(lambda (n)
(if (zero? n)
1
(* n (f (- n 1))))))) 5)
; -> 120
;; observationally equivalent
;; (lambda (p) ((call/cc ... (call/cc call/cc)) p))
;; (lambda (p) ((call/cc ... (call/cc (call/cc id))) p))
;; (lambda (p) ((lambda (x) (x x)) p))
;;; (step 1)
;; y/cc
(lambda (f)
((lambda (u)
(u (lambda (x)
(lambda (n)
((f (u x)) n)))))
(call/cc (call/cc (lambda (x)
x)))))
;;; (step 2)
;; fact
((lambda (f)
((lambda (u)
(u (lambda (x)
(lambda (n)
((f (u x)) n)))))
(call/cc (call/cc (lambda (x)
x)))))
(lambda (f)
(lambda (n)
(if (zero? n)
1
(* n (f (- n 1)))))))
; -> #<closure (#f #f #f #f)>
;;; (step 3)
;; fact 5
(((lambda (f)
((lambda (u)
(u (lambda (x)
(lambda (n)
((f (u x)) n)))))
(call/cc (call/cc (lambda (x)
x)))))
(lambda (f)
(lambda (n)
(if (zero? n)
1
(* n (f (- n 1))))))) 5)
; -> 120
;;; (step 4)
(lambda (g)
(lambda (n)
(if (zero? n)
1
(* n (g (- n 1))))))
(lambda (f)
((lambda (u)
(u (lambda (x)
(lambda (n)
(((lambda (g)
(lambda (n)
(if (zero? n)
1
(* n (g (- n 1)))))) (u x)) n)))))
(call/cc (call/cc (lambda (x)
x)))))
;;; (step 5)
((lambda (u)
(u (lambda (x)
(lambda (n)
(((lambda (g)
(lambda (n)
(if (zero? n)
1
(* n (g (- n 1)))))) (u x)) n)))))
(call/cc (call/cc (lambda (x)
x))))
(((lambda (u)
(u (lambda (x)
(lambda (n)
(((lambda (g)
(lambda (n)
(if (zero? n)
1
(* n (g (- n 1)))))) (u x)) n)))))
(call/cc (call/cc (lambda (x)
x)))) 5)
; -> 120
;;; (step 6)
((lambda (u)
(u (lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n ((u x)(- n 1))))) n)))))
(call/cc (call/cc (lambda (x)
x))))
(((lambda (u)
(u (lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n ((u x)(- n 1))))) n)))))
(call/cc (call/cc (lambda (x)
x)))) 5)
; -> 120
;;; (step 7)
((call/cc (call/cc (lambda (x)
x)))
(lambda (u)
(u (lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n ((u x)(- n 1))))) n))))))
(((call/cc (call/cc (lambda (x)
x)))
(lambda (u)
(u (lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n ((u x)(- n 1))))) n)))))) 5)
; -> 120
;; (step 8)
((call/cc (call/cc (lambda (x)
x)))
(lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n (((call/cc (call/cc (lambda (x)
x))) x)(- n 1))))) n))))
(((call/cc (call/cc (lambda (x)
x)))
(lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n (((call/cc (call/cc (lambda (x)
x))) x)(- n 1))))) n)))) 5)
; -> 120
;;; (step 9)
((call/cc (lambda (x)
x))
(lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n (((call/cc (lambda (x)
x)) x)(- n 1))))) n))))
(((call/cc (lambda (x)
x))
(lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n (((call/cc (lambda (x)
x)) x)(- n 1))))) n)))) 5)
; -> 120
;;; (step 9.5)
;; (step 2)
(((lambda (f)
((lambda (u)
(u (lambda (x)
(lambda (n)
((f (u x)) n)))))
(call/cc (lambda (x)
x))))
(lambda (f)
(lambda (n)
(if (zero? n)
1
(* n (f (- n 1))))))) 5)
; -> 120
;;; (step 10)
((call/cc identity)
(lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n (((call/cc identity) x)(- n 1))))) n))))
(((call/cc identity)
(lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n (((call/cc identity) x)(- n 1))))) n)))) 5)
; -> 120
(((lambda (u)
(u (lambda (x)
(lambda (n)
((lambda (n)
(if (zero? n)
1
(* n ((u x)(- n 1))))) n)))))
(call/cc identity)) 5)
view raw cc.scm hosted with ❤ by GitHub



入門Common Lisp―関数型4つの特徴とλ(ラムダ)計算計算論 計算可能性とラムダ計算 (コンピュータサイエンス大学講座)

Re: Re: syntax-rules: reverse-and-quote-list @ IronScheme

「展開した結果に...を含める」には (... ...) と書くことにR6RSではなっています。

R6RS と聞いて思い浮かんだのは、IronScheme, mosh, Ypsilon でした。
取りあえず今回は、すでにインストール済みの IronScheme で試してみました。
;; R6RS
(define-syntax reverse-and-quote-list
(syntax-rules ()
((_ lis)
(letrec-syntax
((helper
(syntax-rules ()
((_ () (backw (... ...)))
'(backw (... ...)))
((_ (arg rest (... ...))(backw (... ...)))
(helper (rest (... ...))(arg backw (... ...)))))))
(helper lis ())))))




どうやら意図通り動いたようです。

追記

IronScheme は Emacs インターフェースもあったりします。
以前少し試したことが・・・。

Programming C# 4.0

Re: syntax-rules: reverse-and-quote-list

letrec-syntax が、なかなか思ったように動かない(書き方がわからない)という状態でした。
補助マクロやローカルマクロが思ったように動かないなら、パターンを追加すれば良いのかも?

(define-syntax reverse-and-quote-list
(syntax-rules ()
((_ lis)
(reverse-and-quote-list lis ()))
((_ () (backw ...))
'(backw ...))
((_ (arg rest ...)(backw ...))
(reverse-and-quote-list (rest ...)(arg backw ...)))))
(reverse-and-quote-list (1 2 3 4 5))
; -> (5 4 3 2 1)

ということで、今回の場合はこれで動いたようです。
なんかメソッドのオーバーロード(C#とか)に似ていませんか。



shiro さんにコメントを頂き、教えて頂きました。ありがとうございます!
こうやって処理系の作者の方から直接コメントを頂けるなんて、すごい世界ですね、インターネッツは・・・。
define-syntaxの直下にletrec-syntaxが来る形はGaucheではまだサポートされていません。
「展開した結果に...を含める」には (... ...) と書くことにR6RSではなっています。Gaucheでは未サポートです。
R5RS をまともに読んだことがない、というのがよくないですね・・・orz R6RS についてはほとんど何もしりません。。R5RS に比べてページ数が3倍の150ページになったらしいことと、defmacro でできることができるらしい syntax-case なる難しそうなものがある、ということくらいしか知りません。

追記

補助マクロやローカルマクロが思ったように動かないなら、パターンを追加すれば良いのかも?
でも、余計なインターフェース(?)が増えるのか・・・。うーん。

プログラミングGaucheThe Reasoned Schemer

2010/05/26

syntax-rules: amb

非決定性というやつです。よく分からないので、写経してみました。動き気持ち悪いですね。。どうなってるんですかこれ。。
確か、On Lisp や SICP (計算機プログラムの構造と解釈)にも出てくるらしいですね。
;; amb
;; http://people.csail.mit.edu/jhbrown/scheme/continuationslides04.pdf
(define amb-fail '())
(define (initialize-amb-fail)
(set! amb-fail
(lambda (x)
(error "amb tree exhusted"))))
(define (assert pred)
(if (not pred)
(amb)))
(define (fail)
(amb))
(define (next)
(amb))
(define-syntax amb
(syntax-rules ()
((_ argument ...)
(let ((old-amb-fail amb-fail))
(call/cc (lambda (return)
(call/cc (lambda (next)
(set! amb-fail next)
(return argument)))
...
(set! amb-fail old-amb-fail)
(amb-fail #f)))))))
(let ((value (amb 0 1 2 3 4 5 6)))
(assert (> value 2))
(assert (even? value))
value)
; -> 4
(define (three-dice sumto)
(let ((die1 (amb 1 2 3 4 5 6))
(die2 (amb 1 2 3 4 5 6))
(die3 (amb 1 2 3 4 5 6)))
(assert (= sumto (+ die1 die2 die3)))
(list die1 die2 die3)))
(initialize-amb-fail)
(three-dice 4)
; -> (1 1 2)
(next)
; -> (1 2 1)
(next)
; -> (2 1 1)
(next)
;; *** ERROR: amb tree exhusted
;; Stack Trace:
;; _______________________________________
;; 0 (call/cc (lambda (return) (call/cc (lambda (next) (set! amb-fail n ...
;; [unknown location]
view raw amb.scm hosted with ❤ by GitHub

わけわかめ。

追記


On Lisp計算機プログラムの構造と解釈

syntax-rules: try

macroの方のPDFを一通り読み終えたので、continuationの方のPDFを読み始めました。
英語の方は、ほとんどわかりません。The Seasoned SchemerThe Little Schemer, 4th Editionは雰囲気と勢いで読みました。
The Seasoned Schemerに出てくる try のことを思い出しました。

;; try
(define-syntax try
(syntax-rules ()
((_ var a . b)
(let/cc success
(let/cc var
(success a)) . b))))
(define (accept-odd-only ls throw)
(let ((ret (every odd? ls)))
(if ret
ls
(throw ret))))
(use srfi-1)
(try throw
(accept-odd-only '(1 2 3 4 5) throw)
(print "oops")
(print "error!"))
;; oops
;; error!
;; #<undef>
(try throw
(accept-odd-only '(1 3 5 7 9) throw)
(print "oops")
(print "error!"))
;; (1 3 5 7 9)
view raw try.scm hosted with ❤ by GitHub




The Little Schemer, 4th EditionThe Seasoned Schemer

syntax-rules: reverse-and-quote-list

取りあえず書いてみたのがこれ。微妙っぽい。
;; reverse-and-quote-list
(define-syntax reverse-and-quote-list
(syntax-rules ()
((_ lis)
(let loop ((l (quote lis))
(acc '()))
(if (null? l)
acc
(loop (cdr l)(cons (car l) acc)))))))
(reverse-and-quote-list (1 2 3 4 5))
; -> (5 4 3 2 1)

で、PDF に書いてあったのは、こういうの。
;; http://people.csail.mit.edu/jhbrown/scheme/macroslides03.pdf
(define-syntax reverse-and-quote-list
(syntax-rules ()
((_ lis)
(rl-helper lis ()))))
(define-syntax rl-helper
(syntax-rules ()
((_ () (backw ...))
'(backw ...))
((_ (arg rest ...)(backw ...))
(rl-helper (rest ...)(arg backw ...)))))
(reverse-and-quote-list (1 2 3 4 5))
; -> (5 4 3 2 1)

なるほどー!

これは、letrec-syntaxとやらで、rl-helperをローカルに定義できるのでは?
(define-syntax reverse-and-quote-list
(letrec-syntax
((helper
(syntax-rules ()
((_ () (backw ...))
'(backw ...))
((_ (arg rest ...)(backw ...))
(helper (rest ...)(arg backw ...))))))
(syntax-rules ()
((_ lis)
(helper lis ())))))
;; *** ERROR: Compile Error: syntax-error: malformed define-syntax: (define-syntax reverse-and-quote-list (letrec-syntax ((helper (syntax-rules () ((_ () (backw |...|)) '(backw |...|)) ((_ (arg rest |...|) (backw |...|)) (helper (rest |...|) (arg backw |...|)))))) (syntax-rules () ((_ lis) (helper lis ())))))
;; "(stdin)":23:(define-syntax reverse-and-quote-lis ...
(define-syntax reverse-and-quote-list
(syntax-rules ()
((_ lis)
(letrec-syntax
((helper
(syntax-rules ()
((_ () (backw ...))
'(backw ...))
((_ (arg rest ...)(backw ...))
(helper (rest ...)(arg backw ...))))))
(helper lis ())))))
;; *** ERROR: Compile Error: in definition of macro reverse-and-quote-list: a template contains repetition of constant form: (backw |...|)
;; "(stdin)":34:(define-syntax reverse-and-quote-lis ...

エラー。うーん。間違ってるのはどこだろう。。エラーメッセージもよくわからない。
letrec-syntax, let-syntax は余計に情報少ないな・・・(web)。

追記

これは動きますね。。
(letrec-syntax
((helper
(syntax-rules ()
((_ () (backw ...))
(quote (backw ...)))
((_ (arg rest ...)(backw ...))
(helper (rest ...)(arg backw ...))))))
(helper (1 2 3 4 5) ()))
; -> (5 4 3 2 1)

どういうことかよくわかりません。

プログラミングGaucheThe Reasoned Schemer

syntax-rules: shadow shadows

おー。最初見たときは、驚きました。
;; shadow
(define-syntax shadow
(syntax-rules ()
((_ used-arg val body)
(let ((used-arg val))
body))))
(define a 1)
a
; -> 1
(shadow a 10
a)
; -> 10
a
; -> 1
view raw shadow.scm hosted with ❤ by GitHub

では、こうしたら。
(define-syntax shadows
(syntax-rules ()
((_ ((used-arg val) ...) body ...)
(let ((used-arg val) ...)
body ...))))
(define b 100)
b
; -> 100
(define c "Hello")
c
; -> "Hello"
(define d 'dead)
d
; -> dead
(shadows ((a b)
(b 5)
(c "world")
(d 'live))
(values a b c d))
;; 100
;; 5
;; "world"
;; live
view raw shadows.scm hosted with ❤ by GitHub

おー。便利。
待てよ、これなんてlet?

展開。
(let ((- 'minus))
(macroexpand
'(dotimes 5 (print "hello"))))
;; (#<identifier user#let> #0=#<identifier user#loop>
;; ((#1=#<identifier user#i> 5))
;; (#<identifier user#when>
;; (#<identifier user#<> 0 #1#)
;; (print "hello")
;; (#0# (#<identifier user#-> #1# 1))))


プログラミングGaucheThe Reasoned Schemer

Re: syntax-rules: dotimes

;; dotimes
(define-syntax dotimes
(syntax-rules ()
((_ n body ...)
(let loop ((i n))
(when (< 0 i)
body ...
(loop (- i 1)))))))
(dotimes 5 (print 1))
(define i 10)
(dotimes 5 (print (set! i (+ i 1))))
;; 11
;; 12
;; 13
;; 14
;; 15
(macroexpand-1 '(dotimes 5 (print (set! i (+ i 1)))))
;; (#<identifier user#let> #0=#<identifier user#loop>
;; ((#1=#<identifier user#i> 5))
;; (#<identifier user#when>
;; (#<identifier user#<> 0 #1#)
;; (print (set! i (+ i 1)))
;; (#0# (#<identifier user#-> #1# 1))))

プログラミングGaucheThe Reasoned Schemer

2010/05/25

syntax-rules: dotimes

;; dotimes
(define-syntax dotimes
(syntax-rules ()
((_ n body ...)
(do ((i n (- i 1)))
((not (< 0 i)))
body ...))))
(dotimes 5
(display "hello")
(print "world"))
;; helloworld
;; helloworld
;; helloworld
;; helloworld
;; helloworld
;; #t
(define-syntax dotimes
(syntax-rules ()
((_ n body ...)
(let loop ((i n))
(when (< 0 i)
body ...
(loop (- i 1)))))))
(dotimes 5
(print "H")
(print "l")
(print "l")
(print "o"))
;; H
;; l
;; l
;; o
;; H
;; l
;; l
;; o
;; H
;; l
;; l
;; o
;; H
;; l
;; l
;; o
;; H
;; l
;; l
;; o
;; #<undef>
view raw dotimes.scm hosted with ❤ by GitHub


プログラミングGaucheThe Reasoned Schemer

syntax-rules: implecations



追記

コメントでご指摘頂きました。
implecationsではなくimplicationsのようです。

プログラミングGaucheThe Reasoned Schemer

Re: syntax-rules: update-if-true (cond-set!)

shiroさんにご指摘頂きました。大変恐縮です。。
仰る通りですね。(そりゃそうですよね)
(define-syntax cond-set!
(syntax-rules ()
((_ pred var init)
(if pred
(set! var init)))
((_ pred var1 init1 var2 init2 ...)
(if pred
(begin
(set! var1 init1)
(set! var2 init2) ...)))))
(let ((test 5)
(var 0))
(cond-set! (> test 4)
var 5)
(display var))
(let ((test 5)
(v1 0)
(v2 0))
(cond-set! (> test 4)
v1 1 v2 2)
(display v1)
(display v2))
(let ((test 5)
(v1 0)
(v2 0)
(v3 0)
(v4 0)
(v5 0))
(cond-set! (> test 4)
v1 1 v2 2 v3 3 v4 4 v5 5)
(for-each display (list v1 v2 v3 v4 v5)))
; -> 15000#<undef>


こうでしょうか。。
(define-syntax cond-set!
(syntax-rules ()
((_ pred var init)
(if pred
(set! var init)))
((_ pred var1 init1 var2 init2)
(if pred
(begin
(set! var1 init1)
(set! var2 init2))))
((_ pred var1 init1 var2 init2 ...)
(let ((p pred))
(if p
(begin
(cond-set! p var1 init1)
(cond-set! p var2 init2 ...)))))))
(let ((test 5)
(v1 0)
(v2 0)
(v3 0)
(v4 0)
(v5 0))
(cond-set! (> test 4)
v1 1 v2 2 v3 3 v4 4 v5 5)
(for-each display (list v1 v2 v3 v4 v5)))


教えて頂きました。
って、ここは・・・偶然にも今日、眺め始めたページ(笑)

追記

引数2つのところはいらないかな?
(define-syntax cond-set!
(syntax-rules ()
((_ pred var init)
(if pred
(set! var init)))
;; ((_ pred var1 init1 var2 init2)
;; (if pred
;; (begin
;; (set! var1 init1)
;; (set! var2 init2))))
((_ pred var1 init1 var2 init2 ...)
(let ((p pred))
(if pred
(begin
(cond-set! p var1 init1)
(cond-set! p var2 init2 ...)))))))
(let ((test 5)
(v1 0)
(v2 0)
(v3 0)
(v4 0)
(v5 0))
(cond-set! (> test 4)
v1 1 v2 2 v3 3 v4 4 v5 5)
(for-each display (list v1 v2 v3 v4 v5)))


プログラミングGauche

syntax-rules: quoted-append

;; quoted-append
(define-syntax quoted-append
(syntax-rules ()
((_)(append))
((_ lis)
(append (quote lis)))
((_ lis1 lis2)
(append (quote lis1)(quote lis2)))
((_ lis1 lis2 ...)
(append (quote lis1)(quoted-append lis2 ...)))))
(quoted-append (1 2 3) (4 5) (+ x y))
; -> (1 2 3 4 5 + x y)
(quoted-append (1 2 3))
; -> (1 2 3)
(quoted-append (1 2 3)(+ 4 5)(+ 6 7 8)((lambda(x)(* x x)) 4) )
; -> (1 2 3 + 4 5 + 6 7 8 (lambda (x) (* x x)) 4)
(quoted-append)
; -> ()


追記

何か違う気がする。こういう意図じゃないような気がする。

プログラミングGauche

syntax-rules: update-if-true!

プログラミングGauche って、マクロの章すごく少ないですよね・・・。syntax-rules の練習問題というか例題というか、そういうのをたくさん見たい。ソース読め?

;; update-if-true!
(define-syntax cond-set!
(syntax-rules ()
((_ pred var init)
(if pred
(set! var init)))
((_ pred var1 init1 var2 init2 ...)
(if pred
(begin
(set! var1 init1)
(set! var2 init2) ...)))))
(define-syntax update-if-true!
(syntax-rules ()
((_ (pred var))
(let ((p pred))
(cond-set! p var p)))
((_ (pred1 var1)(pred2 var2) ...)
(begin
(update-if-true! (pred1 var1))
(update-if-true! (pred2 var2))
...))))
(define (test x y z)
(let ((x-is-big #f)
(y-is-zero #f)
(z-is-string #f))
(update-if-true!
((> x 5) x-is-big)
((zero? y) y-is-zero)
((string? z) z-is-string))
(values x-is-big y-is-zero z-is-string)))


追記

コメント欄より。
cond-set!の2番目の節はおそらくやりたいことと違うのではないかと推察します。
init2だけが複数扱いになり、var2が繰り返されます。
(cond-set! a b c d e f g)

(if a (begin (set! b c) (set! d e) (set! d f) (set! d g)))
になります。(2番目以降、set!されてるのはすべてd)
修正してみました。

プログラミングGauche


syntax-rules: cond-set!

こうですか。。
;; cond-set!
;; http://people.csail.mit.edu/jhbrown/scheme/macroslides04.pdf
(define-syntax cond-set!
(syntax-rules ()
((_ pred var init)
(if pred
(set! var init)))
((_ pred var1 init1 var2 init2 ...)
(if pred
(begin
(set! var1 init1)
(set! var2 init2) ...)))))
(let ((test 5)
(var 0))
(cond-set! (> test 4)
var 5)
(display var))
(let ((test 5)
(v1 0)
(v2 0))
(cond-set! (> test 4)
v1 1 v2 2)
(display v1)
(display v2))
view raw cond-set!.scm hosted with ❤ by GitHub


追記

修正しました。


プログラミングGauche

syntax-rules: (define-syntax foo (syntax-rules () ((foo (a ...) (b ...)) '((a b) ...))))

これは意外。。
;; http://community.schemewiki.org/?scheme-faq-macros
(define-syntax foo
(syntax-rules ()
((foo (a ...) (b ...)) '((a b) ...))))
(foo (1 2) (3 4 5))
; -> ((1 3) (2 4))
(foo (1 2 3 4 5) (6 7 8 9 10))
; -> ((1 6) (2 7) (3 8) (4 9) (5 10))
(define-syntax foo
(syntax-rules ()
((_ (a ...)(b ...) ...)
'(((a b) ...) ...))))
(foo (1 2)(3 4)(5 6 7))
; -> (((1 3) (1 4)) ((2 5) (2 6) (2 7)))
view raw foo.scm hosted with ❤ by GitHub


プログラミングGauche

syntax-rules: let1

こうかな。
;; let1
(define-syntax letone
(syntax-rules ()
((_ () body ...)
(let ()
body ...))
((_ (var init) body ...)
(let ((var init))
body ...))))
(letone (x 10)
(display x))
(letone ()
(display 1)))
view raw let1.scm hosted with ❤ by GitHub

追記

間違ってるな。
(define-syntax letone
(syntax-rules ()
((_ var init body ...)
(let ((var init))
body ...))))
(letone a 1
(display a))
view raw let1-2.scm hosted with ❤ by GitHub


プログラミングGauche

syntax-rules: let*

こうかな。
;; let*
(define-syntax letstar
(syntax-rules ()
((_ () body ...)
(let ()
body ...))
((_ ((var init)) body ...)
(let ((var init))
body ...))
((_ ((var1 init1)(var2 init2) ...) body ...)
(let ((var1 init1))
(letstar ((var2 init2) ...) body ...)))))
(letstar ()
(display 'a))
(letstar ((x 1))
(display 'a)
(display x))
(letstar ((x 1)
(y 2)
(z (+ x y)))
(print z))
view raw letstar.scm hosted with ❤ by GitHub


プログラミングGauche

syntax-rules: ever

これを眺めていて(ry
;; ever
(define-syntax ever
(syntax-rules ()
((_ ((var init) ...) body ...)
(let ((var init) ...)
(let ((next (call/cc identity)))
body ...
(next next))))
((_ body ...)
(ever () body ...))))
(let/cc hop
(ever ((n 10))
(if (zero? n)
(hop n)
(begin
(print n)
(set! n (- n 1))))))
;; 10
;; 9
;; 8
;; 7
;; 6
;; 5
;; 4
;; 3
;; 2
;; 1
;; 0
view raw ever.scm hosted with ❤ by GitHub


until を書き直してみます。
(define-syntax until
(syntax-rules ()
((_ label ((var init) ...) body ...)
(let/cc label
(ever ((var init) ...)
body ...)))
((_ label body ...)
(until label () body ...))))
(let ((n 10))
(until break
(if (zero? n)
(break n)
(print (* n (set! n (- n 1)))))))
;; 90
;; 72
;; 56
;; 42
;; 30
;; 20
;; 12
;; 6
;; 2
;; 0
;; 0
view raw until.scm hosted with ❤ by GitHub


プログラミングGauche

syntax-rules: until

これを眺めていて思いつきました。
名前付けが適切かわかりませんが、思いつかなかったので、label まで繰り返すということで until 。
(define-syntax until
(syntax-rules ()
((_ label ((var init) ...) body ...)
(let/cc label
(let ((var init) ...)
(let ((next (call/cc identity)))
body ...
(next next)))))))
(until return ((n 10)
(acc 0))
(if (zero? n)
(return acc)
(begin
(print n)
(set! acc (* n acc))
(set! n (- n 1)))))
;; 10
;; 9
;; 8
;; 7
;; 6
;; 5
;; 4
;; 3
;; 2
;; 1
;; 0
(let ((n 10))
(until break ()
(if (zero? n)
(break n)
(print (* n (set! n (- n 1)))))))
;; 90
;; 72
;; 56
;; 42
;; 30
;; 20
;; 12
;; 6
;; 2
;; 0
;; 0
(define-syntax until
(syntax-rules ()
((_ label ((var init) ...) body ...)
(let/cc label
(let ((var init) ...)
(let ((next (call/cc identity)))
body ...
(next next)))))
((_ label body ...)
(until label () body ...))))
(let ((n 10))
(until break
(if (zero? n)
(break n)
(print (* n (set! n (- n 1)))))))
;; 90
;; 72
;; 56
;; 42
;; 30
;; 20
;; 12
;; 6
;; 2
;; 0
;; 0
(until return ((n 10)
(acc 0))
(if (zero? n)
(return acc)
(begin
(print n)
(set! acc (* n acc))
(set! n (- n 1)))))
;; 10
;; 9
;; 8
;; 7
;; 6
;; 5
;; 4
;; 3
;; 2
;; 1
;; 0
view raw until.scm hosted with ❤ by GitHub

プログラミングGauche

2010/05/24

月末取得

私は、今まで以下のようにしていました。
  1. 次月の頭を取得
  2. 1日減算する
例えば、2010/05 の月末を取得したい場合。
  1. 2010/06/01 を取得する
  2. 1から1日減算する
  3. 2010/05/31 が返る
今日、Gauche のリファレンスを眺めていて、この「1日減算する」というのが見当たらなくて、どうやればいいのかわかりませんでした・・・。
検索してみると、こういうのがありました。
(define (days-of-month date)
  (inexact->exact
   (- (date->modified-julian-day (next-month date))
      (date->modified-julian-day (current-month date)))))

julian というのが、たぶんユリウス暦のことだろうというのはわかったのですが、ユリウス暦というのが何なのか、実はよく知りませんでした。

Function: current-julian-day
[SRFI-19] 現在のユリウス日(Julian day)を返します。Julian dayは -4714-11-24T12:00:00Z (November 24, -4714 at noon, UTC) からの日数を 実数で表現したものです。


余談ですが。日付関連って、結構面倒です。業務アプリは日付を扱う機会が多いですよね。プログラマとして仕事を始めたばかりの頃、特に迷走したことを覚えています。

例えば、「期間と基準日を指定して基準日から見て相対的な偶/奇数週の月水金の祝日意外に予定を展開」などの条件指定ができる機能などでしょうか。過去も含めて長期間を指定された場合など、特に面倒そうですね。。まず祝日が面倒ですね。


SQL が面白くて調子に乗っていた時なども悲惨でした。担当していた業務アプリが MSSQL のみのサポートから MSSQL/MySQL サポートになった時などは吐けました。。
--int型の任意の日付から月末を取得する
SELECT
CAST(CONVERT(VARCHAR, DATEADD(DAYOFYEAR, -1, DATEADD(MONTH, 1, CONVERT(DATETIME, CONVERT(VARCHAR(6), REPLACE(STR(20080215), ' ', '')) + '01 00:00:00', 112))), 112) AS INT)
--結果:20080229

この場合、サポート DB が増えたことよりも、こういったクエリを散在させていたことが致命的だったわけです。。下級戦士どころじゃねーぞ。

そういえば JavaScript なんかも、月が0始まり(0~11)で驚きましたね。

プログラミングGauche

syntax-rules: for

結局、9LISP の宿題をやり終えていなかったので、いくつか書いていました。

for をより for らしく書き直していったつもりでしたが、do マクロに近づいて行きました。do マクロと聞くと do ~ while とか do ~ until などを連想しますが、for に近いですね。というか、for じゃないですか。
これは、for というより nfor といった感じでしょうか。
(define-syntax for
(syntax-rules ()
((_ (var from to) body ...)
(let loop ((var from))
(when (< var to)
body ...
(loop (+ var 1)))))))
view raw for-01.scm hosted with ❤ by GitHub


step を追加。
(define-syntax for
(syntax-rules ()
((_ (var from to step) body ...)
(let loop ((var from))
(when (< var to)
body ...
(loop (+ var step)))))
((_ (var from to) body ...)
(for (var from to 1) body ...))))
view raw for-03.scm hosted with ❤ by GitHub


練習がてら do マクロで書き直し。
(define-syntax for
(syntax-rules ()
((_ (var from to step) body ...)
(do ((var from (+ var step)))
((not (< var to)))
body ...))))
view raw for-04.scm hosted with ❤ by GitHub


数値に限らないように書き直し。
(define-syntax for
(syntax-rules ()
((_ (var init pred update) body ...)
(let loop ((var init))
(when pred
body ...
(loop update))))
((_ (var pred update) body ...)
(for (var #f pred update) body ...))))
view raw for-05.scm hosted with ❤ by GitHub


再度 do マクロ。
(define-syntax for
(syntax-rules ()
((_ (var init pred update) body ...)
(do ((var init))
((not pred))
body ...
update))
((_ (var pred update) body ...)
(for (var #f pred update) body ...))))
view raw for-06.scm hosted with ❤ by GitHub


さらに、for らしく。
(define-syntax for
(syntax-rules ()
((_ (((var init) ...)
(pred ...)(update ...)) body ...)
(do ((var init) ...)
((not (and pred ...)))
body ...
update ...))))
view raw for-07.scm hosted with ❤ by GitHub


この辺で、劣化 do マクロを書いている様な気がしてきたので終了。

for って自由度高いですよね
for (var today = new Date(),
y = today.getFullYear(),
m = today.getMonth(),
bom = new Date(y, m, 1),
eom = new Date(y, m + 1, 0),
day = 1;
day <= eom.getDate();
day++){
alert (day);
};
for (var i = 0; i < 10; i % 2 == 0 ? i % 4 == 0 ? i = i + 2 : i = i + 1 : i = i + 1) {
alert (i);
}
var i = 0;
for (;;){
if (10 < i){
break;
}
alert (i++);
}
for (var b1 = false, b2 = false, i = 0; b1 !== b2, i !== 50;){
if (i == 10){
b1 = true;
}
if (i == 20){
b2 = true;
}
alert(i++);
}
view raw for.js hosted with ❤ by GitHub


プログラミングGauche

gauche with-module

前にメモっていますが、もう一度。
;; with-module
(define + 1)
+
; -> 1
(+ 1 2 3)
; -> *** ERROR: invalid application: (1 1 2 3)
(define + (with-module gauche +))
+
; -> #<subr +>
(+ 1 2 3)
; -> 6
view raw with-module.scm hosted with ❤ by GitHub


プログラミングGauche

call/cc sum1-n, reverse

(call/cc identity) が、なるほど!だったので。
;; http://www.rakunet.org/TSNET/topics/compare.html#scheme
(define (sum1-n n)
(let ((total 0)
(i 0))
(let1 next (call/cc identity)
(if (< n i)
total
(begin
(set! total (+ total i))
(set! i (+ i 1))
(next next))))))
(sum1-n 10)
(define (sum1-n n)
(let ((total 0)
(i 0))
(let/cc break
(let1 next (call/cc identity)
(if (< n i)
(break total)
(begin
(set! total (+ total i))
(set! i (+ i 1))
(next next)))))))
(sum1-n 10)
; -> 55

;; reverse
(define (my-reverse ls)
(let ((ls ls)
(acc '()))
(let/cc return
(let1 next (call/cc identity)
(if (null? ls)
(return acc)
(begin
(set! acc (cons (car ls) acc))
(set! ls (cdr ls))
(next next)))))))
(my-reverse '(1 2 3 4 5))


プログラミングGauche

2010/05/22

Emacs custom-set-faces

custom-set-faces のことを知りませんでした。お陰様で、quack.el のシンタックスハイライトを変更したかったとき、quack.el を直に修正しましたよ・・・。

.emacs 編集時(lisp-mode?)の、コメントは斜体ですよね。それを変更しました。
(custom-set-faces
'(font-lock-comment-face ((t (:italic nil :foreground "slate gray")))))
view raw custom-lisp.el hosted with ❤ by GitHub


そこで、quack.el のことを思い出してのぞいて見たら同じことができるようだったので、そうしました。
;; custom faces
;; quack-pltish-comment-face
;; quack-pltish-selfeval-face
;; quack-pltish-paren-face
;; quack-banner-face
;; quack-pltish-class-defn-face
;; quack-pltish-module-defn-face
;; quack-pltish-keyword-face
;; quack-threesemi-h2-face
;; quack-threesemi-h3-face
;; quack-pltfile-prologue-face
;; quack-pltfile-dir-face
;; quack-pltfile-file-face
;; quack-about-title-face
;; quack-about-face
;; quack-smallprint-face
(custom-set-faces
'(quack-pltish-defn-face
((((class color) (background light))(:bold t :foreground "darkgoldenrod4"))
(((class color) (background dark))(:bold t :foreground "darkgoldenrod3"))
(t (:bold t :underline t)))))
(custom-set-faces
'(quack-threesemi-semi-face
((((class color) (background light))(:bold t :foreground "blue"))
(((class color) (background dark))(:bold t :foreground "blue"))
(t (:slant italic)))))
(custom-set-faces
'(quack-threesemi-text-face
((((class color) (background light))(:foreground "cyan4"))
(((class color) (background dark))(:bold t :foreground "blue"))
(t (:slant italic)))))
(custom-set-faces
'(quack-pltish-keyword-face
((((class color)(background light))(:bold t :foreground "maroon2"))
(((class color)(background dark))(:bold t :foreground "maroon2")))))
view raw custom-quack.el hosted with ❤ by GitHub


そういえば、auto-complete.el でもやってましたね。
(custom-set-faces
'(ac-candidate-face ((t (:background "dark orange" :foreground "white"))))
'(ac-selection-face ((t (:background "blue" :foreground "white")))))


何か一冊くらい Emacs の本が欲しいな。。

入門 GNU Emacs 第3版

2010/05/19

Re: TSS rember1*

もっとカッコよく書けないのかなーと思いながら。

;; rember1*
(define (rember1* a tree)
(cond ((null? tree) '())
((list? (car tree))
(let ((ret (rember1* a (car tree))))
(cons ret (if (equal? ret (car tree))
(rember1* a (cdr tree))
(cdr tree)))))
((eq? a (car tree))(cdr tree))
(else (cons (car tree)
(rember1* a (cdr tree))))))
(rember1* 5 '(1 2 (3 4 ()(1 2 3 4)(((5))) 6 7 8)(((5 6 () 5))(9 10))))
; -> (1 2 (3 4 () (1 2 3 4) ((())) 6 7 8) (((5 6 () 5)) (9 10)))
(define (rember1* a tree)
(if (null? tree)
'()
(let ((ar (car tree))
(dr (cdr tree)))
(cond ((list? ar)
(let ((r (rember1* a ar)))
(cons r (if (equal? r ar)
(rember1* a dr)
dr))))
((eq? a ar) dr)
(else (cons ar
(rember1* a dr)))))))
(rember1* 5 '(1 2 (3 4 ()(1 2 3 4)(((5))) 6 7 8)(((5 6 () 5))(9 10))))
; -> (1 2 (3 4 () (1 2 3 4) ((())) 6 7 8) (((5 6 () 5)) (9 10)))
(define (rember1* a tree)
(if (null? tree)
'()
(let ((ar (car tree))
(dr (cdr tree)))
(if (eq? a ar)
dr
(let ((r (if (list? ar)
(rember1* a ar)
ar)))
(cons r (if (equal? r ar)
(rember1* a dr)
dr)))))))
(rember1* 5 '(1 2 (3 4 ()(1 2 3 4)(((5))) 6 7 8)(((5 6 () 5))(9 10))))
; -> (1 2 (3 4 () (1 2 3 4) ((())) 6 7 8) (((5 6 () 5)) (9 10)))
(define (rember1* a tree)
(if (null? tree)
'()
(let ((ar (car tree))
(dr (cdr tree))
(r1* (pa$ rember1* a)))
(if (eq? a ar)
dr
(let ((r (if (list? ar)
(r1* ar)
ar)))
(cons r (if (equal? r ar)
(r1* dr)
dr)))))))
(rember1* 5 '(1 2 (3 4 ()(1 2 3 4)(((5))) 6 7 8)(((5 6 () 5))(9 10))))
; -> (1 2 (3 4 () (1 2 3 4) ((())) 6 7 8) (((5 6 () 5)) (9 10)))
(define (rember1* a tree)
(if (null? tree)
'()
(let ((ar (car tree))
(dr (cdr tree))
(term (lambda (pred x)
(if pred
(rember1* a x)
x))))
(if (eq? a ar)
dr
(let ((r (term (list? ar) ar)))
(cons r (term (equal? r ar) dr)))))))
(rember1* 5 '(1 2 (3 4 ()(1 2 3 4)(((5))) 6 7 8)(((5 6 () 5))(9 10))))
; -> (1 2 (3 4 () (1 2 3 4) ((())) 6 7 8) (((5 6 () 5)) (9 10)))
(define (rember1* a tree)
(if (null? tree)
'()
(let ((f (lambda (pred x)
(if (pred (car tree))
(rember1* a x)
x))))
(if (eq? a (car tree))
(cdr tree)
(let ((r (f list? (car tree))))
(cons r (f (pa$ equal? r)(cdr tree))))))))
(rember1* 5 '(1 2 (3 4 ()(1 2 3 4)(((5))) 6 7 8)(((5 6 () 5))(9 10))))
; -> (1 2 (3 4 () (1 2 3 4) ((())) 6 7 8) (((5 6 () 5)) (9 10)))
(define (rember1* a tree)
(let ((f (lambda (pred x)
(if (pred (car tree))
(rember1* a x)
x))))
(if (null? tree)
'()
(if (eq? a (car tree))
(cdr tree)
(let ((r (f list? (car tree))))
(cons r (f (pa$ equal? r)(cdr tree))))))))
(rember1* 5 '(1 2 (3 4 ()(1 2 3 4)(((5))) 6 7 8)(((5 6 () 5))(9 10))))
; -> (1 2 (3 4 () (1 2 3 4) ((())) 6 7 8) (((5 6 () 5)) (9 10)))
(define (rember1* a tree)
(let ((f (lambda (pred x)
(if (pred (car tree))
(rember1* a x)
x))))
(cond ((null? tree) '())
((eq? a (car tree))(cdr tree))
(else (let ((r (f list? (car tree))))
(cons r (f (pa$ equal? r)(cdr tree))))))))
(rember1* 5 '(1 2 (3 4 ()(1 2 3 4)(((5))) 6 7 8)(((5 6 () 5))(9 10))))
; -> (1 2 (3 4 () (1 2 3 4) ((())) 6 7 8) (((5 6 () 5)) (9 10)))
(define (rember1* a tree . rest)
(let-optionals* rest ((eqp eq?))
(let ((f (lambda (pred x)
(if (pred (car tree))
(rember1* a x)
x))))
(cond ((null? tree) '())
((eqp a (car tree))(cdr tree))
(else (let ((r (f list? (car tree))))
(cons r (f (pa$ equal? r)(cdr tree)))))))))
(rember1* 5 '(1 2 (3 4 ()(1 2 3 4)(((5))) 6 7 8)(((5 6 () 5))(9 10))) eqv?)
; -> (1 2 (3 4 () (1 2 3 4) ((())) 6 7 8) (((5 6 () 5)) (9 10)))


いくつか書いていれば何か思いつくかなー、と思いましたが思いつきませんでした。わかりにくくなった気がします。

しかし、ホント The Seasoned Schemer のコードときたら・・・。。

The Seasoned Schemer