2010/03/31

Hello World

ここの「Hello World」はすごい(笑)
これは「パターン指向リファクタリング入門」で見たJava以来すごい。
読みにくいので貼り付けてみると、こんな感じ。すごくパターンハッピーですね。気持ちはわかります。オブジェクト指向デザインパターンを覚えると必要ないところにまで使いたくなるんですよね、なぜか。なんか必殺技っぽいからでしょうか。

/* http://developers.slashdot.org/comments.pl?sid=33602&cid=3636102 */
public interface MessageStrategy {
    public void sendMessage();
}
 
public abstract class AbstractStrategyFactory {
    public abstract MessageStrategy createStrategy(MessageBody mb);
}
 
public class MessageBody {
    Object payload;
    public Object getPayload() {
        return payload;
    }
    public void configure(Object obj) {
        payload = obj;
    }
    public void send(MessageStrategy ms) {
        ms.sendMessage();
    }
}
 
public class DefaultFactory extends AbstractStrategyFactory {
    private DefaultFactory() {;}
    static DefaultFactory instance;
    public static AbstractStrategyFactory getInstance() {
        if (instance==null) instance = new DefaultFactory();
        return instance;
    }
 
    public MessageStrategy createStrategy(final MessageBody mb) {
        return new MessageStrategy() {
            MessageBody body = mb;
            public void sendMessage() {
                Object obj = body.getPayload();
                System.out.println((String)obj);
            }
        };
    }
}
 
public class HelloWorld {
    public static void main(String[] args) {
        MessageBody mb = new MessageBody();
        mb.configure("Hello World!");
        AbstractStrategyFactory asf = DefaultFactory.getInstance();
        MessageStrategy strategy = asf.createStrategy(mb);
        mb.send(strategy);
    }
}
パターン指向リファクタリング入門~ソフトウエア設計を改善する27の作法

プログラマは皆どのようにしてLisperと化して行くのか?

ハッカーと画家 コンピュータ時代の創造者たち

カッとなって書いた。今は後悔していない。ネタです。

追記

こっそりいくつか追加した。

初めての人のためのLISP[増補改訂版]

2010/03/30

Emacs S式操作

