vallog: 2011/04

2011/04/29

日記

先日、J.P.ホーガンの「星を継ぐもの」を読みました。SF小説を読むのは小学生以来かもしれません。すごくワクワクする楽しい読書でした。続編があることを知ったので、早速「ガニメデの優しい巨人」と「巨人たちの星」を買って読んでいます。先程amazonで、「内なる宇宙」の上・下も購入しました。クレジットカードって怖いですね。

「星を継もの」は、今年の2月からビッグコミックでマンガの連載が始まっているようですね。これもチェックしなくては。公式の画像を見たらダンチェッカーが想像と違ってて驚きました。原作では細身のハゲということでしたが、画像ではわりとがっしりしてます。ちなみに私の想像の中ではじいさんで声は波平でした。

今は「ガニメデの優しい巨人」を読んでいます。これも「星を継もの」同様ワクワクしながら読んでいます。こんなに続きが気になるとは、自分でも意外です。

高校生の頃、数学の先生が授業中に「僕は本が大好きでねぇ。学生の頃も今も変わらず、学校から帰って本の続きを読みたくて仕方がないんだよ。みんなも本を読むと良いよ。」と言っていました。当時の私は「変な人だなぁ。」と思っていましたが、その気持ちが少しわった様な気がします。

そういえば塾の先生も本が好きで「当面の目標は1000冊読むことなんだ。」と楽しそうに話していたなぁ。私は小中学生の頃までは本を読んでいた記憶がありますが、その後は社会人になるまで本を読んだ記憶がありません。高校・大学と、あのありあまる時間をいったい何に使っていたんでしょうか。なにかと充実していてすごく楽しかったことはおぼえていますが、ちょっとくらい本を読めばよかったのにと言いたい。そういえば大学生になってパソコンを買ってからは、図書館でC言語の本を借りて挫折したり、Delphiの本を買って挫折したりしていたことを思い出しました。しかしプログラミングに入門しようというものが、なぜC言語の次にたどり着いたのがDelphiだったのでしょうか。

2011/04/12

日記（Scheme/Lisp とか、DSL とか）

近頃、Scheme(Gauche) で DSL を書くお仕事をしています。domain specific language のあれです。先日までは、Gauche で JSON を使って PostgreSQL とやり取りする CGI な API を書くお仕事をしていました。（主に設計面と進捗的なとこでボツりましたけどね。。面目なさ過ぎて涙目 orz）

現在お世話になっている会社にて、「言語は Scheme でも Common Lisp でも、他のなんでも好きなものを使って良いよ。」という素敵なお話で、Scheme を選びました。Lisp が好きな身としてはすごく幸せな環境です。（windows 環境であれば C# を選らんだと思いますが。）

ただ。私のような下級戦士にとっては仕事で Scheme を使うというのは、それが例え Gauche であっても茨の道だということを実感しました。春ですね。

というのは、Scheme や Lisp という言語がパワフルかどうかとは関係ないところで困るんです。ユーザーが少な過ぎるんだと思います（他国では違うのかも？TIOBE Software: Tiobe Index）。ユーザーが少ないということは、ググっても情報（ある意味"答え"）が出てこないんです。「こういう方法で解決した」「こうやったら、こうなった」「これをこう使ったら、結果こうなった」というような情報もすごく少ないです。あっても「入れてみた」「使ってみた」「試してみた」がほとんどです。なので自ら、"考えること"、"試してみる必要のあること"が多くなります。結果的に他の言語でググったり、他の言語のドキュメントを読んだりしなければならなくなります。この状況にアンビバレントな感情を抱かざるを得ません。仕事では時間を無制限に使うわけにはいきませんよね。ググって「あーこれでできるんだ。（ちゃちゃっ！終）」とはなりません。

弱音でしょうか、いいえゆとりです。ただ、これってプログラミングとしてはすごく楽しいんですよね。Lisp は書くこと自体楽しいですし。その点は幸せです。

