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 引数をもたない メソッドのほうがそうでないものより特定化されているとします。

: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

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

• vallog: let-optionals*, define-values
• vallog: 遅延評価はマクロで、多値は継続とマクロで実装できるんですって
• vallog: メモ 多値

追記

教えて頂きました。

@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))))))))

カプレカ数

• カプレカ数 - Gushwell's C# Programming Page
• カプレカ数 - Wikipedia

ザックリしてますが。

;; 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))

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版

他

• vallog: cygwin に gauche-dbd-pg
• vallog: serversman(centos) に postgreSQL に Gauche-dbd-pg