ytaki:200503-04

ytaki:200503-04


メモ: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 まわりを特に….

演算子による文字列やリストの演算

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

と定義できるかな…とか思ったんですが,なんか例によってコードが汚い(泣). 既にモジュールでありそうな気もするし.というか,あっても使うのかという 話が(汗).

使い捨てスクリプト:バッチファイル編

(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 でいいじゃん』 とか言われた)

仕事の関係でこの手のスクリプト作成は割と多く,自分なりに洗練して流用 しやすくしているつもりなんですが,やはりどうも行き当たりばったり感が ぬぐえない…使い捨てばかり書いてきたのがバレバレ.ツッコミ歓迎.

分かち書き対応 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 を 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 をどのように指定すれば良いのかよくわからない.構成を変えない とダメか?

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)) から抜き出すのも なんだか….


Last modified : 2012/02/07 07:52:40 UTC