ytaki:200503-04
- メモ:Gauche 0.8.4 preview release で WiLiKi 0.5 を動かす時の修正
- Scheme でアルゴリズム
- 演算子による文字列やリストの演算
- 使い捨てスクリプト:バッチファイル編
- 分かち書き対応 Google 検索
- メモ:NetBSD/i386 2.0 への Kahua インストール
- 簡易チャットプログラム
- 時刻表示プログラム
メモ:Gauche 0.8.4 preview release で WiLiKi 0.5 を動かす時の修正
(2005/04/27 02:19:45 PDT)
http://cvs.sourceforge.net/viewcvs.py/wiliki/WiLiKi/src/wiliki/format.scm?r1=1.34&r2=1.35
コンパイラが書き直された時に見つかったようで.
http://sourceforge.net/mailarchive/forum.php?thread_id=7027801&forum_id=2043
Scheme でアルゴリズム
(2005/04/10 11:19:08 PDT)
『Ruby でアルゴリズム』 というサイトに触発されて Scheme (Gauche) で書き始めてみたのですが (はい,全然懲りてませんね),2つ書いて力尽きました(--;).
既にどなたかがやってるような気がしてならないのですが(苦笑), とりあえず書いてみたものを以下に置いときます.モノがモノだけにツッコミ歓迎. というか,著作権の扱いはこの場合どのように考えたらいいのかな…. 書き続けられるようなら(をい)原作者に問い合わせてみます.
http://www.nightbreak.org/ardes/algo/
公開等で特に問題がなければ,いつの間にか増えてたり書き直されてたりして いるかもしれません(いいかげん).いや,まずは 3dgraph.scm 書き直したい. ok まわりを特に….
- ytaki(2005/04/24 11:25:33 PDT): 書籍前書きやソースコード一式の README よく見たら特に利用に制限はない ようなので,それっぽいページにしてみました.とはいえ,一通り書き直せたら 上記サイトや原作者に一報するべきだろうなあ.とりあえず現時点で実質6つか… いつのことになるやら(泣).
- Shiro(2005/04/24 12:05:33 PDT):
- 105.scm: (let ((var init) ...) body ...) の各init...の評価順序は 規格で定められていないので、このように順序に依存するものを書きたい場合は let*を使いましょう。
- 3dgraph.scm: ここのdo文はdotimesを使うと少しすっきりするかもしれません。
- area.scm: インデックスで何度もアクセスする時はlistよりvectorの方が 良いでしょう。
- mathutil.scm: (make-vector nrow (make-vector ncol)) とやると、 (make-vector ncol)で作った単一のベクタを全てのrowが共有してしまいます。 (list->vector (map (lambda (_) (make-vector ncol)) (iota nrow))) などとして nrow回make-vectorを呼ばないとなりません。あるいは GaucheRefj:gauche.arrayを使ってみるとか。
- ytaki(2005/04/24 12:43:02 PDT): 早速ありがとうございます.let はうかつでした orz. 行列については,ヘタに独自にやるよりもやはり既存のコードや手法を 利用させていただく方が簡潔になりそうなので,早いうちに根本的に 書き直すかもしれません(^^;).
演算子による文字列やリストの演算
(2005/04/02 11:49:38 PST)
いえ,たいしたことじゃないんですがちょっと気になって. なんか無理にネタを出してるようにも見えるのがイタい….
O'Reilly の Python 初心者本(^^;)を読んでいるんですが, 演算子による文字列やリストの足し算/掛け算を見て, とりあえず Gauche なら
(define-method + ((str <string>) . more) (string-append str (apply string-append more))) (define-method + ((list <list>) . more) (append list (apply append more))) (define-method * ((str <string>) (i <integer>)) (if (= i 1) str (string-append str (* str (- i 1))))) (define-method * ((list <list>) (i <integer>)) (if (= i 1) list (append list (* list (- i 1)))))
と定義できるかな…とか思ったんですが,なんか例によってコードが汚い(泣). 既にモジュールでありそうな気もするし.というか,あっても使うのかという 話が(汗).
- teranishi(2005/04/02 16:28:49 PST):
上のコードのどこが汚いのか良く分からないのですが・・・
とりあえず、apply は複数引数を取れます。* は無理矢理再帰なしで書いてみました。(use srfi-1) (use srfi-13) (define-method + ((str <string>) . more) (apply string-append str more)) (define-method + ((list <list>) . more) (apply append list more)) (define-method * ((str <string>) (i <integer>)) (string-concatenate (make-list i str))) (define-method * ((list <list>) (i <integer>)) (concatenate (make-list i list)))
- ytaki(2005/04/04 10:58:37 PDT): そういえば apply はそうでしたねえ…リスト1つ
とるパターンばかり書いててすっかりわすれてました(R5RS あらためて読み
直してみたり).で,<collection> クラスに定義すればかなり見通し良く
記述できるようです.
(define-method append ((str <string>) . more) (apply string-append str more)) (define-method + ((coll <collection>) . more) (apply append coll more)) (define-method * ((coll <collection>) (i <integer>)) (if (= i 1) coll (append coll (* coll (- i 1)))))
他の <collection> サブクラスにも append を定義すれば自動的に + や * が 利用できる…はず(自信なし).ハッシュテーブルの append ってなんだろって 気もするので <sequence> の方がいいのかな?オブジェクトシステム特訓中.
- Shiro(2005/04/04 14:05:36 PDT): こういうオーバロードをやっている言語の多くは、 それによってinfix演算子が使えることによる表記上のメリットがあるわけですが、 Lispの場合「演算子」と「関数」は同じことなので、表記上のメリットはあまり ありません。オーバロードをやるとしたら、 「それによってジェネリックなアルゴリズムを書けるかどうか」だけが基準に なると思います。例えばmapやfoldのジェネリック化や、refのようなジェネリック関数は、 それらを使うことで具体的なデータ型に拘らないアルゴリズムを容易に書けるという メリットがあるわけです。 '+' の場合、数値の加算とstring-appendの間に同等の抽象化が見出せるかどうか というと、私は疑問に思います (このジェネリック版 '+' や '*' を使って、 文字列に対しても数値に対しても意味のあるアルゴリズムを書けるかどうか、という ことです)。 まあ、ここはオブジェクトシステムの練習でやっているんだと思いますが、 ジェネリック化する場合の基本的な指針として、こういうことを考えてみるのは 悪くないと思います。
- ytaki(2005/04/07 12:03:27 PDT): すみません,自分で書いといてなんですが,オブジェクト
システムの練習にもなってないと思います(をい).いやもう,ハナから手段と目的が
逆転してますから,悪い意味でどんどん技巧的になっちゃってますね.反省….
それはともかく,もし今回の件でなんらかの抽象化を考えるなら,上記 * に相当する
ものを古典的(?)なやり方で
(define times (lambda (f seq i) (if (= i 1) seq (f seq (times f seq (- i 1)))))) (define-method list-times ((list <list>) (i <integer>)) (times append list i)) (define-method string-times ((str <string>) (i <integer>)) (times string-append str i))
などと書くのが筋なのかもしれません.…が,こうなるともはやメソッド定義は 型チェックのためにしか使ってないという.やっぱり練習になってなかった(汗).
- ytaki(2005/04/09 02:30:21 PDT): 言い訳の追加.今回の件はとにかく,別の言語の記法を
『直訳』しようとしたのがそもそもまずかったなあとあらためて思いました(頭では
わかってたつもりだったけど…).というのも,発端の Python 初心者本を読み進めて
いて,リスト内包表記の例として
[(x,y) for x in range(5) if x%2 == 0 for y in range(5) if y%2 == 1]
というのが出てきたんですが,『LISP を使ったことのある人なら map 関数, filter 関数で同等のコードが書けるかもしれない』とあって,また Scheme で そのまま書こうとしてみたんですね(苦笑).結局,要するに上記の例は 『0 〜 4 の整数を偶数と奇数の集合に分けて直積集合を求める』ものと『意訳』 できて,srfi-1 と util.combinations を使わせてもらって(receive (s1 s2) (partition even? (iota 5)) (cartesian-product (list s1 s2)))
とするのが Scheme/LISP らしいかなと.まあ,この問題(?)はプログラミング言語に 限りませんが….
- Shiro (2005/04/09 05:01:55 PDT): いや、その考え方は結構良い頭の体操だと
思いますよ。ちなみにリスト内包表記はマクロで簡単に書けます。
Scheme:マクロの効用の「リストの内包表記」を参照。そのマクロを使うと
上の例はこう書けます。
(list-of (list x y) (x in (iota 5)) (even? x) (y in (iota 5)) (odd? y))
これをリストだけでなく他のデータ構造にも適用可能なように一般化したものは srfi-42で定義されています。 (Alex ShinnがGauche向けにsrfi-42実装を書いてくれたので、近々入ります)
- ytaki(2005/04/09 07:54:02 PDT): なるほど….上記の例は srfi-42 実装が使えれば
こんな感じに書けるのかな.
(list-ec (: x 5) (if (even? x)) (: y 5) (if (odd? y)) (list x y))
qualifier の定義がいまいち読み取れてない気がしないでもないけど(汗). マルチバイト文字列で string-ec あたりを使うと面白いことができそうですね.
使い捨てスクリプト:バッチファイル編
(2005/03/30 06:33:24 PST)
最近,CSV の MAC アドレス/IP アドレス対応表を使って Windows 2000 Server の DHCP サーバに 150 台分の予約アドレスを登録するハメになったのですが, import のしかたがよくわからなかったので(をい),Scheme (Gauche)で コードを書いてバッチファイルを生成し,Windows にもってきて実行という ことをしました.具体的には,あるソフトが
comment5,hostMM,XXX.XXX.XXX.XXX,aa:ff:22:23:22:33,num1,nnn, commhoge,hostXY,YYY.YYY.YYY.YYY,cc:ee:33:22:33:77,num4,zzz, comment3,hostZZ,XYZ.ZYX.XXX.YYZ,bb:00:22:88:11:33,num2,kkk, ...
という形で吐き出した CSV ファイルを以下のようなバッチファイルに変換する コードを書いたということです.
netsh dhcp server scope XXX.XXX.XXX.0 add reservedip XXX.XXX.XXX.XXX aaff22232233 hostMM "" "BOTH" netsh dhcp server scope YYY.YYY.YYY.0 add reservedip YYY.YYY.YYY.YYY ccee33223377 hostXY "" "BOTH" netsh dhcp server scope XYZ.ZYX.XXX.0 add reservedip XYZ.ZYX.XXX.YYZ bb0022881133 hostZZ "" "BOTH" ...
上記の例を書くだけでもうんざりしたのですが(苦笑),以前にも CSV を扱う 使い捨てスクリプトを Gauche で書いたことがあったので,それをてきとーに流用 して逃げることにしました(一応,登録後に目視確認).
;;;; ユーティリティモジュールの読み込み (use text.csv) (use gauche.regexp) ;;;; エントリ作成 (define make-entries (lambda (ls) (let ((bcoms "netsh dhcp server scope") (mcoms "add reservedip")) (map (lambda (l) (let* ((host (list-ref l 1)) (ipaddr (list-ref l 2)) (macaddr (regexp-replace-all #/:/ (list-ref l 3) "")) (seg (regexp-replace #/\.\d{1,3}$/ ipaddr ".0"))) (format "~a ~a ~a ~a ~a ~a \"\" \"BOTH\"\r\n" bcoms seg mcoms ipaddr macaddr host))) ls)))) ;;;; CSV ファイルからの読み込み (define get-csvlist (lambda (file) (let ((iport (open-input-file file)) (csv (make-csv-reader #\,))) (let loop ((line (csv iport)) (ret '())) (cond ((eof-object? line) (close-input-port iport) ret) (else (loop (csv iport) (append ret `(,line))))))))) ;;;; バッチファイルへの書き出し (define put-commands (lambda (l ofile) (let1 oport (open-output-file ofile) (let loop ((l l)) (cond ((null? l) (close-output-port oport) #t) (else (format oport (car l)) (loop (cdr l)))))))) ;;;; メイン関数 (define main-func (lambda (ifile ofile) (put-commands (make-entries (get-csvlist ifile)) ofile)))
Perl なら数行で済むのかな?(ていうか,同僚には『Excel でいいじゃん』 とか言われた)
仕事の関係でこの手のスクリプト作成は割と多く,自分なりに洗練して流用 しやすくしているつもりなんですが,やはりどうも行き当たりばったり感が ぬぐえない…使い捨てばかり書いてきたのがバレバレ.ツッコミ歓迎.
- Shiro(2005/03/30 12:45:29 PST): リストを分解するときは、matchが手軽です。
ファイル操作は大抵の場合、call-with-*-fileかwith-*-fileで済むので、
自分でopenやcloseを書く必要はあまり無いです。
また、定型的な繰り返しの場合、ループを明示的に書かないで済む場合も多いです。
(use text.csv) (use text.tr) (use util.match) (define (make-entry entry) (match entry ((_ host ipaddr macaddr _ _ _) (format #t "netsh dchp server scope ~a add reservedip ~a ~a ~a \"\" \"BOTH\" \r\n" (regexp-replace #/\..{1,3}$/ ipaddr ".0") ipaddr (string-tr macaddr ":" "" :delete #t) host)) (else #f))) (define (doit iport) (port-for-each make-entry (lambda () ((make-csv-reader #\,) iport)))) (define (main args) (match args ((_ ifile ofile) (with-output-to-file ofile (lambda () (call-with-input-file ifile doit)))) (else (print #`"Usage: ,(car args) <ifile> <ofile>\n") (exit 0))))
- ytaki(2005/03/31 05:15:01 PST): なるほど,port-for-each(や port-map)って
このように使うんですね.いえ,上記の『以前書いた CSV を扱うスクリプト』
というのは出力も CSV で,その時は(なぜか)
(define put-csvlist-to-file (lambda (olist ofile) (let1 p (open-output-file ofile) (for-each (lambda (l) ((make-csv-writer #\, "\r\n") p l)) olist) (close-output-port p))))
みたいなのはさくっと思いついたんですが,入力で似たようなことをするには map を 使って…あれ?みたいな(苦笑).しかも,この記述が上記のスクリプトに全然生かされて いないという(for-each と format でいいのに…).パターンマッチング/ファイル操作 共々修行してきます.ありがとうございました.
分かち書き対応 Google 検索
(2005/03/26 13:27:17 PST)
redirect ってちゃんとわかるといろいろ応用できて便利ですね. ということで,も一つ CGI のサンプルを作ってみました.
文章を入力したら Gauche-kakasi で適当に分かち書きして, それをそのまま Google の検索にまわすというものです. やってることは単純ですが,まあ,自然文検索もどきになるかなと.
;;;; ライブラリモジュール読み込み (use text.html-lite) (use www.cgi) (use rfc.uri) (use text.kakasi) ;;;; CGI プログラムのファイル名 (define googlekks:title "<Google 検索:kakasi 分かち書き>") ;;;; ベタ書き文字列から分かち書き文字列に変換 (define googlekks:wakati (lambda (str) (if (equal? str "") "" (let1 wlis (kakasi-wakati str) (string-append (car wlis) (let loop ((wlis-l (cdr wlis)) (wstr "")) (if (null? wlis-l) wstr (loop (cdr wlis-l) (string-append wstr " " (car wlis-l)))))))))) ;;;; Google 表示のインタフェース (define googlekks:inputform (html:form (html:table :bgcolor "#FFFFFF" (html:tr (html:td (html:a :href "http://www.google.co.jp/" (html:img :src "http://www.google.com/logos/Logo_40wht.gif" :border "0" :alt "Google" :align "absmiddle")) (html:input :type "text" :name "q" :size "31" :maxlength "255" :value "") (html:input :type "submit" :name "btnG" :value "Google 検索")))))) ;;;; メインプログラム (define main (lambda (args) (cgi-main (lambda (params) (let1 q-value (cgi-get-parameter "q" params :default "") (if (equal? q-value "") `(,(cgi-header :content-type "text/html; charset=euc-jp") ,(html-doctype) ,(html:html (html:head (html:title googlekks:title)) (html:body (html:h3 googlekks:title) googlekks:inputform))) (cgi-header :status "302 Moved" :location (format "http://www.google.co.jp/search?hl=ja&ie=EUC-JP&q=~a" (uri-encode-string (googlekks:wakati q-value))))))))))
助詞/助動詞とか適宜削除したり,分野別の単語出現頻度データベースを作って 連動させたりするとそれなりに効率の良い検索もできそうだけど,そこまでやると サンプルではなくなるのでパス(ただの手抜き).
メモ:NetBSD/i386 2.0 への Kahua インストール
(2005/03/26 02:55:47 PST)
他に適切なところが見当たらなかったのでここにメモ.
- たぶん,他のプラットフォームでも同じ手順で可
- apache-2.0.52nb5 package + Gauche-0.8.3 + Kahua-0.3.1 で確認
- 標準設定はあまり変えない方針でインストール
- とりあえず一般ユーザ(users)全員が Kahua 管理者になれるよう設定(危険)
- /cgi-bin/kahua.cgi/hoge でアクセス可能
(Apache を users グループで稼働するよう変更) # vi /usr/pkg/etc/httpd/httpd.conf (Group www を Group users に変更) # /etc/rc.d/apache restart (Kahua の make & make check) $ tar xvpfz Kahua-0.3.1.tgz $ cd Kahua-0.3.1 $ ./configure --with-cgidir=/usr/pkg/libexec/cgi-bin $ make $ make check (root によるインストールおよび各種設定) # make install # vi /usr/local/etc/kahua/kahua.conf (static-document-path を /usr/pkg/share/httpd/htdocs/kahua に変更) # mkdir /usr/pkg/share/httpd/htdocs/kahua # export KAHUA_DIRS='/usr/local/tmp/kahua /usr/local/var/kahua /usr/pkg/share/httpd/htdocs/kahua' # export KAHUA_CGILOGDIR=/usr/local/libexec/kahua # chgrp -R users $KAHUA_DIRS $KAHUA_CGILOGDIR # chmod -R g+ws $KAHUA_DIRS # chmod 755 $KAHUA_CGILOGDIR (一般ユーザによるサンプルアプリケーションインストールおよび稼働) $ make install-examples $ chmod 664 /usr/local/var/kahua/app-servers $ vi /usr/local/var/kahua/app-servers (run-by-default とかいろいろ修正) $ (/usr/local/bin/kahua/kahua-spvr > /dev/null 2>&1) & $ /usr/local/bin/kahua/kahua-admin (run とか kill とか shutdown とかいろいろ制御)
Happy Kahua Programming!
簡易チャットプログラム
(2005/03/23 13:49:22 PST)
時刻表示プログラムのところで述べたサンプルプログラムについて, Shiro さんの時刻表示部とGauche:CGI:スケジュール予定表:Shiro版にある ノウハウなどを取り入れて書き直したものです.ちなみに,Ver.0.3 とかなって
いるのは,内輪向けに公開したものからの修正が入っているためです(^^;). 何百文字もコピペしてからに….
;;;; ;;;; 簡易チャットプログラム Ver.0.3 ;;;; ;;;; ライブラリモジュール読み込み (use text.html-lite) (use www.cgi) (use dbm) (use dbm.gdbm) ;;;; 表示行数,名前文字数制限,発言文字数制限の指定 (define chatsample:line-num 10) (define chatsample:name-num 10) (define chatsample:word-num 80) ;;;; 発言データベース (define chatsample:db "chatsample.db") ;;;; 現在の日時を取得して必要な部分を構成: Thank you, shiro@acm.org. (define chatsample:get-ctime (lambda () (let1 now (sys-localtime (sys-time)) (format "~a/~2,'0d(~a)~2,'0d:~2,'0d:~2,'0d" (+ (ref now 'mon) 1) (ref now 'mday) (string-ref "日月火水木金土" (ref now 'wday)) (ref now 'hour) (ref now 'min) (ref now 'sec))))) ;;;; 入力フォーム表示 (define chatsample:inputform (lambda (name-value) `(,(html:form "名前" (html:input :type "text" :name "name" :size 10 :value name-value) " > " (html:input :type "text" :name "word" :size 80) (html:input :type "submit" :value "発言"))))) ;;;; データベースへの発言登録 (define chatsample:dbput (lambda (name-value word-value) (let* ((db (dbm-open <gdbm> :path chatsample:db :rw-mode :write)) (num-value (string->number (dbm-get db "num")))) ;;;; 各発言は発言順番号 num で登録 (dbm-put! db (number->string num-value) #`",|name-value| > ,|word-value|(,(chatsample:get-ctime))") (dbm-put! db "num" (number->string (+ num-value 1))) (dbm-close db)))) ;;;; 発言データベースから指定行数分を順番に取得してリスト化 (define chatsample:getdblist (lambda () (let* ((db (dbm-open <gdbm> :path chatsample:db :rw-mode :read)) (max (string->number (dbm-get db "num")))) (let loop ((label (if (< max (+ chatsample:line-num 1)) 0 (- max chatsample:line-num))) (ret '())) (cond ((= label max) (dbm-close db) ret) (else (loop (+ label 1) (cons (dbm-get db (x->string label)) ret)))))))) ;;;; 発言リスト表示 (define chatsample:dblist (lambda () `(,(html:hr) ,(let1 out (chatsample:getdblist) (if (null? out) "" (map (lambda (s) (append `(,s) (html:br) (html:hr))) out))) ,chatsample:line-num "行目まで表示"))) ;;;; 発言データベースの初期化 (define chatsample:dbinit (lambda () (let1 db (dbm-open <gdbm> :path chatsample:db :rw-mode :write) (if (not (dbm-exists? db "num")) (dbm-put! db "num" "0")) (dbm-close db)))) ;;;; メインプログラム (define main (lambda (args) (chatsample:dbinit) (cgi-main (lambda (params) (let ((name-value (cgi-get-parameter "name" params :default "")) (word-value (cgi-get-parameter "word" params :default ""))) ;;;; データベースへの発言登録 (if (not (or (and (equal? name-value "") (equal? word-value "")) (> (string-length name-value) chatsample:name-num) (> (string-length word-value) chatsample:word-num))) (chatsample:dbput name-value word-value)) `(,(cgi-header :content-type #`"text/html; charset=,(gauche-character-encoding)") ,(html-doctype) ,(html:html (html:head (html:title "<簡易チャット>")) (html:body (html:h3 "<簡易チャット>") (chatsample:inputform name-value) ;; 入力フォーム表示 (chatsample:dblist))))))))) ;; 発言リスト表示
とても Gauche:CGI に列せられるレベルのものではありません(--;). 問題点は挙げるとキリがないけど,とりあえず致命的なのは reload 未対応ですか. status/location をどのように指定すれば良いのかよくわからない.構成を変えない とダメか?
- teranishi(2005/03/26 00:13:51 PST):
Gauche:CGI:スケジュール予定表:Shiro版の「データのストア」の所に
status/location の指定をしている所があります。
- ytaki(2005/03/26 02:55:47 PST): いえ,そちらは既に参照してるんですが,上記プログラムの場合にどのタイミングで 入れたら良いかいまいちつかめてなくて(^^;).構成があまりにベタなので根本的な 書き直しが必要かなあと.そして Kahua に走る(を).
- teranishi(2005/03/26 03:33:00 PST): こうすればよさげです
;;;; メインプログラム (define main (lambda (args) (chatsample:dbinit) (cgi-main (lambda (params) (let ((name-value (cgi-get-parameter "name" params :default "")) (word-value (cgi-get-parameter "word" params :default ""))) ;;;; データベースへの発言登録 (if (not (or (and (equal? name-value "") (equal? word-value "")) (> (string-length name-value) chatsample:name-num) (> (string-length word-value) chatsample:word-num))) (begin (chatsample:dbput name-value word-value) (cgi-header :status "302 Moved" :location "?")) `(,(cgi-header :content-type #`"text/html; charset=,(gauche-character-encoding)") ,(html-doctype) ,(html:html (html:head (html:title "<簡易チャット>")) (html:body (html:h3 "<簡易チャット>") (chatsample:inputform name-value) ;; 入力フォーム表示 (chatsample:dblist)))))))))) ;; 発言リスト表示
- ytaki(2005/03/26 07:11:53 PST): あー,そっか,発言登録後は表示なしにしつつ, もう一度引数なしで実行すれば良かったんですね.スケジュールの場合は 別ページ生成という形になってたのでちょっと混乱してました(ダメじゃん). ありがとうございました.名前も残らなくなるけど,これは cookie を使うべき だろうなあ.
- ytaki(2005/03/26 08:55:24 PST): 一応,cookie とか考えずに名前を残すための修正.要 (use rfc.uri).しかしまた汚いコードに….
(let ((name-value (cgi-get-parameter "name" params :default "")) (word-value (cgi-get-parameter "word" params :default ""))) ;;;; データベースへの発言登録 - (if (not (or (and (equal? name-value "") (equal? word-value "")) + (if (not (or (or (equal? name-value "") (equal? word-value "")) (> (string-length name-value) chatsample:name-num) (> (string-length word-value) chatsample:word-num))) (begin (chatsample:dbput name-value word-value) - (cgi-header :status "302 Moved" :location "?")) + (cgi-header :status "302 Moved" + :location + (format "?name=~a" (uri-encode-string name-value)))) `(,(cgi-header :content-type #`"text/html; charset=,(gauche-character-encoding)")
ytaki(2005/03/27 12:50:07 PST): というわけで(?),一部オブジェクト化とかしながら 全体を書き直し.リファクタリングと呼べるほどでもないが….
;;;; タイトル (define chatsample:title "<簡易チャット>") ;;;; 表示行数,名前文字数制限,発言文字数制限の指定 (define chatsample:line-num 10) (define chatsample:name-num 10) (define chatsample:word-num 80) ;;;; 発言データベースのファイル名 (define chatsample:db "chatsample.db") ;;;; ライブラリモジュール読み込み (use text.html-lite) (use www.cgi) (use dbm) (use dbm.gdbm) (use rfc.uri) ;;;; 時刻表示のカスタマイズ関数 (define chatsample:get-ctime (lambda () (let1 now (sys-localtime (sys-time)) (format "~a/~2,'0d(~a)~2,'0d:~2,'0d:~2,'0d" (+ (ref now 'mon) 1) (ref now 'mday) (string-ref "日月火水木金土" (ref now 'wday)) (ref now 'hour) (ref now 'min) (ref now 'sec))))) ;;;; 発言クラス (define-class <chatsample:message> () ((name :init-value "" :init-keyword :name :accessor name-of) (word :init-value "" :init-keyword :word :accessor word-of))) ;;;; 登録文字列を生成するメソッド (define-method db-val ((mes <chatsample:message>)) #`",(name-of mes) > ,(word-of mes) (,(chatsample:get-ctime))") ;;;; 数値文字列を 1 増やすメソッド (define-method ++ ((x <string>)) (x->string (+ (x->number x) 1))) ;;;; 1つの発言をデータベースに追加するメソッド (define-method dbput! ((mes <chatsample:message>)) (let* ((db (dbm-open <gdbm> :path chatsample:db :rw-mode :write)) (num (dbm-get db "num"))) (dbm-put! db num (db-val mes)) (dbm-put! db "num" (++ num)) (dbm-close db))) ;;;; 表示開始行の判定関数 (define chatsample:line-begin (lambda (max) (let1 diff (- max chatsample:line-num) (if (< diff 1) 0 diff)))) ;;;; 発言データベースから指定行数分を順番に取得してリスト化 (define chatsample:getdblist (lambda () (let* ((db (dbm-open <gdbm> :path chatsample:db :rw-mode :read)) (max (x->number (dbm-get db "num")))) (let loop ((label (chatsample:line-begin max)) (ret '())) (if (< label max) (loop (+ label 1) (cons (dbm-get db (x->string label)) ret)) (begin (dbm-close db) ret)))))) ;;;; 発言リスト表示 (define chatsample:dblist (lambda () `(,(html:hr) ,(let1 out (chatsample:getdblist) (if (null? out) "" (map (lambda (s) (append `(,s) (html:br) (html:hr))) out))) ,chatsample:line-num "行目まで表示"))) ;;;; 入力フォーム表示 (define chatsample:inputform (lambda (n) `(,(html:form "名前" (html:input :type "text" :name "name" :size 10 :value n) " > " (html:input :type "text" :name "word" :size 80) (html:input :type "submit" :value "発言"))))) ;;;; 全体の表示 (define chatsample:display (lambda (name) `(,(cgi-header :content-type #`"text/html; charset=,(gauche-character-encoding)") ,(html-doctype) ,(html:html (html:head (html:title chatsample:title)) (html:body (html:h3 chatsample:title) (chatsample:inputform name) (chatsample:dblist)))))) ;;;; 発言の登録および全体表示のための自身へのリダイレクト (define chatsample:redirect (lambda (name word) (dbput! (make <chatsample:message> :name name :word word)) (cgi-header :status "302 Moved" :location (format "?name=~a" (uri-encode-string name))))) ;;;; 発言データベースの初期化 (define chatsample:dbinit (lambda () (let1 db (dbm-open <gdbm> :path chatsample:db :rw-mode :write) (if (not (dbm-exists? db "num")) (dbm-put! db "num" "0")) (dbm-close db)))) ;;;; メインプログラム (define main (lambda (args) (chatsample:dbinit) (cgi-main (lambda (params) (let ((name (cgi-get-parameter "name" params :default "")) (word (cgi-get-parameter "word" params :default ""))) ;;;; 名前や発言が空ではなく指定文字数以下ならば登録処理 (if (or (or (equal? name "") (equal? word "")) (> (string-length name) chatsample:name-num) (> (string-length word) chatsample:word-num)) (chatsample:display name) (chatsample:redirect name word)))))))
とはいえ,サンプルとしてはここらで打ち止めかなあ.
時刻表示プログラム
(2005/03/20 07:40:12 PST)
あちこちにツッコミ入れるだけなのもアレなので,少しばかりコードを貼り付け.
;;;; (get-mytime) => "3/21(月)00:34:40" (define get-mytime (lambda () (define get-tm-str (lambda (key tm) (let ((key-val (cdr (assoc key tm)))) (case key ;;; 曜日は漢字表記に変換 ((tm_wday) (x->string (string-ref "日月火水木金土" key-val))) ;;; 月のみ 0 から始まる ((tm_mon) (x->string (+ key-val 1))) ;;;; 時分秒は2桁にする ((tm_hour tm_min tm_sec) (let ((s (x->string key-val))) (if (eq? (string-size s) 1) (string-append "0" s) s))) ;;;; 日のみ通常処理 (else (x->string key-val)))))) (let* ((tm (sys-tm->alist (sys-localtime (sys-time)))) (mon (get-tm-str 'tm_mon tm)) (day (get-tm-str 'tm_mday tm)) (hour (get-tm-str 'tm_hour tm)) (min (get-tm-str 'tm_min tm)) (sec (get-tm-str 'tm_sec tm)) (week (get-tm-str 'tm_wday tm))) (string-append mon "/" day "(" week ")" hour ":" min ":" sec))))
前にゆいちゃっと風のサンプルプログラムを Gauche で作った時のもので,他でも流用できそうなので掲載.なんか既にもっと いいコードやライブラリがありそうな気がするんですが(^^;)とりあえず晒してみたり.
(2005/03/20 08:16:40 PST)正規表現版を作ろうとして挫折(泣).正規表現そのものを使いこなせて いないというのもあるけど,処理対象の文字列を考えるとあんまりきれいなコードに ならないような.時刻部分だけを (sys-ctime (sys-time)) から抜き出すのも なんだか….
- Shiro (2005/03/20 12:42:34 PST): いくつか別解が考えられます。たとえば:
(define (get-mytime) (let1 now (sys-localtime (sys-time)) (format "~a/~2,'0d(~a)~2,'0d:~2,'0d:~2,'0d" (+ (ref now 'mon) 1) (ref now 'mday) (string-ref "日月火水木金土" (ref now 'wday)) (ref now 'hour) (ref now 'min) (ref now 'sec))))
<sys-tm>を使うならPOSIXの日付フォーマット関数strftimeが GaucheRefj:sys-strftimeで呼べますが、曜日の部分を日本語にする カスタマイズがやりにくい (システムのLOCALEサポートに依存する) ので ここで使うとしたら HH:MM:SSの部分だけ、とか限定されそうです。
srfi-19にも日付のフォーマット関数がありますが、 やはり曜日の部分を自分で処理しなくちゃならないんで、あんまり短くなりませんね。(use srfi-19) (define (get-mytime) (let1 now (current-date) (format "~a/~2,'0d(~a)~a" (date-month now) (date-day now) (string-ref "日月火水木金土" (date-week-day now)) (date->string now "~T"))))
(そうそう、sys-tm->alistはsys-tmをシリアライズする目的で昔導入された 関数で、あまり推奨しません。オブジェクトのスロットの参照はslot-refもしくは refで統一的に行えます)
- ytaki(2005/03/21 09:48:38 PST): ぶしつけな記述にていねいな回答ありがとうございます.
オブジェクトシステムが使いこなせずにいるのがバレバレですね(汗).
内輪向けに使わせていただいている WiLiKi の時刻表示のカスタマイズができない
かなと思っているので,wiliki/format.scm あたりも参考にしていきたいと思います.
特に短くする必要はないとも思うのですが,曜日だけ別処理になるのがいろいろな
意味でやはりネックになりますかね….
- ytaki(2005/03/21 10:02:15 PST): って,実際の出力は wiliki/rssmix.scm 等で sys-strftime 使用してますね(汗).