誕生日プレゼントの Kindle が届いた。娘からは黄色いシャープペンシルをもらった。義父と義母からはいつもの靴下とケーキ。
ありがとう。
さて、Kindle すてき。タッチパネルのぞわぞわ感がだめなので、i なんとやタブレット系は選択したくない。本が好き。なので Kindle を選択。意味のわからない単語までカーソル移動はめんどうだけど、面画は美しい。お絵かきせんせいと同じレベルを想像していたので、想像をこえて美しかった。
Common Lisp 本の充実と、日本の Kindle Store のオープンをお祈りしてます。なぜか Prolog 本は充実してるみたい。
あまりよさそうなのが見つからなかったので、てきとうに作ってみた。これも The Lisp Curse かな。
最初 (cxml-xmls:make-xmls-builder) 使ってみたら、とても遅かったので (stp:make-builder) を使うことにした。
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload "drakma")
(ql:quickload "cxml")
(ql:quickload "cxml-stp")
(ql:quickload "xpath")
(ql:quickload "series"))
(series::install :implicit-map t)
(setf drakma:*drakma-default-external-format* :utf-8)
(iterate ((x (scan '(("application" . "xml")
("text" . "xml")))))
(pushnew x drakma:*text-content-types* :test #'equal))
(defclass feed ()
((title :initarg :title)
(link :initarg :link)
(description :initarg :description)
(creator :initarg :creator)
(items :initform () :initarg :items)))
(defclass feed-entry ()
((title :initarg :title)
(link :initarg :link)
(content :initarg :content)
(creator :initarg :creator)
(pub-date :initarg :pub-date)
(category :initarg :category)))
(defun %xv (path context)
(xpath:string-value (xpath:evaluate path context)))
(defun read-url (url)
(delete #\Return (drakma:http-request url)))
(defun fetch-rss (url)
(let ((response (read-url url)))
(parse-rss response)))
;;(fetch-rss "http://cadr.g.hatena.ne.jp/g000001/rss2")
(defun parse-rss (text)
(xpath:with-namespaces (("dc" "http://purl.org/dc/elements/1.1/")
("content" "http://purl.org/rss/1.0/modules/content/"))
(let* ((doc (cxml:parse text (stp:make-builder)))
(feed (make-instance 'feed
:title (%xv "rss/channel/title" doc)
:link (%xv "rss/channel/link" doc)
:description (%xv "rss/channel/description" doc)
:creator (%xv "rss/channel/dc:creator" doc))))
(with-slots (items) feed
(xpath:do-node-set (node (xpath:evaluate "//item" doc))
(push (make-instance 'feed-entry
:title (%xv "title" node)
:link (%xv "link" node)
:content (%xv "description" node)
:creator (%xv "dc:creator" node)
:pub-date (%xv "pubDate" node)
:category (%xv "category" node))
items))
(setf items (nreverse items)))
feed)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; atom
(defun fetch-atom (url)
(let ((response (read-url url)))
(parse-atom response)))
;;(fetch-atom "http://blog.livedoor.jp/chiblits/atom.xml")
;;(fetch-atom "http://feeds.feedburner.com/blogspot/rztf")
(defun parse-atom (text)
(let ((doc (cxml:parse text (stp:make-builder))))
(let ((namespace (collect-first
(choose-if (lambda (namespace)
(xpath:with-namespaces ((nil namespace))
(string/= (%xv "feed/title" doc) "")))
(scan '("http://www.w3.org/2005/Atom" "http://purl.org/atom/ns#"))))))
(xpath:with-namespaces ((nil namespace))
(let ((feed (make-instance 'feed
:title (%xv "feed/title" doc)
:link (%xv "feed/link[@rel=\"alternate\"]/@href" doc)
:description (%xv "feed/tagline" doc)
:creator (%xv "feed/author/name" doc))))
(with-slots (items) feed
(xpath:do-node-set (node (xpath:evaluate "//entry" doc))
(push (make-instance 'feed-entry
:title (%xv "title" node)
:link (%xv "link/@href" node)
:content (%xv "content" node)
:creator (%xv "author/name" node)
:pub-date (%xv "issued|published" node)
:category (%xv "category/@term" node))
items))
(setf items (nreverse items)))
feed)))))
"Paradigms of Artificial Intelligence Programming"(PAIP, 実用 Common Lisp) の 20 Unification Grammars にある definite clause grammer(DCG) が面白かったので、それを使って JSON をパースしてみた。
DCG とは私の勝手な解釈では Prolog による文法解析かな。 DCG の何がいいかは "Artificial Intelligence: A Modern Approach"(AIMA, エージェントアプローチ人工知能) の方に書いてあるw とりあえず、全部宣言的に書けるのはいい。 PAIP と AIMA 面方読むと面白いね。よく理解できないげど。
数値はめんどうになって整数だけの対応にした。
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload "unifgram")
(ql:quickload "info.read-eval-print.mecab"))
(defpackage :unifgram-json
(:use :cl :paiprolog :unifgram :info.read-eval-print.mecab))
(in-package :unifgram-json)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Syntax
;;; 空白
(<-- (whitespace-p #\Space))
(<- (whitespace-p #\Tab))
(<- (whitespace-p #\Newline))
(<- (whitespace-p #\Return))
(<- (whitespace-p #\Page))
(<-- (whitespace (?c . ?s) ?s)
(whitespace-p ?c))
(rule (s*) ---> (whitespace) (s*) !)
(rule (s*) -->)
;;; JSON
(rule (json ?x) ---> (s*) (value ?x) (s*))
(rule (value ?x) ---> (string ?x))
(rule (value ?x) --> (number ?x))
(rule (value ?x) --> (object ?x))
(rule (value ?x) --> (array ?x))
(rule (value true) --> #.`(:word ,@(coerce "true" 'list)))
(rule (value false) --> #.`(:word ,@(coerce "false" 'list)))
(rule (value null) --> #.`(:word ,@(coerce "null" 'list)))
(rule (object (new-object)) ---> (:word #\{) (s*) (:word #\}))
(rule (object (new-object . ?x)) --> (:word #\{) (s*) (members ?x) (s*) (:word #\}))
(rule (members (?k ?v . ?xs)) ---> (pair ?k ?v) (s*) (:word #\,) (s*) (members ?xs))
(rule (members (?k ?v)) --> (pair ?k ?v))
(rule (pair ?k ?v) ---> (string ?k) (s*) (:word #\:) (s*) (value ?v))
(rule (array (new-array)) ---> (:word #\[) (s*) (:word #\]))
(rule (array (new-array . ?x)) --> (:word #\[) (s*) (elements ?x) (s*) (:word #\]))
(rule (elements (?x . ?xs)) ---> (value ?x) (s*) (:word #\,) (s*) (elements ?xs))
(rule (elements (?x)) --> (value ?x))
(rule (string (new-string)) ---> (:word #\") (:word #\"))
(rule (string (new-string . ?x)) --> (:word #\") (chars ?x) (:word #\"))
(rule (chars (?x . ?xs)) ---> (char ?x) (chars ?xs))
(rule (chars (?x)) --> (char ?x))
(<-- (char ?x (?x . ?xs) ?xs)
(\\= ?x #\")
(\\= ?x #\\))
(<- (char #\" (#\\ #\" . ?xs) ?xs))
(<- (char #\\ (#\\ #\\ . ?xs) ?xs))
(<- (char #\/ (#\\ #\/ . ?xs) ?xs))
(<- (char #\Backspace (#\\ #\b . ?xs) ?xs))
(<- (char #\Page (#\\ #\f . ?xs) ?xs))
(<- (char #\Newline (#\\ #\n . ?xs) ?xs))
(<- (char #\Return (#\\ #\r . ?xs) ?xs))
(<- (char #\Tab (#\\ #\t . ?xs) ?xs))
(<- (char (unicode ?c1 ?c2 ?c3 ?c4) (#\\ #\u ?c1 ?c2 ?c3 ?c4 . ?xs) ?xs))
;; number は手抜きで整数のみ
(rule (number (new-number . ?x)) ---> (int ?x))
(rule (int (?x)) ---> (digit ?x))
(rule (int (?x . ?xs)) --> (digit1-9 ?x) (digits ?xs))
(rule (int ('- ?x)) --> (:word #\-) (digit ?x))
(rule (int ('- ?x . ?xs)) --> (:word #\-) (digit1-9 ?x) (digits ?xs))
(rule (digits (?x . ?xs)) ---> (digit ?x) (digits ?xs))
(rule (digits (?x)) --> (digit ?x))
(rule (digit 0) ---> (:word #\0))
(rule (digit ?x) --> (digit1-9 ?x))
(rule (digit1-9 1) ---> (:word #\1))
(rule (digit1-9 2) --> (:word #\2))
(rule (digit1-9 3) --> (:word #\3))
(rule (digit1-9 4) --> (:word #\4))
(rule (digit1-9 5) --> (:word #\5))
(rule (digit1-9 6) --> (:word #\6))
(rule (digit1-9 7) --> (:word #\7))
(rule (digit1-9 8) --> (:word #\8))
(rule (digit1-9 9) --> (:word #\9))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Semantic
(defun new-object (&rest args)
(loop for (k v) on args by #'cddr
collect (cons k v)))
(defun new-array (&rest args)
args)
(defun new-string (&rest args)
(coerce args 'string))
(defun new-number (&rest args)
(let* ((minus-p (eq '- (car args)))
(int (if minus-p (cdr args) args)))
(loop for i in int
for sum = i then (+ (* sum 10) i)
finally (return (if minus-p (* -1 sum) sum)))))
(defun hex-char-to-decimal (hex-char)
(if (digit-char-p hex-char)
(- (char-code hex-char) #.(char-code #\0))
(- (char-code (char-downcase hex-char)) #.(char-code #\a) -10)))
(defun unicode (a b c d)
(code-char (+ (ash (hex-char-to-decimal a) 12)
(ash (hex-char-to-decimal b) 8)
(ash (hex-char-to-decimal c) 4)
(hex-char-to-decimal d))))
(defconstant true t)
(defconstant false nil)
(defconstant null 'null)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ユーティリティ
(defmacro from-json (json-string)
`(eval (prolog-first (?x)
(json ?x ,(coerce json-string 'list) ()))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 動作確認
(from-json "true")
(from-json "[]")
(from-json "[true]")
(from-json "[true,false]")
(from-json "[true,false,null]")
(from-json "\"\"")
(from-json "\"a\"")
(from-json "\"Hello\\\"\\\\\\b\\f\\n\\r\\t\\u308c\"")
(from-json "{}")
(from-json "{\"foo\":true}")
(from-json "0")
(from-json "1")
(from-json "10")
(from-json "12")
(from-json "123")
(from-json "12345")
(from-json "-1")
(from-json "-10")
(from-json "-123")
(from-json "[
{
\"Person\" : {
\"name\" : \"quek\",
\"weight\" : 55,
\"foo\" : [ true, false ]
}
},
{
\"Person\" : {
\"name\" : \"zumu\",
\"weight\" : 123,
\"foo\" : []
}
}
]")
;;=> ((("Person" ("name" . "quek") ("weight" . 55) ("foo" T NIL)))
;; (("Person" ("name" . "zumu") ("weight" . 123) ("foo"))))
