2011/02/27

[1,2,3,4,5] が与えられたとき [[1,2][2,3][3,4][4,5]] を返すような関数を定義せよ

追記あり

リスト処理の問題。
  1. (1 2 3 4 5) が与えられたとき ((1 2)(2 3)(3 4)(4 5)) を返すような関数を定義せよ
  2. 1 の関数を拡張して、(0 1 2 3 4 5 6 7 8 9) と 2 が与えられたとき ((0 1)(1 2)(2 3)(3 4)(4 5)(5 6)(6 7)(7 8)(8 9)) を、(0 1 2 3 4 5 6 7 8 9) と 3 が与えられたとき ((0 1 2) (2 3 4) (4 5 6) (6 7 8) (8 9)) を、(0 1 2 3 4 5 6 7 8 9) と 4 が与えられたとき ((0 1 2 3) (3 4 5 6) (6 7 8 9)) を返すような関数を定義せよ

1

英語が弱いと関数の名前付けに苦労しますね。。適当英語でスマソ。
;; example 1
;; (0 1 2 3 4 5 6 7 8 9)
;; -> ((0 1) (1 2) (2 3) (3 4) (4 5) (5 6) (6 7) (7 8) (8 9))
;; example 2
;; (a b c d e f g h i j k l m n o p q r s t u v w x y z)
;; -> ((a b) (b c) (c d) (d e) (e f) (f g) (g h) (h i) (i j) (j k) (k l) (l m) (m n) (n o) (o p) (p q) (q r) (r s) (s t) (t u) (u v) (v w) (w x) (x y) (y z))

(use util.list :only (slices))
(use srfi-1)