で、急に「ダイの大冒険」の話です。大魔王バーンが使う「光魔の杖」ってありましたよね。簡単に言えば「理力の杖」を超強力にしたもの、ってロン・ベルクが言ってたあれです。理力の杖は、魔力を打撃力に替えることで攻撃力が上がるんですが、これは誰が使ってもだいたい同じくらいの攻撃力になるわけです。光魔の杖は、その上限がなくて、魔力が強ければ強いほど攻撃力が無限に上がるんです。Lisp って、光魔の杖だと思うんですよね。既に高い技術を持ったプログラマが更なる自由とパワーを得ることができる言語。でも私が使ってもせいぜい理力の杖なんじゃないかと。

本題

今やってる DSL については、画像処理系の DSL です。「できたら、BSD ライセンスか何かで公開しちゃえば？」とのことなので、そういうこともあるかもです。

DSL とはインターフェースである
DSL とは極限まで抽象化した API である
DSL のデザインとは、API のデザインである

こういうことを、見たり聞いたりしました。ホントそうだなと思います。API デザイン力（というか抽象化能力）が高くないと、いくらパワフルで DSL 定義が得意と言われてる言語（つまり Lisp のことですが）を使っても意味がないと感じています。当たり前っちゃ当たり前ですよね。

で、いろいろ読んだりするわけです。そのメモ。Martin Fowler 先生は DSL の本（Domain-Specific Languages (Addison-Wesley Signature Series (Fowler))）まで出してるんですね。確かにリファクタリング（リファクタリング―プログラムの体質改善テクニック (Object Technology Series)）の一つの極地の様な気もします。

DSLs in Lisp, an example for an advanced DSL development technique in Lisp.

DSL 本関連。

他

Scheme で DSL といえば

などを思い浮かべます。でもよく考えてみれば、On Lisp でも LOL(LET OVER LAMBDA Edition 1.0) でも PAIP(実用 Common Lisp (IT Architects’Archive CLASSIC MODER)) でもほとんどが DSL と呼べるようなものばかりだったじゃないですか。私は一体何を読んできたんだろう。。

あ、直接関係ないけど、見かけたのでメモ。Monads in Scheme の和訳みたいです。

[haskell-jp:355] Re: モナドって?

そして、DSL といえば、リトル言語。リトル言語といえば UNIX 。UNIX に憧れを持ち始めたこの頃。

Domain-Specific Languages (Addison-Wesley Signature Series (Fowler))

2011/04/07

macroexpand %macroexpand unwrap-syntax

gauche の macroexpand, %macroexpand, unwrap-syntax 。お試しコード垂れ流し。

今まで macroexpand しか使ってなかった。on lisp の mac マクロとかを自前で用意してみたり。で、 %macroexpand ってのは、この mac 相当っぽいですね。
それと unwrap-syntax の存在を知りませんでした。これ便利だー。こんなのないかなーと思ってたんです。

取りあえず、昨日の receive* を使って。

vallog: 多値と receive

(define-syntax receive*
  (syntax-rules ()
    ((_ () . body)
     (begin . body))
    ((_ ((var val)) . body)
     (receive var
         val
       (begin . body)))
    ((_ ((var val) x ...) . body)
     (receive var
         val
       (receive* (x ...) . body)))
    ))

それぞれこんな感じ。

(macroexpand '(receive* (((a b c)(values 1 2 3))
                         ((d e . rest)(values 4 5 6 7 8 9 10)))
                  (list a b c d e rest)))
;; (#<identifier user#receive> (a b c)
;;               (values 1 2 3)
;;               (#<identifier user#receive*> (((d e . rest) (values 4 5 6 7 8 9 10)))
;;                             (list a b c d e rest)))

(%macroexpand (receive* (((a b c)(values 1 2 3))
                         ((d e . rest)(values 4 5 6 7 8 9 10)))
                  (list a b c d e rest)))
;; (#<identifier user#receive> (a b c)
;;               (values 1 2 3)
;;               (#<identifier user#receive*> (((d e . rest) (values 4 5 6 7 8 9 10)))
;;                             (list a b c d e rest)))

(unwrap-syntax (%macroexpand (receive* (((a b c)(values 1 2 3))
                                        ((d e . rest)(values 4 5 6 7 8 9 10)))
                                 (list a b c d e rest))))
;; (receive (a b c)
;;     (values 1 2 3)
;;   (receive* (((d e . rest) (values 4 5 6 7 8 9 10)))
;;       (list a b c d e rest)))

