現在自宅にある日本酒一覧
九頭龍、いづみ橋、田ゆうは川崎の「地酒や たけくま酒店」にて購入。
溪は父親がどこからか購入してきた。
雪吟は大学の卒業式(学位授与式)後に後輩にもらった。
梵は大学の友人にもらった。
田ゆうは神奈川県海老名市にある泉橋酒造で作られたものだが、使用している米は川崎で取れたものとのこと。
Clojureの練習がてらTwitterクライアントの作成を目指す。
取り合えず、タイムラインを取得してJTableで表示してみた。
(require 'clojure.contrib.http.agent)
(import java.net.URLEncoder sun.misc.BASE64Encoder)
(import '(javax.swing.table AbstractTableModel))
(def status-list (atom []))
(defn seq->map [seq]
(reduce
(fn [map [key val]]
(assoc map key val))
{}
seq))
(defn basic-authentication [id pass]
(str "Basic "
(.encode (BASE64Encoder.)
(.getBytes (str id ":" pass)))))
(defn xml-request
([uri] (xml-request uri {}))
([uri headers]
(clojure.xml/parse
(clojure.contrib.http.agent/stream
(clojure.contrib.http.agent/http-agent
uri
:headers headers)))))
(defn xml-request-with-auth
([uri auth] (xml-request-with-auth uri auth {}))
([uri auth headers]
(xml-request
uri
(merge headers {"Authorization" auth} ))))
(defn collect-from-status [{tag :tag content :content :as status} & tags]
(filter
(fn [st] (some #(= % (:tag st)) tags))
content))
(defn collect-default-elements [status]
(seq->map
(map
(fn [st] [(:tag st) (first (:content st))])
(concat
(collect-from-status
status
:text
:created_at
:id
:in_reply_to_status_id)
(collect-from-status
(first (collect-from-status status :user))
:name
:screen_name
:profile_image_url
:location
:description)))))
;;例："Sun Mar 28 00:18:31 +0000 2010"
(defn time->number [time-str]
(let [[week month day hour minitu sec _ year]
(re-seq #"\w+" time-str)
m-num
({"Jan" 1, "Feb" 2, "Mar" 3, "Apr" 4, "May" 5,
"Jun" 6, "Jul" 7, "Aug" 8, "Sep" 9, "Oct" 10,
"Nov" 11, "Dec" 12}
month)]
(+
(* (Integer/parseInt year) 10000000000)
(* m-num 100000000)
(* (Integer/parseInt day) 1000000)
(* (Integer/parseInt hour) 10000)
(* (Integer/parseInt minitu) 100)
(Integer/parseInt sec))))
(defn sort-status-list [statuses]
(sort #(> (time->number (:created_at %1)) (time->number (:created_at %2)))
(map collect-default-elements statuses)))
(defn update-timeline [statuses id pass]
(let [since-id (:id (first @statuses))]
(reset! statuses
(concat
(sort-status-list
(:content
(xml-request-with-auth
(if (nil? since-id)
"http://twitter.com/statuses/home_timeline.xml"
(str
"http://twitter.com/statuses/home_timeline.xml?"
since-id))
(basic-authentication id pass)
{})))
@statuses))))
(defn model [column-names statuses]
(proxy [AbstractTableModel] []
(getRowCount [] (count @statuses))
(getValueAt [row col]
(if (= col 0)
(:screen_name (nth @statuses row))
(:text (nth @statuses row))))
(getColumnName [c](print (nth column-names c))
(nth column-names c))
(getColumnCount []
(count column-names))
(isCellEditable [r c] false)))
;;atomであるstatus-listの内容を表示する
(defn run []
(let [f (javax.swing.JFrame. "Test")
m (model ["name" "本文"] status-list)
tbl (javax.swing.JTable. m)]
(doto f
(.setSize 300 300)
(.setVisible true))
(doto tbl
(.setVisible true))
(.. f getContentPane
(add (new javax.swing.JScrollPane tbl)))))
;;(update-timeline status-list "id" "pass")
;;(run)
Clojureをさわり始めたので、メモ。
;;空白文字が入る箇所に,(カンマ)を入れても良い。
;;rangeは[end] [start end] [start end step]の3パターンで利用できる.
;;start(デフォルトは0)からstep(デフォルトは0)ずつend未満の値を集める
(print (range 0 10))
|(0 1 2 3 4 5 6 7 8 9)
(print (range 0 10 2))
|(2 4 6 8)
;;mapはシーケンスの各要素を引数として関数を呼び出した結果を集めて返す。
;;無名関数はfnで作成できるが、省略記法として#(hoge %)のように
;;作成することもできる。この時、%は第1引数を、%nは第n引数を表す。
(map #(* % %) (range 10))
;;同様の処理はforでは以下のように書ける。
;;forはループではなくリスト内包表記というらしい。
;;CLと違い、forやlet,defnなどで変数束縛や仮引数を書く場所は
;;丸括弧()ではなく角括弧[]で括る。
(for [x (range 10)] (* x x))
->(0 1 4 9 16 25 36 49 64 81)
;;forにはwhenやwhileなどのキーワードを指定して式を評価する条件を与える
;;ことができる。
;;whenは条件が真の場合のみ本体を評価して値を集める。
;;whileは条件が真の間本体を評価して値を集め、条件が偽になった時点で終了する。
(for [x (range 10) :when (odd? x)] x)
->(1 3 5 7 9)
(for [x (range 10) :while (< x 5)] x)
(0 1 2 3 4)
;;forにキーワードwhenを与えた場合と同じような動作はfilterで行える。
(filter odd? (range 10))
->(1 3 5 7 9)
;;forは変数束縛(?)を複数指定出来る。
;;並行に束縛されるのではなく、多重ループのような順序で束縛される。
;;後ろに書いた変数ほど先に束縛が繰り返される。
(for [x "abc" y "ABC"] (str x y))
->("aA" "aB" "aC" "bA" "bB" "bC" "cA" "cB" "cC")
;;Scheme等でネタにされた'Lisp脳'的FizzBuzzは以下のように書ける。
;;condはCLなどと異なり、条件式と真の時の動作を括弧では括らず順番に書く。
;;:elseの箇所は偽以外ならなんでも良いと思う。
;;(rem a b)はa/bの余りを返す。remainderの略だと思う。
(defn fizzbuzz []
(map
#(cond
(zero? (rem % 15)) "FizzBuzz"
(zero? (rem % 5)) "Buzz"
(zero? (rem % 3)) "Fizz"
:else %)
(range 1 31)))
;;シーケンスは遅延評価されるため無限長のシーケンスを扱える。
;;takeでシーケンスの要素を先頭から指定した個数分取り出せる。
;;シーケンスは変更不可能なので、シーケンスに対する処理を行うと新しいシーケンスが作られている。
;;リストのように丸括弧で表示されていても、シーケンス操作の返り値の実際のクラスはシーケンスである。
'(1)
->(1)
(class '(1))
->clojure.lang.PersistentList
(map (fn [x] x) '(1))
->(1)
(class (map (fn [x] x) '(1)))
->clojure.lang.LazySeq
;;マップ(hash-map)はキーと値のペアを並べたもの。
;;関数として扱うこともでき、その場合は引数にキーを取り、対応する値を返す。
({1 2 3 4 5 6} 3)
->4
;;キーワードは、マップからそのキーワードに対する値を取り出す関数でもある。
(:a {:a 2 :b 3})
->2
;;ベクタも関数として扱うことができ、その場合は引数にインデックスを取る。
([1 2 3] 0)
->1
;;関数定義にはdefnを用いる。
;;mapcatはCLのmapcanのように各要素に関数を適用した後のリストを
;;つなげ合わせて返すようだ。
(defn flatten [tree]
(mapcat
#(if (list? %)
(flatten %)
(list %))
tree))
(flatten '(1 2 (3 4)))
->(1 2 3 4)
;;リスト(というかシーケンス)の長さを返すにはcountを用いる。
;;自前で実装すると、例えば以下のようになる。
;;CLでは両方あるけれど、Clojureにはcar/cdrは存在せず、first/restのみ利用できる。
;;また、nilは空リストでは無いので気をつける。ex) (nil? ()) => false
(defn length [lst]
(if (empty? lst)
0
(+ 1 (length (rest lst)))))
;;ClojureではJavaの仕様上末尾再帰を最適化しないらしい。
;;かわりにrecurを利用すると関数の初め(またはloop)に飛ぶ。
;;相互再帰はtrampolineで行える。
;;末尾再帰よりも遅延シーケンスを利用するのがClojure流らしい。
;;関数は引数の個数によって動作を変える事が出来る。
;;仮引数と関数本体を括弧で括ったものを列挙すれば良い。
(defn length-tail
([lst] (length-tail lst 0))
([lst acc]
(if (empty? lst)
acc
(recur (rest lst) (+ 1 acc)))))
土曜日(3/20)にShibuya.lisp#5に参加した。残念ながら予定があったので懇親会は不参加。
毎度のことながらTT、LTの発表は濃かったりおもしろかったりで素晴らしかったですが、どうも今回はClojure祭り状態のようで、Lisperを目指しているくせに1度も触ったことのない私は精神的ダメージを負うことになったのでした。
会場にオーム社の方々(らしい)が来ており、商魂たくましく(?)会場で書籍の販売を行っている中に狙いすましたかのように「プログラミングClojure」が置いてあったのでついうっかり購入してしまった。
ということで、書籍を読みつつLispの最先端たるClojureを書いてみようと思う。
Emacs使いたるもの、設定をせずにプログラミングを始めるというのはおそらくありえないので、 clojure-modeとswank-clojureの導入を行おうとした。
clojure-contribのコンパイルに、書籍の内容と異なり antではなくmavenというツールを使ったり、各所の解説でrequireしている swank-clojure-autoload.elなんてファイルが存在しなかったりしてだいぶ時間がかかった。
swank-clojure-autoloadの内容をググって調べ、slime-lisp-implementationsの設定にそれっぽい記述をすることで一応動くようになった。
(setq slime-lisp-implementations
`((sbcl
("/usr/local/bin/sbcl"
"--core" "/home/kurohuku/emacslib/sbcl.core-with-swank")
:init (lambda (port-file _)
(format "(progn
(load \"/home/kurohuku/emacslib/util.lisp\")
(setf swank::*coding-system* \"utf-8-unix\")
(swank:start-server %S))\n" port-file))
:coding-system utf-8-unix)
(clojure
,(swank-clojure-cmd)
:init swank-clojure-init)
))
ググってたらClojureでクラスパスを表示する方法を見つけた。便利そうなのでメモっておく。
(println
(seq
(.getURLs (java.lang.ClassLoader/getSystemClassLoader))))
正規表現を文字列で考えていて頭がいたくなってきたので、一旦リストにしてからNFAにするようにしてみる。
;;regexp->list
(defun regexp->list (reg)
(let* ((top nil)
(stack (list top)))
(loop :for ch across reg
:do
(case ch
((#\()
(push top stack)
(setf top nil))
((#\))
(let ((prev (pop stack)))
(push top prev)
(setf top prev)))
((#\|)
(setf top
(list top :or)))
((#\*)
(let ((tmp (list (pop top) :loop)))
(push tmp top)))
((#\.)
(push :all top))
(T
(push ch top)))
:finally (return-from regexp->list
(reverse-tree top)))))
(defun reverse-tree (tree)
(if (listp tree)
(reverse (mapcar #'reverse-tree tree))
tree))
(defun list->nfa (lst)
(reduce
#'merge-nfa-concat
(remove
nil
(mapcar
#'(lambda (obj)
(typecase obj
(character
(make-nfa-char obj))
(list
(case (car obj)
((:loop)
(make-nfa-loop
(list->nfa (cdr obj))))
((:or)
(merge-nfa-or
(list->nfa (list (second obj)))
(list->nfa (cddr obj))))
(T
(list->nfa obj))))
(symbol
(case obj
((:all)
(make-nfa-all))
(T (error "Unexpected symbol:~A" obj))))
(T (error "Unexpected type:~A" obj))))
lst))))
>(match (list->nfa (regexp->list "(hoge|fuga|piyo)*"))
"foobarhogefugapiyofizzbuzz")
"hogefugapiyo"
6
18
>(match (list->nfa (regexp->list "'.*(hoge|fuga|piyo).*'"))
"this is 'test hoge.'")
"'test hoge.'"
8
20
正規表現からNFAへ変換処理をデバッグするときに、NFAの状態遷移図どのようになったかを知りたい。手書きするのも面倒くさくなってきたので、cl-dotで描画することにした。
NFAは前回の記事の形式であるとする。
cl-dotのノードや矢印に属性値を指定したい場合、元々のオブジェクトをattributedというクラスのオブジェクトでラップすれば良いようだ。
;;;nfaの遷移図を描画
(defparameter *table* nil)
(defparameter *f* nil)
(defun mklist (lst)
(if (listp lst) lst (list lst)))
(defmethod cl-dot:graph-object-node ((graph (eql 'nfa)) (key symbol))
(make-instance 'cl-dot:node
:attributes
(list :label (format nil "~A" key)
:shape :box
:fontname "Arial"
:style :filled
:fillcolor
(if (member key *f*)"#aaaaaa" "#ffffff")
:color :black)))
(defmethod cl-dot:graph-object-points-to ((graph (eql 'nfa)) (key symbol))
(let ((alist (gethash key *table*)))
(mapcan
#'(lambda (lst)
(mapcar
#'(lambda (next)
(make-instance 'cl-dot:attributed :object next
:attributes (list
:label (format nil "~A" (car lst))
:dir :forward)))
(cdr lst)))
alist)))
(defun run (nfa path &key (format :png))
(let ((*table* (nfa-table nfa))
(*f* (mklist (nfa-f nfa))))
(let ((graph (cl-dot:generate-graph-from-roots
'nfa
(list (nfa-start nfa)))))
(cl-dot:dot-graph graph path :format format))))
;;(run nfa
;; "/home/kurohuku/edit/lisp/graphic/nfa.png")
ドラゴンブックの字句解析の項目を参考に、正規表現を表す文字列からNFAを作る。
(defvar *label-count* 0)
;;遷移図で特殊な入力記号として用いるもの
;; :epsilon イプシロン遷移
;; :all 任意の1文字
(defun mklist (obj)
(if (listp obj) obj (list obj)))
(defmacro do-hash ((key val) table &body body)
`(maphash
#'(lambda (,key ,val)
,@body)
,table))
(defun make-new-state ()
(incf *label-count*)
(intern (format nil "STATE-~A" *label-count*) :keyword))
(defun get-states (input move-table)
(or (cdr (assoc input move-table))
(if (eq input :epsilon)
nil
(cdr (assoc :all move-table)))))
;;tableはハッシュテーブルで、状態をキーとして、
;;入力とそれに対する遷移後の状態をalistで保存する
(defstruct NFA
start ;初期状態
table ;遷移図
f) ;受理状態の集合
(defun make-nfa-char (ch)
(let ((i (make-new-state))
(f (make-new-state)))
(let ((table (make-hash-table)))
(setf
(gethash i table)
(acons ch (list f) nil))
(make-nfa
:start i
:table table
:f (list f)))))
;;任意の一文字を受理する
(defun make-nfa-all ()
(let ((i (make-new-state))
(f (list (make-new-state)))
(table (make-hash-table)))
(setf (gethash i table)
(acons :all f nil))
(make-nfa
:start i
:f f
:table table)))
;;正規表現abを、a,bを表すNFA1,NFA2を連結して作成
(defun merge-nfa-concat (nfa1 nfa2)
(let ((i (nfa-start nfa1))
(nfa1f (mklist (nfa-f nfa1)))
(nfa2i (nfa-start nfa2))
(f (mklist (nfa-f nfa2))))
(let ((table (make-hash-table)))
(do-hash (s val) (nfa-table nfa1)
(setf
(gethash s table)
val))
(do-hash (s val) (nfa-table nfa2)
(dolist (move val)
;;nfa2の初期状態とnfa1の終了状態をくっつける
(if (eq s nfa2i)
(dolist (f nfa1f)
(push
move
(gethash f table)))
(push
move
(gethash s table)))))
(make-nfa
:start i
:f f
:table table))))
;;a|bをあらわすNFAを合成する
(defun merge-nfa-or (nfa1 nfa2)
(let ((newi (make-new-state))
(newf (make-new-state))
(table (make-hash-table)))
;;遷移図をコピー
(do-hash (key val) (nfa-table nfa1)
(setf (gethash key table) val))
(do-hash (key val) (nfa-table nfa2)
(setf (gethash key table) val))
;;新しい初期状態(newi)からのイプシロン遷移
(push
(list :epsilon (nfa-start nfa1) (nfa-start nfa2))
(gethash newi table))
;;新しい終了状態(newf)へのイプシロン遷移を追加
(dolist (f (mklist (nfa-f nfa1)))
(let ((old (gethash f table)))
(push
`(:epsilon ,newf ,@(get-states :epsilon old))
(gethash f table))))
(dolist (f (mklist (nfa-f nfa2)))
(let ((old (gethash f table)))
(push
`(:epsilon ,newf ,@(get-states :epsilon old))
(gethash f table))))
(make-nfa
:start newi
:f (list newf)
:table table)))
(defun make-nfa-loop (nfa)
(let ((newi (make-new-state))
(newf (make-new-state))
(table (make-hash-table)))
;;nfaのテーブルをコピー
(do-hash (k v) (nfa-table nfa)
(setf (gethash k table) v))
;;newiからnewfへのイプシロン遷移
;;newiから(nfa-start nfa)へのイプシロン遷移
(setf
(gethash newi table)
`((:epsilon ,(nfa-start nfa) ,newf)))
;;(nfa-f nfa)から(nfa-start nfa),newfへのイプシロン遷移
(dolist (f (mklist (nfa-f nfa)))
(let ((old (gethash f table)))
(push
`(:epsilon ,newf ,(nfa-start nfa) ,@(get-states :epsilon old))
(gethash f table))))
(make-nfa
:start newi
:f (list newf)
:table table)))
(defun nfa-start-states (nfa)
(move-epsilon (nfa-table nfa)
(nfa-start nfa)))
(defun move (nfa states input)
(let ((states (mklist states))
(table (nfa-table nfa)))
(move-epsilon
table
(move-inner table states input))))
(defun move-inner (table states input)
(if (not (listp states))
(get-states input (gethash states table))
(let ((result nil))
(dolist (s states)
(dolist (next (get-states input (gethash s table)))
(pushnew next result)))
result)))
(defun move-epsilon (table states)
(let ((unchecked (if (listp states) states (list states)))
(checked nil))
(do ((s (pop unchecked) (pop unchecked)))
((null s) checked)
(push s checked)
(dolist (next (move-inner table s :epsilon))
(unless (or (member next checked)
(member next unchecked))
(push next unchecked))))))
(defun regexp->nfa (str &optional (start 0))
(let ((len (length str))
(result nil))
(do ((i start (1+ i)))
((>= i len) (values
(reduce #'merge-nfa-concat
(nreverse result))
i))
(case (char str i)
((#\()
(multiple-value-bind (nfa next)
(regexp->nfa str (1+ i))
(push nfa result)
(setf i next)))
((#\))
(return-from regexp->nfa
(values
(reduce #'merge-nfa-concat
(nreverse result))
i)))
((#\*)
(let ((prev (pop result)))
(push (make-nfa-loop prev) result)))
((#\|)
(multiple-value-bind (nfa next)
(regexp->nfa str (1+ i))
(let ((prev
(reduce #'merge-nfa-concat
(nreverse result))))
(setf result nil)
(push
(merge-nfa-or prev nfa)
result))
(setf i next)))
((#\.)
(push (make-nfa-all) result))
(T
(push (make-nfa-char (char str i)) result))))))
(defun match (nfa str)
(let ((is (nfa-start-states nfa))
(f (nfa-f nfa))
(path nil)
(strlen (length str)))
(do ((begin 0 (1+ begin)))
((>= begin strlen) nil)
(setf path nil)
(do ((i 0 (1+ i))
(crr is crr))
((>= (+ begin i) strlen) nil)
(setf crr
(move nfa crr (char str (+ begin i))))
(if crr
(push crr path)
(setf i strlen))) ;次のループで終了する
(loop
:for sts in path
:for rest = path then (cdr rest)
:when (intersection sts f)
:do
(let ((end (+ begin (length rest))))
(return-from match
(values (subseq str begin end)
begin end)))))))
;;テスト用
(defun grep-file (reg file &optional (num nil))
(with-open-file (s file :direction :input)
(let ((nfa (regexp->nfa reg)))
(loop
:for line = (read-line s nil nil)
:for n from 1
:while line
:when (match nfa line)
:do
(if num
(format t "~A:~A~%" n line)
(format t "~A~%" line))))))
いちおう.*|の3種類を特別扱いしてくれるはず。今回のメインなのに、読み取りがうまく出来ないなぁ。
使ってみる。
>(match (regexp->nfa "'.*((lisp|scheme)|c++).*'")
"I like 'common lisp'")
"'common lisp'"
7
20
>(match (regexp->nfa "'.*((lisp|scheme)|c++).*'")
"I like 'white space'")
NIL
Case文がパターンマッチっぽい.
MODULE Main;
IMPORT IO;
BEGIN
FOR i := 1 TO 100 DO
CASE i MOD 15 OF
| 0 => IO.Put("FizzBuzz");
| 3,6,9,12 => IO.Put("Fizz");
| 5,10 => IO.Put("Buzz");
ELSE
IO.PutInt(i);
END;
IO.Put("\n");
END;
END Main.
PCIデバイスがあるかどうか確認する。一応それっぽいデバイスが表示はされる。
io_inXとio_outX,Printfが既に定義されているものとする。 io_inとio_outはそれぞれのビット数のin,out命令。
enum PCI_CONFIGURATION_REGISTER
{
VenderID = 0x00, //bit0-15
DeviceID = 0x00, //bit16-32
CommandRegister = 0x04, //bit0-15
StatusRegister = 0x04, //bit16-32
RevisionRegister = 0x08, //bit0-7
ClassCode = 0x08, //bit8-31
CacheLineSize = 0x0C, //bit0-7
MasterLatencyTimer = 0x0C, //bit8-15
HeaderType = 0x0C, //bit16-32
BISTRegister = 0x0C, //bit24-31
};
#define CONFIGURATION_ADDRESS 0x0CF8
#define CONFIGURATION_DATA 0x0CFC
#define CONFIGURATION_DATA1 0x0CFD
#define CONFIGURATION_DATA2 0x0CFE
#define CONFIGURATION_DATA3 0x0CFF
struct PCIConfigHeader{
uint16 venderID;
uint16 deviceID;
uint16 command;
uint16 status;
uint8 revision;
uint8 classCode[3]; //3byte
uint8 chacheLineSize;
uint8 latency;
uint8 header;
uint8 builtInSelftest;
uint32 baseAddrReg0;
uint32 baseAddrReg1;
uint32 baseAddrReg2;
uint32 baseAddrReg3;
uint32 baseAddrReg4;
uint32 baseAddrReg5;
uint32 cardBusCISPointer;
uint16 subSystemVenderID;
uint16 subSystemID;
uint32 expansionRomAddr;
uint32 Reserved0;
uint32 Reserved1;
uint8 irqLine;
uint8 interruptPin;
uint8 minGrant;
uint8 maxLatency;
};
//bus=バス番号 dev=デバイス番号,reg=レジスタ番号(bit0-7) func = 機能番号
int WriteConfigAddr(int bus, int dev, int reg, int func)
{
int data;
data = 0x80000000 |
((bus << 16) & 0xFF0000) |
((dev << 11) & 0xF800) |
((func << 8) & 0x700) |
(((reg/4) << 2) & 0xFC);
io_out32(CONFIGURATION_ADDRESS, data);
return 0;
}
int ReadConfig32(int bus, int dev, int reg, int func)
{
WriteConfigAddr(bus, dev, reg, func);
return io_in32(CONFIGURATION_DATA);
}
int CheckBus(int bus)
{
int dev;
for(dev=0; dev<32; dev++)
{
int vender,devid;
int tmp = ReadConfig32(bus, dev, VenderID, 0);
vender = tmp&0xFFFF;
devid = (tmp>>16)&0xFFFF;
if(vender == 0xFFFF) //デバイスは存在しない
continue;
Printf("PCI bus %d, dev %d Exist. Vender=%x, DevID=%x\n", bus, dev,vender,devid);
}
return 0;
}
int CheckPCI()
{
for(int i = 0; i < 0x0100; i++)
{
CheckBus(i);
}
return 0;
}
qemuでCheckPCIを呼び出したら以下のように表示された。
PCI bus 0, dev 0 Exist. Vender=8086, DevID=1237
PCI bus 0, dev 1 Exist. Vender=8086, DevID=7000
PCI bus 0, dev 2 Exist. Vender=1013, DevID=B8
PCI bus 0, dev 3 Exist. Vender=10EC, DevID=8029
PCI bus 0, dev 4 Exist. Vender=1AF4, DevID=1002
Critical Mass Modula-3のライブラリにSLispというものがある。名前を見るにLispっぽいので使おうと試みる。
ちなみに、m3makefileでimportに書く名前は、 modula3のディレクトリのpkgディレクトリのサブディレクトリの名前だと思う。
MODULE Main;
IMPORT SLisp,Stdio,Rd,Wr,IO;
VAR slisp :SLisp.T;
VAR rd :SLisp.Reader;
VAR wr :SLisp.Writer;
BEGIN
rd := Stdio.stdin;
wr := Stdio.stdout;
slisp := NEW(SLisp.T);
slisp := slisp.new();
LOOP
SLisp.Write(wr ,slisp.eval(SLisp.Read(rd)));
IO.Put("\n");
END;
END Main.
CommonLispのマクロ定義に、&wholeでパラメータを指定できる。
どうやら式そのものが束縛されるようだ。
(defmacro hoge (&whole call &optional (from 0) (to 10))
`(progn
(print ',call)
(format t "from:~A -> to:~A" ,from ,to)))
>(hoge 2 3)
(HOGE 2 3) from:2 -> to:3
>(macroexpand-1 '(hoge 2 3))
(PROGN (PRINT '(HOGE 2 3)) (FORMAT T "from:~A -> to:~A" 2 3))
>(hoge)
(HOGE) from:0 -> to:10
>(macroexpand-1 '(hoge))
(PROGN (PRINT '(HOGE)) (FORMAT T "from:~A -> to:~A" 0 10))
オプショナルパラメータなどがあっても、実際に呼び出す式に字面上現れないものは束縛されないようだ。
DFAの次は当然NFA。
NFAは現在取りうる状態の集合から、入力により次の状態の集合へと遷移する操作を繰り返し、最終的な状態の集合に受理状態が含まれていれば受理、そうでなければ拒否となると考えれば良いと思われる。これは、すべての遷移を並行処理しているようなイメージだろう。
'次の状態'には、イプシロン遷移で辿れるすべての状態を含む。
CommonLispでリストを集合として扱う関数にunion(nunion),set-difference(nset-difference) ,intersection(nintersection)などがある。
果たして正しく動いているのかどうか。
;;; Nondeterministic Finit Automaton
;;イプシロン遷移を表す特殊な入力記号として利用する
(defparameter *epsilon* '@)
(defclass NFA ()
((terminals :accessor terminals :initarg :terminals)
(move-functions :accessor move-functions :initarg :move-functions)
(entry-state :accessor entry-state :initarg :entry-state)
(all-states :accessor all-states :initarg :all-states)
(current-states :accessor current-states :initarg :current-states)))
;;;すべての状態を抜き出す
;;;結局使わないけれど。
(defun get-all-states (entry terminals rules)
(let ((states (copy-list (cons entry terminals))))
(loop :for rule in rules
:do
(pushnew (car rule) states)
(dolist (mv-rule (cdr rule))
(dolist (s (cdr mv-rule))
(pushnew s states))))
states))
(defmacro define-nfa (name (entry (&rest terminals)) &body rules)
`(defclass ,name (NFA)
((terminals :reader terminals :initform ',terminals)
(move-functions :reader move-functinos :initform ',rules)
(entry-state :reader entry-state :initform ',entry)
(all-states :reader all-states :initform (get-all-states ',entry ',terminals ',rules))
(current-states :accessor current-states
:initform (adjoin ',entry (move-epsilon ',entry ',rules nil))))))
;;;nfaが受理状態かどうか
(defun accept? (nfa)
(let ((terminals (terminals nfa)))
(loop :for s in (current-states nfa)
:when (find s terminals)
:do (return-from accept? t))
nil))
;;この時点ではイプシロン遷移しない。現在の状態に移ったときに完了しているはず。
(defun move (nfa input)
(let ((states (current-states nfa))
(result nil))
(let ((acc nil))
(dolist (s states)
(unless (eq s *epsilon*)
(push (move-inner s input (move-functions nfa)) acc)))
(dolist (next-states acc)
(dolist (s next-states)
(pushnew s result))))
(setf (current-states nfa) result)))
(defun move-inner (state input rules)
(let ((rule (assoc state rules)))
(let ((r (assoc input (cdr rule))))
(when r
(let ((result (cdr r)))
(reduce #'union
(mapcar
#'(lambda (s)
(move-epsilon s rules result))
result)
:initial-value result))))))
;;イプシロン遷移
;;tracked-statesは今までに現れた'次の状態'の集合
;;ループしたときに終了させる手段として保持
(defun move-epsilon (state rules tracked-states)
(let ((rule (assoc state rules)))
(let ((r (assoc *epsilon* (cdr rule))))
(when r
(let ((result (cdr r)))
(let ((next-tracked-states (union result tracked-states)))
(reduce #'union
(mapcar
#'(lambda (s)
(if (find s tracked-states)
nil
(move-epsilon s rules next-tracked-states)))
result)
:initial-value result)))))))
(defmethod run ((obj nfa) symbols)
(dolist (s symbols)
(setf (current-states obj)
(move obj s)))
(accept? obj))
(defmethod run ((obj symbol) symbols)
(let ((nfa (make-instance obj)))
(run nfa symbols)))
;;; テスト
(define-nfa test-nfa (:0 (:q :r))
(:0
(@ :q :r))
(:q
(0 :q)
(@ :a))
(:a
(0 :q))
(:r
(1 :r)))
;;"a(a|b)*bb"を受理する
(define-nfa test-nfa-2 (:i (:f))
(:i
(#\a :1))
(:1
(@ :2 :4))
(:2
(#\a :3)
(#\b :3))
(:3
(@ :2 :4))
(:4
(#\b :5))
(:5
(#\b :f)))
;;(trace move)
;;(run 'test-nfa '(0 1))
;;(run 'test-nfa '(1 1))
;;(run 'test-nfa-2 (coerce "aababb" 'list))
綺麗に書けたと納得のいくソースコードが書けるようになるのはいつの日のことか。
Modula-3のお勉強。
TCPモジュールを使ってエコーサーバー(受信した内容をそのまま送り返す)を作ってみる。
(* Main.m3 *)
MODULE Main;
IMPORT TCP,IP,ConnRW;
IMPORT Rd,Wr, IO, Text;
VAR con :TCP.Connector;
VAR server :TCP.T;
VAR endpoint :IP.Endpoint;
VAR addr :IP.Address;
VAR rd: Rd.T;
VAR wr: Wr.T;
BEGIN
EVAL IP.GetHostByName("localhost",addr);
endpoint := IP.Endpoint{addr,9999};
con := TCP.NewConnector(endpoint);
IO.Put(IP.GetCanonicalByAddr(IP.GetHostAddr()));
IO.Put("Addr:");
IO.PutInt(endpoint.addr.a[0]);
IO.Put(".");
IO.PutInt(endpoint.addr.a[1]);
IO.Put(".");
IO.PutInt(endpoint.addr.a[2]);
IO.Put(".");
IO.PutInt(endpoint.addr.a[3]);
IO.Put("\nPort:");
IO.PutInt(endpoint.port);
IO.Put("\n");
LOOP
server := TCP.Accept(con);
rd := ConnRW.NewRd(server);
wr := ConnRW.NewWr(server);
LOOP
WITH com = IO.GetLine(rd) DO
IF Text.Equal(com,"quit") THEN
EXIT;
END;
IO.Put(com & "\n", wr);
IO.Put(com);
IO.Put("\n");
END;
END;
Rd.Close(rd);
Wr.Close(wr);
TCP.Close(server);
END;
END Main.
(* m3makefile *)
import("libm3")
import("tcp")
implementation("Main")
program("echoserv")
例外処理を書いてないあたり問題かもしれないが、とりあえず動くと思われる。ぶっちゃけ、処理系のexamplesにあるHTTPDの劣化版です。
IP.GetHostAddr()の返り値が、どうも127.0.1.1になってるっぽいのでIP.GetHostByName()を使った。
以下、今回のModula-3プログラムについてのメモ
Kernel/VM探検隊で教えていただいたということもあり、Modulaに手をだしてみる。
Modula-3のコンパイラCritical Mass Modula-3を利用した。
Webページのサンプルとほとんど内容が変わらないが、とりあえずHello,Worldを出力するプログラムを書いてみた。
Main.m3にプログラムの内容を記述する。
MODULE Main;
IMPORT IO;
BEGIN
IO.Put("Hello Modula-3 World\n");
END Main.
m3makefileにプログラムのモジュール等の定義を書く?
import("libm3")
implementation("Main")
program("hello")
ソースコードとmakefileのあるディレクトリでcm3コマンドを実行するとコンパイルされる。実行ファイルはm3makefileのprogramで指定したもののようだ。
>./hello
Hello Modula-3 World