(define (duplicate-without-edge ls)
  (define tail? (cut equal? <> (last-pair ls)))
  (if (or (null? ls)(tail? ls))
      ls
      (cons (car ls)
            (pair-fold-right
             (^ (pr acc)
                (cons (car pr)
                      (if (tail? pr)
                          acc
                          (cons (car pr) acc))))
             '() (cdr ls)))))

(define (overlap-slices ls)
  (slices (duplicate-without-edge ls) 2))
実行結果。
(overlap-slices (iota 5))
;; -> ((0 1) (1 2) (2 3) (3 4))
(overlap-slices (iota 10))
;; -> ((0 1) (1 2) (2 3) (3 4) (4 5) (5 6) (6 7) (7 8) (8 9))

(use srfi-14)
(define alphabet (map (compose string->symbol (pa$ x->string))
                      (reverse (string->list (char-set->string #[a-z])))))
(overlap-slices alphabet)
;; -> ((a b) (b c) (c d) (d e) (e f) (f g) (g h) (h i) (i j) (j k) (k l) (l m) (m n) (n o) (o p) (p q) (q r) (r s) (s t) (t u) (u v) (v w) (w x) (x y) (y z))

2

初めは、1 の定義を基に考えていましたが、named let の方が簡単でスッキリしました。効率とかは考えてません。
;; example 1
;; (0 1 2 3 4 5 6 7 8 9) 2
;; -> ((0 1) (1 2) (2 3) (3 4) (4 5) (5 6) (6 7) (7 8) (8 9))
;; example 2
;; (0 1 2 3 4 5 6 7 8 9) 3
;; -> ((0 1 2) (2 3 4) (4 5 6) (6 7 8) (8 9))
;; example 3
;; (0 1 2 3 4 5 6 7 8 9) 4
;; -> ((0 1 2 3) (3 4 5 6) (6 7 8 9))
;; example 4
;; (0 1 2 3 4 5 6 7 8 9) 5
;; -> ((0 1 2 3 4) (4 5 6 7 8) (8 9))
;; example 5
;; (0 1 2 3 4 5 6 7 8 9) 6
;; -> ((0 1 2 3 4 5) (5 6 7 8 9))
;; example 6
;; (a b c d e f g h i j k l m n o p q r s t u v w x y z)
;; -> ((a b c d e f g h i j) (j k l m n o p q r s) (s t u v w x y z))

(define (overlap-slices ls n)
  (let rec ((ls ls)(acc '()))
    (if (<= n (length ls))
        (receive (head tail)
            (split-at ls n)
          (rec (cons (last head) tail)(append acc head)))
        (slices (if (equal? ls (last-pair ls))
                    acc
                    (append acc ls)) n))))
実行結果。
(overlap-slices (iota 10) 2)
;; -> ((0 1) (1 2) (2 3) (3 4) (4 5) (5 6) (6 7) (7 8) (8 9))
(overlap-slices (iota 10) 3)
;; -> ((0 1 2) (2 3 4) (4 5 6) (6 7 8) (8 9))
(overlap-slices (iota 10) 4)
;; -> ((0 1 2 3) (3 4 5 6) (6 7 8 9))
(overlap-slices (iota 10) 5)
;; -> ((0 1 2 3 4) (4 5 6 7 8) (8 9))
(overlap-slices (iota 10) 6)
;; -> ((0 1 2 3 4 5) (5 6 7 8 9))
(use srfi-14)
(define alphabet (map (compose string->symbol (pa$ x->string))
                      (reverse (string->list (char-set->string #[a-z])))))
(overlap-slices alphabet 10)
;; -> ((a b c d e f g h i j) (j k l m n o p q r s) (s t u v w x y z))

そういえば、L-99 もやりかけでしたな。。

追記

1 についていろいろ反応が。
(define (x l)
  (map list (drop-right l 1) (cdr l)))

(define (hoge ls)
 (let loop ((ls0 ls) (ls1 (cdr ls)) (acc '()))
  (if (null? ls1)
    (reverse acc)
    (loop (cdr ls0) (cdr ls1) (cons `(,(car ls0) ,(car ls1)) acc)))))

(define (func x)
  (if (>= (length x) 2)
      (cons (take x 2)
            (func (drop x 1))) ()))

(define (f x a)
  (if (>= (length x) 2)
      (f (drop x 1) (cons (take x 2) a))
      (reverse a)))

(define(overlap-slices ls)
  (map list ls(cdr ls)))

(define(overlap-slices ls)
  (zip ls(cdr ls)))

(define (overlaps xs n)
  (unfold null? (cut take* <> n)
          (cute drop* <> (- n 1)) xs))


2 についてのこの解答、すごくエレガント!というか美しい。

(それぞれ srfi-1 や util.list などが必要になったりしますね)

いやー勉強になりました。
私の解答が残念過ぎて恥ずかしい。

追記2

かっけぇー!
(define (transpose m)
  (apply map list m))

(transpose '((0 1 2 3)(4 5 6 7)(8 9 10 11)(12 13 14 15)))
;; -> ((0 4 8 12) (1 5 9 13) (2 6 10 14) (3 7 11 15))

Scheme手習い

2011/02/24

cygwin uuid(uuidgen)

cygwin に uuidgen ないんだー、cygwin の setup.exe にもなさそうだなーと思ったら、windows SDK にあるみたい。
/cygdrive/c/"Program Files"/"Microsoft SDKs"/Windows/v7.1/bin/Uuidgen.Exe

chaton のぞいてたらこういうのがあって、試してみようと思ったらできなかったので。
(define (uuidgen)
  (let* ((process (run-process '("uuidgen" "-t") :output :pipe))
         (line (read-line (process-output process))))
    (process-wait process)
    line))
windows sdk がなければ入れる。

で、cygwin の gauche からも。
(process-output->string "/cygdrive/c/\"Program Files\"/\"Microsoft SDKs\"/Windows/v7.1/bin/Uuidgen.Exe")
;; -> "29ebb62d-c2bd-4baa-b218-999fa49f7487"

こんなのもあるみたいで。
最近 cygwin が重い。colinux が良いらしいですねー。近いうちに乗り換えてみようかなーとか。

関係ないけど、windows にも cron みたいなコマンドないのかなーと思ったら、schtasks なんてコマンドがあるんですね。

超簡単Linux入門 (日経BPパソコンベストムック)

PostgreSQL 「The server lacks instrumentation functions. なんたらかんたら」

The server lacks instrumentation functions.

pgAdmin III uses some support functions that are not available by default in all PostgreSQL versions.
These enable some tasks that make life easier when The server lacks instrumentation functions.

After the module is installed, you need to create the instrumentation functions in your maintenance database using the admin.sql script (admin81.sql for PostgreSQL) which are usually located in the pgsql share directory (e.g. /usr/local/pgsql/share)

pgAdmin III 使ってたらこういうのがよく出てきてた。いい加減よく読んでみたら、admin81.sql しなよみたいなことらしいのでその通りに。


ここを参考に。
yum install postgresql-contrib

updatedb
locate adminpack.sql

sudo psql -U postgres < adminpack.sql

で、locate って何よ?と。whereis とか which は使ってましたが locate は知りませんでした。

で、バックアップとかリストアとかも GUI でやると何かとひっかかる。pg_dump, pg_restore の方がすんなり。
テーブル作成後に複合キー付けれなかったり、カラムのデータ型の変更が厳しかったりであたふたしたり。SQL Server は私のようなゆとりにもやさしかったなぁ(白目)。

PostgreSQL徹底入門 第3版

eshell のプロンプトに git のブランチを表示

話題に乗って eshell を使い始めてみました。

で、掲題の通りこんな感じに。
Welcome to the Emacs shell

[2011/02/24(Thu) 00:09][foo@hogehoge ~/temp/fuga(Git:master)]
$ 

プロンプトの設定。
(setq eshell-prompt-function
      (lambda ()
        (concat
         "[" (format-time-string "%Y/%m/%d(%a) %H:%M") "]"
         "["
         (user-login-name) "@" (system-name) " "
         (eshell/pwd)
         "(" (vc-git-mode-line-string (eshell/pwd)) ")"
         "]\n"
         (if (= (user-uid) 0)
             "#"
           "$")
         " "
         )))
(vc-git-mode-line-string (eshell/pwd)) 
の部分。

ここを参考に。
bash のときみたいに modified, deleted, added, not pushed とかも出した方がうれしいかも?


そういえば、今後カイゼンしたいところ。
  • 補完は auto-complete を使ってるつもりなんだけど、どういう時なのかわからないけど下からポップアップで補完候補一覧が出てきたりするのが不満。
  • その時の補完タイミングが自動なのが不満。
  • auto-complete での補完時も補完候補から選ばずに全て自分でタイプしたときに C-m を二回押下しないと実行されない(1.補完確定、2.実行)のが不満。

便利なツール Emacsらくらく入門

2011/02/22

org-agenda の weekly-view の日付フォーマットを変更した

これを
Sunday     20 February 2011
こうした
2011/02/15 (Tue)

これと同じような感じで。
(defadvice org-agenda (around org-agenda-around)
  (let ((system-time-locale "English"))
    ad-do-it))

(defadvice org-agenda-redo (around org-agenda-redo-around)
  (let ((system-time-locale "English"))
    ad-do-it))

(custom-set-variables
  '(org-agenda-format-date "%Y/%m/%d (%a)"))

(custom-set-faces
 '(org-agenda-date ((t :weight bold))))

当日のイタリック表記も解除したくてソース(org-agenda.el)読んでみたけど、わかんなかった。org-remember も org-remember-templates をシャドウしてカテゴリ別に複数定義したら使いやすくなった。書き換えずにシャドウできるってのは良いですね。

scheme(というかgauche) の parameter と parameterize の組み合わせや fluid-let も使い方が見えてきました(ここの with-db が素敵だった)。ダイナミックスコープとレキシカルスコープはどちらか一方でなくて、両方ある方が良いっすね。ダイナミックスコープだとクロージャを使うのに一手間かかってしまうので、レキシカルスコープメインでダイナミックスコープをエミュレートする方が好きかなーと思います。

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

eshell を使ってみることに

どうせ bash も zsh もライトユーザなので、この際流れに乗って eshell を試してみようかと。bash も zsh もなかなかうまいこと Emacs の中で動かせなかったし。

取りあえずプロンプトを変えるとかそんなもんだけど。こんな感じに。
Welcome to the Emacs shell

[2011/02/22(Tue) 22:30][foo@hoge ~]
$ 
git のブランチ表示とかもやりたいところですね。

eshell の設定はこの辺を参考に。
(setq eshell-cmpl-ignore-case t)
(setq eshell-ask-to-save-history (quote always))
(setq eshell-cmpl-cycle-completions t)
(setq eshell-cmpl-cycle-cutoff-length 5)
(setq eshell-hist-ignoredups t)

(defadvice eshell (around eshell-around)
  (let ((system-time-locale "English"))
    ad-do-it))

;; prompt
(setq eshell-prompt-function
      (lambda ()
        (concat
         "[" (format-time-string "%Y/%m/%d(%a) %H:%M") "]"
          "["
         (user-login-name) "@" (system-name) " "
         (eshell/pwd)
         "]\n"
         (if (= (user-uid) 0)
             "#"
           "$")
         " "
         )))

(setq eshell-prompt-regexp "^[^#$]*[$#] ")

(add-hook 'eshell-mode-hook
          '(lambda ()
             (progn
               (define-key eshell-mode-map "\C-a" 'eshell-bol)
               (define-key eshell-mode-map "\C-p" 'eshell-previous-matching-input-from-input)
               (define-key eshell-mode-map "\C-n" 'eshell-next-matching-input-from-input)
               )
             ))

(require 'pcomplete)
(add-to-list 'ac-modes 'eshell-mode)
(ac-define-source pcomplete
  '((candidates . pcomplete-completions)))

(defun my-ac-eshell-mode ()
  (setq ac-sources
        '(ac-source-pcomplete
          ac-source-words-in-buffer
          ac-source-dictionary)))

(add-hook 'eshell-mode-hook
          (lambda ()
            (my-ac-eshell-mode)
            (define-key eshell-mode-map (kbd "C-i") 'auto-complete)))

(custom-set-faces
    '(eshell-prompt-face ((t (:foreground "maroon2" :bold nil)))))

プロンプトに日付を表示した時に曜日が日本語なのが気にくわないので、defadvice してます。system-time-locale を let でシャドウしてるだけ。この辺、ダイナミックスコープも良いとこあるなーと思わされます。

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

2011/02/17

Gauche: use してる module から export されてる symbol たち

(use srif-1)
(use srfi-13)


(for-each (^e (newline)
              (print (car e) ":")
              (for-each print (cdr e)))
          (fold (^ (e acc)
                   (acons e
                          (module-exports e)
                          acc))
                '() (all-modules)))

;; ->

;; #<module gauche.gf>:

;; #<module gauche.vm.debugger>:

;; #<module srfi-17>:

;; #<module scheme>:

;; #<module srfi-2>:

;; #<module gauche.object>:

;; #<module gauche.internal>:

;; #<module srfi-6>:

;; #<module gauche>:

;; #<module srfi-10>:

;; #<module util.match>:

;; #<module null>:

;; #<module srfi-13>:
;; string-kmp-partial-search
;; kmp-step
;; make-kmp-restart-vector
;; substring-spec-ok?
;; check-substring-spec
;; let-string-start+end
;; string-parse-final-start+end
;; string-parse-start+end
;; string-delete
;; string-filter
;; string-tokenize
;; string-replace
;; string-xcopy!
;; xsubstring
;; string-for-each-index
;; string-for-each
;; string-unfold-right
;; string-unfold
;; string-fold-right
;; string-fold
;; string-map!
;; string-map
;; string-concatenate-reverse/shared
;; string-concatenate-reverse
;; string-concatenate/shared
;; string-append/shared
;; string-concatenate
;; string-reverse!
;; string-reverse
;; string-downcase!
;; string-downcase
;; string-upcase!
;; string-upcase
;; string-titlecase!
;; string-titlecase
;; string-contains-ci
;; string-contains
;; string-count
;; string-skip-right
;; string-skip
;; string-index-right
;; string-index
;; string-suffix-ci?
;; string-prefix-ci?
;; string-suffix?
;; string-prefix?
;; string-suffix-length-ci
;; string-prefix-length-ci
;; string-suffix-length
;; string-prefix-length
;; string-hash-ci
;; string-hash
;; string-ci>=
;; string-ci<=
;; string-ci>
;; string-ci<
;; string-ci<>
;; string-ci=
;; string>=
;; string<=
;; string>
;; string<
;; string<>
;; string=
;; string-compare-ci
;; string-compare
;; string-trim-both
;; string-trim-right
;; string-trim
;; string-pad-right
;; string-pad
;; string-drop-right
;; string-drop
;; string-take-right
;; string-take
;; string-copy!
;; substring/shared
;; reverse-list->string
;; string-tabulate
;; string-any
;; string-every
;; string-null?

;; #<module gauche.interactive>:
;; reload-verbose
;; module-reload-rules
;; reload-modified-modules
;; reload
;; info
;; d
;; describe
;; apropos

;; #<module user>:

;; #<module srfi-8>:
;; #<undef>

追記


プログラミングGauche

ちゅーしょーか

手続きの抽象化はどこまでやるべきか迷うことがあります。手続きに限らずクラスなんかもそうです。考えうる最高の抽象度で手続きを定義して具体的な名前のラッパ手続きを定義するようなことは日常的にありますが、結局最も抽象度の低い手続きしか使わないこともしばしば。引数の数やシグネチャによってディスパッチするようにしたりキーワード引数やオプショナル引数を用意、けど実際には使うことがなかった、なんてこともよくあります。早過ぎる最適化ってやつですかね。

ということは、思いつくまま書いて、必要になってから初めて抽象度の高い関数を定義し、それを元の関数から呼ぶようにリファクタリングするのが正解なのかなあ。でも、思いついたまま書いたら書いたで、規模や内容によっては後から分離したり抽象度を上げたりするのが難し(辛)くて、結局「最初から抽象度を高く定義しときゃよかったわ・・・」となり放置あるいわ断念ということもしばしば。
プログラミング自体やロジックを考えたりするのも簡単ではありませんが、こういう落とし所の判断も難しいれす。「現時点ではこれで良い。」と判断するのってなかなか勇気がいります。それとも判断しようとすること自体が余計なのか。必要になるまで判断しない、とか。lazy に。


例としては小粒過ぎるかもしれませんが、例えば
三つの数を引数としてとり、大きい二つの数の二乗の和を返す手続きを定義せよ。
(SICP の 1.3 の問題ですね)

準備。
(define (square x)
  (* x x))

現実の開発でも大きな問題を細切れにしていくとこのくらいの粒度の問題に行きつきますよね。抽象度はばらけてますが、最後の例は抽象度が高いと思います。でもここまでやるか、ということです。その手前くらいで良いような気がします。

問題に対してバカ正直に
;; cond
(define (sum-of-square-picked-big2 a b c)
  (cond ((and (< a b) (< a c))(+ (square b) (square c)))
        ((and (< b a) (< b c))(+ (square c) (square a)))
        (else (+ (square a)(square b)))))

(sum-of-square-picked-big2 1 2 3)
;; -> 13
(sum-of-square-picked-big2 9 10 8)
;; -> 181

ソートして先頭の2つを使う
;; sort
(define (sum-of-square-picked-big2 . args)
  (let1 sls (sort args >)
    (+ (square (car sls))
       (square (cadr sls)))))

(sum-of-square-picked-big2 1 2 3)
;; -> 13
(sum-of-square-picked-big2 1 2 3 4 5 6 7 8 9 10)
;; -> 181

先頭から指定した分を取得して計算するケース
;; head
(define (head n ls :key (sorter identity))
  (let rec ((n n)(ls (sorter ls))(acc '()))
    (if (zero? n)
        acc
        (rec (- n 1)(cdr ls)(cons (car ls) acc)))))

(define (pick-big n nums)
  (head n nums :sorter (lambda (ls)
                         (sort ls >))))

(define (sum-of-square-picked-big2 . args)
  (apply + (map square (pick-big 2 args))))


(sum-of-square-picked-big2 1 2 3)
;; -> 13
(sum-of-square-picked-big2 9 10 8)
;; -> 181

「選択」して「計算」するとしたケース
(use gauche.experimental.app)
(define (pick-calc picker calculator . args)
  ($ calculator $ picker args))

(define (sum-of-square-picked-big2 . args)
  (apply pick-calc
         (^l (pick-big 2 l))
         (^l (apply + (map square l)))
         args))

(sum-of-square-picked-big2 1 2 3)
;; -> 13
(sum-of-square-picked-big2 1 2 3 4 5 6 7 8 9 10)
;; -> 181

ちょっと例が微妙過ぎたか。

リファクタリング―プログラムの体質改善テクニック (Object Technology Series)

日記

知ってると思ってたことも実は表面的な部分だけだった、できると思っていたこともやってみたらうまくできなかった、難しくないと思ってたことも実際にやってみると難しかった、そんなことがよくあります。残念。
別段凹んでるわけではなくて「やべぇー」となるわけです。やったことのあることしかできないもんだなーとか、やったことがあることをやるのがやっとだなーと思うなどします。ギア6段に入れて漕ぎ始めたばっかのチャリで坂を上ってる気分です。世の中の PG・SE の皆さんすごいですね。まじで。加速がつくまであとどのくらいだ。

いちいち悩みます。Linux そのものやその文化(Linux 初心者)、プログラムの設計、APIの設計、DBのテーブル設計、アーキテクチャ、開発環境、開発の進め方、などなど。他にもプロジェクトにおけるディレクトリの切り方をどうするか、セットアップやインストールはどうするか、モジュール分割の判断、バージョン管理、バグトラッキング、ログの吐き方と吐く内容と吐くタイミング、例外の扱いと想定、etc, etc ... 。それぞれやったことがあっても部分的だったり、大枠が決まっている中でのことだったのだと気づきます。
(開発の初期に深く考える必要のないこともあるのですが)

windows と .NET だけで開発のお仕事をしていた時より悩むことが多いような気がします。と言うと、少し違うか。与えられた環境だったから迷うところがなかったのかも。IDE に RDB にサーバにディレクトリ構成に言語にバージョン管理にリリース方法に BTS になんやらかんやら全部決まってたから。
正直な話、新卒で入った会社にいた頃、2~3年経つ頃には先輩や上司のソースを見て「なんてクソなんだ。ガラクタだ。正気か。。」などと思って軽蔑したもんですが(申し訳ありません悔い改めます)、0からあんなにたくさん大きなモノを作った彼(彼女)らは今思えばすごい。出来上がったものの一部を見て「クソだ」と言ってた私がクソだったのかもしれないと今思う。

技術も知識も特に経験が足りないで FA なわけですが、誰でも初めはそうなんだし高望みせず地道にやるしかないなと。

ソフトウェア職人気質―人を育て、システム開発を成功へと導くための重要キーワード (Professional Computing Series)

2011/02/16

リストをランダムに並べ変える

blogger で過去の日付で投稿するテスト。「投稿オプション」の「予定」などという項目ががが。

全然関係ないけど。「リストをランダムに並べ変える」。
(use srfi-1)
(use math.mt-random)
(use gauche.sequence)

(define (list-randomize ls)
  (define (remove-with-index n ls)
    (reverse
     (fold-with-index (^ (i e acc)
                         (if (= i n)
                             acc
                             (cons e acc)))
                      '() ls)))
  (define rand
    (let1 m (make <mersenne-twister>
              :seed (sys-time))
      (^ (size)
         (mt-random-integer m size))))
  (define (randomize ls)
    (let rec ((ls ls)(acc '()))
      (if (null? ls)
          acc
          (let1 idx (rand (length ls))
            (rec (remove-with-index idx ls)
                 (cons (list-ref ls idx) acc))))))
    (randomize ls))

(list-randomize (iota 10))
;; -> (0 1 2 5 8 9 7 6 3 4)
(list-randomize (iota 10))
;; -> (4 3 0 8 7 6 5 9 2 1)

プログラミングGauche

SICP の友

ってことで、どこかで紹介されてたけどどこか忘れた。

見た目的にはやっぱりここがダントツすげーよなぁ・・・。

SICP 買ってから2年以上経ったけど、未だに読み終えてない。

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

query string


小粒つながりで、こういうのも良いかも。あんまりスッキリしないけど。
(alist->query-string '((hoge . 1)(fuga . 2)(foo . bar)))
;; -> "?hoge=1&fuga=2&foo=bar"

(use srfi-13)
(use util.list)
(use rfc.uri)

(define (alist->query-string alist)
  (let1 ues (^v (uri-encode-string (x->string v)))
    (string-append
     "?"
     (string-concatenate
      (intersperse
      "&"
      (fold-right (^ (e acc)
                     (cons (string-append
                            (ues (car e)) "=" (ues (cdr e)))
                           acc))
                  '() alist))))))

それともこんなん。
(use srfi-1)
(use rfc.uri)

(define (alist->query-string 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 (query-compose query)
  (string-join (map (cut string-join <> "=") query) "&"))

(query-compose '(("hoge" "1")("fuga" "foo")))
;; "hoge=1&fuga=foo"
うわー、すっきり。

パズルゲームアルゴリズムマニアックス

0から1000までの0の数を数える

(use srfi-1)
(use srfi-13)

(string-count (string-concatenate (map x->string (iota 1001))) #\0)

上のは真面目に考えたもの。こっちっが最初に何も考えずに書いたもの。
(use srfi-1 :only (iota))

(let1 zeros (fold (^ (e acc)
                     (string-append
                      acc
                      (regexp-replace-all #/[1-9]/ (x->string e) "")))
                  "" (iota 1001))
  (string-length zeros))

こういう小ぶりの問題好きです。というか、むしろこういうのが一番楽しいかもしれない。大きな問題も分解すればこういう小さな問題の集合なのかもしれないけども。いや、でも「全体は部分の総和にあらず」とも言いますか。


検索したらいっぱいった。


パズルゲームアルゴリズムマニアックス

2011/02/12

gauche の oo

今まで gauche のオブジェクトシステム周りはスルーしてきましたが、何かと使う機会が出てきました。なので、プログラミング Gauche の「総称関数とオブジェクト」のところを再読・写経などしてます。MOP(メタオブジェクトプロトコル)すごいですね。CLOS!CLOS!CLOS!すごくメタメタしいですね。アスペクト指向っぽいことも超お手軽ですね。

以前、@s1mple さんに見せてもらった Common Lisp オブジェクトシステム をもう一度読んでみたくなりました。

ここの o/r mapper すごいすね。
ちゃんとドキュメント読んでみよう。


プログラミングGauche を見ながら写経してみたコードをつらつらと。

;; programming gauche - P.248

(define-class <count-instance-meta> (<class>)
  ((num-of-instance :init-value 0)))

(define-class <count-instance-mixin> ()
  ()
  :metaclass <count-instance-meta>)

(define-method make ((klass <count-instance-meta>) . initargs)
  (inc! (~ klass 'num-of-instance))
  (next-method))

(define-class <myclass> (<count-instance-mixin>)())

(make <myclass>)

(~ <myclass> 'num-of-instance)
;; -> 1

(make <myclass>)

(~ <myclass> 'num-of-instance)
;; -> 2


(define-class <logger-generic> (<generic>)())

(define-generic add :class <logger-generic>)

(define-method apply-generic ((gf <logger-generic>) args)
  (format #t "args: ~s\n" args)
  (let ((return-value (next-method)))
    (format #t "result: ~s\n" return-value)
    return-value))

(define-method add ((num1 <number>)(num2 <number>))
  (+ num1 num2))

(add 3 4)
;; args: (3 4)
;; result: 7
;; 7

(use gauche.time)

(define-class <profiler-generic> (<logger-generic>)
  ((counter :init-value 0)
   (time :init-form (make <real-time-counter>))))

(define-generic sub :class <profiler-generic>)

(define-method apply-generic ((gf <profiler-generic>) args)
  (inc! (~ gf 'counter))
  (with-time-counter (~ gf 'time)(next-method)))

(define-method sub ((num1 <number>)(num2 <number>))
  (- num1 num2))

(define-method get-profile ((gf <profiler-generic>))
  (format #t "~s: ~d times called and spent time ~d\n"
          (~ gf 'time)(~ gf 'counter)
          (time-counter-value (~ gf 'time))))

(define-method init-profile ((gf <profiler-generic>))
  (set! (~ gf 'counter) 0)
  (set! (~ gf 'time)(make <real-time-counter>)))


(use srfi-1)

(init-profile sub)

(define val (with-output-to-string
              (^ _ (map sub
                        (iota 10000 100 3)
                        (iota 10000 100 5)))))

(get-profile sub)
;; #<<real-time-counter>   0.836>: 10000 times called and spent time 0.8360000000000006

(define-class <profiler-generic> (<generic>)
  ((counter :init-value 0)
   (time :init-form (make <real-time-counter>))))

(define-class <logger-profiler-generic>
  (<logger-generic> <profiler-generic>)())

(define-generic mul :class <logger-profiler-generic>)

(define-method mul ((num1 <number>)(num2 <number>))
  (* num1 num2))

(init-profile mul)

(define val (with-output-to-string
              (^ _ (map mul
                        (iota 10000 100 3)
                        (iota 10000 100 5)))))

(get-profile mul)
;; #<<real-time-counter>   0.339>: 10000 times called and spent time 0.33900000000000025

プログラミングGauche

プログラミング Gauche の object マクロと LOL の dlambda マクロ

プログラミング Gauche をパラパラ読んでたら、P.270 に object というマクロ(syntax-rules)が載ってたんですね。よく見たら、どこかで見たこのあるような形と機能だなーと。LOL(LET OVER LAMBDA Edition 1.0)の dlambda にそっくりなんですね。

dlambda はもともと Common Lisp の伝統的なマクロで書かれているので、見た目は object マクロとは似ていません。ですが、dlambda を scheme の衛生的マクロで書くとそっくりです。(似たような機能なのでそりゃそうなんですが)
以前書いた衛生的マクロ版 dlambda をちょっと書き直して再掲するとこんなの。
(define-syntax dlambda
  (syntax-rules (else)
    ((_ (msg (arg ...) body ...) ...)
     (^ (key . args)
        (case key
          ((msg)(apply (^ (arg ...)
                          body ...) args))
          ...
          (else key))
        ))))

使い方はこんな感じ。
(define counter
  (let1 count 0
    (dlambda
     (inc (:optional (n 1))(inc! count n))
     (dec (:optional (n 1))(dec! count n)))))

(counter 'inc)
;; -> 1
(counter 'inc)
;; -> 2
(counter 'dec 10)
;; -> -6


で、これが プログラミング Gauche に載ってる object マクロ。(P.270)
(define-syntax object
  (syntax-rules ()
    [(object (ivar ...) (method (arg ...) body ...) ...)
     (lambda (ivar ...)
       (lambda (message . args)
         (case message
           [(method) (apply (lambda (arg ...) body ...) args)]
           ...)))]
    ))

で、こんな感じでオブジェクトっぽいものを作るのに使える。
(define make-count
  (let1 count 0
    (object ()
            (inc (:optional (n 1))(inc! count n))
            (dec (:optional (n 1))(dec! count n)))))

(define counter (make-count))

(counter 'inc)
;; -> 1
(counter 'inc 10)
;; -> 11
(counter 'dec)
;; -> 10

メソッド名はキーワードでも良いかも。こんな風に。
(define make-count
  (let1 count 0
    (object (:optional step)
            (:inc (:optional (n step))(inc! count n))
            (:dec (:optional (n step))(dec! count n)))))

(define counter (make-count 3))

(counter :inc)
;; -> 3
(counter :inc 1)
;; -> 4
object マクロの方が初期値を取れる分良いかも。

プログラミング Gauche を読んでたら object マクロが目にとまりました -> LOL の dlambda に似てるなー -> ただそれだけです。

ついでに LOL に載ってる Common Lisp 版の dlambda 。
(defmacro! dlambda (&rest ds)
  `(lambda (&rest ,g!args)
     (case (car ,g!args)
       ,@(mapcar
           (lambda (d)
             `(,(if (eq t (car d))
                  t
                  (list (car d)))
               (apply (lambda ,@(cdr d))
                      ,(if (eq t (car d))
                         g!args
                         `(cdr ,g!args)))))
           ds))))

LOL の dlambda には defmacro! が必要なので、実際に使うには以下のようになる。伝統的マクロは確かに強力だけど、syntax-rules だと簡単に書けるものもあるので、syntax-rules も結構よくね?
(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec
                        (car x)
                        (rec (cdr x) acc))))))
    (rec x nil)))

(defun mkstr (&rest args)
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))

(defun symb (&rest args)
  (values (intern (apply #'mkstr args))))

(defun g!-symbol-p (s)
  (and (symbolp s)
       (> (length (symbol-name s)) 2)
       (string= (symbol-name s)
                "G!"
                :start1 0
                :end1 2)))

(defmacro defmacro/g! (name args &rest body)
  (let ((syms (remove-duplicates
                (remove-if-not #'g!-symbol-p
                               (flatten body)))))
    `(defmacro ,name ,args
       (let ,(mapcar
               (lambda (s)
                 `(,s (gensym ,(subseq
                                 (symbol-name s)
                                 2))))
               syms)
         ,@body))))


(defun o!-symbol-p (s)
  (and (symbolp s)
       (> (length (symbol-name s)) 2)
       (string= (symbol-name s)
                "O!"
                :start1 0
                :end1 2)))

(defun o!-symbol-to-g!-symbol (s)
  (symb "G!"
        (subseq (symbol-name s) 2)))

(defmacro defmacro! (name args &rest body)
  (let* ((os (remove-if-not #'o!-symbol-p args))
         (gs (mapcar #'o!-symbol-to-g!-symbol os)))
    `(defmacro/g! ,name ,args
       `(let ,(mapcar #'list (list ,@gs) (list ,@os))
          ,(progn ,@body)))))

(defmacro! dlambda (&rest ds)
  `(lambda (&rest ,g!args)
     (case (car ,g!args)
       ,@(mapcar
           (lambda (d)
             `(,(if (eq t (car d))
                  t
                  (list (car d)))
               (apply (lambda ,@(cdr d))
                      ,(if (eq t (car d))
                         g!args
                         `(cdr ,g!args)))))
           ds))))

LET OVER LAMBDA Edition 1.0

2011/02/11

gauche script の linux と windows

linux とかだと、例えば glp.scm という名前で
#! /usr/local/bin/gosh

(use gauche.parseopt)

(define (main args)
  (let-args (cdr args)
      ((ls "l|list")
       . rest)
    (if ls
        (for-each print *load-path*)
        (print *load-path*))
    0))

$ glp
(/usr/local/share/gauche-0.9/site/lib /usr/local/share/gauche-0.9/0.9.1/lib /usr/local/share/gauche/site/lib /usr/local/share/gauche/0.9/lib)
$ glp -l
/usr/local/share/gauche-0.9/site/lib
/usr/local/share/gauche-0.9/0.9.1/lib
/usr/local/share/gauche/site/lib
/usr/local/share/gauche/0.9/lib

で、windows だとこんな感じでできるみたい。
;; @rem -*- mode: scheme -*-
;; @echo off
;; gosh "%~f0" %*
;; goto :__gauche_script_end

(use gauche.parseopt)

(define (main args)
  (let-args (cdr args)
      ((ls "l|list")
       . rest)
    (if ls
        (for-each print *load-path*)
        (print *load-path*))
    0))

;;
;; :__gauche_script_end
;;
C:\>glp.scm.cmd
(C:\Gauche\share\gauche-0.9\site\lib C:\Gauche\share\gauche-0.9\0.9.1\lib C:\Gauche\share\gauche/site/lib C:\Gauche\share\gauche/0.9/lib)
C:\>glp.scm.cmd -l
C:\Gauche\share\gauche-0.9\site\lib
C:\Gauche\share\gauche-0.9\0.9.1\lib
C:\Gauche\share\gauche/site/lib
C:\Gauche\share\gauche/0.9/lib

検索したらこんなものが。。

追記

さっそく教えて頂きました!
@valvallow Windows だと拡張子 .scm を gosh に関連付けしておけばコマンドラインからファイル名を入力するだけでOKです。 更に環境変数 PATHEXT に拡張子を定義しておけばその拡張子を省略した名前がコマンド名として使えるようになります。
@valvallow 参考記事。 http://goo.gl/UidLd この記事ではコマンドで設定しています。 エクスプローラから関連付けするとコマンドライン引数がうまく渡されなくなってしまうことがあるようです。

詳解 シェルスクリプト

cygwin に gauche-dbd-pg

gauche-dbd-pg は、先日 serversman(CentOS)にも入れました。
Emacs から tramp でサーバ側の shell を立ち上げるとローカルの Emacs からサーバ側の gosh REPL にコードを送ることができるので、サーバの PostgreSQL を操作するプログラムをローカルで開発できます。

できますが、例えば何かモジュールを作ってそれを利用するようなコードを書いた時にそのモジュールをサーバにアップロードしてからでないとテストができません。アップロードといっても、tramp を用いてローカルの Emacs の dired から直接コピーできるのですが、その一手間が面倒です。それに gosh の再起動もしくは reload 等も必要になります。一手間どころか、そもそもモジュールに変更があるたびに手作業が発生するなんて狂気の沙汰。
開発のサイクルのなかで、モジュールを再ロードしなければならないことは 頻繁におこります。このモジュールはそれを支援するものです。

ということで、ローカルの cygwin にも gauche-dbd-pg を入れて、ネットワーク越しにサーバの PostgreSQL に接続できるようにすることにしました。

当然ですが PostgreSQL の方も設定が必要。

で、cygwin の setup から postgresql を入れて、gauche-dbd-pg をダウンロードして展開して ./configure で make ・・・ でコケました。
dbd_pglib.c:817: error: too few arguments to function `Scm_Apply'
GAUCHE_API_PRE_0_9 のことを教えてもらって、試しましたがうまくいきませんでした。
で、もう一度エラーメッセージをよく見ていたら、以前 serversman に入れた時も見たことがあるような気がしてきました。確か、kahua のページにある gauche-dbd-pg-0.2.1 を入れようとした時に見た気がします。
0.2.1 が同様のエラーでうまく入らなかったから trunk から持ってきて入れたんでした。で、今回もその trunk から入れてるつもりでしたが、持ってくるものを間違ってました。

これ
を入れないといけないのに、これ
を持ってきてました。うっかり。で、後者前者の trunk は何の問題もなく入りました。
(use dbi)
(use dbd.pg)

(dbi-open?
 (dbi-connect "dbi:pg:dbname=test;port=5432;host=example.com"
              :username "postgres" :password "hoge"))
;; -> #t
ところで、dbi 周りには transaction 系の api がなさげ?with-transaction 的なものが欲しいです。取りあえず自前で用意することになりそうですかね。

で、ネットに落ちてる gauche-dbd-* を用いたコードを眺めていましたが、あまりたくさんはなさそうですね。。
Ruby の ActiveRecord みたいのを mop で実現してる(?)のがなんかすごそう。

プログラミングGauche