2010/09/30

おめでとうございます!「『Scheme手習い』(The Little Schemer, 4th edition)10月23日発売予定」

めでたい!今年は Lisp 本が豊作ですね!
『Scheme手習い』(The Little Schemer, 4th edition)、印刷所に入稿。10月23日発売予定。 http://bit.ly/bokZZk




追記

MIT の教科書 "計算機プログラムの構造と解釈" (昔は構造と実行) を読む為の本だったそうである。
まじか!

追記2


Scheme手習い

2010/09/27

unfold の cons が指定できても良いような

そんなことを思ったのでメモがてら。
(define (accrec-right p f g c seed . terminal-fun)
(let-optionals* terminal-fun ((terminal-fun identity))
(let rec ((ls seed)(acc '()))
(if (p ls)
(terminal-fun acc)
(rec (g ls)(c (f ls) acc))))))
(define (accrec p f g c seed . terminal-fun)
(let-optionals* terminal-fun ((terminal-fun identity))
(accrec-right p f g c seed (lambda (ls)
(terminal-fun (reverse ls))))))
view raw accrec.scm hosted with ❤ by GitHub


追記

@valvallow (define(accrec-right p f g c s :optional(t'()))(let l((s s)(a t))(if(p s)a(l(g s)(c(f s)a))))) unfoldとunfold-rightの最後の引数は意味が違いますよ
(define (accrec-right p f g c s :optional(t'()))
   (let l ((s s)(a t))
     (if (p s)
         a
         (l(g s)(c (f s) a)))))

(accrec-right null? car cdr cons '(1 2 3 4 5) '(0))
;; (5 4 3 2 1 0)

このオプション引数の指定のやり方、知りませんでした。。
それに、unfold、unfold-right の引数も確認しました。
ありがとうございました!!

追記2

これは Hylomorphism になるのかなあ: 「unfold の cons が指定できても良いような」 http://valvallow.blogspot.com/2010/09/unfold-cons.html
ヒロモーフィズム?ハイロモーフィズム?何と読むんでしょうか。。初めて聞きました。
意味はわかりませんが、
「アナモルフィズム」(anamorphism)
「アポモルフィズム」(apomorphism)
とかいった言葉は srfi-1 のドキュメントで目にしたことがあります。

追記3

leque さんのコメントより。ありがとうございます!
『関数プログラミングの楽しみ』ではリストに対する hylomorphism を次のような感じで定義しています。
(define (hylo f e p g h seed)
  (fold-right f e (unfold p g h seed)))

(define (fact n)
  (hylo * 1 (cut = <> 0) values (cut - <> 1) n))
おお。なんかカッコイイ!

こんな感じでも良いのかな。
(define (fact n)
  (hylo * 1 zero? identity (lambda (n)
                             (- n 1)) n))

(define (fact n)
  (fold * 1 (unfold zero? identity (cut - <> 1) n)))


プログラミングGauche

Re: comp.lang.scheme で簡単なリスト操作のお題が出ておるな。

comp.lang.scheme で簡単なリスト操作のお題が出ておるな。 http://goo.gl/5GAm
ということで、やってみました。Scheme(Gauche)です。

以下コード。
;; http://twitter.com/baal5084/status/25592330085
;; ((0 a b) (1 c d) (2 e f) (3 g h) (1 i j)(2 k l) (4 m n) (2 o p) (4 q r) (5 s t))
;; ->
;; ((a b) (c d i j) (e f k l o p) (g h) (m n q r) (s t))
(define data
'((0 a b) (1 c d) (2 e f) (3 g h) (1 i j)
(2 k l) (4 m n) (2 o p) (4 q r) (5 s t)))
(use srfi-1)
;; (slice-if '(1 1 1 2 2 2 3 4 4 5 5 5 5 5))
;; -> ((1 1 1) (2 2 2) (3) (4 4) (5 5 5 5 5))
(define (slice-if ls . args)
(let-optionals* args ((eq? eq?)(combiner cons))
(let rec ((ls ls)(acc '()))
(if (null? ls)
(reverse acc)
(receive (took rest)(span (lambda (e)
(eq? e (car ls))) ls)
(rec rest (combiner took acc)))))))
(define (key-sorted-combine table)
(slice-if (sort table (lambda (e1 e2)
(< (car e1)(car e2))))
(lambda (e rest)
(= (car e)(car rest)))
(lambda (took acc)
(cons (apply append (map cdr took)) acc))))
(key-sorted-combine data)
;; ((a b) (c d i j) (e f k l o p) (g h) (m n q r) (s t))


追記

教えて頂きました!いつもありがとうございます!
@valvallow (use gauche.sequence)(use srfi-1)(define(key-sorted-combine lst)(map(pa$ append-map cdr)(group-collection lst :key car)))
(use gauche.sequence)
(use srfi-1)
(define (key-sorted-combine lst)
  (map (pa$ append-map cdr)
       (group-collection lst :key car)))

(define data
  '((0 a b) (1 c d) (2 e f) (3 g h) (1 i j)
    (2 k l) (4 m n) (2 o p) (4 q r) (5 s t)))

(key-sorted-combine data)
;; ((a b) (c d i j) (e f k l o p) (g h) (m n q r) (s t))
group-collection 要チェックや!

そういえば、以前 group-sequence は見た記憶が。。

The Little Schemer, 4th Edition

2010/09/23

番号付き部分適用 cutn

srfi-26 の cut を使ってると (cut list 1 <0> 3 <1> 4) って書けたら・・・なんて思います。衛生的なマクロではありませんが、試しに書いてみました。

使用例はこんな感じ。<...> は考慮していません。あと、(cutn list <0> <1> (* <0> <0>)) のようなネストしたものは cut 同様考慮していません。
((cutn list <1> <0> <1> <2> <0>) 1 2 3)
;; (2 1 2 3 1)
(let1 i 9
((cutn list <0> <1> <2> <0> <1> <2>) i (inc! i) (inc! i)))
;; (9 10 11 9 10 11)
((cutn list 1 <1> 3 <0> 5) 4 2)
;; (1 2 3 4 5)
((cutn list 1 <1> <1> <1> 3 <0> 5) 4 2)
;; (1 2 2 2 3 4 5)
((cutn list <0> ((cutn list <0>) <0>) <0>) 1)
;; (1 (1) 1)
(let1 i 9
((cutn list <0> ((cutn list <0>) <0>) <0>) (inc! i)))
;; (10 (10) 10)
(let1 i 9
((cutn list <0> ((cutn list <0>) (inc! <0>)) <0>) (inc! i)))
;; (10 (11) 11)

(最後の例が微妙な気もする)

cutn のコードはこちら。
(use liv.lol.defmacro) ; defmacro!
(use liv.onlisp.symbols) ; explode
(use liv.cl) ; cl:remove-duplicates
(use srfi-1) ; unfold
(define (cutn-symbol? sym)
(and (symbol? sym)
(let1 symls (explode sym)
(and (eq? '< (car symls))
(number? (x->integer (cadr symls)))
(eq? '> (caddr symls))))))
(define (gen-cutn-symbols . params)
(let1 cnt 0
(apply unfold null? (lambda _
(rlet1 r (symb '< cnt '>)
(inc! cnt))) cdr params)))
(define (symbol<? a b)
(string<? (symbol->string a)(symbol->string b)))
(defmacro! (cutn . body)
(let ((g!cs (sort (filter cutn-symbol?
(cl:remove-duplicates body))
symbol<?)))
`(lambda ,g!cs
,body)))
view raw cutn.scm hosted with ❤ by GitHub


うーん。

LET OVER LAMBDA Edition 1.0

ドット対をリストに変換する

基本的には終端を空リストにしたリストを返します。一応 terminal-fun にて終端を指定できるようにしました。
コードは以下の通り。
(use srfi-1)
(define (dotted-list->list dl . terminal-fun)
(let-optionals* terminal-fun ((terminal-fun (lambda _ '())))
(unfold not-pair? car cdr dl terminal-fun)))
(dotted-list->list '(a b . c))
;; (a b)
(dotted-list->list '(a b . c) identity)
;; (a b . c)
(dotted-list->list '(a b . c) (lambda (term)
(list term)))
;; (a b c)


プログラミングGauche

先日書いた defmacro! がバグっていたので

先日書いたものがバグっていたので、修正しようとしましたが解決できず・・・。
バグは、defmacro! で可変長引数が取れないというものです。
例えば、
(defmacro! (sum . args) ...
とした時に args を filter して o! シンボルを g! シンボルに置き換えようとするところで、args がまだシンボルのままであるためエラーになるというものです。よって、その処理を書く場所に気をつけて評価順序を制御すれば良いだろうと思って修正を試みていたのですが、なかなかうまくいかず。。悔しいれす(^p^)

(define defmacro define-macro)
(defmacro (defmacro/g! name . body)
(let1 syms (cl:remove-duplicates (filter g!-symbol? (flatten body)))
`(defmacro (,(car name) ,@(cdr name))
(let ,(map (lambda (s)
`(,s (gensym ,(remove-mark s)))) syms)
,@body))))
(define-macro (defmacro! name . body)
(let* ((args (cdr name))
(os (filter o!-symbol? args))
(gs (map o!-symbol->g!-symbol os)))
`(defmacro/g! (,(car name) ,@args)
`(let ,(map list (list ,@gs)(list ,@os))
,(begin ,@body)))))
view raw defmacro.scm hosted with ❤ by GitHub


猫好きながら猫アレルギーにより鼻水ダラダラを理由に今日は一旦諦めます。。

追記

勘違いだったようです。というか見当違いでした。filter の引数に非リストを渡していたからっぽい。全然見当違いの修正を数時間やってました。。ご飯食べてお風呂入って、再度コードを見たらあっけなく・・・。


(defmacro (defmacro! name . body)
(let* ((args (cdr name))
(os (filter o!-symbol? (if (dotted-list? args)
(dotted-list->list args)
args)))
(gs (map o!-symbol->g!-symbol os)))
`(defmacro/g! (,(car name) ,@args)
`(let ,(map list (list ,@gs)(list ,@os))
,(begin ,@body)))))
view raw defmacro2.scm hosted with ❤ by GitHub


LET OVER LAMBDA Edition 1.0

2010/09/22

Emacs ポップアップ辞書

何これ便利すぎだろ!!(笑)
単語の上で C-c p




追記

教えてもらいました!ありがとうござます。
sdic-inline.el,sdic-inline-pos-tip.elもいいですよ!
なるほどこれも便利そうだ!

Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

`',hoge は `(quote ,hoge)

実用 Common Lisp (IT Architects’Archive CLASSIC MODER) P.272
イディオム「`',fn-names」はコメントする価値がある。最初は混乱するかもしれないが、よく使用されるイディオムである。等価な形式 `(quote ,fn-names) のほうが、理解しやすいかもしれない。
これはわかりやすい。

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

PAIP の pipe でエラトステネスの篩(ふるい)

実用 Common Lisp (IT Architects’Archive CLASSIC MODER) 9.3 P.263 ~。
遅延評価による無限集合の例。遅延リストとしてのpipe。Scheme(Gauche)で書いたこともあり、コードは書籍とは若干違います。

pipe を用いたエラトステネスの篩。
;; example
(define (pipe-enumerate pipe . keys)
(let-keywords* keys ((count 0)(key #f)(result pipe))
(if (or (pipe-empty? pipe)(zero? count))
result
(begin
(when key
(key (head pipe)))
(pipe-enumerate (tail pipe)
:count (- count 1)
:key key
:result result)))))
(define (pipe-filter pred pipe)
(if (pred (head pipe))
(make-pipe (head pipe)
(pipe-filter pred (tail pipe)))
(pipe-filter pred (tail pipe))))
(define (sieve pipe)
(make-pipe (head pipe)
(pipe-filter (lambda (x)
((complement zero?)(modulo x (head pipe))))
(sieve (tail pipe)))))
(pipe-enumerate (sieve (integers 2)) :count 10)
;; (2 3 5 7 11 13 17 19 23 29 31 . #<closure (pipe-filter pipe-filter)>)
(pipe-enumerate (sieve (integers 2)) :count 100)
;; (2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 . #<closure (pipe-filter pipe-filter)>)


delay と force による pipe
;; PAIP 9.3 P.263-
;; pipe
;; delay & force
(define-macro (make-pipe head tail)
`(cons ,head (delay ,tail)))
(define-constant empty-pipe '())
(define (head pipe)
(car pipe))
(define (tail pipe)
(force (cdr pipe)))
(define (pipe-ref pipe n)
(if (zero? n)
(head pipe)
(pipe-ref (tail pipe)(- n 1))))
(define (integers . startend)
(let-optionals* startend ((start 0)(end +inf.0))
(if (<= start end)
(make-pipe start (integers (+ start 1) end))
empty-pipe)))
view raw pipe1.scm hosted with ❤ by GitHub


クロージャによる pipe
;; PAIP 9.3 P.266-
;; pipe
;; closure
(define-macro (make-pipe head tail)
`(cons ,head (lambda () ,tail)))
(define-constant empty-pipe '())
(define (head pipe)
(car pipe))
(define (pipe-empty? pipe)
(equal? empty-pipe pipe))
(define (pipe-ref pipe n)
(cond ((pipe-empty? pipe) #f)
((zero? n)(head pipe))
(else (pipe-ref (tail pipe)(- n 1)))))
(define (tail pipe)
(cond ((pipe-empty? pipe) empty-pipe)
((procedure? (cdr pipe))
(set! (cdr pipe)((cdr pipe)))
(cdr pipe))
(else (cdr pipe))))
(define (integers . startend)
(let-optionals* startend ((start 0)(end +inf.0))
(if (<= start end)
(make-pipe start (integers (+ start 1) end))
empty-pipe)))
view raw pipe2.scm hosted with ❤ by GitHub



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

Common Lisp の /=

Common Lisp の /= は、(complement =) ってことですか。
で、これ何て読むのよ・・・。

COMMON LISP 第2版

Emacs 日付の挿入

F5 押したら「2010/09/22 18:29:20」のような日付が挿入されるだけなんだけど、意外と便利かも。
(define-key global-map [f5]
  '(lambda ()
     (interactive)
     (insert (format-time-string "%Y/%m/%d %H:%M:%S"))))

Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

Re: schemeで全dataを+するのを知りたいです、か?

私もやってみました。

mysum
;; http://d.hatena.ne.jp/yad-EL/20100921/p1
;; (mysum 20) => error
;; (mysum '()) => 0
;; (mysum '(1 2 3)) => 6
;; (mysum '((1 2) ((3)) (4 (5)))) => 15
(define (tree-fold proc seed tree)
(if (list? tree)
(fold (lambda (e acc)
(if (list? e)
(tree-fold proc acc e)
(proc e acc))) seed tree)
(error "argument must be a list, but got")))
(define (mysum tree)
(tree-fold + 0 tree))
(mysum 20)
;; *** ERROR: argument must be a list, but got
(mysum '())
;; 0
(mysum '(1 2 3))
;; 6
(mysum '((1 2) ((3)) (4 (5))))
;; 15
view raw mysum.scm hosted with ❤ by GitHub

mytrans
;; http://d.hatena.ne.jp/yad-EL/20100921/p1
;; (mytrans 1) => error
;; (mytrans '()) => 0
;; (mytrans '(1 2 3)) => (one two three)
;; (mytrans '((1 2) ((3)) (4 (5 6)))) => ((one two) ((three)) (four (five six)))
(define (tree-map proc tree)
(map (lambda (e)
(if (list? e)
(tree-map proc e)
(proc e))) tree))
(define *table* '(zero one two three
four five six seven
eight nine ten))
(define (mytrans tree)
(cond ((not (list? tree))(error "argument must be a list, but got"))
((null? tree) 0)
(else (tree-map (lambda (e)
(list-ref *table* e)) tree))))
(mytrans 1)
;; *** ERROR: argument must be a list, but got
(mytrans '())
;; 0
(mytrans '(1 2 3))
;; (one two three)
(mytrans '((1 2) ((3)) (4 (5 6))))
;; ((one two) ((three)) (four (five six)))
view raw mytrans.scm hosted with ❤ by GitHub

myfind
;; http://d.hatena.ne.jp/yad-EL/20100921/p1
;; (myfind 10) => error
;; (myfind 'a) => error
;; (myfind '((x 10) (y 20) (x 30)) 'x) => 10
;; (myfind '((x 10) (y 20) (z 30)) 'i) => #f
(define (myfind ls key)
(let/cc hop
(fold (lambda (e seed)
(if (eq? key (car e))
(hop (cadr e))
seed))
#f ls)))
(myfind 10)
;; error
(myfind 'a)
;; error
(myfind '((x 10) (y 20) (x 30)) 'x)
(myfind '((x 10) (y 20) (z 30)) 'i) => #f
view raw myfind.scm hosted with ❤ by GitHub


プログラミングGauche

2010/09/17

Gauche の info を anything で引く

まじ便利!!

調べたい語句の前で C-M-;

すると anything のインターフェースで gauche の info が。



こちらを参考にしました。

.emacs に以下を追加しただけですが、これは劇的 before/after 。。
(defvar anything-c-source-info-gauche-refj
   ;; '((info-index . "~/../gauche/share/info/gauche-refj.info")))
  '((info-index . "gauche-refj.info")))
(defun anything-info-ja-at-point ()
  "Preconfigured `anything' for searching info at point."
  (interactive)
  (anything '(anything-c-source-info-gauche-refj)
            (thing-at-point 'symbol) nil nil nil "*anything info*"))
(define-key global-map (kbd "C-M-;") 'anything-info-ja-at-point)

今まではこちらを参考に使ってましたが、結局 Web のリファレンスを引くことが多かったです。

Emacsテクニックバイブル ~作業効率をカイゼンする200の技~

2010/09/15

LOL defmacro!

LET OVER LAMBDA Edition 1.0 の defmacro! を scheme(Gauche)で書きました。
基本的に同じものですが、実験的に g! や o! を変更できるようにしています。
Un-Common Lisp の defmacro* がプレフィックスに g!, o! をつけるのでなく、サフィックスに #, % を付けるスタイルなのを見て、切り替えられるようにしてみても良いかなぁと。切り替え方が不細工ですが、まぁお試しということで。

使用例はこんな感じ。
(use liv.lol.defmacro)
(use srfi-27)
;; g!expr, o!expr
(defmacro! nif (o!expr pos zero neg)
`(cond ((positive? ,g!expr) ,pos)
((zero? ,g!expr) ,zero)
(else ,neg)))
(macroexpand '(defmacro! nif (o!expr pos zero neg)
`(cond ((positive? ,g!expr) ,pos)
((zero? ,g!expr) ,zero)
(else ,neg))))
;; (define-macro (nif o!expr pos zero neg)
;; (let ((g!expr (gensym "expr")))
;; `(let ,(map list (list g!expr) (list o!expr))
;; ,(begin `(cond ((positive? ,g!expr) ,pos)
;; ((zero? ,g!expr) ,zero) (else ,neg))))))
(macroexpand '(nif (- (random-integer 10)(random-integer 10)) 'pos 'zero 'neg))
;; (let ((#0=#:expr39 (- (random-integer 10) (random-integer 10))))
;; (cond ((positive? #0#) 'pos)
;; ((zero? #0#) 'zero)
;; (else 'neg)))
(*g!-symbol* '%)
(*o!-symbol* '$)
(*defmacro!-symbol-position* 'sufix)
(apply-defmacro!-config!)
;; expr%, expr$
(macroexpand '(defmacro! nif (expr$ pos zero neg)
`(cond ((positive? ,expr%) ,pos)
((zero? ,expr%) ,zero)
(else ,neg))))
;; (define-macro (nif expr$ pos zero neg)
;; (let ((expr% (gensym "expr")))
;; `(let ,(map list (list expr%) (list expr$))
;; ,(begin `(cond ((positive? ,expr%) ,pos)
;; ((zero? ,expr%) ,zero)
;; (else ,neg))))))
(apply-defmacro!-config! 'g! 'o! 'prefix)
(defmacro! nif (o!expr pos zero neg)
`(cond ((positive? ,g!expr) ,pos)
((zero? ,g!expr) ,zero)
(else ,neg)))
(macroexpand '(defmacro! nif (o!expr pos zero neg)
`(cond ((positive? ,g!expr) ,pos)
((zero? ,g!expr) ,zero)
(else ,neg))))
;; (define-macro (nif o!expr pos zero neg)
;; (let ((g!expr (gensym "expr")))
;; `(let ,(map list (list g!expr) (list o!expr))
;; ,(begin `(cond ((positive? ,g!expr) ,pos)
;; ((zero? ,g!expr) ,zero)
;; (else ,neg))))))
view raw example.scm hosted with ❤ by GitHub


以下 defmacro! のコード。
(define-module liv.lol.defmacro
(use srfi-1)
(use srfi-13)
(use liv.cl)
(use liv.onlisp.utils)
(use gauche.parameter)
(export *g!-symbol* *o!-symbol* *defmacro!-symbol-position*
apply-defmacro!-config! defmacro defmacro/g! defmacro!))
(select-module liv.lol.defmacro)
(define *g!-symbol* (make-parameter 'g!))
(define *o!-symbol* (make-parameter 'o!))
(define *defmacro!-symbol-position* (make-parameter 'prefix))
(define %string-append string-append)
(define %mark-position string-prefix?)
(define %string-drop string-drop)
(define apply-defmacro!-config!
(case-lambda
((g! o! pos)
(*g!-symbol* g!)
(*o!-symbol* o!)
(*defmacro!-symbol-position* pos)
(apply-defmacro!-config!))
(()
(case (*defmacro!-symbol-position*)
((prefix)
(set! %string-append string-append)
(set! %mark-position string-prefix?)
(set! %string-drop string-drop))
((sufix)
(set! %string-append (lambda (s1 s2)
(string-append s2 s1)))
(set! %mark-position string-suffix?)
(set! %string-drop string-drop-right))))))
(define (mark-symbol? sym mark pred)
(pred (symbol->string mark)(symbol->string sym)))
(define (g!-symbol? sym)
(mark-symbol? sym (*g!-symbol*) %mark-position))
(define (o!-symbol? sym)
(mark-symbol? sym (*o!-symbol*) %mark-position))
(define (remove-mark sym)
(%string-drop (symbol->string sym)
(string-length (symbol->string (*o!-symbol*)))))
(define (o!-symbol->g!-symbol sym)
(string->symbol
(%string-append (symbol->string (*g!-symbol*))
(remove-mark sym))))
(define-macro (defmacro/g! name args . body)
(let1 syms (cl:remove-duplicates (filter g!-symbol? (flatten body)))
`(define-macro (,name ,@args)
(let ,(map (lambda (s)
`(,s (gensym ,(remove-mark s)))) syms)
,@body))))
(define-macro (defmacro! name args . body)
(let* ((os (filter o!-symbol? args))
(gs (map o!-symbol->g!-symbol os)))
`(defmacro/g! ,name ,args
`(let ,(map list (list ,@gs)(list ,@os))
,(begin ,@body)))))
(define-syntax defmacro
(syntax-rules ()
((_ name (arg ...) body ...)
(define-macro (name arg ...) body ...))))
(provide "liv/lol/defmacro")
view raw defmacro!.scm hosted with ❤ by GitHub


追記

defmacro! に可変長引数が受け取れないバグがありました。修正しました。

LET OVER LAMBDA Edition 1.0

2010/09/14

On Lisp のユーティリティをいくつか

いくつか Gauche で書きました。写経がてら。前回読んだ時にあまり書いてないので、揃えておいた方が良いなぁと。
ざっくり書いただけなので、動かないところがあるかもしれません。

LET OVER LAMBDA Edition 1.0On Lisp を再読しているので、こういうのを揃えていこうと考えています。書きたいものがあるときにすぐに書き始められる状態を作っておかないといけないなぁと思った次第です。

以下コード。
;; on lisp
;; http://www.komaba.utmc.or.jp/~flatline/onlispjhtml/
(define-module liv.onlisp.utils
(use srfi-1)
(use util.list)
(export-all))
(select-module liv.onlisp.utils)
(define (single ls)
(and (pair? ls)
(null? (cdr ls))))
(define (append1 ls obj)
(append ls (list obj)))
(define (append1! ls obj)
(append! ls (list obj)))
(define (mklist obj)
(if (pair? obj)
obj
(list obj)))
(define (flatten tree)
(if (list? tree)
(append (flatten (car tree))
(if (null? (cdr tree))
'()
(flatten (cdr tree))))
(mklist tree)))
(define group slices)
(define (prune test tree)
(fold-right (lambda (e acc)
(if (pair? e)
(cons (prune test e) acc)
(if (test e)
acc
(cons e acc))))
'() tree))
(define (before x y ls)
(and (not (null? ls))
(let1 a (car ls)
(cond ((test y a) => (lambda (b)
(not b)))
((test x a) ls)
(else (before x y (cdr ls) :test test))))))
(define (after x y ls)
(let1 rest (before y x ls)
(and rest (member x rest))))
(define (duplicate obj ls)
(member obj (cdr (member obj ls))))
(define (split-if fn ls)
(let rec ((ls ls)(acc '()))
(if (or (null? ls)
(fn (car ls)))
(values (reverse acc) ls)
(rec (cdr ls)(cons (car ls) acc)))))
(define (most fn ls)
(if (null? ls)
(values '() -inf.0)
(with-module gauche.collection
(fold2 (lambda (e ret max)
(let1 score (fn e)
(if (< max score)
(values e score)
(values ret max)))) '() -inf.0 ls))))
(define (best fn ls)
(if (null? ls)
'()
(fold (lambda (e acc)
(if (fn e acc)
e
acc))(car ls) ls)))
(define (mostn fn ls)
(if (null? ls)
(values '() -inf.0)
(with-module gauche.collection
(fold2 (lambda (e ret max)
(let1 score (fn e)
(cond ((< max score)(values (list e) score))
((= max score)(values (append ret (list e)) max))
(else (values ret max)))))
'() -inf.0 ls))))
(define (mapa-b fn a b . step)
(let-optionals* step ((step 1))
(let rec ((i a)(end b)(acc '()))
(if (< end i)
(reverse acc)
(rec (+ i step) end (cons (fn i) acc))))))
(define (map0-n fn n)
(mapa-b fn 0 n))
(define (map1-n fn n)
(mapa-b fn 1 n))
(define (map-> fn start test-fn succ-fn)
(let rec ((i start)(acc '()))
(if (test-fn i)
(reverse acc)
(rec (succ-fn i)(cons (fn i) acc)))))
(define (mappend fn . lss)
(apply append (apply map fn lss)))
(define (rmap fn . lss)
(apply map (lambda (e)
(if (list? e)
(rmap fn e)
(fn e))) lss))
(define (mkstr . args)
(with-output-to-string
(lambda ()
(dolist (a args)
(display a)))))
(define (symb . args)
(string->symbol (apply mkstr args)))
(define (explode sym)
(map (compose string->symbol string)
((compose string->list symbol->string) sym)))
(define (fif pred then . else)
(let-optionals* else ((else #f))
(lambda x
(if (apply pred x)
(apply then x)
(if else
(apply else x))))))
(define (fint fn . funs)
(if (null? funs)
fn
(let1 chain (apply fint funs)
(lambda x
(and (apply fn x)(apply chain x))))))
(define (fun fn . funs)
(if (null? funs)
fn
(let1 chain (apply fint funs)
(lambda x
(or (apply fn x)(apply chain x))))))
(define (lrec rec . base)
(let-optionals* base ((base '()))
(letrec ((self (lambda (lst)
(if (null? lst)
(if (procedure? base)
(base)
base)
(rec (car lst)
(lambda ()
(self (cdr lst))))))))
self)))
(provide "liv.onlisp.utils")


On LispLET OVER LAMBDA Edition 1.0

昨日のライフゲームのソース

Scheme(gauche)で書かれています。

UI はまだありません。取り敢えずの使用方法。

10×10 でランダムな配置から始める。
(define lifegame (make-auto-step-lifegame 10 10))
(print-lifegame-table (lifegame :next))

30×30 でランダムな配置から始める。
(define erl (endless-repeat-lifegame (make-auto-step-lifegame 30 30)))
(erl)

データから読込む。読み込むデータが PULSER の場合。
(define pl (endless-repeat-lifegame (const->auto-step-lifegame PULSER)))
(pl)

以下ソース。
;; life game
;; http://github.com/valvallow/lifegame
(use srfi-1)
(use srfi-9) ; define-record-type
(use srfi-27) ; random-integer
(use util.list) ; slices
(use gauche.parameter)
(define (make-matrix w h . keys)
(let-optionals* keys ((seed-fun identity))
(let1 size (* w h)
(slices (list-tabulate size seed-fun) w))))
(define (map-matrix proc matrix)
(map (pa$ map proc) matrix))
(define (ref-matrix matrix x y)
(list-ref (list-ref matrix y) x))
(define (matrix-size matrix)
(values (length matrix)(length (car matrix))))
(define (random-bit)
(random-integer 2))
(define (make-random-bit-matrix w h)
(make-matrix w h (lambda args (random-bit))))
(define-record-type point
(make-point x y) point?
(x point-x)
(y point-y))
(define-record-type cell
(make-cell point live?) cell?
(point cell-point)
(live? cell-live?))
(define (map-matrix-with-point proc matrix)
(let ((x 0)(y 0))
(map (lambda (row)
(set! x 0)
(rlet1 r (map (lambda (e)
(rlet1 r (proc e (make-point x y))
(inc! x)))
row)
(inc! y)))
matrix)))
(define (make-lifegame-table bit-matrix)
(map-matrix-with-point (lambda (e p)
(let1 live? (complement zero?)
(make-cell p (live? e))))
bit-matrix))
(define (ref-lifegame-table table p)
(ref-matrix table (point-x p)(point-y p)))
(define (negative-point? p)
(any negative? (list (point-x p)(point-y p))))
(define (point-hold? p table)
(and (not (negative-point? p))
(receive (w h)(matrix-size table)
(and (< (point-x p) w)
(< (point-y p) h)))))
(define-constant RELATIVES
`((-1 1)(0 1)(1 1)
(-1 0)(1 0)
(-1 -1)(0 -1)(1 -1)))
(define (add-point p1 p2)
(make-point (+ (point-x p1)
(point-x p2))
(+ (point-y p1)
(point-y p2))))
(define (list-repeat n obj)
(list-tabulate n (lambda args obj)))
(define (neighborhood-points cell table)
(filter (cut point-hold? <> table)
(map (lambda (xy p)
(add-point p (make-point (car xy)(cadr xy))))
RELATIVES
(list-repeat (length RELATIVES)(cell-point cell)))))
(define (neighborhood-cells cell table)
(let1 np (neighborhood-points cell table)
(map (lambda (p)
(ref-lifegame-table table p)) np)))
(define (next-cell-live? cell table)
(let1 cnt-live (count cell-live? (neighborhood-cells cell table))
(if (cell-live? cell)
(<= 2 cnt-live 3)
(= cnt-live 3))))
(define (point-xy p)
(cons (point-x p)(point-y p)))
(define (next-lifegame-table table)
(map-matrix (lambda (cell)
(make-cell (cell-point cell)(next-cell-live? cell table)))
table))
(define-syntax dlambda
(syntax-rules (else)
((_ (msg1 (darg1 ...) dbody1 ...)(msg2 (darg2 ...) dbody2 ...) ...)
(lambda (key . args)
(case key
((msg1)(apply (lambda (darg1 ...)
dbody1 ...) args))
((msg2)(apply (lambda (darg2 ...)
dbody2 ...) args))
...
(else key))
))))
(define (make-auto-step-lifegame w h . args)
(let-optionals* args ((matrix (make-random-bit-matrix w h)))
(let1 lg (lambda ()
(make-lifegame-table matrix))
(let ((cur (lg))(prev '()))
(dlambda
(:reset ()
(set! cur (lg))
cur)
(:next ()
(set! prev cur)
(rlet1 r (next-lifegame-table cur)
(set! cur r)))
(:current () cur)
(:previouse () prev))))))
(define-record-type state-symbol
(make-state-symbol live dead) state-symbol?
(live state-symbol-live)
(dead state-symbol-dead))
(define-constant DEFAULT_STATE_SYMBOL
(make-state-symbol '�� '��))
(define *state-symbol* (make-parameter DEFAULT_STATE_SYMBOL))
(define (print-lifegame-table table)
(let1 ss (*state-symbol*)
(newline)
(for-each (lambda (row)
(print (map (lambda (cell)
(if (cell-live? cell)
(state-symbol-live ss)
(state-symbol-dead ss)))
row)))
table)))
(define (equal-lifegame? lg1 lg2)
(let/cc hop
(map (lambda (row1 row2)
(map (lambda (e1 e2)
(rlet1 r (eq? (cell-live? e1)(cell-live? e2))
(if (not r)
(hop r))))
row1 row2)) lg1 lg2)))
(define (endless-repeat-lifegame lifegame . args)
(let-optionals* args ((printer print-lifegame-table))
(lambda ()
(printer
(rlet1 r (lifegame :next)
(when (equal-lifegame? (lifegame :previouse)(lifegame :current))
(print 'restart)
(lifegame :reset)))))))
(define (const->auto-step-lifegame bit-matrix)
(receive (w h)(matrix-size bit-matrix)
(make-auto-step-lifegame w h bit-matrix)))
view raw lifegame.scm hosted with ❤ by GitHub

取りあえず用意したデータ。
(load "./lifegame.scm")
(define-constant BLOCK
'((0 0 0 0)
(0 1 1 0)
(0 1 1 0)
(0 0 0 0)))
(define-constant BEEHIVE
'((0 0 0 0 0 0)
(0 0 1 1 0 0)
(0 1 0 0 1 0)
(0 0 1 1 0 0)
(0 0 0 0 0 0)))
(define-constant LOAT
'((0 0 0 0 0)
(0 1 1 0 0)
(0 1 0 1 0)
(0 0 1 0 0)
(0 0 0 0 0)))
(define-constant BLINKER
'((0 0 0 0 0)
(0 0 1 0 0)
(0 0 1 0 0)
(0 0 1 0 0)
(0 0 0 0 0)))
(define-constant TOAD
'((0 0 0 0 0 0)
(0 0 0 0 0 0)
(0 0 1 1 1 0)
(0 1 1 1 0 0)
(0 0 0 0 0 0)))
(define-constant BEACON
'((0 0 0 0 0 0)
(0 1 1 0 0 0)
(0 1 1 0 0 0)
(0 0 0 1 1 0)
(0 0 0 1 1 0)
(0 0 0 0 0 0)))
(define-constant PULSER
'((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
(0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
(0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
(0 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 0)
(0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
(0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
(0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
(define-constant GLIDER
'((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
(define-constant LIGHTWEIGHT_SPACESHIP
'((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
;; test
(define lifegame (make-auto-step-lifegame 10 10))
(print-lifegame-table (lifegame :next))
(define erl (endless-repeat-lifegame (make-auto-step-lifegame 30 30)))
(erl)
(define bl (endless-repeat-lifegame (const->auto-step-lifegame BLINKER)))
(bl)
(define gl (endless-repeat-lifegame (const->auto-step-lifegame GLIDER)))
(gl)
(define ls (endless-repeat-lifegame (const->auto-step-lifegame LIGHTWEIGHT_SPACESHIP)))
(ls)
(define pl (endless-repeat-lifegame (const->auto-step-lifegame PULSER)))
(pl)
view raw examples.scm hosted with ❤ by GitHub


追記

改めて書き直してみました。

プログラミングGauche

ライフゲーム作った


9LISP の宿題。Scheme(Gauche)で作りました。作りかけですが、動くので取りあえず。
行き当たりばったりで作ったこともあり、突っ込みどころ満載でちょっと恥ずかしいですが。。

ライフゲームの動き見てるのって意外と面白いんですね。

例えば、繰り返すパターン。
(load "./lifegame.scm")

(define-constant PULSER
  '((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
    (0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
    (0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
    (0 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 0)
    (0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
    (0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
    (0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 1 1 1 0 0 0 1 1 1 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)))

(define pl (endless-repeat-lifegame (const->auto-step-lifegame PULSER)))
(pl)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ● ● ● ○ ○ ● ● ○ ● ● ○ ○ ● ● ● ○)
;; (○ ○ ○ ● ○ ● ○ ● ○ ● ○ ● ○ ● ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ● ○ ● ○ ● ○ ● ○ ● ○ ● ○ ○ ○)
;; (○ ● ● ● ○ ○ ● ● ○ ● ● ○ ○ ● ● ● ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
(pl)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ● ● ○ ○ ○ ○ ○ ● ● ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ● ○ ○ ● ○ ● ○ ● ○ ● ○ ○ ● ○ ○)
;; (○ ○ ● ● ● ○ ● ● ○ ● ● ○ ● ● ● ○ ○)
;; (○ ○ ○ ● ○ ● ○ ● ○ ● ○ ● ○ ● ○ ○ ○)
;; (○ ○ ○ ○ ● ● ● ○ ○ ○ ● ● ● ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ● ● ● ○ ○ ○ ● ● ● ○ ○ ○ ○)
;; (○ ○ ○ ● ○ ● ○ ● ○ ● ○ ● ○ ● ○ ○ ○)
;; (○ ○ ● ● ● ○ ● ● ○ ● ● ○ ● ● ● ○ ○)
;; (○ ○ ● ○ ○ ● ○ ● ○ ● ○ ● ○ ○ ● ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ● ● ○ ○ ○ ○ ○ ● ● ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
(pl)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ● ● ● ○ ○ ○ ● ● ● ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ● ○ ○ ○ ○ ● ○ ● ○ ○ ○ ○ ● ○ ○)
;; (○ ○ ● ○ ○ ○ ○ ● ○ ● ○ ○ ○ ○ ● ○ ○)
;; (○ ○ ● ○ ○ ○ ○ ● ○ ● ○ ○ ○ ○ ● ○ ○)
;; (○ ○ ○ ○ ● ● ● ○ ○ ○ ● ● ● ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ● ● ● ○ ○ ○ ● ● ● ○ ○ ○ ○)
;; (○ ○ ● ○ ○ ○ ○ ● ○ ● ○ ○ ○ ○ ● ○ ○)
;; (○ ○ ● ○ ○ ○ ○ ● ○ ● ○ ○ ○ ○ ● ○ ○)
;; (○ ○ ● ○ ○ ○ ○ ● ○ ● ○ ○ ○ ○ ● ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ● ● ● ○ ○ ○ ● ● ● ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
(pl)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ● ● ● ○ ○ ● ● ○ ● ● ○ ○ ● ● ● ○)
;; (○ ○ ○ ● ○ ● ○ ● ○ ● ○ ● ○ ● ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ● ○ ● ○ ● ○ ● ○ ● ○ ● ○ ○ ○)
;; (○ ● ● ● ○ ○ ● ● ○ ● ● ○ ○ ● ● ● ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ● ○ ○ ○ ● ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○ ● ○ ○ ○ ○ ○)
;; (○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○)

まだ UI がないので、IronScheme で作ろうかなぁとか考えてます。それか手っ取り早く C# で GUI 作ってデータ読み込むとか。。それなら最初から C# で作れば良いじゃんという話ですね。

プログラミングGauche

2010/09/11

フィボナッチ数列の公式

今日の 9LISP で shunsuk さんに教えて頂きました。
(define (fib-p n)
(let1 r5 (sqrt 5)
(round->exact (* (/ 1 r5)
(- (expt (/ (+ 1 r5) 2) n)
(expt (/ (- 1 r5) 2) n))))))
(use srfi-1)
(map fib-p (iota 30 1))
;; (1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711 28657 46368 75025 121393 196418 317811 514229 832040)
view raw fib-p.scm hosted with ❤ by GitHub

知りませんでした。。

数学ガール

2010/09/10

「最も簡単に fib を高速化する方法」を試してみた。

どうしてこれで速くなるの?
二つ値を返せば良いんですよ。メモ化なんてしなくていい。
取りあえず Scheme の多値でやってみました。速い。。どうして?
;; http://d.hatena.ne.jp/mrkn/20100906/easy_faster_fib
(define (fib-i n)
(if (or (zero? n)(= n 1))
(values 1 1)
(receive (cur prev)
(fib-i (- n 1))
(values (+ cur prev) cur))))
(fib-i 10)
;; 89
;; 55
(time (fib-i 10000))
;(time (fib-i 10000))
; real 0.094
; user 0.047
; sys 0.047
view raw fib-i.scm hosted with ❤ by GitHub



あとはまぁ、取りあえず参考までに。

メモ化。昨日のメモ化マクロを使ってみました。
;; memoize
;; http://valvallow.blogspot.com/2010/09/paip-memo-memoize-define-memo.html
(define-memo (fib-m n)
(if (or (zero? n)
(= n 1))
1
(+ (fib-m (- n 1))
(fib-m (- n 2)))))
(fib-m 10)
;; 89
(time (fib-m 10000))
;(time (fib-m 10000))
; real 0.125
; user 0.125
; sys 0.000
view raw fib-m.scm hosted with ❤ by GitHub


遅延ストリーム。
;; stream
;; http://valvallow.blogspot.com/2010/06/fib-tail-call-fib-lazy-fib.html
(use util.stream)
(define fib-s (stream-cons 1 (stream-cons 1 (stream-map + fib-s (stream-cdr fib-s)))))
(stream-ref fib-s 10)
;; 89
(time (stream-ref fib-s 10000))
;(time (stream-ref fib-s 10000))
; real 0.172
; user 0.157
; sys 0.016
view raw fib-s.scm hosted with ❤ by GitHub


末尾再帰。ようはループですわな。
;; tail call
;; http://valvallow.blogspot.com/2010/06/fib-tail-call-fib-lazy-fib.html
(define (fib-t n)
(let rec ((cur 1)(next 2)(n n))
(if (or (zero? n)
(= n 1))
cur
(rec next (+ cur next)(- n 1)))))
(fib-t 10)
;; 89
(time (fib-t 10000))
;(time (fib-t 10000))
; real 0.109
; user 0.047
; sys 0.047
view raw fib-t.scm hosted with ❤ by GitHub


普通の再帰。これは 10000 なんてとても試す気になれませんね。。
;; normal
(define (fib n)
(if (or (zero? n)
(= n 1))
1
(+ (fib (- n 1))
(fib (- n 2)))))
(fib 10)
;; 89
(time (fib 35))
;(time (fib 35))
; real 2.094
; user 2.078
; sys 0.000
;; (time (fib 10000))
;; ...
view raw fib.scm hosted with ❤ by GitHub


fib-i なぞ・・・。

追記

わかりました!というか教えて頂きました。末尾再帰の例と同じような計算の仕方だからですね。
末尾再帰ではないし、末尾再帰のようにその都度計算を行うのではなく再帰を戻りながら最後にまとめて計算する点は違えども、計算量は末尾再帰の例と同じということですよね。
というか、末尾再帰とか多値とかそういう話じゃないわけですね。。なんか、すいません。

ありがとうございました!

追記2

爆速過ぎワロタ
(define (fib-l n)
(let rec ((a 1)(b 1)(p 0)(q 1)(count n))
(cond ((= count 0) b)
((even? count)
(rec a
b
(+ (* p p) (* q q))
(+ (* 2 p q) (* q q))
(/ count 2)))
(else (rec (+ (* b q) (* a q) (* a p))
(+ (* b p) (* a q))
p
q
(- count 1))))))
(time (fib-l 10000))
;(time (fib-l 10000))
; real 0.000
; user 0.000
; sys 0.000
(time (fib-l 100000))
;(time (fib-l 100000))
; real 0.203
; user 0.203
; sys 0.000
view raw fib-l.scm hosted with ❤ by GitHub



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

PAIP: メモ化, memo, memoize, define-memo

メモ化。以前もいくつかいい加減な記事を書いています。。


メモ化については On Lisp や SICP(計算機プログラムの構造と解釈)なんかでも出てきますね。

今回はPAIP(実用 Common Lisp (IT Architects’Archive CLASSIC MODER))P.253 第3部 第9章 9.1 より。Common Lisp ではなく Gauche(Scheme)で書いてあるので、コードが多少違います。

以下コード。一つ目がmemo関数のプロトタイプで二つ目が本番 memo, meomize, define-memo, clear-memoize。都合により clear-memo も追加しています。
;; memo
(define (memo fn)
(let1 cache (make-hash-table)
(lambda (x)
(if-let1 val (hash-table-get cache x #f)
val
(rlet1 r (fn x)
(hash-table-put! cache x r))))))
(define (fib n)
(if (or (zero? n)
(= n 1))
1
(+ (fib (- n 1))
(fib (- n 2)))))
(use slib)
(require 'trace)
(trace fib)
(fib 3)
;; CALL fib 3
;; CALL fib 2
;; CALL fib 1
;; RETN fib 1
;; CALL fib 0
;; RETN fib 1
;; RETN fib 2
;; CALL fib 1
;; RETN fib 1
;; RETN fib 3
;; 3
(define memo-fib (memo fib))
(trace memo-fib)
(memo-fib 3)
;; CALL fib 3
;; CALL fib 2
;; CALL fib 1
;; RETN fib 1
;; CALL fib 0
;; RETN fib 1
;; RETN fib 2
;; CALL fib 1
;; RETN fib 1
;; RETN fib 3
;; 3
(memo-fib 3)
;; 3
view raw memo.scm hosted with ❤ by GitHub

本番。
(define *memo-hash-tables* (make-hash-table))
(define (memo fn fn-name . keys)
(let-keywords* keys ((key car)(test 'eq?))
(let1 cache (make-hash-table test)
(hash-table-put! *memo-hash-tables* fn-name cache)
(lambda args
(let1 key (key args)
(if-let1 val (and (hash-table-exists? cache key)
(hash-table-get cache key))
val
(rlet1 r (apply fn args)
(hash-table-put! cache key r))))))))
(define-syntax memoize
(syntax-rules ()
((_ fn . args)
(set! fn (apply memo fn 'fn args)))))
(define (clear-memo fn-name)
(let1 cache (hash-table-get *memo-hash-tables* fn-name #f)
(when cache (hash-table-clear! cache))))
(define-syntax clear-memoize
(syntax-rules ()
((_ fn)
(clear-memo 'fn))))
(memoize fib)
(trace fib)
(fib 10)
;; CALL fib 10
;; CALL fib 9
;; CALL fib 8
;; CALL fib 7
;; CALL fib 6
;; RETN fib 13
;; CALL fib 5
;; RETN fib 8
;; RETN fib 21
;; CALL fib 6
;; RETN fib 13
;; RETN fib 34
;; CALL fib 7
;; RETN fib 21
;; RETN fib 55
;; CALL fib 8
;; RETN fib 34
;; RETN fib 89
;; 89
(fib 10)
;; CALL fib 10
;; RETN fib 89
;; 89
(clear-memo 'fib)
(fib 10)
;; CALL fib 10
;; CALL fib 9
;; CALL fib 8
;; CALL fib 7
;; CALL fib 6
;; RETN fib 13
;; CALL fib 5
;; RETN fib 8
;; RETN fib 21
;; CALL fib 6
;; RETN fib 13
;; RETN fib 34
;; CALL fib 7
;; RETN fib 21
;; RETN fib 55
;; CALL fib 8
;; RETN fib 34
;; RETN fib 89
;; 89
(clear-memoize fib)
(fib 10)
;; CALL fib 10
;; CALL fib 9
;; CALL fib 8
;; CALL fib 7
;; CALL fib 6
;; RETN fib 13
;; CALL fib 5
;; RETN fib 8
;; RETN fib 21
;; CALL fib 6
;; RETN fib 13
;; RETN fib 34
;; CALL fib 7
;; RETN fib 21
;; RETN fib 55
;; CALL fib 8
;; RETN fib 34
;; RETN fib 89
;; 89
(fib 10)
;; CALL fib 10
;; RETN fib 89
;; 89
(define-syntax define-memo
(syntax-rules ()
((_ (fn arg ...) body ...)
(begin
(define (fn arg ...)
body ...)
(memoize fn)))))
(macroexpand '(define-memo (fib n)
(if (or (zero? n)
(= n 1))
1
(+ (fib (- n 1))
(fib (- n 2))))))
;; (#<identifier user#begin>
;; (#<identifier user#define> (fib n)
;; (if (or (zero? n) (= n 1)) 1
;; (+ (fib (- n 1)) (fib (- n 2)))))
;; (#<identifier user#memoize> fib))
(define-memo (fib n)
(if (or (zero? n)
(= n 1))
1
(+ (fib (- n 1))
(fib (- n 2)))))
(clear-memoize fib)
(trace fib)
(fib 10)
;; CALL fib 10
;; CALL fib 9
;; CALL fib 8
;; CALL fib 7
;; CALL fib 6
;; RETN fib 13
;; CALL fib 5
;; RETN fib 8
;; RETN fib 21
;; CALL fib 6
;; RETN fib 13
;; RETN fib 34
;; CALL fib 7
;; RETN fib 21
;; RETN fib 55
;; CALL fib 8
;; RETN fib 34
;; RETN fib 89
;; 89
(fib 10)
;; CALL fib 10
;; RETN fib 89
;; 89
view raw memoize.scm hosted with ❤ by GitHub



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

2010/09/09

syntax-rules, defmacro: define-cxr, define-cxr*

caaaar とか cadadadar などを定義するマクロ。LET OVER LAMBDA Edition 1.0 にもありました。

取りあえず書いてみました。
組み合わせて作っていく感じ。car + car で caar を作る、みたいな。
以下コード。
;; define-cxr
(define-syntax define-cxr
(syntax-rules ()
((_ name a b)
(define (name x)
((compose a b) x)))))
(define-cxr my-caar car car)
(my-caar '((a)))
;; a
(define-cxr my-caaar car my-caar)
(my-caaar '(((a))))
;; a
view raw define-cxr1.scm hosted with ❤ by GitHub


自分なりに考えてみたもの。もといし、効率も悪いけど意図通り動きます。
こちらは (define-cxr caar) とされたら a と d を car と cdr として手続きを組み立てる感じ。でも入力を制限していないので、my-caaar が caaar 相当の手続きに、ashitahadounaru? が caaadar 相当の手続きになります。。
(use srfi-1)
(use gauche.collection)
;; (symbol->list 'cadar) -> (c a d a r)
(define (symbol->list sym)
(map (compose string->symbol string)
((compose string->list symbol->string) sym)))
;; (cxr->ad-fun-lis 'cadar) -> (list car cdr car)
(define (cxr->ad-fun-lis sym)
(reverse
(values-ref
(map-accum
(lambda (e acc)
(let1 p (coalesce ((eq? e 'a) car)
((eq? e 'd) cdr))
(values p (if p
(cons p acc)
acc)))) '() (symbol->list sym)) 1)))
(define-macro (define-cxr name)
`(define ,name
,(apply compose (cxr->ad-fun-lis name))))
(define-syntax define-cxr*
(syntax-rules ()
((_ name ...)
(begin
(define-cxr name)
...
(values)))))
(define-cxr cdaaaaaaaaaaaaar)
;; cdaaaaaaaaaaaaar
(cdaaaaaaaaaaaaar '((((((((((((((b c)))))))))))))))
;; (c)
(define-cxr my-caaar)
;; my-caaar
(my-caaar '(((bbb))))
;; bbb
(define-cxr my-cdaddaaadr)
;; my-cdaddaaadr
(my-cdaddaaadr '(a (((b c (d 1))))))
;; (1)
(define-cxr* my-cdar my-cddar my-cdddaar)
(list my-cdar my-cddar my-cdddaar)
;; (#<closure (compose compose)> #<closure (compose compose)> #<closure (compose compose)>)
view raw define-cxr2.scm hosted with ❤ by GitHub


追記

下のコード貼り間違えてました。修正。

追記2

map-accum でなくてもよかったですね。fold-right でよさそうです。
(define (cxr->ad-fun-lis sym)
  (fold-right (lambda (e acc)
                (let1 p (coalesce ((eq? e 'a) car)
                                  ((eq? e 'd) cdr))
                  (if p
                      (cons p acc)
                      acc))) '() (symbol->list sym)))

LET OVER LAMBDA Edition 1.0

syntax-rules: coalesce

これの関連で。。
(define-syntax coalesce
(syntax-rules ()
((_) #f)
((_ (exp val) x ...)
(if exp
val
(coalesce x ...)))))
view raw coalesce.scm hosted with ❤ by GitHub


こういうのが
(let1 e 'd
  (if (or (if (eq? e 'a)
              'car)
          (if (eq? e 'd)
              'cdr))
      'found
      'notfound))

こうなる
(let1 e 'd
  (if (coalesce ((eq? e 'a) 'car)
                ((eq? e 'd) 'cdr))
      'found
      'notfound))

cond みたい。inspired by SQL's coalesce.

プログラミングGauche

syntax-rules: if-true

(if (hoge? fuga) 'fuga #f) ってのをどうにかできないかなーと思うんですが良いアイディアがありません。マクロを書いてみましたがいまいち。。
(define-syntax if-true
(syntax-rules ()
((_ pred exp)
(if pred exp #f))))
view raw if-true.scm hosted with ❤ by GitHub


追記

そうか and か!

プログラミングGauche

2010/09/08

Re: syntax-rules: define-overload (match-lambda*)

なるほど match-lambda* ですか!
実は match, match-lambda 辺りはよくわかってなかったので良い機会です。

書いてみました。以下コード。
(use util.match)
;; expand image
(define fact
(match-lambda*
((n)
(fact n 1))
((n acc)
(if (zero? n)
acc
(fact (- n 1)(* n acc))))))
(fact 10)
;; 3628800
;; macro
(define-syntax define-overload
(syntax-rules ()
((_ name ((arg ...) body ...) ...)
(define name
(match-lambda*
((arg ...) body ...) ...)))))
(define-overload fact
((n)
(fact n 1))
((n acc)
(if (zero? n)
acc
(fact (- n 1)(* n acc)))))
(fact 5)
;; 120
(macroexpand '(define-overload fact
((n)
(fact n 1))
((n acc)
(if (zero? n)
acc
(fact (- n 1)(* n acc))))))
;; (#<identifier user#define> fact
;; (#<identifier user#match-lambda*>
;; ((n)
;; (fact n 1))
;; ((n acc)
;; (if (zero? n)
;; acc
;; (fact (- n 1) (* n acc))))))


というかもうマクロにする必要もなさそうですね。。match-lambda* 使えば良いですね・・・。

追記

case-lambda でよかったのかもしれない。。

プログラミングClojure

syntax-rules: define-overload (clojure の defn みたいなもの)

引数の数にマッチして呼び出される本体が変わる clojure の defn を思い出したので書いてみました。
書いてみると別にどうということはありませんね・・・。

なぜ define-overload という名前かというと、始めて defn を見たときの感想が C# のオーバーロードっぽいなぁだったので。。かっこいい名前が思いつきませんでした。そういや syntax-rules にも似てますよね。

まずはマクロを書く前に展開イメージを
(use util.match)
;; image
(define-overload fact
((n)
(fact n 1))
((n acc)
(if (zero? n)
acc
(fact (- n 1)(* n acc)))))
;; expand image
(define (fact . args)
(match args
((n)
(fact n 1))
((n acc)
(if (zero? n)
acc
(fact (- n 1)(* n acc))))))
(fact 5)
;; 120
(use slib)
(require 'trace)
(trace fact)
(fact 5)
;; CALL fact 5
;; CALL fact 5 1
;; CALL fact 4 5
;; CALL fact 3 20
;; CALL fact 2 60
;; RETN fact 120
;; RETN fact 120
;; RETN fact 120
;; RETN fact 120
;; RETN fact 120
;; 120
(untrace fact)
(use liv.debugs)
(debug :fact)
(define (fact . args)
(match args
((n)
(dbg :fact ";; fact n = ~a" n)
(fact n 1))
((n acc)
(dbg :fact ";; fact n = ~a, acc = ~a" n acc)
(if (zero? n)
acc
(fact (- n 1)(* n acc))))))
(fact 5)
;; fact n = 5
;; fact n = 5, acc = 1
;; fact n = 4, acc = 5
;; fact n = 3, acc = 20
;; fact n = 2, acc = 60
;; fact n = 1, acc = 120
;; fact n = 0, acc = 120
120
view raw image.scm hosted with ❤ by GitHub

以下マクロ本体
(use util.match)
(define-syntax define-overload
(syntax-rules ()
((_ name ((arg ...) body ...) ...)
(define (name . args)
(match args
((arg ...) body ...) ...)))))
(macroexpand '(define-overload fact
((n)
(fact n 1))
((n acc)
(if (zero? n)
acc
(fact (- n 1)(* n acc))))))
;; (#<identifier user#define>
;; (fact . #0=#<identifier user#args>)
;; (#<identifier user#match> #0#
;; ((n)
;; (fact n 1))
;; ((n acc)
;; (if (zero? n)
;; acc
;; (fact (- n 1) (* n acc))))))
(fact 5)
;; 5
(define-overload greeting
(()(greeting "world"))
((name)(print #`"Hello, ,|name|!!")))
(greeting)
;; Hello, world!!
;; #<undef>
(greeting 'valvallow)
;; Hello, valvallow!!
;; #<undef>


プログラミングClojure

読んだ「小さなチーム、大きな仕事」37signals

よく耳にするので気になっていた 小さなチーム、大きな仕事―37シグナルズ成功の法則 (ハヤカワ新書juice) を読みました。

読み始めこそ少し妙な感触でしたが、評判通り面白かったです。
途中で Getting Real の方もつまんでみましたが、雰囲気というかテンポというか、その辺がキモくて読むの止めました。

この 小さなチーム、大きな仕事―37シグナルズ成功の法則 (ハヤカワ新書juice) で述べられているものの中で、ポール・グレアムがよく言っている「早過ぎる最適化」と同様のものが多いなぁーと感じました。

例えば・・・
計画は予想に過ぎない(P.17)
計画は、過去に未来の操縦をさせる。(P.18)
完璧主義なのだと主張するかもしれないが、それは次の仕事にとりかからずに、つまらない細部に執着して時間を無駄にしているにすぎない。(P.23)
初めのうち詳細は気にしない(P.54)
完璧なタイミングは決して到来しない。いつも若すぎたり、年寄りすぎたり、忙しかったり、金がなかったり、その他いろいろだったりする。(P.33)
何が一番よいか想像するのはやめ、現実を見出すのだ。(P.68)
まだ起こっていない問題を作ってはいけない。現実に問題になってから考えれば良いことだ。多くの「もしも」は起こらない。(P.164)

他にも・・・
ポール・グレアム「変人の力」 - らいおんの隠れ家を思い出します。
無名であるのは、すばらしいことだ。日陰にいることを幸せに思おう。(P.118)
無名であれば、プライドを失うことも我を失うこともないだろう。(P.118)
誰もあなたの言うことに腹を立てないのなら、おそらく押しが足りないのだ(多分つまらないのだろう)。(P.34)

scheme みたいですね。サン・テグジュペリの言葉を思い出します。
多くのものは小さくすればするほどよくなる。(P.52) 

言語にこだわったり.emacsをチューニングし過ぎることですね、わかります。
誰にもありがちなことだが、ツールに没頭するあまり、やるべきことを忘れてしまうことがある。(P.62)
変わった書体や高価なフォトショップの特殊効果を駆使しながらも、伝えるものがなにもないデザイナー。(P.62)
銀塩カメラとデジタル機器について延々と議論をするものの、真に写真をすばらしくするものに注目しないアマチュア写真家。(P.63)
ビジネスの世界では、本質的な問題から目をそむけ、ツールや、ソフトウェアの細かなテクニック、スケールの問題、高価なオフィス空間、豪華な備品といったどうでもいいことに心酔する人があまりに多すぎる。(P.63)
実際に形あるものをつくり始めるのだ。それ以外のことはすべて注意をそらすだけだ。(P.70)

この37signalsの本や、いつも楽しく読んでいるポール・グレアムのエッセイなんかと、自己啓発系の書籍の違いが最近よくわかりません。何かが違うような気がしつつ、似てるよなぁーとも思います。何が違うんでしょうか。。それとも同じ類なんでしょうか。わかりません。どちらにしろ煽られ過ぎ、乗せられ過ぎには注意した方が良いのかもしれません。

まぁ、ハッカーと画家 コンピュータ時代の創造者たちを読んで Lisp をはじめたクチなので、なんとも言えませんが(笑)


小さなチーム、大きな仕事―37シグナルズ成功の法則 (ハヤカワ新書juice)

syntax-rules: dlambda

今日は、Twitter のタイムラインで LET OVER LAMBDA Edition 1.0 の話題が出ていました。
私も読みましたが、詳細はすでに記憶の彼方です。。再読したいところです。

記憶に残っている dlambda を scheme の syntax-rules で書いてみました。たぶん同じように動くと思います。

マクロを書く前に・・・
;; image
(define count-test
  (let ((count 0))
    (dlambda
     (:reset ()(set! count 0))
     (:inc (n)(inc! count n))
     (:dec (n)(dec! count n))
     (:bound (lo hi)
             (set! count (min hi (max lo count)))))))

;; expand image
(define count-test
  (let ((count 0))
    (lambda (key . args)
      (case key
        ((:reset)(apply (lambda ()
                          (set! count 0)) args))
        ((:inc)(apply (lambda (n)
                        (inc! count n)) args))
        ((:dec)(apply (lambda (n)
                        (dec! count n)) args))
        ((:bound)(apply (lambda (lo hi)
                          (set! count
                                (min hi (max lo count)))) args))
        (else key)))))

(count-test :reset)
;; 0
(count-test :inc 100)
;; 100
(count-test :inc 1)
;; 101
(count-test :inc 2)
;; 102
(count-test :bound -10 10)
;; 10
(count-test :reset)
;; 0
(count-test :inc 1)
;; 1

以下マクロのコード
;; http://letoverlambda.com/index.cl/guest/chap5.html#sec_7
(define-syntax dlambda
(syntax-rules (else)
((_ (msg1 (darg1 ...) dbody1 ...)(msg2 (darg2 ...) dbody2 ...) ...)
(lambda (key . args)
(case key
((msg1)(apply (lambda (darg1 ...)
dbody1 ...) args))
((msg2)(apply (lambda (darg2 ...)
dbody2 ...) args))
...
(else key))
))))
(define count-test
(let ((count 0))
(dlambda
(:reset ()(set! count 0))
(:inc (n)(inc! count n))
(:dec (n)(dec! count n))
(:bound (lo hi)
(set! count (min hi (max lo count)))))))
(count-test :inc 1)
;; 1
(count-test :inc 1)
;; 2
(count-test :hoge)
;; :hoge
(count-test :dec 1)
;; 1
(count-test :dec 1)
;; 0
(count-test :dec 100)
;; -100
(count-test :bound -10 10)
;; -10
(count-test :reset)
;; 0
view raw dlambda.scm hosted with ❤ by GitHub


LET OVER LAMBDA Edition 1.0

2010/09/06

append

ちゃんと書こうとすると、意外と難しいですね。

これだと (append '() 1) が 1 にならないですね。
(define (append1 ls1 ls2)
(let rec ((ls (reverse ls1))(acc ls2))
(if (null? ls)
acc
(rec (cdr ls)(cons (car ls) acc)))))
(append1 '(1 2 3)'(4 5 6))
;; (1 2 3 4 5 6)
(use srfi-1)
(define (append1 ls1 ls2)
(fold-right cons ls2 ls1))
(define (append ls . lss)
(fold-right append1 '() (cons ls lss)))
(append1 '() 1)
;; 1
(append '(1 2 3)'(4 5 6)'(7 8 9))
;; (1 2 3 4 5 6 7 8 9)
(append '() 1)
;; error
(with-module gauche (append '() 1))
;; 1
view raw append-1.scm hosted with ❤ by GitHub

こんな感じでしょうか。
(define (append . lss)
(if (null? lss)
'()
(let rec ((lss lss))
(if (null? (cdr lss))
(car lss)
(fold-right cons (rec (cdr lss))(car lss))))))
(append '(1 2 3)'(4 5 6)'(7 8 9))
;; (1 2 3 4 5 6 7 8 9)
(append '() 1)
;; error
(with-module gauche (append))
;; ()
(append)
;; ()
view raw append-2.scm hosted with ❤ by GitHub


最近、諸事情により昼間にパソコンを開く時間があまりありません。。

追記

(use srfi-1)
(define (list-append x . n)
  (if (null? n)
      x
      (unfold null? car cdr x
              (lambda _
                (apply list-append n)))))

なるほど!そういえば・・・

追記2

reduce-right!
(use srfi-1)
(define (list-append . xss)
 (reduce-right append1 '() xss))

The Little Schemer, 4th Edition

2010/09/01

ほんやく


下手は上手の下地なり 下手よりだんだん上手になるなり。(寒河正親)

って言うし。
日本語で読みたいけど、どうやら翻訳されていないっぽい短い文章があった。取りあえずやってみようかなーとか。

翻訳の基本―原文どおりに日本語に