表を拝借。C-M-f, C-M-b, C-x C-e しか使ってない・・・。あー C-M-a, C-M-e, C-c C-l も使うか。
Key定義コメント
C-M-@, C-M-SPCmark-sexpこれでS式をマークできるので、切り取ったりコピーしたりする
C-M-hmark-defun関数をマーク
C-M-f, C-M-bforward-sexp, backward-sexpS式単位で移動
C-M-ttranspose-sexpM-t のS式版
C-x n dnarrow-to-defun現在の関数以外を不可視に。defun の奥深くからでも可能
M-(insert-parentheses括弧を挿入し、カーソルをその間に移動(□)
M-TABlisp-complete-symbol補完
C-M-abeginning-of-defun関数定義の先頭へ
Esc C-deletebackward-kill-sexp前の S 式を削除
C-M-kkill-sexpS 式 をkill
C-c C-eeval-expressionS式の評価
C-x C-eeval-last-sexp直前のS式の評価
C-c C-reval-regionリージョン内のS式の評価
  • C-x n d からの復帰は C-x n w
こちらからも表を拝借。
コマンド動作
C-x C-eカーソルのS式を評価
C-c C-eカーソルのS式を含むトップレベルのS式を評価
C-c C-lファイルをロード
C-c C-rリージョンを評価
C-c C-zSchemeのインタプリタが動いているバッファへフォーカスを移動

コマンド動作
M-C-f次のS式へ移動
M-C-b前のS式へ移動
M-C-aカーソルのS式を含むトップレベルのS式の先頭へ移動
M-C-eカーソルのS式を含むトップレベルのS式の末尾へ移動
M-C-d1つ内側のS式へ移動
M-C-u1つ外側のS式へ移動
M-C-SPCカーソルのS式の次のS式をマーク
M-C-tカーソルのS式の前後の式を交換

プログラミングGauche

UML, ER(Entity Relation)図エディタ, Database Diagram

UML、ERDのエディタで使い易いものはないでしょうか。Linuxで使えるものが良いです。
JUDE, NClass, DBDesignerは以前使っていました。

UML

Web-based

ERD

Web-based


参考


UMLモデリングレッスン 21の基本パターンでわかる要求モデルの作り方

2010/03/29

defmacro: fluid-let

マクロ
ほぼ写経ですが。
;; fluid-let macro
(define-macro (my-fluid-let xexe . body)
(let ((xx (map car xexe))
(ee (map cadr xexe))
(old-xx (map (lambda (ig)
(gensym)) xexe))
(result (gensym)))
`(let ,(map (lambda (old-x x)
`(,old-x ,x)) old-xx xx)
,@(map (lambda (x e)
`(set! ,x ,e)) xx ee)
(let ((,result (begin ,@body)))
,@(map (lambda (x old-x)
`(set! ,x ,old-x)) xx old-xx)
,result))))
(define x 100)
(define y 200)
(define (p)
(format #t "~a:~a\n" x y))
(p)
;; 100:200
;; #<undef>
(my-fluid-let ((x 10)
(y 20))
(p))
;; 10:20
;; #<undef>
(macroexpand '(my-fluid-let ((x 10)
(y 20))
(p)))
; -> (let ((#0=#:G70 x) (#1=#:G71 y)) (set! x 10) (set! y 20) (let ((#2=#:G72 (begin (p)))) (set! x #0#) (set! y #1#) #2#))
(display
(macroexpand '(my-fluid-let ((x 10)
(y 20))
(p))))
; -> (let ((G76 x) (G77 y)) (set! x 10) (set! y 20) (let ((G78 (begin (p)))) (set! x G76) (set! y G77) G78))#<undef>
;; (let ((G76 x)
;; (G77 y))
;; (set! x 10)
;; (set! y 20)
;; (let ((G78 (begin (p))))
;; (set! x G76)
;; (set! y G77)
;; G78))
view raw fluid-let.scm hosted with ❤ by GitHub

プログラミングGauche

defmacro: or

gensymはgenerate symbolでしょうか。
;; or
;; http://www.sampou.org/scheme/t-y-scheme/t-y-scheme-Z-H-10.html#node_chap_8
(define-macro (my-or x y)
`(if ,x ,x ,y))
(my-or 1 2)
; -> 1
(my-or #f 2)
; -> 2
(macroexpand '(my-or 1 2))
; -> (if 1 1 2)
(macroexpand '(my-or #f 2))
; -> (if #f #f 2)
(my-or (begin
(display "doing first argument")
(newline)
#t)
2)
;; doing first argument
;; doing first argument
;; #t
(macroexpand '(my-or (begin
(display "doing first argument")
(newline)
#t)
2))
; -> (if #0=(begin (display "doing first argument") (newline) #t) #0# 2)
(define-macro (my-or x y)
`(let ((temp ,x))
(if temp temp ,y)))
(my-or (begin
(display "doing first argument")
(newline)
#t)
2)
;; doing first argument
;; #t
(macroexpand '(my-or (begin
(display "doing first argument")
(newline)
#t)
2))
;; (let ((temp (begin (display "doing first argument") (newline) #t))) (if temp temp 2))
(define temp 3)
(my-or #f temp)
; -> #f
(my-or #t temp)
; -> #t
(macroexpand '(my-or #f temp))
; -> (let ((temp #f)) (if temp temp temp))
(define-macro (my-or x y)
`(let ((+temp ,x))
(if +temp +temp ,y)))
(my-or #f temp)
; -> 3
(macroexpand '(my-or #f temp))
; -> (let ((|+temp| #f)) (if |+temp| |+temp| temp))
(define-macro (my-or x y)
(let ((temp (gensym)))
`(let ((,temp ,x))
(if ,temp ,temp ,y))))
(my-or #f temp)
; -> 3
(macroexpand `(my-or #f temp))
; -> (let ((#0=#:G3 #f)) (if #0# #0# temp))
view raw or.scm hosted with ❤ by GitHub
プログラミングGauche

syntax-rules: if

マクロとは式の変換です。 
;; if
;; http://www.shido.info/lisp/scheme_syntax.html
(define-macro (my-if pred then else)
`(cond (,pred ,then)
(else ,else)))
(display (my-if (odd? 1)
"yes"
"no"))
(macroexpand '(my-if (odd? 1)
"yes"
"no"))
; -> (cond ((odd? 1) "yes") (else "no"))
view raw if.scm hosted with ❤ by GitHub

プログラミングGauche

syntax-rules: when, unless

define-macroとdefine-syntax。
;; syntax
(define-syntax my-when
(syntax-rules ()
((_ pred b1 ...)
(if pred (begin b1 ...)))))
(my-when (> 0 -1)
(display "hello")
(newline))
;; hello
;; #<undef>
(macroexpand
'(my-when (> 0 -1)
(display "hello")
(newline)))
; -> (#<identifier user#if> (> 0 -1) (#<identifier user#begin> (display "hello") (newline)))
;; (#<identifier user#if> (> 0 -1)
;; (#<identifier user#begin>
;; (display "hello")
;; (newline)))
(define-syntax my-unless
(syntax-rules ()
((_ pred b1 ...)
(if (not pred) (begin b1 ...)))))
(my-unless (> 0 1)
(display "world")
(newline))
;; world
;; #<undef>
(macroexpand '(my-unless (> 0 1)
(display "world")
(newline)))
; -> (#<identifier user#if> (#<identifier user#not> (> 0 1)) (#<identifier user#begin> (display "world") (newline)))
;; (#<identifier user#if> (#<identifier user#not> (> 0 1))
;; (#<identifier user#begin>
;; (display "world")
;; (newline)))

プログラミングGauche

defmacro: when, unless

実は、マクロについては「プログラミングGauche」をサラッと眺めただけだったりします。
;; when, unless, macroexpand
;; http://www.sampou.org/scheme/t-y-scheme/t-y-scheme-Z-H-10.html#node_chap_8
;; when
(define-macro my-when
(lambda (test . branch)
(list 'if test
(cons 'begin branch))))
;; quasiquote, unquote, unquote-splicing
(define-macro my-when
(lambda (test . branch)
`(if ,test
(begin ,@branch))))
((lambda (x)
(my-when (> x 5)
(display "ok")
(newline)
(display x)
(newline))) 6)
;; ok
;; 6
;; #<undef>
(macroexpand '((lambda (x)
(my-when (> x 5)
(display "ok")
(newline)
(display x)
(newline))) 6))
; -> ((lambda (x) (my-when (> x 5) (display "ok") (newline) (display x) (newline))) 6)
;; unless
(define-macro my-unless
(lambda (test . branch)
(list 'if (list 'not test)
(cons 'begin branch))))
;; quasiquote, unquote, unquote-splicing
(define-macro my-unless
(lambda (test . branch)
`(if (not ,test)
(begin ,@branch))))
((lambda (x)
(my-unless (> x 5)
(display "ok")
(newline)
(display x)
(newline))) 3)
;; ok
;; 3
;; #<undef>
(macroexpand '((lambda (x)
(my-unless (> x 5)
(display "ok")
(newline)
(display x)
(newline))) 3))
; -> ((lambda (x) (my-unless (> x 5) (display "ok") (newline) (display x) (newline))) 3)
view raw when-unless.scm hosted with ❤ by GitHub

プログラミングGauche

2010/03/28

member?, let/cc

こういうのもありかな。
(define (member? a lat)
(let/cc skip
(fold (lambda (e acc)
(if (eq? e a)
(skip #t)
acc))
#f lat)))
(member? 1 '(a b c))
; -> #f
(member? 'c '(a b c d e))
; -> #t
view raw cc.scm hosted with ❤ by GitHub

The Little Schemer, 4th EditionThe Seasoned Schemer

TSS deep

The Seasoned Schemer 16章。

(deep 3)
; -> (((pizza)))

というような手続きを書け、とのこと。無理やり(?)fold-rightなんかで書いてみたり。
;; deep
;; (deep 3)
;; -> (((pizza)))
;; (deep 7)
;; -> (((((((pizza)))))))
;; (deep 0)
;; -> pizza
(define (deep n)
(if (zero? n)
'pizza
(cons (deep (- n 1))
'())))
(deep 3)
; -> (((pizza)))
;; again letrec
(define (make-deep a)
(lambda (n)
(letrec
((d (lambda (n)
(if (zero? n)
a
(cons (d (- n 1)) '())))))
(d n))))
((make-deep 'pizza) 3)
; -> (((pizza)))
;; again named-let, accumulate
(define (make-deep a)
(lambda (n)
(let loop ((n n)
(acc a))
(if (zero? n)
acc
(loop (- n 1)
(cons acc '()))))))
((make-deep 'pizza) 3)
; -> (((pizza)))
;; again fold-right
(use srfi-1)
(define (make-deep a)
(lambda (n)
(fold-right (lambda (e acc)
(if (zero? e)
acc
(cons acc '())))
a
(iota (+ n 1)))))
((make-deep 'pizza) 5)
; -> (((((pizza)))))
;; The Seasoned Schemer
(define sub1
(lambda (n)
(- n 1)))
(define deep
(lambda (n)
(cond
((zero? n)(quote pizza))
(else (cons (deep (sub1 n))
(quote ()))))))
(deep 3)
; -> (((pizza)))
view raw deep.scm hosted with ❤ by GitHub

続きのdeepR, deepMなど。
;; Ns, Rs
(define Ns (quote ()))
(define deepR
(lambda (n)
(set! Ns (cons n Ns))
(deep n)))
(deepR 3)
; -> (((pizza)))
Ns
; -> (3)
(define Rs (quote ()))
(define Ns (quote ()))
(define deepR
(lambda (n)
(set! Rs (cons (deep n) Rs))
(set! Ns (cons n Ns))
(deep n)))
(deepR 3)
; -> (((pizza)))
Ns
; -> (3)
Rs
; -> ((((pizza))))
(deepR 5)
; -> (((((pizza)))))
Ns
; -> (5 3)
Rs
; -> ((((((pizza))))) (((pizza))))
(deepR 3)
; -> (((pizza)))
Ns
; -> (3 5 3)
Rs
; -> ((((pizza))) (((((pizza))))) (((pizza))))
;; ((((pizza)))
;; (((((pizza)))))
;; (((pizza))))
;; find
;; (find 3 Ns Rs)
;; -> (((pizza)))
;; (find 5 Ns Rs)
;; -> (((((pizza)))))
(define (find n ns rs)
(cond
((or (null? ns)
(null? rs)) #f)
((= n (car ns))(car rs))
(else (find (- n 1)(cdr ns)(cdr rs)))))
(find 3 Ns Rs)
; -> (((pizza)))
;; The Seasoned Schemer
(define find
(lambda (n Ns Rs)
(letrec
((A (lambda (ns rs)
(cond
((= (car ns) n)(car rs))
(else (A (cdr ns)(cdr rs)))))))
(A Ns Rs))))
(find 5 Ns Rs)
; -> (((((pizza)))))
;; deepM
(define (member? a lat)
(let/cc skip
(fold (lambda (e acc)
(if (eq? e a)
(skip #t)
acc))
#f lat)))
(member? 1 '(a b c))
; -> #f
(member? 'c '(a b c d e))
; -> #t
(define deepM
(lambda (n)
(if (member? n Ns)
(find n Ns Rs)
(deepR n))))
Ns
; -> (3 5 3)
Rs
; -> ((((pizza))) (((((pizza))))) (((pizza))))
(set! Ns (cdr Ns))
(set! Rs (cdr Rs))
Ns
; -> (5 3)
Rs
; -> ((((((pizza))))) (((pizza))))
(define deepM
(lambda (n)
(if (member? n Ns)
(find n Ns Rs)
(let ((result (deep n)))
(set! Rs (cons result Rs))
(set! Ns (cons n Ns))
result))))
; (deep 6) -> (cons (deep 5)(quote ()))
(define deep
(lambda (m)
(cond
((zero? m)(quote pizza))
(else (cons (deepM (sub1 m))
(quote ()))))))
(deep 6)
; -> ((((((pizza))))))
Ns
; -> (5 3)
(deep 9)
; -> (((((((((pizza)))))))))
Ns
; -> (8 7 6 5 3)
(define deepM
(let ((Rs (quote ()))
(Ns (quote ())))
(lambda (n)
(if (member? n Ns)
(find n Ns Rs)
(let ((result (deep n)))
(set! Rs (cons result Rs))
(set! Ns (cons n Ns))
result)))))
(deepM 16)
; -> ((((((((((((((((pizza))))))))))))))))
(define find
(lambda (n Ns Rs)
(letrec
((A (lambda (ns rs)
(cond
((null? ns) #f)
((= (car ns) n)(car rs))
(else (A (cdr ns)(cdr rs)))))))
(A Ns Rs))))
(define (atom? a)
(and (not (pair? a))
(not (null? a))))
(define deepM
(let ((Rs (quote ()))
(Ns (quote ())))
(lambda (n)
(if (atom? (find n Ns Rs))
(let ((result (deep n)))
(set! Rs (cons result Rs))
(set! Ns (cons n Ns))
result)
(find n Ns Rs)))))
(define deepM
(let ((Rs (quote ()))
(Ns (quote ())))
(lambda (n)
(let ((exists (find n Ns Rs)))
(if (atom? exists)
(let ((result (deep n)))
(set! Rs (cons result Rs))
(set! Ns (cons n Ns))
result)
exists)))))

The Seasoned Schemer

内包表記

この機構は豊富な操作手続を提供しているので、リストジェネレータとい うだけではなく、ジェネリックなループ構文(Common Lisp の loop マ クロ並みに強力/邪悪だという人もいます)を提供しています。
(use srfi-42)
(do-ec (: n 10)(display n))
; -> 0123456789#<undef>
(do-ec (:range n 1 10)(display n))
; -> 123456789#<undef>
(let ((acc 'pizza))
(do-ec (: n 5)(set! acc (cons acc '())))
acc)
; -> (((((pizza)))))
(list-ec (: x 2 5) (: y 1 x) (list x y))
; -> ((2 1) (3 1) (3 2) (4 1) (4 2) (4 3))
view raw 42.scm hosted with ❤ by GitHub
プログラミングGauche

TSS set!

The Seasoned Schemerの15章になって初めて出てきたset!。set!ってのはこういうのだよーという章。
;; chapter.15
(define x
(cons (quote chicago)
(cons (quote pizza)
(quote ()))))
; -> x
x
; -> (chicago pizza)
(set! x (quote gone))
; -> gone
x
; -> gone
(set! x (quote skins))
; -> skins
x
; -> skins
(define gourmet
(lambda (food)
(cons food
(cons x (quote ())))))
x
; -> skins
(gourmet (quote onion))
; -> (onion skins)
(set! x (quote rings))
(gourmet (quote onion))
; -> (onion rings)
(define gourmand
(lambda (food)
(set! x food)
(cons food
(cons x
(quote ())))))
(gourmand (quote potato))
; -> (potato potato)
(define dinner
(lambda (food)
(cons (quote milkshake)
(cons food
(quote ())))))
(define dinnerR
(lambda (food)
(set! x food)
(cons (quote milkshake)
(cons food
(quote ())))))
(dinnerR (quote onion))
; -> (milkshake onion)
(dinnerR (quote pecanpie))
; -> (milkshake pecanpie)
x
; -> pecanpie
(gourmand (quote onion))
; -> (onion onion)
x
; -> onion
(define omnivore
(let ((x (quote minestrone)))
(lambda (food)
(set! x food)
(cons food
(cons x
(quote ()))))))
(omnivore (quote bouillabaisse))
; -> (bouillabaisse bouillabaisse)
(define gobbler
(let ((x (quote minestrone)))
(lambda (food)
(set! x food)
(cons food
(cons x
(quote ()))))))
(gobbler (quote gumbo))
; -> (gumbo gumbo)
(define nibbler
(lambda (food)
(let ((x (quote donut)))
(set! x food)
(cons food
(cons x
(quote ()))))))
(nibbler (quote cheerio))
; -> (cheerio cheerio)
;; Isn't (let ...) like (letrec ...)
(define food (quote none))
(define glutton
(lambda (x)
(set! food x)
(cons (quote more)
(cons x
(cons (quote more)
(cons x
(quote ())))))))
(glutton (quote garlic))
; -> (more garlic more garlic)
food
; -> garlic
(define chez-nous
(lambda ()
(set! food x)
(set! x food)))
food
; -> garlic
x
; -> onion
(chez-nous)
food
; -> onion
x
; -> onion
(define chez-nous
(lambda ()
(let ((a food))
(set! food x)
(set! x a))))
(glutton (quote garlic))
; -> (more garlic more garlic)
food
; -> garlic
(gourmand (quote potato))
; -> (potato potato)
x
; -> potato
(chez-nous)
food
; -> potato
x
; -> garlic



cond, and, or

1
2
3
4
(and a b)
; -> (cond (a b) (else #f))
(or a b)
; -> (cond (a #t) (else b))
The Little Schemer, 4th Edition

また出てきたYコンビネータ。Y!。

また出てきました。今度はThe Seasoned Schemerに。The Little Schemerでも9章で出てきました。理解できなくて散々書きました。
Yコンビネータは、いろんなサイトや解説記事を読みましたが、結局The Little Schemerが一番わかりやすかったです。The Seasoned SchemerではY!が出てきます。「!」ということで、副作用ありです。side effectです。その名もY-bang。ワイバーンみたい。
The Little SchemerThe Seasoned Schemer合わせて20章のうちで、初めて副作用が出てくるのが15章です。ここまで代入などを使わずにきて、急に使うことになるとさすがに気持ち悪く感じますね。

ちなみにY!が出てくるのは16章です。
Thunk you, Peter J. Landin.
だそうです。
1
2
3
4
5
6
7
8
9
10
11
12
(define Y!
 (lambda (L)
  (let ((h (lambda (l)(quote ()))))
   (set! h
    (L (lambda (arg)(h arg))))
   h)))

(define Y-bang
 (lambda (f)
  (letrec
   ((h (f (lambda (arg)(h arg)))))
   h)))
あれ、でも下のY-bangは副作用あるか?

そういえば、Yコンビネータはこれを見たときに、理解のきっかけになりました。
1
2
3
4
5
6
7
((lambda (f) 
   (f f 10)) 
 (lambda (f n) 
   (cond 
    ((< 0 n) 
     (print "hello") 
     (f f (- n 1))))))


2010/03/27

敷金は結構な金額が返ってきたりする

以前、引っ越した際に「掃除や修繕等で、敷金はほとんど返ってこないと思って下さい。」と不動産屋さんに言われました。「そうなんですか。(そんなはずないやろ~)」と思って調べてみました。結果的には電話一本で7割くらい戻ってきました。

「『原状回復ガイドライン』に添った敷金の用途の明細を下さい。」というようなことを言っただけです。同じように言ったからといって、返ってくるとは限らないとは思います。ただ、この辺の事情を知っておくと交渉の余地があるかもしれません。
掃除代金や修繕費用は原則的には大家さんが負担しないといけない、などのガイドラインがあるとかないとか(ハッキリ覚えていませんが)。

あまりよく覚えていませんが、引越しの季節ですし、調べてみてはいかがでしょうか。

2010/03/26

確定申告に行ってきました

初めての確定申告。遅ればせながら行ってきました。本来は15日までだったのですが、諸事情により今日行ってきました。特に問題なく、すぐに終わりました。10分もかからなかったかもしれません。15日を過ぎているので人が少なくて、逆によかったかも知れません。

必要なものは
  • 源泉徴収票
  • 通帳 or キャッシュカード
  • 保険料の納付書(などの証明できるもの)
  • 生命保険の書類
ぐらいでしょうか。

append1, append

昨日TLで見かけたので。いろいろ書いてみるつもりでしたが、たいして差のないコードばかりになりました。やはりfold系は、余計なことを考えなくて済むので好きです。
recur, letrec, named-let, cps, let/cc, fold, fold-right など。
;; append1
;; fold-right
(use srfi-1)
(define (append1 l1 l2)
(fold-right cons l2 l1))
(append1 '(1 2 3)'(4 5 6))
;; fold
(define (append1 l1 l2)
(fold cons l2 (reverse l1)))
(append1 '(1 2 3)'(4 5 6))
;; again recur
(define (append1 l1 l2)
(if (null? l1)
l2
(cons (car l1)
(append1 (cdr l1) l2))))
(append1 '(1 2 3)'(4 5 6))
;; again named-let
(define (append1 l1 l2)
(let loop ((l l1)
(acc l2))
(if (null? l)
acc
(cons (car l)
(loop (cdr l) acc)))))
(append1 '(1 2 3)'(4 5 6))
;; again letrec
(define (append1 l1 l2)
(letrec
((rec (lambda (l acc)
(if (null? l)
acc
(cons (car l)
(rec (cdr l) acc))))))
(rec l1 l2)))
(append1 '(1 2 3)'(4 5 6))
;; again accumulate
(define (append1 l1 l2)
(letrec
((rec (lambda (l acc)
(if (null? l)
acc
(rec (cdr l)(cons (car l)
acc))))))
(rec (reverse l1) l2)))
(append1 '(1 2 3)'(4 5 6))
;; again cps
(define (append1 l1 l2)
(letrec
((rec/cps (lambda (l seed cont)
(if (null? l)
(cont seed)
(rec/cps (cdr l)
seed
(lambda (ls)
(cont (cons (car l)
ls))))))))
(rec l1 l2 identity)))
(append1 '(1 2 3)'(4 5 6))
;; again call/cc
(define (append1 l1 l2)
(let/cc return
(let* ((continue #f)
(l (reverse l1))
(acc l2))
(let/cc cont
(set! continue cont))
(when (null? l)
(return acc))
(set! acc (cons (car l)
acc))
(set! l (cdr l))
(continue '()))))
(append1 '(1 2 3)'(4 5 6))
;; append
(use srfi-1)
(define (append . l)
(fold (lambda (e acc)
(fold-right cons e acc))
'() l))
(append '(1 2 3)'(4 5 6)'(7 8 9))
;; again letrec
(define (append . l)
(if (null? l)
'()
(letrec
((a1 (lambda (l acc)
(if (null? l)
acc
(cons (car l)(a1 (cdr l) acc)))))
(rec (lambda (l)
(if (null? (cdr l))
(car l)
(a1 (car l)(rec (cdr l)))))))
(rec l))))
(append '(1 2 3)'(4 5 6)'(7 8 9))
view raw appends.scm hosted with ❤ by GitHub


追記

unfold, unfold-right
;; again unfold
;; http://practical-scheme.net/gauche/man/gauche-refj_225.html
;; (unfold p f g seed tail-gen) ==
;; (if (p seed)
;; (tail-gen seed)
;; (cons (f seed)
;; (unfold p f g (g seed))))
(define (append1 l1 l2)
(unfold null? car cdr l1 (lambda (l)
l2)))
;; again unfold-right
;; http://practical-scheme.net/gauche/man/gauche-refj_225.html
;; (unfold-right p f g seed tail) ==
;; (let lp ((seed seed) (lis tail))
;; (if (p seed)
;; lis
;; (lp (g seed) (cons (f seed) lis))))
(use srfi-1)
(define (append1 l1 l2)
(unfold-right null? car cdr (reverse l1) l2))


プログラミングGauche

MCTSのカード


先日、財布と一緒に掲題のカード無くしたんだけど、再発行できるのかな。
そうそう、こういうカード↓。





srfi さーふぃ

srfiは「さーふぃ」(とか「するふぃー」)と読むらしいですね。つい先日まで「えすあーるえふあい」と読んでましたよ。わりと長くそう読んでいたので、第一声で「さーふぃ」と私の口から出ることはまずありません。
はてな住人がかかわったものに、id:higepon 氏が、CGIライブラリさえポータブルに書けないという事実に奮起して作られた、SRFI 98: An interface to access environment variables がある
ところでこれって、何で書かれているのでしょうか。Schemeで書かれているのでしょうか。Schemeで書かれていないのでしょうか。どこかにソースが落ちていたりするのでしょうか。

念のため確認。SLIBは「えすりぶ」で良いですよね。まさか「すりぶ」とか「すりびー」とか「すらいぶ」とか。SLIB・・・、traceしか使ったことないです。

追記

ん?ん?
もしかして、srfiって仕様だけで実装は処理系任せ的な?

追記2

Ω ΩΩ<な、なんだってー

プログラミングGauche

2010/03/25

cycle

リストを受け取り、そのリストの要素を先頭から順に返す(全ての要素を返したら、再びリストの先頭を返す)関数を返す関数cycle
こうかな。
;; cycle
;; Scheme:初心者の質問箱:log00 - http://goo.gl/Clv8
(define (make-cycle ls)
(let ((rest ls))
(lambda ()
(begin0
(car (if (null? rest)
(begin
(set! rest ls)
rest)
rest))
(set! rest (cdr rest))))))
(define c (make-cycle '(1 2 3)))
(dotimes (i 5)
(print (c)))
;; 1
;; 2
;; 3
;; 1
;; 2
;; #t
; again
(define (make-cycle ls)
(let ((l ls))
(lambda ()
(begin0
(car l)
(set! l (if (null? (cdr l))
ls
(cdr l)))))))
(define c (make-cycle '(1 2 3)))
(dotimes (i 5)
(print (c)))
;; 1
;; 2
;; 3
;; 1
;; 2
;; #t
view raw cycle.scm hosted with ❤ by GitHub

circular-listってのがあるのか。中はどうなってんだろう。
let1, if-let1, rlet1, and-let*, fluid-let ...
The Seasoned Schemer

filter-break

ストlisと述語手続きpredを取り、lisの各要素に順にpredを適用して、 predが真の値を返したら直ちにその要素を返すような関数find
; filter-break
(define (filter-break pred? ls)
(if (null? ls)
#f
(if (pred? (car ls))
(car ls)
(filter-break pred? (cdr ls)))))
(filter-break odd? '(2 2 2 3 4 4 4))
; -> 3
(define (filter-break pred? ls)
(let/cc skip
(fold (lambda (e r)
(if (pred? e)
(skip e)
r))
#f ls)))
(filter-break odd? '(2 2 2 3 4 4 4))
; -> 3

The Seasoned Schemer

find-fold/cps

ですです、これです!目が回ります・・・。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
;http://cametan-001.tumblr.com/post/470529715/cps-rt-valvallow
(define (find-fold/cps pred?/cps proc/cps seed lis cont)
  (null?/cps lis
      (lambda (result)
        (if result
     (cont seed)
     (pred?/cps (car lis)
         (lambda (result) ;テキストじゃここが抜けてる。ここがないとダメ。
         (if result
      (proc/cps (car lis)
         seed
         (lambda (seed2)
           (find-fold/cps pred?/cps proc/cps seed2 (cdr lis) cont)))
      (find-fold/cps pred?/cps proc/cps seed (cdr lis) cont))))))))


まあ、ホントの事言うと、プログラミングGaucheのあの例が適切で分かりやすいもの選んでるのか、って言うと疑問なんですけどね。
これは私も、もちょっとシンプルな例はなかったのかなー、と思いました。
書けたとしても書く気にはなれないコードだなと。

プログラミングGauche

auto-complete.el




ちょうど、補完候補の選択が↑↓でしかできないのは、どうやったら変更できるかなー。と思っていたところでした。
(define-key ac-complete-mode-map "\C-n" 'ac-next)
(define-key ac-complete-mode-map "\C-p" 'ac-previous)
(custom-set-faces
 '(ac-candidate-face ((t (:background "dark orange" :foreground "white"))))
 '(ac-selection-face ((t (:background "gray25" :foreground "white")))))
色は適当にこの辺で。

memo, call/cc, named let, do

1
2
3
4
5
6
7
8
9
10
(define (my-reverse ls)
  (let/cc return
   (let ((r #f))
     (let ((l ls) (acc '()))
       (let/cc continue
        (set! r continue))
       (and (null? l) (return acc))
       (set! acc (cons (car l) acc))
       (set! l (cdr l))
       (r '())))))

Scheme:
;; named let
(define (my-reverse ls)
  (let loop ((l ls) (acc '()))
    (if (null? l)
        acc
        (loop (cdr l) (cons (car l) acc)))))
 
(display (my-reverse '(1 2 3 4 5)))
(newline)

;; do
(define (my-reverse ls)
  (do ((l ls (cdr l))
       (acc '() (cons (car l) acc)))
      ((null? l) acc)))

(display (my-reverse '(1 2 3 4 5)))
(newline)

(define (my-reverse ls)
  (do ((l ls (cdr l))
       (acc '() (cons (car l) acc)))
      ((null? l) acc)
    (for-each (lambda (x)
  (for-each display x)
  (newline)) `(("l => " ,l) ("acc => " ,acc)))))

(my-reverse '(1 2 3 4 5))


Output:
1
2
3
4
5
6
7
8
9
10
11
12
(5 4 3 2 1)
(5 4 3 2 1)
l => (1 2 3 4 5)
acc => ()
l => (2 3 4 5)
acc => (1)
l => (3 4 5)
acc => (2 1)
l => (4 5)
acc => (3 2 1)
l => (5)
acc => (4 3 2 1)
1
2
3
4
5
6
7
(define (depth* l)
  (let loop ((e l) (d 1) (acc '(1)))
    (if (null? e)
 (apply max acc)
 (let ((kar (car e)))
   (let ((recur (if (pair? kar) (depth* kar) 0)))
     (loop (cdr e) (+ d recur) (cons d acc)))))))
1
2
3
4
5
6
(define (leftmost l)
  (let/cc skip
   (let loop ((l l))
     (let ((kar (car (if (null? l) (skip l) l))))
       (cond ((pair? kar) (loop kar) (loop (cdr l)))
      (else (skip kar)))))))
1
2
3
4
5
6
7
8
9
10
11
12
13
14
(define (filter* pred? l)
  (let loop ((l l))
    (if (null? l)
 '()
 (let ((kar (car l))
       (kdr (cdr l)))
   (let ((fd (loop kdr)))
     ;; let/cc (あるいは call/cc) をここに被せる
     (let/cc skip
      (cons (cond ((pair? kar) (loop kar))
    ((pred? kar) kar)
    ;; 脱出
    (else (skip fd)))
     fd)))))))

プログラミングGauche