leque

leque はレキとかレクとか読むらしい。愛知県在住。最近はぶらぶらしてます。

作ったもの

作りの甘そうなもの

あとは http://www.katch.ne.jp/~leque/software/ にも色々と

Library Wish List

Gauche:LibraryWishList みたいなものがあったら、ネタに困ったときや、必要なライブラリの拡充に便利かもしれないとふと思った。→作ってみた

GaucheNight

平日の夜ということだったのに盛況だった。メモとかはとっていなかったので簡単な感想を。

LALR(1) 構文解析器

未完成。 lalr.scm

勉強がてら LALR(1) 構文解析器を書いてみました。

bigloo の LALR Parser と同じような構文で使えるつもり。 最初に LR(1) 構文解析表をつくってから LALR(1) 構文解析表をつくるので実用的な速度は出ません （PowerPC G4 800 MHz、メモリ 640 MB で、下記の四則演算の場合で 1 秒程度、 c-wrapper クラスのものになると 10 分弱）。

例: 

(use util.lalr)

(define *tokens*
  ; (2 + 3) * 4 / 2 - 1 * 7 => 3
  '(lp (i . 2) op-plus (i . 3) rp op-mult (i . 4) op-div (i . 2) op-minus (i . 1) op-mult (i . 7))
  )

(define lexer
  (let1 tokens *tokens*
    (lambda ()
      (let1 v (or (null? tokens) (pop! tokens))
        (if (pair? v)
            v
            (cons v v))))))

(define parser
  (lalr-grammar
   ((left op-mult op-div)
    (left op-plus op-minus)
    lp rp i)
   (expr
    ((lp expr rp) expr)
    ((op-plus expr) expr)
    ((op-minus expr) (- expr))
    ((expr@a op-mult expr@b) (* a b))
    ((expr@a op-div expr@b) (/ a b))
    ((expr@a op-plus expr@b) (+ a b))
    ((expr@a op-minus expr@b) (- a b))
    ((i) i))))

(define (main args)
  (print (lr-parse parser lexer)))    ; => 3

で動くはずなんだけれど、lr1-parser->lalr1-parser のなかで 

*** ERROR: hash table doesn't have an entry for key #<set equal?(45)>
Stack Trace:
_______________________________________
  0  (ref lr1->lalr1-table state)

と言われる。debug-print を仕込んでみると 

#?=(and (member state (hash-table-keys lr1->lalr1-table)) #t)
#?-    #t
#?=(hash-table-exists? lr1->lalr1-table state)
#?-    #f

うーん…。

Editing with Emacs

ときどき UTF-8 なテキストを編集しなくてはいけないことがあって nvi だといろいろ不便なので これを機に Emacs に乗り換えた（vim も候補にあがったけれど、vim script があまり好きになれそうにないのと、:set lisp しても ( や ) が S式単位でうごいてくれなかったので×）。

とりあえず viper-mode で :set lisp できるようにして (, ), {, }, [[, ]] の挙動をそれらしくした。

Scheme プログラムの編集は Gauche:EditingWithEmacs を参考に inferior-gacuhe-mode と koguro さんの gca を使わせていただくことにした。

ついでに EmacsLisp の練習にカーソル位置のシンボルを export する関数を書いてみた （gca に依存しています）。 

(defun gca-export-current-sym ()
  (interactive)
  (let ((word (gca-current-word)))
    (save-excursion
      (unless (re-search-backward "^\\s *(export\\Sw+" nil t)
        (error "No export clause found."))
      (let ((bp (match-beginning 0)))
        (unless (re-search-forward "\\s)" nil t)
          (error "Unclosed export clause."))
        (let ((ep (match-beginning 0)))
          (goto-char bp)
          (if (re-search-forward
               (concat "\\s " (regexp-quote word) "[ \t\n\f\v\)]") (1+ ep) t)
              (message "%s is already exported." word) 
            (goto-char ep)
            (insert " " word)
            (lisp-indent-line)
            (message "Exported %s." word)))))))

SS Tagger with c-wrapper

c-wrapper を使って SS Tagger を Gauche から使えるようにしてみました（libsstagger.tar.gz）。 mecab と同じ方式で C++ で書かれた元プログラムを一旦 C で wrap してから c-wrapper を使っています。