vallog: Scheme マクロのデバッグ4種

再帰的に展開する macroexpand はないんでしたよね。Ypsilon にはあると、以前聞いたことがある気が。

イプシロン - R6RS Scheme System

scheme と common lisp のマクロの話。ここ読んでたら %macroexpand と unwrap-syntax のことが書いてあった。

define-method

gauche の define-method 。お試しコード垂れ流し。

(define-method dispatch ((i <integer>)(sym <symbol>))
  (print 4)
  (set! total (+ total i))
  (set! sum (string->symbol (string-append (symbol->string sum)(symbol->string sym))))
  (list total sum))

(define-method dispatch ((proc <procedure>)(i <integer>)(sym <symbol>))
  (print 3)
  (rlet1 r (dispatch i sym)
         (proc total ":" sum)))

(define-method dispatch ((proc <procedure>)(i <integer>)(sym <symbol>) . rest)
  (print 2)
  (dispatch i sym)
  (apply dispatch proc rest))

(define-method dispatch ((i <integer>)(sym <symbol>) . rest)
  (print 1)
  (dispatch i sym)
  (apply dispatch print rest))

(define total 0)
(define sum 'a)

(fluid-let ((total 0)
            (sum 'a))
  (dispatch 1 'a 2 'b))
;; 1
;; 4
;; 3
;; 4
;; 3:aab
;; (3 aab)

(fluid-let ((total 0)
            (sum 'a))
  (dispatch 1 'a 1 'a 1 'b 4 'c))
;; 1
;; 4
;; 2
;; 4
;; 2
;; 4
;; 3
;; 4
;; 7:aaabc
;; (7 aaabc)

(fluid-let ((total 0)
            (sum 'a))
  (dispatch 1 'a 1 'a 1 'b 4 'c 5 'd 6 'e))
;; 1
;; 4
;; 2
;; 4
;; 2
;; 4
;; 2
;; 4
;; 2
;; 4
;; 3
;; 4
;; 18:aaabcde
;; (18 aaabcde)

Gauche ユーザリファレンス: 7.5 ジェネリックファンクションとメソッド

(A1 A2 …) という特定化子リストをもつメソッド a と (B1 B2 …) という特定化子リストをもつメソッド b とがあるとします。

An と Bn とが異る最小の n を見つけます。n 番目の引数のクラスをとり、そのクラスの順位リストをチェックします。もし、その CPL の中で、An が Bn より先にくれば、method a はメソッド b より特定化されているということにし、さもなければ、 b が a がより特定化されているということにします。

もし、a および b のすべての特定化子が、一方は rest 引数をもち、もう一方はもたないという以外同じであれば、rest 引数をもたないメソッドのほうがそうでないものより特定化されているとします。

2011/04/06

:init-value でハマった・・・ :init-form が正解だった

これはかなりハマってしまった・・・

こんなコードがあるとして

(define-class <point> ()
  ((x :init-keyword :x :init-value 0)
   (y :init-keyword :y :init-value 0)))

(define-method point ((p <point>))
  (values (~ p 'x)(~ p 'y)))

(define-method set-point! ((p <point>)(x <integer>)(y <integer>))
  (set! (~ p 'x) x)
  (set! (~ p 'y) y)
  (point p))


(define-class <foo-point> (<point>) ())
(define-class <bar-point> (<point>) ())

(define-class <position> ()
  ((foo :init-keyword :foo :init-value (make <foo-point>))
   (bar :init-keyword :bar :init-value (make <bar-point>))))

結果がこうなわけですよ。すげーハマった・・・。

(define pos (make <position>))

(set-point! (~ pos 'foo) 100 100)
;; 100
;; 100
(point (~ pos 'foo))
;; 100
;; 100

(define pos2 (make <position>))
(point (~ pos2 'foo))
;; 100
;; 100

正解はこうみたいだ。

(define-class <position> ()
  ((foo :init-keyword :foo :init-form (make <foo-point>))
   (bar :init-keyword :bar :init-form (make <bar-point>))))

希望通りこうなる。

(define pos (make <position>))

(set-point! (~ pos 'foo) 100 100)
;; 100
;; 100
(point (~ pos 'foo))
;; 100
;; 100

(define pos2 (make <position>))
(point (~ pos2 'foo))
;; 0
;; 0

Gauche ユーザリファレンス: 7.3 クラス

多値と receive

多値は便利ですよね。多値がサポートされてると嬉しいですね。無くても困らないかもしれませんけどね。common lisp の ~~multiple-value-bind~~ destructuring-bind みたいな分配束縛があれば多値は無くても良いような気もするんですがどうなんでしょうか。match-let で良いじゃんという話もありますか。

Scheme:多値

世の中には「多値」の他に「多価」というのもあるらしいですね。よく知りませんが。

多値は便利なので使う機会も少なくないですが、receive（srfi-8）が多段にネストしてくるとウザいです。そうすると let に対する let* みたいな、receive に対する receive* が欲しくなるので書くわけです。

SRFI 8: RECEIVE による多重値の束縛

(define-syntax receive*
  (syntax-rules ()
    ((_ () . body)
     (begin . body))
    ((_ ((var val)) . body)
     (receive var
         val
       (begin . body)))
    ((_ ((var val) x ...) . body)
     (receive var
         val
       (receive* (x ...) . body)))
    ))

で、使ってみるわけです。

(define (foo)
  (values 'a 'b 'c))

(define (bar)
  (apply values '(1 2 3 4 5)))

(define (baz)
  (values + - * /))

(receive* (((a b c)(foo))
           ((v1 v2 . rest)(bar))
           (procs (baz)))
    (list a b c v1 v2 rest procs))

で、これなんて let*-values ？

SRFI 11: 多重値を受け取る構文

と、しばらくして気づくわけです。

scheme wiki にこんなページが。

syntax-define-values

そういや、多値が継続で実装できるって話が今でもよくわからないです。

追記

教えて頂きました。

@valvallow 多値は継続手続きを多引数に拡張したものと思えばわかりやすいかも。call/ccで取り出せる継続が一引数の場合でも http://scheme.com/tspl4/control.html#./control:h8 みたいにすれば多値をエミュレートできます

Control Operations

でもやっぱりわかりませんorz

gauche で json を post

gauche で json を受け取って json を返す cgi な api を書いてる時に、テスト用に書いたスクリプト。あまり楽になってない。

#! /usr/local/bin/gosh

(use rfc.json)
(use rfc.http)
(use rfc.uri :only (uri-encode-string))
(use gauche.parseopt :only (let-args))
(use srfi-1 :only (pair-fold))

(define (main args)
  (print "args : " args)
  (let/cc abort
    (let-args (cdr args)
        ((help "u|usage" => (^ _ (usage abort)))
         (host "h|host=s" "hoge.com")
         (uri "i|uri=s" "/cgi-bin/test/post-json.cgi")
         (alist "a|alist=s" "((\"hoge\" . 1))")
         (param-name "p|param-name=s" "json")
         (method "m|method=s" "POST")
         (not-string? "s|key-is-not-string"))
      (let1 alist (read-from-string alist)
        (cond ((string=? method "POST")
               (let* ((al (if not-string?
                              (alist-key->string alist)
                              alist))
                      (body (post host uri param-name al)))
                 (default-print-body host uri param-name al body)))
              ((string=? method "GET")
               (let* ((param (alist->uri-param alist))
                      (body (get host uri alist)))
                 (default-print-body host uri "" alist body)))
              (else '???)))))
  0)

(define (default-print-body host uri param-name param body)
  (newline)
  (print "host\t\t: " host)
  (print "uri\t\t: " uri)
  (print "param\t\t: " param)
  (print "param name\t: " param-name)
  (print "response body\t: " body)
  (print "body -> alist\t: " (parse-json-string body)))

(define (get host uri alist)
  (receive (status header body)
      (http-get host (string-append uri (alist->uri-param alist)))
    body))

(define (post host uri param-name alist)
  (receive (status header body)
      (http-post host uri
                 (string-append
                  param-name "="
                  (construct-json-string alist)))
    body))

(define (alist-key->string alist)
  (fold-right (^ (e acc)
                 (acons (x->string (car e))
                        (if (list? (cdr e))
                            (alist-key->string (cdr e))
                            (cdr e))
                        acc))
              '() alist))

(define (alist->uri-param alist)
  (let1 ues (^v (uri-encode-string (x->string v)))
    (pair-fold (^ (pr acc)
                  (let1 e (car pr)
                    (string-append
                     acc
                     (ues (car e)) "=" (ues (cdr e))
                     (if (null? (cdr pr))
                         ""
                         "&")
                     )))
               "?" alist)))

(define (usage abort)
  (abort))

使い方はこんな感じ。

$ gosh pjc.scm -h hogehoge.com -s -a "((\"hoge\" . 1))" -m POST -i /cgi-bin/api/insert-hoge.scm

$ gosh pjc.scm -h hogehoge.com -s -a "((\"fuga\" . 11))" -m POST -i /cgi-bin/api/begin-fuga.scm

$ $ gosh pjc.scm -h hogehoge.com -s -m GET -i /cgi-bin/api/get-bar.scm

初めて書いた cgi スクリプト。その言語が scheme って結構レアじゃないか。

追記

これwgetで間に合うんじゃね

json に変換可能な alist を walk

コード垂れ流し。

(use srfi-43)

(define (walk-json-alist alist :key (key-fun identity)(val-fun identity))
  (define (junction x)
    (cond ((pair? x)(walk-json-alist x :key-fun key-fun :val-fun val-fun))
          ((vector? x)(vector-case x))
          (else (val-fun x))))
  (define (vector-case v)
    (vector-map (^ (idx e)
                   (junction e))
                v))
  (map (^l (cons (key-fun (car l))
                 (junction (cdr l))))
       alist))

(define json1
  '((query . ((where . #(and #(< hoge 10)
                             #(= fuga foo)
                             #(< 5 baz 10)))
              (orderby . #(#(fugafuga desc)
                           #(hogehoge asc)))
              (limit . ALL)
              (offset . 0)))))

(walk-json-alist json1 :key-fun x->string :val-fun x->string)
;; (("query" ("where" . #("and" #("<" "hoge" "10") #("=" "fuga" "foo") #("<" "5" "baz" "10"))) ("orderby" . #(#("fugafuga" "desc") #("hogehoge" "asc"))) ("limit" . "ALL") ("offset" . "0")))

(walk-json-alist json1 :key-fun x->string)
;; (("query" ("where" . #(and #(< hoge 10) #(= fuga foo) #(< 5 baz 10))) ("orderby" . #(#(fugafuga desc) #(hogehoge asc))) ("limit" . ALL) ("offset" . 0)))

gauche cgi カレンダー

今年の初めの頃にやった写経。面白かった～これ。

Gauche:CGI:スケジュール予定表:Shiro版

#! /usr/local/bin/gosh

;; http://practical-scheme.net/wiliki/wiliki.cgi?Gauche:CGI:%E3%82%B9%E3%82%B1%E3%82%B8%E3%83%A5%E3%83%BC%E3%83%AB%E4%BA%88%E5%AE%9A%E8%A1%A8:Shiro%E7%89%88

(use srfi-1 :only (iota))
(use srfi-19)
(use util.list :only (slices))
(use text.html-lite)
(use text.tree)
(use gauche.sequence)
(use gauche.charconv)
(use gauche.parameter)
(use www.cgi)
(use dbm.gdbm)


;;
;; variables
;;

(define *db-name* "/var/www/cgi-bin/test/data/cal.data")

(define db (make-parameter #f))

(define *style* "
  span.planned {
                background-color : #ffcccc
                }
")

;;
;; utilities
;;

(define-syntax with-db
  (syntax-rules ()
    ((_ (db path) . body)
     (parameterize ((db (dbm-open <gdbm> :path path :rw-mode :write)))
       (with-error-handler
         (^e (dbm-close (db))
             (raise e))
         (^ _
            (begin0
                (begin . body)
              (dbm-close (db)))))))))

(define (db-key y m d)
  #`",|y|-,|m|-,|d|")

;;
;; calendar logic
;;

(define (make-month m y)
  (make-date 0 0 0 0 1 m y
             (date-zone-offset (current-date))))

(define (first-day-of-month date)
  (make-month (date-month date)
              (date-year date)))

(define (next-month date)
  (let ((m (date-month date))
        (y (date-year date)))
    (if (= m 12)
        (make-month 1 (+ y 1))
        (make-month (+ m 1) y))))

(define (prev-month date)
  (let ((m (date-month date))
        (y (date-year date)))
    (if (= m 1)
        (make-month 12 (- y 1))
        (make-month (- m 1) y))))

(define (days-of-month date)
  (inexact->exact
   (- (date->modified-julian-day (next-month date))
      (date->modified-julian-day (first-day-of-month date)))))

(define (date-slices-of-month date)
  (slices (append
           (make-list (date-week-day
                       (first-day-of-month date)) #f)
           (iota (days-of-month date) 1))
          7 #t #f))

;;
;; display
;;

(define (month->link date content)
  (html:a :href #`"?y=,(date-year date)&m=,(date-month date)" content ))

(define (date-cell year month date)
  (if date
      (html:a :href #`"?y=,|year|&m=,|month|&d=,|date|"
              (if (dbm-exists? (db)(db-key year month date))
                  (html:span :class "planned" date)
                  date))
      ""))

(define (calendar date)
  (html:table
   (html:tr (html:td (month->link (prev-month date) "←"))
            (html:td :colspan 5 :align "center"
                     #`",(date-year date)/,(date-month date)")
            (html:td (month->link (next-month date) "→")))
   (html:tr (map html:td
                 '("sun" "mon" "tue" "wed" "thu" "fri" "sut")))
   (map (^w (html:tr
             (map (^d (html:td (date-cell (date-year date)
                                          (date-month date)
                                          d)))
                  w)))
        (date-slices-of-month date))))

(define (page . content)
  `(,(cgi-header
      :contetn-type #`"text/html; char-set=,(gauche-character-encoding)")
    ,(html-doctype :type :xhtml-1.0-transitional)
    ,(html:html
      (html:head (html:title "schedule")
                 (html:style :type "text/css" *style*))
      (apply html:body content))))

;;
;; commands
;;

(define (cmd-show-calendar y m)
  (page
   (calendar (if (and y m (<= 1 m 12)(<= 1753 y))
                 (make-month m y)
                 (current-date)))))

(define (cmd-show-plan y m d)
  (let1 plan (dbm-get (db) (db-key y m d) "")
    (page
     (calendar (make-month m y))
     (html:form
      (html:p #`"schedule of ,|y|/,|m|/,d")
      (html:pre (html-escape-string plan))
      (html:a :href #`"?y=,|y|&m=,|m|&d=,|d|&c=e" "edit schdule")
      ))))

(define (cmd-change-plan y m d plan)
  (if (and plan (not (string=? plan "")))
      (dbm-put! (db) (db-key y m d) plan)
      (dbm-delete! (db)(db-key y m d)))
  (cgi-header :status "302 moved"
              :location #`"?y=,|y|&m=,|m|&d=,|d|"))

(define (cmd-edit-plan y m d)
  (let ((inp (cut html:input :type <> :name <> :value <>))
        (plan (dbm-get (db)(db-key y m d) "")))
    (page
     (html:form
      (html:p #`"schedule of  ,|y|/,|m|/,|d|")
      (inp "hidden" "c" "c")
      (inp "hidden" "y" (x->string y))
      (inp "hidden" "m" (x->string m))
      (inp "hidden" "d" (x->string d))
      (html:p (html:textarea :rows 8 :cols 40 :name "p"
                             (html-escape-string plan)))
      (html:p (html:input :type "submit" :name "submit" :value "modify"))))))

;;
;; main entry
;;

(define (main args)
  (cgi-main
   (^p (let1 cgp (cut cgi-get-parameter <> p :convert x->integer)
         (let ((y (cgp "y"))(m (cgp "m"))(d (cgp "d"))
               (cmd (cgi-get-parameter "c" p))
               (plan (cgi-get-parameter "p" p
                                        :convert (cut ces-convert <> "*jp"))))
           (with-db (db *db-name*)
                    (if (and y m d)
                        (cond ((equal? cmd "e")
                               (cmd-edit-plan y m d))
                              ((equal? cmd "c")
                               (cmd-change-plan y m d plan))
                              (else
                               (cmd-show-plan y m d)))
                        (cmd-show-calendar y m))))))))

カプレカ数

ザックリしてますが。

;; 1. 2乗して前の部分と後ろの部分に分けて和を取ったとき、元の値に等しくなるもの
;; 2. 桁を並べ替えて最大にしたものから最小にしたものの差を取ったとき、元の値に等しくなるもの

(define (Kaprekar1? num)
  (let* ((dbl (expt num 2))
         (str (number->string dbl))
         (len (string-length str))
         (prelen (div len 2)))
    (let* ((pre (string->number (substring str 0 prelen)))
           (suf (string->number (substring str prelen len))))
      (rlet1 r (= num (+ pre suf))
             (format #t "base: ~a, double: ~a, exp: ~a + ~a = ~a -> ~a\n"
                     num dbl pre suf (+ pre suf) r)))))


(map Kaprekar1? '(9 45 55 99 297 703 999 2223 2728 4950 5050 7272 7777 9999 17344 22222 38962
                    77778 82656 95121 99999 142857 148149 181819 187110 208495 318682 329967
                    351352 356643 390313 461539 466830 499500))
;; -> (#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)



(define (Kaprekar2? num)
  (let* ((ls (string->list (x->string num)))
         (min (string->number (list->string (sort ls char<?))))
         (max (string->number (list->string (sort ls char>?)))))
    (rlet1 r (cons (- max min)
                   (= num (- max min)))
           ;; (format #t "base: ~a, exp: ~a - ~a = ~a -> ~a\n"
           ;;         num min max (- max min) r)
           )))

(use srfi-1 :only (iota filter))
(filter (pa$ cdr)
        (map Kaprekar2? (iota 10000)))
;; -> ((0 . #t) (495 . #t) (6174 . #t) (549945 . #t) (631764 . #t))

2011/04/05

Gauche-dbd-pg を使うにあたって

自分で使うためにいくつかユーティリティ的なものを書いた。粗末だけど取りあえず動いてます。取りあえずさらしておくことに。

そういえば、dbi-connect には undocumented な auto-commit キーワード引数があるっぽい。

with-connection

(use dbi)
(use gauche.parameter)

(define *db* (make-parameter #f))
(define *dsn* (make-parameter #f))
(define *username* (make-parameter #f))
(define *password* (make-parameter #f))

(define-syntax with-connection
  (syntax-rules ()
    ((_ (*db* dsn) . body)
     (with-connection
      (*db* dsn (lambda (dsn)
                  (dbi-connect dsn)))
      . body))
    ((_ (*db* dsn username password) . body)
     (with-connection
      (*db* dsn (lambda (dsn)
                  (dbi-connect dsn
                               :username username
                               :password password)))
      . body))
    ((_ (*db* dsn connector) . body)
     (parameterize
         ((*db* (connector dsn)))
       (guard (e (else
                  (dbi-close (*db*))
                  (raise e)))
         (begin0
             (begin . body)
           (dbi-close (*db*))))))))

.NET の ConnectionStringBuilder みたいなのが欲しいなと思って。
dsn

(use util.match)

(define-class <dsn> ()
  ((platform :init-keyword :platform :initi-value #f)
   (dbname :init-keyword :dbname :init-value #f)
   (host :init-keyword :host :init-value #f)
   (port :init-keyword :port :init-value #f)
   (dsn :init-keyword :dsn :init-value #f)))

(define (%ref-join obj name delim)
  (if-let1 v (~ obj name)
           (string-append
            (symbol->string name) delim v)
           v))

(define-method build! ((con <dsn>))
  (let1 g (cut %ref-join con <> "=")
    (let ((platform (string-append
                     "dbi" ":" (or (~ con 'platform) "")))
          (dbname (g 'dbname))
          (host (g 'host))
          (port (g 'port)))
      (let1 constr (string-append
                    platform
                    (if-let1 dbname dbname
                             (string-append ":" dbname)
                             ""))
        (when host
          (set! constr (string-append constr ";" host)))
        (when port
          (set! constr (string-append constr ";" port)))
        constr))))

(define (build-dsn platform . keys)
  (let-keywords* keys ((dbname #f)(host #f)(port #f))
    (build! (apply make <dsn>
                   :platform platform keys))))

(define (%split-constring constring splitter)
  (let1 splitted (string-split constring splitter)
    (match splitted
      ((base)(values base #f #f))
      ((base host)(values base host #f))
      ((base host port)(values base host port))
      (else (values #f #f #f)))))

(define (%split-base base splitter)
  (let1 splitted (string-split base splitter)
    (match splitted
      ((dbi)(values dbi #f #f))
      ((dbi platform)(values dbi platform #f))
      ((dbi platform dbname)(values dbi platform dbname))
      (else (values #f #f #f)))))

(define-method decompose! ((con <dsn>) constring)
  (let1 v (^n (list-ref (string-split n "=") 1))
    (receive (base host port)
        (%split-constring constring ";")
      (when base
        (receive (dbi platform dbname)
            (%split-base base ":")
          (set! (~ con 'platform) platform)
          (set! (~ con 'dbname)(v dbname))))
      (when host
        (set! (~ con 'host)(v host)))
      (when port
        (set! (~ con 'port)(v port)))
      con)))

transaction, call-with-transaction など。なぜだか transaction クラスを作りました。connection もクラスにしとけばよかったかなと思います。

(use dbi)

(define-class <transaction> ()
  ((connection :init-keyword :connection)
   (begin-query :init-keyword :begin-query :init-value #f)
   (commit-query :init-keyword :commit-query :init-value #f)
   (rollback-query :init-keyword :rollback-query :init-value #f)
   (state :init-keyword :state :init-value 'ready)))

(define-class <pg-transaction> (<transaction>)())

(define-method initialize ((tran <pg-transaction>) initargs)
  (next-method)
  (set! (~ tran 'begin-query) "begin;")
  (set! (~ tran 'commit-query) "commit;")
  (set! (~ tran 'rollback-query) "rollback;"))

(define-method transaction-begin ((tran <transaction>))
  (rlet1 r (dbi-do (~ tran 'connection)(~ tran 'begin-query))
         (set! (~ tran 'state) 'begin)))

(define-method transaction-commit ((tran <transaction>))
  (rlet1 r (dbi-do (~ tran 'connection)(~ tran 'commit-query))
         (set! (~ tran 'state) 'committed)))

(define-method transaction-rollback ((tran <transaction>))
  (rlet1 r (dbi-do (~ tran 'connection)(~ tran 'rollback-query))
         (set! (~ tran 'state) 'rollbacked)))

(define (call-with-transaction proc)
  (let1 tran (make <pg-transaction>
               :connection (*db*))
    (guard (e ((<dbi-error> e)
               (transaction-rollback tran)
               (raise e))
              (else (raise e)))
      (transaction-begin tran)
      (rlet1 r (proc tran)
             (unless (let1 state (~ tran 'state)
                       (or (eq? state 'commeted)
                           (eq? state 'rollbacked)))
               (transaction-commit tran))))))

使う前に少し設定が必要になりますね。

(use file.util)
(use util.list)

(define-constant +server-bin-dir+ "/some/foo/bar")
(define-constant +db-config+
  (load-config (build-path +server-bin-dir+ "conf/db.conf")))

(define (init-module-dbi)
  (let* ((platform (assoc-ref +db-config+ 'db-platform))
         (host (assoc-ref +db-config+ 'db-host))
         (port (assoc-ref +db-config+ 'db-port))
         (dbname (assoc-ref +db-config+ 'db-dbname))
         (user (assoc-ref +db-config+ 'db-user))
         (password (assoc-ref +db-config+ 'db-password)))
    ;; dbi
    (*dsn* (build-dsn platform
                      :host host
                      :port port
                      :dbname dbname))
    (*username* user)
    (*password* password)))

db.conf は例えばこんなの。load-config はここに載ってませんが、load-config で db.conf 読み込むと alist になるような手続きです。

;; -*- mode:scheme; coding:utf-8 -*-

(db-platform "pg")
(db-host "hogehoge.com")
(db-port "5432")
(db-dbname "fuga")
;; (db-user "postgres")
;; (db-password "")

with-connection は with-db を参考にしました。

Gauche:CGI:スケジュール予定表:Shiro版

他

登録: 投稿 (Atom)