これで Scheme 側から finalizer を追加できたら C で拡張ライブラリを書くのとほとんど遜色がなさそう。

使い方: 

% tar xzf postagger-1.0.tar.gz
% cd postagger-1.0
% tar xzf ../libsstagger.tar.gz
% ./configure   # 注: オリジナルの Makefile を上書きします
% make
% make install
% cp sstagger.scm `gauche-config --sitelibdir`/lingua/en
% gosh
gosh> (use lingua.en.sstagger)
#<undef>
gosh> (define tagger (make-sstagger "/path/to/postagger-1.0/models"))
tagger
gosh> (sstagger-do-tagging tagger "He opened the window.")
"He/PRP opened/VBD the/DT window/NN ./."
gosh> (tagger "He opened the window.")
"He/PRP opened/VBD the/DT window/NN ./."
gosh> (sstagger-destroy tagger)
#<undef>
gosh> ^D

2006/03/18 11:57:01 PST

今日の一行 木の復元。先行順の場合だけ。 

(use srfi-11)
(use srfi-42)
(use util.match)

(define (enum from to step)
  (unfold (cut > <> to) values (cut + <> step) from (lambda _ '())))

(define make-tree
  (case-lambda
   ((val) (list val))
   ((val left right)
    (list val left right))))

(define (list->tree/preorder xs)
  (match xs
    (() xs)
    ((val) (list (make-tree val)))
    (_
     (let* ((x (car xs))
            (ys (cdr xs))
            (left&rights (map (lambda (i)
                                (call-with-values (cut split-at ys i) cons))
                              (enum 1 (- (length ys) 1) 2))))
       (append-map (lambda (left&right)
                     (receive (left right) (car+cdr left&right)
                       (list-ec (: l (list->tree/preorder left))
                                (: r (list->tree/preorder right))
                                (make-tree x l r))))
            left&rights)))))

2006/03/15 08:39:18 PST

続 AA 折れ線グラフ

hanatani さんの解答を 見て map-accum の存在に気づいた。 

(use srfi-1)
(use srfi-11)
(use util.match)
(use gauche.collection)

(define (main args)
  (graph (second args)))

(define (graph spec)
  (let*-values (((xs _)
                 (map-accum (lambda (ch y)
                              (case ch
                                ((#?C) (values (cons #?_ y) y))
                                ((#?R) (values (cons #?/ y) (+ y 1)))
                                ((#?F) (values (cons #?? (- y 1)) (- y 1)))))
                            0 spec))
                ((bottom top) (apply min&max (map cdr xs))))
    (apply for-each
           (cut print <...>)
           (map (match-lambda
                  ((c . pos)
                   (map (lambda (i) (if (= i pos) c #?space))
                        (iota (+ (- top bottom) 1) top -1))))
                xs))))

2006/03/14 23:50:50 PST

今日の一行(2006-03-14) AA 折れ線グラフ をやってみた。 

(use srfi-1)
(use util.match)

(define (main args)
  (graph (second args)))

(define (graph spec)
  (for-each
   print
   (let loop ((cs (string->list spec))
              (top 0)
              (bottom 0)
              (y 0)
              (rs '()))
     (if (null? cs)
         (let1 height (+ (- top bottom) 1)
           (apply map string
                  (map (match-lambda
                         ((c . pos)
                          (list-tabulate height
                                         (lambda (i)
                                           (if (= i (- height (- pos bottom) 1))
                                               c
                                               #?space)))))
                   (reverse! rs))))
         (match (car cs)
           (#?C
            (loop (cdr cs) top bottom y (alist-cons #?_ y rs)))
           (#?R
            (let1 ny (+ y 1)
              (loop (cdr cs) (max top ny) bottom ny (alist-cons #?/ y rs))))
           (#?F
            (let1 ny (- y 1)
              (loop (cdr cs) top (min ny bottom) ny (alist-cons #?? ny rs)))))))))
Topics
Sponsored Links
Search
Recent Changes
More ...
Last modified : 2012/03/18 11:14:21 UTC
WiLiKi 0.8.3 running on Gauche 0.9.15-p2