本日の酒
- 鎌倉ビール 花(神奈川/鎌倉ビール醸造株式会社)
2010年12月21日火曜日
2010年12月19日日曜日
2010年12月15日水曜日
昨日の続き(syntax-table)
word-at-pointやsymbol-at-pointはメジャーモードごと、というかsyntax-tableごとに動きをかえてしまうので、適当なsyntax-tableを定義してつねにそいつを利用するようにしてみました。
Emacsで単語の省略形を定義する
最近どうにかして同じようなコードを何度も何度も何度も書くような真似をしなくて良い方法はないだろうかと考えています。
基本的にEmacsユーザーなので、Elispでそれっぽい機能を書けばいいんじゃないかと考えて思いついたネタの一つが、劣化yasnippetといいますか、単にある文章(単語)の省略形を登録しておいて、それを展開してもとの文章(単語)になるようにする、というものでした。
まぁ、補完があるのでたいして役に立たないかもしれません。
(require 'cl)
;;; メジャーモードで分けたほうがよいだろうか
(defvar shorthand:*shorthand-expand-ht*
(make-hash-table :test 'equal))
(defvar shorthand:*shorthand-fold-ht*
(make-hash-table :test 'equal))
(defun shorthand:add (short long)
(interactive "Sshort:\nslong:")
(setf (gethash long shorthand:*shorthand-fold-ht*) short
(gethash short shorthand:*shorthand-expand-ht*) long))
(fset 'sh:add #'shorthand:add)
;; syntax-tableによっては. や / で区切られてしまう
(defun shorthand:word-at-point ()
(let ((s (sexp-at-point)))
(typecase s
(string (format "\"%s\"" s))
(list nil)
(symbol (symbol-name s))
(t nil))))
(defun shorthand:symbol-at-point ()
(symbol-at-point))
(defun shorthand:add-at-point-short (long)
(interactive "slong:")
(let ((short (shorthand:symbol-at-point)))
(when short
(shorthand:add short long))))
(fset 'sh:add-at-point-short #'shorthand:add-at-point-short)
(defun shorthand:add-at-point-long (short)
(interactive "Sshort:")
(let ((long (shorthand:word-at-point)))
(when long
(shorthand:add short long))))
(fset 'sh:add-at-point-long #'shorthand:add-at-point-long)
(defun shorthand:get (short)
(gethash short shorthand:*shorthand-expand-ht*))
(fset 'sh:get #'shorthand:get)
(defun shorthand:get-short (long)
(gethash long shorthand:*shorthand-fold-ht*))
(defun shorthand:expand (short)
(interactive (list (shorthand:symbol-at-point)))
(let ((long (shorthand:get short)))
(when long
(cond
((functionp long) (funcall long short))
((not (interactive-p)) long)
(t (shorthand:replace long))))))
(fset 'sh:expand #'shorthand:expand)
(defun shorthand:fold (long)
(interactive (list (shorthand:word-at-point)))
(let ((short (shorthand:get-short long)))
(when short
(if (not (interactive-p))
short
(let ((short (format "%S" short)))
(shorthand:replace short))))))
(fset 'sh:fold #'shorthand:fold)
(defun shorthand:replace (new)
(backward-sexp)
(kill-sexp)
(pop kill-ring-yank-pointer)
(let ((pos (point))
(len (length new)))
(insert new)
(goto-char (+ pos len))))
(defvar shorthand:*expand-fold-toggle-flag* nil)
(defun shorthand:expand-and-fold ()
(interactive)
(if (and (eq this-command last-command)
shorthand:*expand-fold-toggle-flag*)
(progn
(setf shorthand:*expand-fold-toggle-flag* nil)
(command-execute 'shorthand:fold))
(progn
(setf shorthand:*expand-fold-toggle-flag* t)
(command-execute 'shorthand:expand)))
(when (interactive-p)
(setf this-command 'shorthand:expand-and-fold)))
;; key bindings
(global-set-key (kbd "C-o") 'shorthand:expand-and-fold)
(global-set-key (kbd "M-RET") 'shorthand:add-at-point-long)
(global-set-key (kbd "M-SPC") 'shorthand:add-at-point-short)
;; example
;; (sh:add 'sysout "System.out.println")
;; sysout [M-x sh:expand]
;; =>
;; System.out.println
;; System.out.println [M-x sh:fold]
;; =>
;; sysout
(sh:add 'file
(lambda (short)
(let ((name (read-file-name "Filename:")))
(when name
(shorthand:replace name)))))
単語の展開だけではつまらないので関数の呼び出しも行えるようにしました。
syntax-tableによって、単語やS式(シンボル)の範囲が異なるあたりがめんどくさそうです。
とりあえず、interactiveについての勉強にはなりました。
2010年12月8日水曜日
最近飲んでいる(いた)日本酒リスト
- 賀儀屋 無濾過純米吟醸 (愛媛/成龍酒造株式会社)
- 古緑川(平成9年度産) (新潟/緑川酒造株式会社)
- 櫻室町 吟醸純米酒 (岡山/室町酒造株式会社)
- 幻の瀧 山田錦大吟醸袋しぼり(製造No.0428) (富山/皇国晴酒造株式会社)
- 伝兵衛 純米 (石川/合名会社中島酒造店)
- 霧筑波 特別純米酒 (茨城/合名会社浦里酒造店)
「皇国晴」は「みくにはれ」と読むらしい。
2010年12月6日月曜日
cl-gtk2
cl-gtk2を使ってウィンドウに絵を書いてみます。
;;(asdf:load-system :cl-gtk2-glib)
;;(asdf:load-system :cl-gtk2-gdk)
;;(asdf:load-system :cl-gtk2-cairo)
(defun run-test-1 ()
(let ((out *standard-output*))
(gtk:within-main-loop
(let ((window (make-instance 'gtk:gtk-window
:type :toplevel
:window-position :center
:title "run-test-1"
:default-width 300
:default-height 100))
(area (make-instance 'gtk:drawing-area
:default-width 100 :default-height 100))
(button (make-instance 'gtk:button :label "はろー, World"))
(v-box (make-instance 'gtk:v-box)))
(gobject:g-signal-connect button "clicked"
(lambda (b)
(format out "Hello,World Clicked: ~A~%" b)
(multiple-value-bind (width height)
(gdk:drawable-get-size (gtk:widget-window area))
(cl-gtk2-cairo:with-gdk-context
(ctx (gtk:widget-window area))
(cairo:with-context (ctx)
(cairo:set-source-rgb (random 1.0)
(random 1.0)
(random 1.0))
(cairo:move-to (random width) (random height))
(cairo:line-to (random width) (random height))
(cairo:stroke)
nil)))))
(gtk:container-add window v-box)
(gtk:box-pack-start v-box button :expand nil)
(gtk:box-pack-start v-box area)
(gtk:widget-show window :all t)))))
画面上部のボタンを押すと、ウィンドウに線を描きます。
ウィジェットを並べるにはv-boxやh-boxその他が使えるようです。
2010年11月28日日曜日
たくさんの閉じ括弧を不快に思う人のためのリーダマクロ
本日(2010/11/27)はShibuya.lisp TT6に参加してきました。
Lisperばかりが70以上も集まるという、とても楽しいイベントでした。運営、発表者、会場、その他参加者の皆様、どうもありがとうございました。
内容についてはきっとどなたかがナイスな感じでまとめてくださるはずなので、帰宅して書いてみたネタを晒そうと思います。
今日のTTで Programming 2.0 という話題がでました。自分の中で要約すると、「おいコンパイラ、そのくらいのタイポでエラーをだすな。俺がやりたいことくらいわかるだろ？」という感じになりましたが、そのあたりに関連して、「Lispのネストした閉じ括弧をたくさん書くのが面倒、わかりにくい」というようなつぶやきが聞こえてきたので、なんとかしてみようと頑張ってみました。
(defparameter *unclose-parenthesis* 0)
(defparameter *super-kokka-sym* (gensym))
(defparameter *kokka-sym* (gensym))
(defun super-kakko-reader (stream ch)
(let ((*unclose-parenthesis* 0))
(loop :for s = (read stream t nil t)
:until (eq s *super-kokka-sym*)
:collect s)))
(defun super-kokka-reader (stream ch)
(when (> *unclose-parenthesis* 0) (unread-char ch stream))
*super-kokka-sym*)
(defun kakko-reader (stream ch)
(let ((*unclose-parenthesis* (1+ *unclose-parenthesis*)))
(loop :for s = (read stream t nil t)
:until (or (eq s *kokka-sym*)
(eq s *super-kokka-sym*))
:collect s)))
(defun kokka-reader (stream ch)
*kokka-sym*)
(set-macro-character #\{ #'super-kakko-reader)
(set-macro-character #\} #'super-kokka-reader)
(set-macro-character #\) #'kokka-reader)
(set-macro-character #\( #'kakko-reader)
「{」 で始まった式は、どれだけネストしていようと 「}」 が現れた時点で終端だと判断されます。
;; example
'{dotimes (i 3)
(dotimes (j 3)
(format t "~A x ~A = ~A~%" i j (* i j}
;; => (DOTIMES (I 3) (DOTIMES (J 3) (FORMAT T "~A x ~A = ~A~%" I J (* I J))))
最大の問題は、エディタのインデント支援の恩恵を受けられなくなるというところ。致命的ですね。
2010年11月26日金曜日
LOLを参考に間接参照
Let Over Lambda(LOL)のalambda,aletあたりを読んで間接参照を定義する単純な方法を考えてみました。
(let ((set-sym (gensym))
(deref-sym (gensym)))
(defun ref (fn)
(let ((this fn))
(lambda (&rest args)
(cond
((eq (car args) set-sym)
(setf this (cadr args)))
((eq (car args) deref-sym)
this)
(T (apply this args))))))
(defun deref (ref)
(funcall ref deref-sym))
(defun (setf deref) (fn ref)
(funcall ref set-sym fn)))
;; example
(ref (lambda (a b) (+ a b)))
(setf (symbol-function 'a) *)
(a 2 3)
;;=> 5
(funcall (deref #'a) 4 5)
;;=> 9
(setf (deref #'a) (lambda () :a))
(a)
;;=> :a
2010年11月25日木曜日
#`..`で外部コマンドの出力を取得する
Perlのバッククオートをパクってみました。
とりあえず、kmrclのcommand-outputを使いめんどくさいところを丸投げします。
(asdf:oos 'asdf:load-op :kmrcl)
(defun |#`-reader| (stream ch numarg)
(declare (ignore ch numarg))
(let (acc-fmt acc-args)
(loop
:for curr = (read-char stream)
:until (char= curr #\`)
:do
(if (char= curr #\\)
(let ((c (read-char stream)))
(case c
((#\n) (push #\Newline acc-fmt))
((#\t) (push #\Tab acc-fmt))
((#\{) (push #\{ acc-fmt))
((#\`) (push #\` acc-fmt))
(T (error "#`-reader invalid escaped character"))))
(if (char= curr #\{)
(let ((s (read-delimited-list #\} stream)))
(push (car s) acc-args)
(push #\~ acc-fmt)
(push #\A acc-fmt))
(push curr acc-fmt))))
`(kmrcl:command-output
,(coerce (nreverse acc-fmt) 'string)
,@(nreverse acc-args))))
(defun enable-sharp-backquote-reader ()
(set-macro-character
#\}
(get-macro-character #\)))
(set-dispatch-macro-character
#\# #\`
#'|#`-reader|))
;;; example
;;' #`ls -a {a}.lisp`
;;> (KMRCL:COMMAND-OUTPUT "ls -a ~A.lisp" A)
;;' #`ls -a {a b}.lisp`
;;> (KMRCL:COMMAND-OUTPUT "ls -a ~A.lisp" A)
2010年11月20日土曜日
ASDF-INSTALLでhttpsからのインストールを行う
asdf-installはURLを指定するとそこからパッケージをダウンロードしてインストールしてくれますが、httpsには対応していません(たぶん)
GitHubがいつの間にかhttpsのみのサポートに切り替わっていたので、 URLを指定してプロジェクトをインストールすることができなくなりました。
とりあえず、CL+SSLを利用してhttpsでも動かせるようなコードを書いてみました。
パッケージ名が文字列かつ"https://"から始まっている場合の動きを若干追加しています。
(asdf:oos 'asdf:load-op :cl+ssl)
(in-package :asdf-install)
(setf (symbol-function 'make-stream-from-url-old)
#'make-stream-from-url)
(setf (symbol-function 'url-host-old)
#'url-host)
(setf (symbol-function 'url-port-old)
#'url-port)
(setf (symbol-function 'request-uri-old)
#'request-uri)
(defun make-stream-from-url (connect-to-url)
(let ((sock (make-stream-from-url-old connect-to-url)))
(if *proxy*
sock
(cl+ssl:make-ssl-client-stream sock))))
(defun url-host (url)
(if (string= url "https://" :end1 8)
(let* ((port-start (position #\: url :start 8))
(host-end (min (or (position #\/ url :start 8) (length url))
(or port-start (length url)))))
(subseq url 8 host-end))
(url-host-old url)))
(defun url-port (url)
(if (string= url "https://" :end1 8)
(let ((port-start (position #\: url :start 8)))
(if port-start
(parse-integer url :start (1+ port-start) :junk-allowed t)
443))
(url-port-old url)))
(defun request-uri (url)
(if (string-equal url "https://" :end1 8)
(if *proxy*
url
(let ((path-start (position #\/ url :start 8)))
(assert (and path-start) nil "url does not specify a file.")
(subseq url path-start)))
(request-uri-old url)))
2010年11月18日木曜日
テストツールその2
関数を簡単にテストするなら、このくらい単純で良いような気もしました。
(defvar *test-function-table* (make-hash-table))
;; clause -> ((arg1 arg2 ... ) result) = ((arg1 arg2 ... ) :eq result)
;; clause -> ((arg1 arg2 ... ) :not result)
;; clause -> ((arg1 arg2 ... ) :test test-fn)
(defparameter *test-report-function*
#'(lambda (fn-name args expected actual)
(format t "TEST FAILED. Form: (~A ~{~A~^ ~}), Expected: ~A, Actual: ~A~%"
fn-name args expected actual)))
(defmacro deftest (fn-name &body clauses)
(let ((sym (gensym)))
(labels
((expander (clause)
(let ((result-spec (cdr clause))
(test-fn-form `(,fn-name ,@(car clause))))
(when (= (length result-spec) 1)
(setf result-spec (cons :eq result-spec)))
`(let ((,sym ,test-fn-form))
,(let ((report-form `(funcall *test-report-function*
',fn-name
',(car clause)
',result-spec
,sym)))
(case (car result-spec)
((:eq)
`(unless (eq ,sym ,(second result-spec))
,report-form))
((:eql)
`(unless (eql ,sym ,(second result-spec))
,report-form))
((:equal)
`(unless (equal ,sym ,(second result-spec))
,report-form))
((:not :not-eq)
`(when (eq ,sym ,(second result-spec))
,report-form))
((:not-eql)
`(when (eql ,sym ,(second result-spec))
,report-form))
((:not-equql)
`(when (equal ,sym ,(second result-spec))
,report-form))
((:test)
`(unless (funcall ,(second result-spec) ,sym)
,report-form))
(T (error "invalid test result keyword"))))))))
`(setf (gethash ',fn-name *test-function-table*)
(lambda ()
,@(mapcar #'expander clauses))))))
(defun run-test (fn-name)
(multiple-value-bind (test-fn ?) (gethash fn-name *test-function-table*)
(when ?
(funcall test-fn))))
(defun run-test-all ()
(maphash
#'(lambda (key val)
(when (functionp val)
(format t "TEST START : ~A~%" key)
(funcall val)))
*test-function-table*))
;; example
(deftest length
(('(1 2 3)) 3)
((#(1 2)) 2))
(deftest oddp
((2) :not-eq t)
((3) :eq t))
(deftest symbol-name
((:a) :equal "A")
(('hoge) :equal "hoge"))
(run-test-all)
;; TEST START : LENGTH
;; TEST START : ODDP
;; TEST START : SYMBOL-NAME
;; TEST FAILED. Form: (SYMBOL-NAME 'HOGE), Expected: (EQUAL hoge), Actual: HOGE
Common Lispで図形を描くための27の方法
ありがちなタイトルの付け方ですね。
Common Lispで図形を描くために取り得る手段を列挙してみました。一部現在は使えないか、使うために努力が必要なものがあるかもしれません。
- CUIで充分だよ派
- 表示されれば良いよ派 format関数
- Cursesを使うよ派 cl-Ncurses
- ファイルに書き出すよ派
- Lispで何とかするよ派
- PNG派 zpng
- JPEG派 cl-jpeg
- PDF派 cl-pdf
- なんでも来いよ派 ch-image, IMAGO
- ベクタイメージで書いてPNGにするよ派 vecto
- 外部ライブラリを使うよ派
- ImageMagic派 cl-magic
- libpng派 CL-PNG
- グラフを書くよ派(Graphviz) cl-dot, s-dot, cl-graphviz
- GDを使うよ派 cl-gd
- Lispで何とかするよ派
- ウィンドウに表示するよ派
- Lispでなんとかするよ派
- X11プロトコルをしゃべるよ派 CLX
- LispでCLOSでGUIだよ派 CLIM
- 処理系に組み込まれてるよ派 LispWorks, Allegro
- 処理系の実装言語に頼るよ派 ABCL
- 外部ライブラリを使うよ派
- OpenGL派 cl-opengl, その他たぶん色々
- GLFW派 cl-glfw
- GTK派 cl-gtk, cells-gtk
- SDL派 CL-SDL, CFFI-SDL, lispbuilder-sdl
- Tk派 Ltk
- Qt派 CommonQt, cl-smoke
- wxWindows派 wxCL
- Win32で頑張るよ派 lispbuilder-windows
- .NET FrameworkはGUIライブラリだよ派 RDNZL, Foil
- JavaはGUIライブラリだよ派 CL+J, Jfli
- HTML5ならお絵描きもできるよ派
- S式でJavascriptを書くよ派 Parenscript
- HTMLごとS式で描くよ派 CL-WHO
- Lispでなんとかするよ派
注) ネタです。
2010年11月8日月曜日
ユニットテストツールのようななにか
動的言語を使う人達は、簡単なユニットテストくらいなら言語自体の機能をつかってぱぱっと書いてしまうのではないかと想像しています。
私は趣味で適当なプログラムを書いているだけでろくにテストをしませんが、カバレッジのとりかたもわかったことなのでテストツールを書いてみました。
前のエントリでは、SBCLでのカバレッジの結果の出力先はファイルパスと書きましたが、どうもSBCLでもディレクトリのパスっぽいです。どうしてファイルを指定すると思い込んでいたのでしょう。
(defpackage unit-test
(:use :cl)
(:shadow cl:assert)
(:nicknames :utest)
(:export test-error
assert
do-as-test
define-test-case
*unit-test-error-port*
*default-assert-error-message*
*continue-on-test-error*
*assert-count*
*assert-error-count*
*assert-error-report-function*
*coverage-p*
*coverage-files*
*coverage-path*))
#+SBCL (require 'sb-cover)
#+SBCL (declaim (optimize sb-cover:store-coverage-data))
(in-package :utest)
(define-condition test-error (condition)
((msg :accessor message-of :initarg :message)
(form :accessor form-of :initarg :form)
(result :accessor result-of :initarg :result))
(:default-initargs :message "" :form nil :result nil))
(defun make-test-error (msg form result)
(cerror "continue to eval forms"
'test-error
:message msg
:form form
:result result))
(defvar *unit-test-error-port* *standard-output*)
(defparameter *default-assert-error-message*
"Assertion failed")
(defparameter *continue-on-test-error* nil)
(defparameter *assert-count* 0)
(defparameter *assert-error-count* 0)
(defparameter *coverage-p* nil)
(defparameter *coverage-files* nil)
(defparameter *coverage-path* nil)
(defparameter *assert-error-report-function*
(lambda (msg form result)
(format *unit-test-error-port*
"Assert failed: ~S~%form: ~S~%result: ~S~%"
msg form result)))
(defun compile-and-load (path)
(compile-file path)
(load path))
(defun coverage-p ()
#+SBCL *coverage-p*
#+CCL *coverage-p*
#+OPEM-MCL *coverage-p*)
#+SBCL
(defun start-coverage-sbcl ()
(dolist (file *coverage-files*)
(compile-and-load file)))
#+SBCL
(defun report-coverage-sbcl ()
;; *coverage-path* is file-path
(sb-cover:report *coverage-path*))
#+CCL
(defun start-coverage-ccl ()
(setf ccl:*compile-code-coverage* t)
(dolist (file *coverage-files*)
(compile-and-load file)))
#+CCL
(defun report-coverage-ccl ()
;; *coverage-files* is directory-path
(ccl:report-coverage *coverage-path*))
(defun report-test ()
(format *unit-test-error-port*
"Assertion ~A, Success ~A, Fail ~A~%"
*assert-count*
(- *assert-count* *assert-error-count*)
*assert-error-count*)
(when (and (coverage-p) *coverage-files*)
#+SBCL (report-coverage-sbcl)
#+CCL (report-coverage-ccl)))
(defun handler-test-error (e)
(incf *assert-error-count*)
(funcall *assert-error-report-function*
(message-of e)
(form-of e)
(result-of e))
(when *continue-on-test-error*
(continue)))
(defmacro define-test-case (name lambda-list &body body)
`(defun ,name ,lambda-list
(format *unit-test-error-port*
"Run test case: ~A~%"
',name)
(handler-bind ((test-error #'handler-test-error))
,@body)))
(defmacro assert (&whole form test-form &optional msg-fmt &rest args)
(let ((sym (gensym)))
`(progn
(incf *assert-count*)
(let ((,sym ,test-form))
(unless ,sym
(make-test-error
(format nil (or ,msg-fmt *default-assert-error-message*) ,@args)
',form
,sym))
,sym))))
(defmacro do-as-test
((&key error-port continue-on-test-error-p
assert-error-report-function coverage-p
coverage-path coverage-files)
&body body)
`(let ((*unit-test-error-port* (or ,error-port *unit-test-error-port*))
(*continue-on-test-error*
(or ,continue-on-test-error-p *continue-on-test-error*))
(*assert-error-report-function*
(or ,assert-error-report-function *assert-error-report-function*))
(*assert-error-count* 0)
(*assert-count* 0)
(*coverage-path* (or ,coverage-path *coverage-path*))
(*coverage-p* (or ,coverage-p *coverage-p*))
(*coverage-files* (or ,coverage-files *coverage-files*)))
(when (and (coverage-p) *coverage-files*)
#+SBCL (start-coverage-sbcl)
#+CCL (start-coverage-ccl))
(unwind-protect
(handler-bind ((test-error #'handler-test-error))
,@body)
(report-test))))
;; function.lisp
(defun make-add (a)
(lambda (x)
(+ x a)))
(defun quoted? (obj)
(if (and (listp obj)
(eq (car obj) 'quote))
T
nil))
(defun bad-quoted? (obj)
(if (and (listp obj)
(eq (car obj) 'quote))
nil
T))
;; テストコード
(utest:define-test-case test-01 ()
(let ((add-5 (make-add 5)))
(utest:assert (eq 6 (funcall add-5 1)))))
(utest:define-test-case test-02 ()
(utest:assert (eq nil (quoted? :hoge))))
(utest:define-test-case test-03 ()
(utest:assert (eq T (bad-quoted? ''hoge)))))
(utest:do-as-test
(:continue-on-test-error-p t
:coverage-p t
:coverage-files '("/path/to/function")
:coverage-path "/path/to/dir/")
(test-01)
(test-02)
(test-03))
;;Run test case: TEST-01
;;Run test case: TEST-02
;;Run test case: TEST-03
;;Assert failed: "Assertion failed"
;;form: (UNIT-TEST:ASSERT (EQ T (BAD-QUOTED? ''HOGE)))
;;result: NIL
;;Assertion 3, Success 2, Fail 1
メソッドがクラスに属しているかのような錯覚をおこす為のマクロ
タイトルどおりのものを作ろうとしてみましたが案の定ぐだぐだに。
Common Lispのインスタンス変数(スロット)は :allocation :class と指定することで同じクラスのオブジェクトで共有されますが、共有されるだけで実際にインスタンスを生成しなければアクセスすることができません(たぶん)。
なので、クラス変数をメタクラスのインスタンス変数とすることで他のオブジェクト指向言語に近付こうとしてみました。
ソースコードはgistに置きました。
https://gist.github.com/662369
;; example
(class <foo> ()
(def sum ()
(+ @@a @b))
(setf @@a 10)
(def set-b (b)
(setf @b b)))
(defvar *obj* (make-instance '<foo> :b 20))
(sum *obj*)
;;=> 30
(set-b *obj* 10)
(sum *obj*)
;;=> 20
<foo>
;;=> #<#:META-<FOO>1306 <FOO>>
もっと頑張ってみても面白いかもしれない。
2010年11月3日水曜日
SBCLとCCLでのカバレッジの取りかた
SBCLとClozure Common Lisp(以下CCL)にはファイルのカバレッジを取り、HTMLで出力してくれる機能があるようです。
CCLでは ccl:*compile-code-coverage*をTにしてからカバレッジを取りたいファイルをコンパイル->ロードして、テストの実行とカバレッジの集計結果出力を行います。
SBCLでは、SB-COVERパッケージを読み込んでから、ファイルのコンパイル、ロード、テスト実行、結果の出力を行います。
結果の出力時に指定するパスは、CCLではファイル名ですが、SBCLではディレクトリ名のようです。
(defun compile-and-load (path)
(compile-file path)
(load path))
;;; clozure common lisp
(setf ccl:*compile-code-coverage* t)
(compile-and-load "path/to/source")
(run-test)
(ccl:report-coverage "file")
;;; SBCL
(require 'sb-cover)
(declaim (optimize sb-cover:store-coverage-data))
(compile-and-load "path/to/source")
(run-test)
(sb-cover:report "dir")
lengthとeltのgeneric-function版
Common Lispパッケージの内容を上書きするのはよろしく無いのではと思い、適当な名前でタイトル通りのものを書いてみました。
(defun defmethods-args-expander (args specifiers)
(when (< (length args) (length specifiers))
(error "Too many specifiers"))
(labels
((inner (ar sr acc)
(if (null ar)
(nreverse acc)
(inner (cdr ar)
(cdr sr)
(cons
(if (null sr)
(car ar)
(list (car ar) (car sr)))
acc)))))
(inner args specifiers nil)))
(defun defmethods-clause-expander (name args clause)
(destructuring-bind (specifiers &rest definition)
clause
(unless (listp specifiers)
(setf specifiers (list specifiers)))
`(defmethod ,name
,(defmethods-args-expander args specifiers)
,@definition)))
(defmacro defmethods (name (&rest args) &body clauses)
(when (null args)
(error "There is no argument"))
`(progn
,@(mapcar
#'(lambda (clause)
(defmethods-clause-expander name args clause))
clauses)))
(defgeneric size (object))
(defmethods size (object)
(list (length object))
(integer (integer-length object))
(file-stream (file-length object)))
(defgeneric ref (object place))
(defmethods ref (object place)
((sequence integer) (elt object place))
((simple-vector integer) (svref object place))
((array integer) (aref object place))
((array list) (apply #'aref object place))
((list integer) (nth place object))
((list T) (assoc place object)))
2010年10月25日月曜日
McCLIMで接続するディスプレイを選択する
McCLIMはX11プロトコルをしゃべるためにCLXを利用しています。なのでディスプレイ番号などを指定するのは最終的にはCLXの役割です。
McCLIMからCLXのopen-displayがどのように呼ばれるかを眺めることで、接続するディスプレイを選択する方法がわかったような気分になりました。
(asdf:oos 'asdf:load-op :mcclim)
(sb-posix:getenv "DISPLAY")
;;=> ":0.0"
;; .Xauthorityを読み込み、 ホスト名、ディスプレイ番号、プロトコルに対応する
;; :authorization-nameと:authorization-dataを取得する
(xlib::get-best-authorization "localhost" 0 :local)
;; =>"MIT-MAGIC-COOKIE-1"
;; =>#(161 76 219 58 93 240 175 179 37 197 235 248 55 5 32 117)
;; CLIMがこの関数を呼ぶ際の引数は、clx-portのserver-pathスロットに
;; セットされている。デフォルトだとcar部にキーワードシンボル:clxが、
;; cdr部に属性リストがセットされる。
;; clx-portオブジェクトはfind-port関数の中で作られる。
;; find-portはserver-pathをオプショナル引数とするが、デフォルトでは
;; *default-server-path*が渡されるので、この値を設定すると好きなディスプレイに接続できそう。
;; server-pathの第一要素はシンボルで、属性リストの:server-path-parserに関数が設定されている
;; 必要がある。この関数をserver-pathを引数として呼び出した返り値がclx-portにセットされる。
;; server-pathがnilの場合、find-default-server-pathの返り値を
;; server-pathとして利用する。おそらくcar部に:clxが入ったリストが返るので、:clxの属性リスト
;; に設定されている関数を変更することでも接続するディスプレイを選ぶことが出来ると思われる。
(funcall (get :clx :server-path-parser) '(:clx))
;; => (:CLX :HOST "" :DISPLAY-ID 0 :SCREEN-ID 0 :PROTOCOL :LOCAL)
2010年10月23日土曜日
CLOSでオブジェクトのクラスを変更する
Common LispのオブジェクトシステムであるCLOSには、実行時にオブジェクトのクラスを変更する機能や、クラスを再定義するとそのクラスのオブジェクトが新しいクラスのオブジェクトへ変更されるという機能があるそうです。
それぞれの動作を制御するためのメソッドが update-instance-for-different-class と update-instance-for-redefined-class です。
ともに関数名が35文字で、Common Lispの仕様上最長の関数名です。ちなみに、変数名を含めれば least-positive-normalized-double-float などの38文字が最長であるようです。
;;;; update-instance-for-different-class
(defclass class-a ()
((a :accessor a-of :initarg :a)
(b :accessor b-of :initarg :b))
(:default-initargs :a 1 :b 2))
(defclass class-b ()
((a :accessor a-of :initarg :a)
(c :accessor c-of :initarg :c))
(:default-initargs :a 10 :c 30))
;; クラスclass-aのオブジェクトを作る。
(defvar obj (make-instance 'class-a))
(describe obj)
;; #<CLASS-A {DB18DD9}>
;; [standard-object]
;; Slots with :INSTANCE allocation:
;; A = 1
;; B = 2
;; オブジェクトの暮らすをclass-bに変更する
;; スロット名が同じである場合、そのスロットの値はそのままのようだ
(change-class obj 'class-b)
(describe obj)
;; #<CLASS-B {E38F199}>
;; [standard-object]
;; Slots with :INSTANCE allocation:
;; A = 1
;; C = #<unbound slot>
;; オブジェクトのクラスをclass-aに変更する。
;; キーワードパラメータ:bに値を渡す。
(change-class obj 'class-a :b 99)
(describe obj)
;; #<CLASS-A {E38F199}>
;; [standard-object]
;; Slots with :INSTANCE allocation:
;; A = 1
;; B = 99
;;; オブジェクトを変換するメソッド
;;; 直接呼ぶことはしない。change-classが呼ばれたときに裏で呼ばれる。
(defmethod update-instance-for-different-class ((prev class-a) (new class-b) &key)
(setf (a-of new) (a-of prev)
(c-of new) (b-of prev)))
;; objのクラスをclass-bに変更する。
;; update-instance-for-different-classで定義したとおり、
;; class-aでのスロットbの値が、class-bでのスロットcにセットされた。
(change-class obj 'class-b)
(describe obj)
;; #<CLASS-B {E38F199}>
;; [standard-object]
;; Slots with :INSTANCE allocation:
;; A = 1
;; C = 99
;;;; update-instance-for-redefined-class
(defclass class-c ()
((hoge :accessor hoge-of :initarg :hoge)
(fuga :accessor fuga-of :initarg :fuga))
(:default-initargs :hoge 'a :fuga 'b))
;; クラスclass-cのオブジェクトを作る
(defvar o (make-instance 'class-c))
(describe o)
;; #<CLASS-C {E0E2DA1}>
;; [standard-object]
;; Slots with :INSTANCE allocation:
;; HOGE = A
;; FUGA = B
;; class-cを再定義する。
(defclass class-c ()
((hoge :accessor hoge-of :initarg :hoge))
(:default-initargs :hoge 'c))
;; 再定義後、class-cのオブジェクトにアクセスすると、
;; 新しいクラスのオブジェクトへ変換される。
;; :default-initargsの値ではなく、
;; 古いクラスのスロットの値が使われるようだ。
(describe o)
;; #<CLASS-C {E405751}>
;; [standard-object]
;; Slots with :INSTANCE allocation:
;; HOGE = A
(defclass class-c ()
((hoge :accessor hoge-of :initarg :hoge)
(fuga :accessor fuga-of :initarg :fuga))
(:default-initargs :hoge 'e :fuga 'f))
;; 再定義後のクラスへ変換する際に動作するメソッドを定義する。
(defmethod update-instance-for-redefined-class :before
((obj class-c) added deleted plist &key)
(setf (fuga-of obj) 1000))
;; スロットfugaの値はupdate-instance-for-redefined-classで
;; セットした値になる。
(describe o)
;; #<CLASS-C {E4707B1}>
;; [standard-object]
;; Slots with :INSTANCE allocation:
;; HOGE = A
;; FUGA = 1000
2010年10月15日金曜日
動的束縛なlabels
fletやlabelsはlexical bindingなので、定義した関数の名前は字面上現れる位置でないと利用できません。
>(defun hoge ()
(print 3))
>(defun fuga ()
(hoge))
>(fuga)
3
>(labels
((hoge ()
(print 10)))
(fuga))
3
変数ならばdeclareでspecial変数だと宣言すれば良いけれど、関数の場合どうすれば良いか分からなかったのでマクロを書いてみました。
(defun generic-function-p (x)
#+SBCL (sb-pcl::generic-function-p x)
#-SBCL nil)
(defmacro dynamic-labels
((&rest definitions) &body body)
(let ((olds (mapcar #'(lambda (x)
(declare (ignore x))
(gensym))
definitions)))
`(let ,(mapcar
#'(lambda (sym def)
`(,sym ,(and (fboundp (car def)) (symbol-function (car def)))))
olds
definitions)
,@(mapcar
#'(lambda (def)
`(,(if (generic-function-p (car def))
`cl:defmethod
`cl:defun)
,@def))
definitions)
(unwind-protect
(progn
,@body)
,@(mapcar
#'(lambda (old def)
`(if ,old
(setf (symbol-function ',(car def))
,old)
(fmakunbound ',(car def))))
olds
definitions)))))
以下実行例。再定義時に警告が出るかもしれない。
>(dynamic-labels
((hoge () (print 10)))
(fuga))
10
(Lisp (を書いて学ぶ) Ruby)
Peter Norvigせんせーの記事の邦訳、((Pythonで) 書く (Lisp) インタプリタ) を写経してみました。Rubyで。
class String
def tokenize()
return self.gsub(/(\(|\))/){|s| " " + s + " " }.split(' ');
end
end
def parse(tokens)
if(tokens.length == 0)
raise "error"
end
tk = tokens.shift
if(tk == "(")
acc = []
while ( (tk = tokens.shift) != ")")
if(tk == "(")
acc.unshift(parse(tokens.unshift(tk)))
else
acc.unshift(to_atom(tk))
end
end
return acc.reverse
elsif(tk == ")")
raise "error"
else
return to_atom(tk)
end
end
def eval(x, env = $global_env)
if(x.is_a? Numeric)
return x
elsif (x.is_a? String)
return env.find(x)[x]
elsif(! (x.is_a? Array) )
raise "Error"
elsif(x[0] == 'quote')
return x[1]
elsif(x[0] == 'if')
if ( eval(x[1],env) )
return eval(x[2], env)
else
return eval(x[3], env)
end
elsif(x[0] == 'set!')
return env.find(x[1]).store(x[1], eval(x[2], env))
elsif(x[0] == 'define')
return env.store(x[1], eval(x[2], env))
elsif(x[0] == 'lambda')
return Proc.new{| *args |
r = nil
ev = Env.new(env)
x[1].each_index{|i|
ev.store(x[1][i], args[i])
}
for s in x[2..-1] do
r = eval(s, ev)
end
r
}
elsif(x[0] == 'begin')
val = []
x[1..-1].each{|s|
val = eval(s, env)
}
return val
else
exps = x.collect{|s| eval(s, env)}
return exps[0].call(*exps[1..-1])
end
end
def to_atom(x)
if ( /^\d+$/ =~ x )
return x.to_i
elsif ( /^\d*\.\d+$/ =~ x)
return x.to_f
else
return x
end
end
class Env < Hash
@outer = nil
def initialize(outer = nil)
@outer = outer
super()
end
def find(key)
if( self.member?(key) )
return self
elsif( @outer )
return @outer.find(key)
else
return nil
end
end
end
$global_env = Env.new()
$global_env.store("+", Proc.new{|x, y| x + y })
print parse("(a 2 (b c d))".tokenize()),"\n"
print eval(parse("2".tokenize())),"\n"
print eval(parse("(+ 2 3)".tokenize())),"\n"
print eval(parse("((lambda (a b) (+ a b)) 10 20)".tokenize())),"\n"
print eval(parse("(define a 2)".tokenize())),"\n"
print eval(parse("a".tokenize())),"\n"
print eval(parse("(set! a 10)".tokenize())),"\n"
print eval(parse("a".tokenize())),"\n"
メモ
- to_i は文字列が数字でない場合0を返す。先頭が数字なら、可能なぶんだけ数値にする。
- アスタリスクは可変長引数や配列の展開?を表す
- アットマークから始まるシンボルはメンバ変数
- ドルマークから始まるシンボルはグローバル変数
- 例外を投げるにはraiseを使う
2010年10月4日月曜日
Common Lispでexpect的ななにか
最近存在を知りましたが、鯖やってる人にはお馴染み?らしいexpectというプログラムが存在するそうです。
TCLで書かれたプログラムで、Passwordという文字列が表示されたらxxxを入力する、というような形で、対話的なコマンドを自動実行するために利用するものとのことです。
PerlやPython、Rubyなどにもそれっぽいライブラリが存在し、なんとGuileにまでexpect.scmというファイルにモジュールが存在します。
Common Lispにもあるよね・・・と思っていたら見つからないので、Guileのプログラムを一部パクって簡単なものを書いてみました。
(asdf:oos 'asdf:load-op :cl-ppcre)
(defpackage expect
(:use :cl :cl-ppcre)
(:export expect expect-strings))
(in-package expect)
(defmacro expect (port (&rest options) &body clauses)
(let ((ch (gensym "ch"))
(str (gensym "str"))
(p (gensym "port"))
(eof (gensym "eof"))
(next (gensym "next")))
`(let ((,p ,port)
(,str ""))
(labels ((,next ()
(let ((,ch (read-char ,p nil ',eof)))
(unless (eq ',eof ,ch)
(setf ,str
(concatenate 'string ,str (string ,ch)))
(cond
,@(mapcar
#'(lambda (clause)
`((funcall ,(car clause) ,str)
,@(cdr clause)))
clauses)
(T (,next)))))))
(,next)))))
(defmacro expect-strings (port (&rest options) &body clauses)
(let ((syms (mapcar
#'(lambda (_) (declare (ignore _)) (gensym))
clauses))
(s (gensym)))
`(let ,(mapcar
#'(lambda (clause sym)
`(,sym (lambda (,s)
(cl-ppcre:all-matches
,(car clause)
,s))))
clauses
syms)
(expect ,port (,@options)
,@(mapcar
#'(lambda (clause sym)
`(,sym ,@(cdr clause)))
clauses
syms)))))
;;
(with-input-from-string (s "Hello,World")
(expect-strings s ()
("Foo" (print 0))
("Hello" (print 1))
("World" (print 2))))
タイムアウトも入力文字ごとに関数を呼ぶ機能もありませんが、取り合えず読み込んだ文字列が正規表現にマッチすると処理が実行されるようになりました。
引数optionsは、後で何か付けたそうと思って書いたもので今は特に意味はありません。
それにしても、Guileのモジュール名のice-9って何なんでしょう。無駄に格好良く見えます。
2010年9月24日金曜日
Common Lispで (object method args...)の形式でメソッド呼び出し
Common Lispのオブジェクトシステムはそのまんまのネーミングで、 Common Lisp Object System (CLOS:シーロス、クロス)と言います。
CLOSでは、メソッド呼び出しが普通の関数呼び出しと同じように (method object args...) という形式になっていますが、これは他のオブジェクト指向言語から見たらへんてこな順序で、わかりにくいかもしれません。 Javaを触ってきた人からすると、(object method args...)と書きたいでしょう。たぶん。
当然、用意されている書き方が気にくわないならば自分で書き換えてしまうのがCommon Lisp なので、解決方法はいくつかあるかと思います。
仕様にはなっていませんが、CLOSに加えて Meta Object Protocol(MOP)という、デファクトスタンダード的なメタプログラミングの方法が用意されています。
マクロを使うのも良いかもしれませんが、たまには違う方法で実現してみましょう、ということで MOPを利用してみました。
MOPには処理系毎の差異を吸収するラッパーライブラリも存在しますが、面倒くさいので処理系依存のコードを書いてしまいます。
(defclass funcallable-base-class ()
()
(:metaclass sb-mop:funcallable-standard-class))
(defmethod initialize-instance :after ((obj funcallable-base-class) &rest args)
(declare (ignore args))
(sb-mop:set-funcallable-instance-function
obj
#'(lambda (method &rest args)
(apply method obj args))))
(defun callable-object-reader (stream ch1 ch2)
(declare (ignore ch1 ch2))
`(lambda (&rest args)
(apply ,(read stream) args)))
(set-dispatch-macro-character
#\# #\^
'callable-object-reader)
(defmacro defclass! (name direct-superclasses direct-slots &rest options)
`(defclass ,name (funcallable-base-class ,@direct-superclasses)
,direct-slots
(:metaclass sb-mop:funcallable-standard-class)
,@options))
;; example
(defclass! hoge ()
((a :accessor a-of :initform 0 :initarg :a)))
(defclass! fuga ()
((b :accessor b-of :initform 0 :initarg :b)))
(defmethod dump ((obj hoge))
(format t "hoge class: ~A~%" (a-of obj)))
(defmethod dump ((obj fuga))
(format t "fuga class: ~A~%" (b-of obj)))
(defparameter obj (make-instance 'hoge :a 20))
;; 1. funcallで呼び出す
(funcall obj 'dump)
;; : hoge class: 20
;; => nil
;; 2. 関数スロットにセットして関数呼び出し
(setf (symbol-function 'obj) obj)
(obj 'dump)
;; : hoge class: 20
;; => nil
;; 3. リーダマクロを利用してlambdaで包む
(#^obj 'dump)
;; : hoge class: 20
;; => NIL
(#^(make-instance 'fuga :b 10) 'dump)
;; : fuga class: 10
;; => nil
メタクラスにfuncallable-standard-classを指定したクラスのオブジェクトは、 set-funcallable-instance-functionでセットした関数を、普通の関数と同じように呼び出すことができます。
これで、シンボルの関数スロットにオブジェクトをセットすれば、(object method args...)という形式でメソッド呼び出しが出きるようになります。
2010年9月23日木曜日
EmacsからGhostScriptを利用する
make-comintを使ってみたかったので。
(defun postscript-process ()
(get-buffer-process (get-buffer "*postscript*")))
(defun run-postscript ()
(interactive)
(require 'comint)
(switch-to-buffer (make-comint "postscript" "gs")))
(push '("postscript" . utf-8) process-coding-system-alist)
(defun to-postfix (s)
(if (atom s) `(,s)
`(,@(cdr s)
,(car s))))
(defun send-postscript-no-newline (s &optional ps)
(unless ps
(setf ps (postscript-process)))
(unless ps
(error "no running postscript process"))
(dolist (obj (to-postfix s))
(if (listp obj)
(send-postscript-no-newline obj ps)
(comint-send-string ps (format "%s " obj)))))
(defun send-postscript (s &optional ps)
(unless ps
(setf ps (postscript-process)))
(unless ps
(error "no running postscript process"))
(send-postscript-no-newline s ps)
(comint-send-string ps "\n"))
(defun ps (&rest ss)
(dolist (s ss) (send-postscript-no-newline s))
(unless (postscript-process)
(error "no running postscript process"))
(comint-send-string (postscript-process) "\n"))
(defmacro with-ps-context (&rest body)
`(ps ,@(mapcar (lambda (s) `(quote ,s)) body)))
M-x run-postscriptで起動
;; 線を引く
(with-ps-context
gsave
newpath
(moveto 0 100)
(lineto 100 100)
stroke
grestore)
S式からPostScriptへの変換は、単純に順序を入れ替えているだけなのでたいした意味が無いような気がしますが、括弧にかこわれているほうが精神が落ち着きますね。
2010年9月17日金曜日
ELispでobjdumpを呼んでバイト列を逆アセンブルする
Linuxなどでプログラムを逆アセンブルする際には、objdumpを使うと便利です、たぶん。
Twitterなどでバイナリアンな方々が16進数で会話をしているのについていけなくて困るときのために、 Emacsからobjdumpを呼んでバイト列を逆アセンブルするようなELispを書いてみました。
バイト列といってもリストしか対応していませんが。
(defvar *arch-type* "i386")
(defun make-disasm-command (target file)
(format "objdump -b binary -m %s -D %s" target file))
(defun make-perl-command (lst tmp-file)
(concat
"perl -e 'print \""
(apply
'concat
(mapcar
(lambda (n)
(format "\\x%x" n))
lst))
"\"' >"
tmp-file))
(defun disasm-byte-list (lst)
(let ((tmp-file (make-temp-file "disasm_")))
(let ((file-buf (find-file-noselect tmp-file))
(cmd (make-disasm-command *arch-type* tmp-file)))
(shell-command (make-perl-command lst tmp-file))
(let ((buf (get-buffer-create "*disasm*")))
(shell-command cmd buf)
(delete-file tmp-file)
(pop-to-buffer buf)))))
;; example
(disasm-byte-list '(#x90))
超リードマクロに対抗してchar-codeの限界までリードマクロ
CLerはもっと他人のネタに反応すべきらしいので対抗してみた。
元ネタは @nitro_idiot さん の: SBCLのリーダを上書きして"超リードマクロ"を実装
組み込みのリーダを書き換えるのは敷居が高いので、ごく普通の方法にしました。
正規表現ライブラリのcl-ppcreを利用していますが、それ以外はごく標準的なCommon Lispです。
私はSBCLで動かしましたが、CL処理系なら大抵は動くのではないでしょうか。
(asdf:oos 'asdf:load-op :cl-ppcre)
(defun range-symbol-name-p (str)
(and (= (length (cl-ppcre:all-matches "\\.\\." str)) 2)
(= (length (cl-ppcre:split "\\.\\." str)) 2)))
(defun range-name->symbols (str)
(mapcar #'read-from-string (cl-ppcre:split "\\.\\." str)))
(let ((old (copy-readtable)))
(defun range-reader (stream ch1)
(unread-char ch1 stream)
(if (let ((*readtable* old)) (get-macro-character ch1))
(let ((*readtable* old)) (read stream))
(let ((*readtable* old))
(let ((sexp (read stream)))
(if (and (symbolp sexp)
(range-symbol-name-p (format nil "~A" sexp)))
(let ((syms (range-name->symbols (format nil "~A" sexp)))
(tmp (gensym)))
`(loop
:for ,tmp :from ,(first syms) :to ,(second syms)
:collect ,tmp))
sexp))))))
(let ((old (copy-readtable)))
(defun enable-range-reader ()
(loop
:for i :from 0 :below char-code-limit
:do (let ((ch (code-char i)))
(unless (or (get-macro-character ch)
(find ch '(#\Space #\Return #\Newline
#\Tab #\Linefeed #\Page
#\Backspace)))
(set-macro-character ch #'range-reader)))))
(defun disable-range-reader ()
(setf *readtable* old)))
;;; example
(enable-range-reader)
'0..10
;;=> (LOOP :FOR #:G1473 :FROM 0 :TO 10
;; :COLLECT #:G1473)
(remove-if #'oddp 0..10)
;;=> (0 2 4 6 8 10)
おかしい。仕様に乗っ取ったやり方のはずなのにアレゲな気配がぷんぷんする・・・。
2010年9月13日月曜日
list処理マクロ
map系関数のような処理をするマクロを作ってみました。
いつもどおり毒にも薬にもならない感じです。
(defvar *mapping-action-keywords*
`(:collect :collect-if
:remove :remove-if
:reverse :append
:funcall
:action))
(defvar *mapping-action-optional-keywords*
`(:if :key))
(defvar *mapping-action-optional-sub-keywords*
`(:else))
(defun action-keyword-p (sym)
(member sym *mapping-action-keywords*))
(defun action-optional-keyword-p (sym)
(member sym *mapping-action-optional-keywords*))
(defun action-optional-sub-keyword-p (sym)
(member sym *mapping-action-optional-sub-keywords*))
(defun parse-actions (actions acc)
(cond
((null actions) (nreverse acc))
((atom actions) (error "Invalid action form"))
(T
(unless (action-keyword-p (car actions))
(error "Invalid action form"))
(let ((rest (cdr actions)))
(let ((act
(cons (car actions)
(loop
:for exp = (car rest)
:until (or (null rest) (action-keyword-p exp))
:do (pop rest)
:collect exp))))
(parse-actions rest (cons act acc)))))))
(defun mapping-expander (actions expr)
(if (null actions)
expr
(let ((action (car actions))
(rest (cdr actions)))
(case (car action)
(:collect
(mapping-expander rest (collect-expander action expr)))
(:collect-if
(mapping-expander rest (collect-if-expander action expr)))
(:remove
(mapping-expander rest (remove-expander action expr)))
(:remove-if
(mapping-expander rest (remove-if-expander action expr)))
(:funcall
(mapping-expander rest (funcall-expander action expr)))
(:reverse
(mapping-expander rest `(reverse ,expr)))
(:append
(mapping-expander rest `(apply #'append ,expr)))
(:action
(mapping-expander rest (action-expander action expr)))
(error "Invalid mapping action keyword")))))
(defun collect-expander (action expr)
(let ((sym1 (gensym))
(sym2 (gensym)))
(destructuring-bind (obj &key if key &allow-other-keys) (cdr action)
`(remove ,obj ,expr
,@(if key `(:key ,key) nil)
,@(if if `(:test ,if) nil)
:test-not (lambda (,sym1 ,sym2) (eq ,sym1 ,sym2))))))
(defun collect-if-expander (action expr)
(destructuring-bind (fn &key if key &allow-other-keys) (cdr action)
`(remove-if-not ,fn ,expr
,@(if key `(:key ,key) nil))))
(defun remove-expander (action expr)
(destructuring-bind (obj &key if key &allow-other-keys) (cdr action)
`(remove ,obj ,expr
,@(if key `(:key ,key) nil)
,@(if if `(:test ,if) nil))))
(defun remove-if-expander (action expr)
(destructuring-bind (fn &key if key &allow-other-keys) (cdr action)
`(remove-if ,fn ,expr
,@(if key `(:key ,key)))))
(defun funcall-expander (action expr)
`(funcall ,(second action) ,expr))
(defun action-expander (action expr)
(let ((sym (gensym)))
(destructuring-bind (fn &key if key &allow-other-keys) (cdr action)
(cond
((and if key)
`(mapcar
(lambda (,sym)
(if (funcall ,if (funcall ,key ,sym))
(funcall ,fn (funcall ,key ,sym))
,sym))
,expr))
(if
`(mapcar
(lambda (,sym)
(if (funcall ,if ,sym)
(funcall ,fn ,sym)
,sym))
,expr))
(key
`(mapcar
(lambda (,sym)
(funcall ,fn (funcall ,key ,sym)))
,expr))
(T `(mapcar ,fn ,expr))))))
(defmacro mapping (lst &rest actions)
(mapping-expander (parse-actions actions nil) lst))
(mapping リスト キーワード 関数[オブジェクト] ...) といった形で利用します。出現順にキーワードごとに決まった処理を行い、リストを操作します。
;; example
(mapping
`(1 2 3 nil 4 5 9 nil)
:remove nil)
=> (1 2 3 4 5 9)
(mapping
`((1 2) (2 3) (3 4) (4 5))
:collect-if #'oddp :key #'car
:funcall #'(lambda (lst) (apply #'append lst))
:action #'1+ :if #'oddp)
=> (2 2 4 4)
2010年9月8日水曜日
古い値を利用する更新処理(Common Lisp)
Clojureのswap!はアトムの古い値を引数にして関数を呼び出し、その結果を新しい値とします。たしか。
似たような値の更新方法をCommon Lispで計4パターン書いてみました。
(defmacro update/fn-1! (generaized-variable update-fn &rest args)
(let ((old-val (gensym)))
`(let ((,old-val ,generaized-variable))
(setf ,generaized-variable (funcall ,update-fn ,old-val ,@args))
,old-val)))
(defmacro update/fn-2! (generaized-variable update-fn &rest args)
`(setf ,generaized-variable
(funcall ,update-fn ,generaized-variable ,@args)))
(defmacro update/fn-r-1! (generaized-variable update-fn &rest args)
(let ((old-val (gensym)))
`(let ((,old-val ,generaized-variable))
(setf ,generaized-variable (funcall ,update-fn ,@args ,old-val))
,old-val)))
(defmacro update/fn-r-2! (generaized-variable update-fn &rest args)
`(setf ,generaized-variable
(funcall ,update-fn ,@args ,generaized-variable )))
;;example
(let ((a 0)) (update/fn-1! a #'cons 1) a)
=>(0 . 1) ; (cons 古い値 引数)
(let ((a 0)) (update/fn-r-1! a #'cons 1) a)
=>(1 . 0) ; (cons 引数 古い値)
(let ((a 0)) (update/fn-1! a #'cons 1))
=>0 ; 古い値が返る
(let ((a 0)) (update/fn-2! a #'cons 1))
=>(0 . 1) ; 新しい値が返る
fnとfn-rの違いは、古い値が関数の引数として渡される際、第1引数となるか最後の引数となるかです。
1と2の違いは、返り値として古い値を返すか新しい値を返すかです。
どのパターンが有用なのかは、使ってみないことには判断できないような気がします。
Common Lisp でC風switch その2
C風switchをgoを使わない形に書き直して見ました。
caseの実行する式の部分に、後続で処理するすべての式をぶち込んでいます。
今回は明示的にブロックを抜けない限り、最後に評価された値が返ります。
(defmacro switch-2 (val &body clauses)
(let ((break (gensym)))
`(block ,break
(macrolet ((break-switch ()
`(return-from ,',break nil)))
(case ,val
,@(maplist
#'(lambda (rest)
`(,(caar rest) ,@(loop :for i in rest
:append (cdr i))))
clauses))))))
;; example
(switch-2 2
(2 (print 2))
(3 (print 3) (break-switch))
(4 (print 4)))
loopマクロの箇所は、最初はmapcanで書いていたのですが、なぜか処理が止まったので書き換えました。 mapcanが破壊的関数なため、maplistで段階的にアクセスしているリストの構造(clausesの一部)を変更してしまっているのだろうと思っています。
mapcanの非破壊版くらい仕様に入れておいて欲しかったです。
Common Lisp で C 風のswitch
Twitterを眺めていたらネタに出会ったので書いてみました。
(defmacro switch (val &body clauses)
(let ((syms (loop :repeat (length clauses)
:collect (gensym))))
`(tagbody
(case ,val
,@(mapcar
#'(lambda (clause sym)
`(,(car clause) (go ,sym)))
clauses
syms))
,@(mapcan
#'(lambda (clause sym)
`(,sym ,@(cdr clause)))
clauses
syms)
break)))
switchのclauses部にはCommon Lispのcaseと同様の式を書くことができます。
caseと異なるのは、条件に一致した場合goで目的の処理の前に飛ぶところです。このため、明示的に(go break)としない限り、一致した箇所以降の式をすべて実行します。
また、caseと異なり、tagbodyに展開するため返り値は常にnilになります。
;; 例
(switch 2
(2 (print 2) (go break))
(3 (print 3))
(4 (print 4)))
2
=> nil
(switch 3
(2 (print 2) (go break))
(3 (print 3))
(4 (print 4)))
3
4
=> nil
2010年9月7日火曜日
Common Lispでforマクロ その2
昨日の続きのforマクロ。
昨日のままだと、外側のletのbinding内でそんなシンボル無いです、と怒られて動かないことがあると思われるので修正．
せっかくなのでgithubを活用する事にしました。
http://github.com/kurohuku/for-loop
現状の動作はこんな感じです。
(for ((a :in (list 1 2))
(b :range 4 6)
(c :across #(10 11)))
(list a b c))
;; => ((1 4 10) (1 4 11) (1 5 10) (1 5 11)
;; (2 4 10) (2 4 11) (2 5 10) (2 5 11))
2010年9月6日月曜日
Common Lispでオレオレforマクロを定義する
Common Lispにはやたらと高機能なかわりに構文がおかしなloopマクロが存在します。
loopマクロは高機能なのですが、多重ループを処理しようとすると collect や nconc などのキーワードを使ってネストさせる必要があります(多分)。
Clojureのforは多重ループ(のようなもの)を簡潔に記述できるので、似たような構文をマクロで定義してみようと思います。
(defun enumrate (from to)
(loop :for i from from to to :collect i))
(defun pattern-binding (form pattern)
(if (/= (length form) (length pattern))
nil
(let ((binding
(mapcar
#'(lambda (f p)
(cond
((and (keywordp f) (keywordp p))
(if (eq f p)
f
nil))
((keywordp p) nil)
((symbolp p) (list p f))
(T (error "Invalid pattern or form"))))
form
pattern)))
(if (member nil binding)
nil
(remove-if #'keywordp binding)))))
(defmacro keyword-pattern-case (form &body pattern-clauses)
(if (null pattern-clauses)
nil
(let ((binding (pattern-binding form (caar pattern-clauses))))
(if binding
`(let ,binding
,@(cdar pattern-clauses))
`(keyword-pattern-case ,form ,@(cdr pattern-clauses))))))
(defun expand-for-forms (forms body)
(if (null forms)
`(progn ,@body)
(let ((form (car forms))
(rest (cdr forms))
(sym1 (gensym))
(sym2 (gensym)))
(let ((gather (if rest :nconc :collect)))
`(keyword-pattern-case ,form
((,(car form) :in ,sym1)
(loop :for ,(car form) :in ,sym1
,gather ,(expand-for-forms rest body)))
((,(car form) :range ,sym1 ,sym2)
(loop :for ,(car form) :in (enumrate ,sym1 (1- ,sym2))
,gather ,(expand-for-forms rest body))))))))
(defmacro for ((&rest forms) &body body)
(unless (every #'listp forms)
(error "Invalid forms"))
(if (null forms)
`(progn
,@body)
(expand-for-forms forms body)))
;; example
(for ((i :in '(1 2 3))
(j :in '(4 5 6)))
(list i j))
;; => ((1 4) (1 5) (1 6) (2 4) (2 5) (2 6) (3 4) (3 5) (3 6))
(for ((i :in (list 2 3))
(j :range 10 13))
(list i j))
;; =>((2 10) (2 11) (2 12) (3 10) (3 11) (3 12))
現在、formとして許されるのは loopマクロのinに展開されるものと、 for - from - toに展開されるものだけです。また、手抜きパターンマッチのせいで:inや:rangeはキーワードでなければなりません。
展開後の一番外側のletのせいで警告が出てきますし、まだまだ改良が必要なようです。
2010年9月1日水曜日
Common Lisp でC++風出力
githubを試しに使ってみるテスト。
C++のストリーム出力っぽい雰囲気になるように gray streamsを使ってみました。
http://github.com/kurohuku/manip-stream
動作させるには trivial-gray-streams が必要です。
>(<< (make-instance 'manip-output-stream
:stream *standard-output*)
+binary+
(set-width 8)
(set-fill #\0)
+left+
3)
00000011
#<MANIP-OUTPUT-STREAM {DDF79C9}>
stream-write-stringの引数がstream-manipulatorクラスのオブジェクトの場合、manip-streamを引数としてactionスロットの関数が呼び出され、manip-streamの状態を変化させます。
format関数は高機能なかわりにやたらと複雑なので、こういった書き方のほうが多少はわかりやすくなるかもしれません。
2010年8月28日土曜日
ClojureでJWindowを作る
ふせんちっくなウィンドウを作ってみます。
無駄にクリック時の動作をかえられるようにしたりしてみました。
;;; MouseAdapter
(ns example.MouseAdapter
(:gen-class
:extends java.awt.event.MouseAdapter
:init init
:state actionTable
:constructors {[clojure.lang.Atom][] [][]}
:main false
;; :expose-methods {mouseClicked mouseClicked}
:methods
[
[clickAction [java.awt.event.MouseEvent] void]
[doubleClickAction [java.awt.event.MouseEvent] void]
[rightClickAction [java.awt.event.MouseEvent] void]
]))
(defmacro call-action [action-type]
`(let [act# (get @(.actionTable ~'this) ~action-type)]
(when act#
(act# ~'evt))))
(defn -init ([action-table-atom] [[] action-table-atom])
([] (letfn ((dummy [evt] nil))
[[] (atom {:click-action dummy :double-click-action dummy :right-click-action dummy :press-action dummy
:drag-action dummy})])))
(defn -clickAction [this evt] (call-action :click-action))
(defn -doubleClickAction [this evt] (call-action :double-click-action))
(defn -rightClickAction [this evt] (call-action :right-click-action))
(defn -mouseClicked [this evt]
(cond
(= java.awt.event.MouseEvent/BUTTON3 (.getButton evt)) (.rightClickAction this evt)
(= java.awt.event.MouseEvent/BUTTON1 (.getButton evt))
(if (>= (.getClickCount evt) 2)
(.doubleClickAction this evt)
(.clickAction this evt))))
(defn -mousePressed [this evt]
(call-action :press-action))
(defn -mouseDragged [this evt]
(call-action :drag-action))
(defn alter-action [adapter type action]
(swap! (.actionTable adapter) assoc type action))
(defn set-action-table [adapter action-table]
(set! (.actionTable adapter) action-table))
(defn get-action-table [adapter]
@(.actionTable adapter))
(require 'example.MouseAdapter)
(defstruct item :name :object :listener)
(defstruct husen-window :window :label :adapter :popup :item-map :size)
(def *default-husen-size* (list 150 50))
(defn get-x [size] (first size))
(defn get-y [size] (second size))
(defmacro define-and-add-item [[popup item-map name text] [evt] & action-performer]
`(let [obj# (javax.swing.JMenuItem. ~text)
listener# (proxy [java.awt.event.ActionListener][]
(actionPerformed [~'evt]
~@action-performer))]
(.addActionListener obj# listener#)
(.add ~'popup obj#)
(swap! ~'item-map assoc ~'name (struct item obj# listener#))))
(defn make-husen-window []
(let [win (javax.swing.JWindow.)
adapter (atom (example.MouseAdapter.))
popup (javax.swing.JPopupMenu.)
item-map (atom nil)
lbl (javax.swing.JLabel. "")
size (atom *default-husen-size*)
point-map (atom {:location nil :press-point nil})]
(.setSize lbl (get-x @size) (get-y @size))
(.setVisible lbl true)
(.add (.getContentPane win) lbl)
(define-and-add-item [popup item-map :set-visible-item "setVisible(false)"]
[evt]
(.setVisible win false))
(define-and-add-item [popup item-map :set-text-item "Set Text"]
[evt]
(let [txt (javax.swing.JOptionPane/showInputDialog (.getContentPane win) "Input Text:")]
(when txt
(.setText lbl txt))))
(define-and-add-item [popup item-map :set-icon-item "Set Icon"]
[evt]
(let [chooser (javax.swing.JFileChooser.)]
(if (= javax.swing.JFileChooser/APPROVE_OPTION
(.showOpenDialog chooser (.getContentPane win)))
(let [icon (javax.swing.ImageIcon. (.. chooser getSelectedFile getAbsolutePath))]
(if icon
(.setIcon lbl icon)
(.setText lbl (.. chooser getSelectedFile getName)))))))
(define-and-add-item [popup item-map :set-default-size "Set Default Size"]
[evt]
(.setSize win (get-x @size) (get-y @size))
(.setSize lbl (get-x @size) (get-y @size)))
(define-and-add-item [popup item-map :set-icon-size "Set Icon Size"]
[evt]
(let [icon (.getIcon lbl)
height
(if (isa? (.getClass icon) javax.swing.ImageIcon)
(.getHeight (.getImage icon))
(.getIconHeight icon))
width
(if (isa? (.getClass icon) javax.swing.ImageIcon)
(.getWidth (.getImage icon))
(.getIconWidth icon))]
(.setSize win width height)
(.setSize lbl width height)))
(example.MouseAdapter/alter-action
@adapter
:right-click-action
(fn [evt]
(.show popup (.getComponent evt) (.getX evt) (.getY evt))))
(example.MouseAdapter/alter-action
@adapter
:press-action
(fn [evt]
(swap! point-map assoc :press-point (.getPoint evt))))
(example.MouseAdapter/alter-action
@adapter
:drag-action
(fn [evt]
(swap! point-map assoc :location (.getLocation win))
(let [{p :press-point loc :location} @point-map
x (-
(+ (.x loc)
(.getX evt))
(.getX p))
y (- (+ (.y loc) (.getY evt)) (.getY p))]
(.setLocation win x y))))
(doto win
(.addMouseListener @adapter)
(.addMouseMotionListener @adapter)
(.setSize (get-x @size) (get-y @size))
(.setVisible true))
(struct husen-window win lbl adapter popup item-map size)))
Clojureのメソッドチェイン風マクロをCommon Lispのマクロで書いてみる
すでにいろいろなところで書かれているネタな気はしますが、書いてみました。
->はexpを次の式の第一引数の位置に挿入し、 ->>はexpを次の式の最後の引数の位置に挿入します。
(defmacro -> (exp &rest rest)
(if rest
(let ((fst (car rest))
(rest (cdr rest)))
(typecase fst
(symbol `(-> (,fst ,exp) ,@rest))
(atom `(-> (,fst ,exp) ,@rest))
(list `(-> (,(car fst) ,exp ,@(cdr fst)) ,@rest))))
exp))
(defmacro ->> (exp &rest rest)
(if rest
(let ((fst (car rest))
(rest (cdr rest)))
(typecase fst
(symbol `(->> (,fst ,exp) ,@rest))
(atom `(->> (,fst ,exp) ,@rest))
(list `(->> (,(car fst) ,@(cdr fst) ,exp) ,@rest))))
exp))
Clojureでバイナリファイルを読み込む
実践Common Lisp(Practical Common Lisp)のバイナリファイルのパースっぽいものを書こうとしてみました。
(defmulti read-binary-class (fn [class in] class))
(defmulti read-binary-raw (fn [class in] class))
(def *class-list* (atom []))
(def *direct-super-classes-map* (atom {}))
(defn defined-class-p [sym]
(some #(= sym %1) @*class-list*))
;; Symbol like <xxx> means forward declaration
(defn forward-declaration-symbol-p [sym]
(let [tmp (str sym)
len (count tmp)]
(if (<= len 2)
false
(and (= \< (first tmp)) (= \> (last tmp))))))
(defn deref-forward-declaration-symbol [sym map]
`(get ~map '~(symbol (subs (str sym)
1
(dec (count (str sym)))))))
(defn deref-forward-declaration-symbol-recur [obj m]
(cond
(symbol? obj)
(if (forward-declaration-symbol-p obj)
(deref-forward-declaration-symbol obj m)
obj)
(list? obj) (map
#(deref-forward-declaration-symbol-recur %1 m)
obj)
(number? obj) obj
true obj))
(defn make-binary-object
([name]
{:binary-class-name name})
([name map]
(assoc map :binary-class-name name )))
(defn get-direct-super-classes [name]
(get @*direct-super-classes-map* name))
(defmacro with-map [map bind & body]
`(let [~bind ~map]
~@body))
(defn expand-clause-for-reader [clause in]
(if (list? (second clause))
;; (second clause) = (:list class expr)
(if (= (first (second clause)) :list)
;; (:list class expr) expr -> length
(let [[_ class expr] (second clause)
m (gensym "map")]
`(with-map ~m
(assoc ~m
'~(first clause)
(doall
(for [_# (range ~(deref-forward-declaration-symbol-recur expr m))]
~(if (defined-class-p class)
`(~'read-binary-class '~class ~in)
`(~'read-binary-raw '~class ~in)))))))
;; return class name (symbol) expr
(let [m (gensym "map")]
`(with-map ~m
(assoc ~m
'~(first clause)
(let [sym# ~(deref-forward-declaration-symbol-recur (second clause) m)]
(if (~'defined-class-p sym#)
(~'read-binary-class sym# ~in)
(~'read-binary-raw sym# ~in)))))))
`(assoc '~(first clause)
~(if (defined-class-p (second clause))
`(~'read-binary-class '~(second clause) ~in)
`(~'read-binary-raw '~(second clause) ~in)))))
(defn expand-clauses-for-reader [m clauses in]
`(-> ~m
~@(map (fn [clause]
(expand-clause-for-reader clause in))
clauses)))
(defn expand-read-binary-body [name in clauses]
(let [var (gensym "var")
class (gensym "class")
tmp (gensym "tmp")]
`(let [super-classes# (get-direct-super-classes '~name)
~tmp (apply merge
(map
(fn [super#]
(~'read-binary-class super# ~in))
super-classes#))]
~(expand-clauses-for-reader tmp clauses in))))
(defmacro def-binary-raw [name reader]
`(do
(defmethod read-binary-raw '~name ~@reader)))
;; clause = (name class)
(defmacro def-binary-class [name [& supers] & clauses]
(let [obj (gensym "obj")
in (gensym "in")
out (gensym "out")
classname (gensym "classname")]
`(do
(swap! *class-list* conj '~name)
(swap! *direct-super-classes-map* assoc '~name '~supers)
(defmethod read-binary-class '~name [~classname ~in]
~(expand-read-binary-body name in clauses)))))
;;; examples
(def-binary-raw u1
;; reader
([type in]
(bit-and 255 (.read in))))
;; big endian
(def-binary-raw u2
;; reader
([type in]
(+ (bit-shift-left (bit-and 255 (.read in)) 8)
(bit-and 255 (.read in)))))
(def-binary-raw u4
;; reader
([type in]
(+ (bit-shift-left (bit-and 255 (.read in)) 24)
(bit-shift-left (bit-and 255 (.read in)) 16)
(bit-shift-left (bit-and 255 (.read in)) 8)
(bit-and 255 (.read in)))))
;;; java class file format
;; tagはcp-infoが保持し、cp-infoのinfo部にtagに応じた
;; クラスの値が入るようにする
(def-binary-class constant-class-info []
(name-index u2))
(def-binary-class constant-fieldref-info []
(class-index u2)
(name-and-type-index u2))
(def-binary-class constant-methodref-info []
(class-index u2)
(name-and-type-index u2))
(def-binary-class constant-interface-methodref-info []
(class-index u2)
(name-and-type-index u2))
(def-binary-class constant-string-info []
(string-index u2))
(def-binary-class constant-integer-info []
(bytes u4))
(def-binary-class constant-float-info []
(bytes u4))
(def-binary-class constant-long-info []
(high-bytes u4)
(low-bytes u4))
(def-binary-class constant-double-info []
(high-bytes u4)
(low-bytes u4))
(def-binary-class constant-name-and-type-info []
(name-index u2)
(descriptor-index u2))
(def-binary-class constant-utf8-info []
(length u2)
(bytes (:list u1 <length>)))
(def-binary-class cp-info []
(tag u1)
(info (case <tag>
7 'constant-class-info
9 'constant-fieldref-info
10 'constant-methodref-info
11 'constant-interface-methodref-info
8 'constant-string-info
4 'constant-integer-info
3 'constant-float-info
5 'constant-long-info
6 'constant-double-info
12 'constant-name-and-type-info
1 'constant-utf8-info)))
(def-binary-class attribute-info []
(attribute-name-index u2)
(attribute-length u4)
(info (:list u1 <attribute-length>)))
(def-binary-class method-info []
(access-flag u2)
(name-index u2)
(descriptor-index u2)
(attributes-count u2)
(attributes (:list attribute-info <attributes-count>)))
(def-binary-class field-info []
(access-flags u2)
(name-index u2)
(descriptor-index u2)
(attributes-count u2)
(attributes (:list attribute-info <attributes-count>)))
(def-binary-class jvm-class-file []
(magic u4)
(minor-version u2)
(major-version u2)
(constant-pool-count u2)
(constant-pool (:list cp-info (- <constant-pool-count> 1)))
(access-flags u2)
(this-class u2)
(super-class u2)
(interfaces-count u2)
(interfaces (:list u2 <interfaces-count>))
(fields-count u2)
(fields (:list field-info <fields-count>))
(methods-count u2)
(methods (:list method-info <methods-count>))
(attributes-count u2)
(attributes (:list attribute-info <attributes-count>)))
(defn test-read-binary-class [class fname]
(with-open [in (java.io.FileInputStream. fname)]
(read-binary-class class in)))
(use 'clojure.contrib.trace)
(defn test-read-binary-class-with-trace [class fname]
(dotrace [read-binary-class read-binary-raw]
(with-open [in (java.io.FileInputStream. fname)]
(read-binary-class class in))))
2010年8月26日木曜日
符号的プログラミングのすすめ on Common Lisp
初めに
Lispの括弧ネタ(注1)に触発されて思い浮かんだネタを書いていきます。
注1: @nitro_idiotさん http://e-arrows.sakura.ne.jp/2010/08/is-lisp-really-has-too-many-parenthesis.html
符号的プログラミングについて
Perlは非常にリッチな言語です。世界はPerlでかかれているらしいです。Perl最強ですね。
このPerl言語のエキスパートたちが、Perlの持つリッチな機能をフル活用するプログラミングスタイルを符号的プログラミングと呼びます。
Perlには及ばないかもしれませんが、私の大好きなCommon Lispも非常にリッチな言語なため、符号的プログラミングを行うことができます。
これから、一般的なスタイルのCommon Lispプログラムをいかにして符号的なスタイルに変換していくかを見ていきましょう。
一般的なスタイルのCommon Lispプログラム
元ネタに合わせて、階乗の値を順番に表示していくプログラムを書いてみます。
(defun fact-1 (to)
(labels ((inner (n acc)
(when (<= n to)
(format t "~A! = ~A~%" n acc)
(inner (1+ n) (* (1+ n) acc)))))
(inner 1 1)))
(fact-1 20)
関数fact-1の内部で、関数innerを定義し、再帰呼び出しを行っています。
この関数を徐々に符号的に改良していきます。
名前は付けない、使わない
fact-1を眺めて、まず気づく問題点は内部関数に名前を付けている点です。 Common Lispには無名関数を作るlambdaマクロ(注2)があるので、これを利用しましょう。
注2: 関数呼び出しの位置にlambdaフォームがくると特別扱いされるので、他のシンボルより特殊な存在だと思います。
(defun fact-2 (to)
((lambda (fn n acc)
(when (<= n to)
(format t "~A! = ~A~%" n acc)
(funcall fn fn (1+ n) (* (1+ n) acc))))
(lambda (fn n acc)
(when (<= n to)
(format t "~A! = ~A~%" n acc)
(funcall fn fn (1+ n) (* (1+ n) acc))))
1 1))
関数に名前を付けることは避けられましたが、今度はまったく同じ式を2回も記述しなければならないという問題が発生しました。関数(サブルーチン)にも言えますが、同じものはまとめてしまうのが普通でしょう。
しかし、このlambdaフォームをまとめるために名前を付けてしまっては本末転倒です。そこで、共有構造を利用することにしましょう。
(defun fact-3 (to)
(#1=(lambda (fn n acc)
(when (<= n to)
(format t "~A! = ~A~%" n acc)
(funcall fn fn (1+ n) (* (1+ n) acc))))
#1#
1 1))
これで見やすくなりました。
せっかくなので、defunもlambdaに直してみましょう。
(set 'fact-4
(lambda (to)
(#1=(lambda (fn n acc)
(when (<= n to)
(format t "~A! = ~A~%" n acc)
(funcall fn fn (1+ n) (* (1+ n) acc))))
#1#
1 1)))
setはマクロではなく関数です。第1引数のシンボルに、第2引数引数の値をセットします。 setは関数スロットではなく普通の値を格納するスロットに第2引数をセットするため、関数呼び出しにはfuncallが必要となります。
> (funcall fact-4 20)
さて、本題に戻ります。内部関数の名前は消え去りましたが、この関数にはまだまだ名前がたくさん残っています。
まずは関数名から消していきましょう。関数は単純に他のシンボルにセットすればいいだけなので簡単です。
(setf (symbol-function '@) #'funcall)
(setf (symbol-function '~) #'format)
(set 'fact-5
(lambda (to)
(#1=(lambda (fn n acc)
(when (<= n to)
(~ t "~A! = ~A~%" n acc)
(@ fn fn (1+ n) (* (1+ n) acc))))
#1#
1 1)))
(@ fact-5 20)
次は変数名を消していきましょう。先ほどから何度か話題に出ていましたが、 Common Lispのシンボルには値をセットするスロットが複数あるので、関数と通常の変数で同じシンボルを別々の意味で利用できます。
(defparameter & t)
(set 'fact-6
(lambda (>)
(#1=(lambda (@ - *)
(when (<= - >)
(~ & "~A! = ~A~%" - *)
(@ @ @ (1+ -) (* (1+ -) *))))
#1#
1 1)))
whenはマクロなので、setfで設定できません(多分)
なので、他のマクロでラップしてしまいましょう。
(defmacro ? (&rest args)
`(when ,@args))
(set 'fact-7
(lambda (>)
(#1=(lambda (@ - *)
(? (<= - >)
(~ & "~A! = ~A~%" - *)
(@ @ @ (1+ -) (* (1+ -) *))))
#1#
1 1)))
lambdaと括弧を符号的にする
lambdaも同じように対処できるかと思いきや、「注2」に書いたように、関数呼び出し位置に現れるlambdaフォームは特別扱いされるため、うまくいきません。
;; 例
((lambda (x y) (list x y)) 2 3)
-> (2 3)
(defmacro my-lambda (&rest args)
`(lambda ,@args))
(macroexpand-1 '(my-lambda (x y) (list x y)))
->(LAMBDA (X Y) (LIST X Y))
((my-lambda (x y) (list x y)) 2 3)
この問題を解決するためには、自分の定義したシンボルが読み込みんむタイミングでlambdaに変化してくれれば良さそうです。
Common Lispでは、実行時、コンパイル時(≒マクロ)の他に、読み込み時の動作を定義するリーダマクロが存在します。
リーダマクロを利用すれば、問題を解決できるに違いありません。
(set-macro-character
#\^
#'(lambda (stream char)
(declare (ignore char))
`(lambda ,@(read-delimited-list #\) stream t))))
(set 'fact-8
^ (>)
(#1=^ (@ - *)
(? (<= - >)
(~ & "~A! = ~A~%" - *)
(@ @ @ (1+ -) (* (1+ -) *))))
#1#
1 1)))
ここまで書くとふと思います。この括弧の群れは符号的ではないのではないか、と。
消し去ってやりましょう。
(set-macro-character
#\!
#'(lambda (stream char)
(declare (ignore char))
(read-delimited-list #\$ stream t)))
(set-macro-character
#\^
#'(lambda (stream char)
(declare (ignore char))
`(lambda ,@(read-delimited-list #\$ stream t))))
! set 'fact-9
^ ! > $
! #1= ^ ! @ - * $
! ? ! <= - > $
! ~ & "~A! = ~A~%" - * $
! @ @ @ ! 1+ - $ ! * ! 1+ - $ * $ $ $ $
#1#
1 1 $ $ $
ここまでくれば後一歩です。最後に残った関数名、fact-nを取り去り、直接引数を与えて呼び出してみましょう。
! @ ^ ! > $
! #1= ^ ! @ - * $
! ? ! <= - > $
! ~ & "~A! = ~A~%" - * $
! @ @ @ ! 1+ - $ ! * ! 1+ - $ * $ $ $ $
#1#
1 1 $ $
20 $
終わりに
最初と最後のプログラムを比べると、もはや別のプログラミング言語ではないかと思えてしまいます。しかし、これはどちらも同じCommon Lispプログラムなのです。
符号的プログラミングは、一般的なプログラミングスタイルとはかけ離れているように見え、一部のエキスパートにしか駆使することの出来ない黒魔術かのような錯覚を覚えますが、一つ一つの要素を抜き出して考えれば、私たちが日頃書いているごく普通のプログラムとかわりはありません。
Perlは非常に高機能ですが敷居が高いのが難点です。その点、Common Lispは一般的なスタイルのプログラムも非常に書きやすいので、符号的プログラミング入門者にもおすすめです。
Perlを極めた人も、これからプログラミングを始める人も、ぜひ一度Common Lispで遊んでみてください。
2010年8月19日木曜日
Emacsで指定した正規表現が現れる場所までkillする
C-hやC-dを連打するのに疲れたので、タイトルどおりのEmacs Lisp関数を作ってみた。 M-dなどをうまく駆使すれば連打の必要はなかったのかもしれないけれど。
実は組み込みで求めている機能がある、なんてことはないと信じたい。
(defun kill-to-regexp-forward (regexp)
(interactive "sRegexp:")
(let ((start-point (point)))
(when (re-search-forward regexp nil t)
(re-search-backward regexp nil t)
(kill-region start-point (point)))))
(defun kill-to-regexp-backward (regexp)
(interactive "sRegexp:")
(let ((start-point (point)))
(when (re-search-backward regexp nil t)
(re-search-forward regexp nil t)
(kill-region (point) start-point))))
現状、正規表現にマッチした部分は切り取らないようにしている。使ってみて、マッチした部分も消したほうが便利そうなら変更しようと思う．
2010年8月17日火曜日
旅行履歴(2010/08/11 - 2010/08/15)
青春18切符で京都と長野に行ってきました。とりあえず記録を残しておこう。
- 1日目
- 京都
- 夕食 錦魚亭
- 飲み 酒Bar よらむ
- 飲んだ酒
- 麒麟 時醸酒
- 十酒(とき) 1988
- 開春 純米蝶辛口
- 舞美人 純米 常温生熟 おりがらみ
- 能登 3年酒
- 宿泊：FIRST CABIN
- 2日目
- 京都
- 八坂神社
- 平安神宮 お神酒(橘酒)購入
- 吉田山 大文字の形は見えず
- 伏見稲荷大社
- 飲み たかはし (日本酒酒バー)
- 飲んだ酒
- 竹鶴(日本酒) 純米原酒
- 出置桜 強力 純米
- 竹鶴 純米吟醸 古酒
- 勝駒
- 宿泊:FIRST CABIN
- 3日目
- 京都 -> 長野(岡谷)
- 岡谷太鼓祭り
- 宿泊:岡谷セントラルホテル
- 4日目
- 長野
- 諏訪大社 春宮、秋宮、前宮、本宮
- 北斗神社。本宮の近くの急な階段を昇ったところ。
- 日本酒購入@二葉屋酒店: 黒松仙醸 寒造り純米 新春仕込み だるま市しぼり(低温熟成)
- 昼食:本宮の近くの蕎麦屋
- 夕食:御うな 小松屋 の 御うなまぶし
- 宿泊:岡谷セントラルホテル
- 5日目
- 帰路
日本酒の古酒にときめいた。
冷やし飴を始めて飲んだが、ショウガの風味があるやつで結構おいしかった。
2010年8月4日水曜日
2010年8月3日火曜日
McCLIMで升目を描く
formatting-tableを利用すれば良さそうだけど、無理やりな感じが現れてる。
LispworksのCLIMのページを参考にした。
(asdf:oos 'asdf:load-op :mcclim)
;;(asdf:oos 'asdf:load-op :mcclim-truetype)
(in-package :clim-user)
(defun output-table (&key (stream *standard-output*)
inter-row-spacing
inter-column-spacing)
(clim:formatting-table
(stream :x-spacing inter-row-spacing
:y-spacing inter-column-spacing)
(dotimes (i 3)
(clim:formatting-row
(stream)
(dotimes (j 3)
(clim:formatting-cell
(stream)
(clim:draw-rectangle* stream 10 10 50 50 :filled nil)))))))
(define-application-frame formatting-test-frame
()
()
(:menu-bar t)
(:panes
(app-pane :application
:min-width 150
:min-height 150
:scroll-bar t
:display-time :command-loop
:display-function #'(lambda (frame stream)
(output-table :stream stream :inter-row-spacing '(0 :line) :inter-column-spacing '(0 :line))))
)
(:layouts
(default (horizontally () app-pane))))
(define-formatting-test-frame-command (com-quit :menu t) ()
(frame-exit *application-frame*))
;;(run-frame-top-level (make-application-frame 'formatting-test-frame))
2010年7月31日土曜日
ClojureでBrainf*ck
プログラミング言語の勉強する時は、
- Hello World!
- FizzBuzz
- Brainfu*k
というのを最初に書いてみることにしている。
ClojureでもBrainfu*kを書いてみた。
(defstruct env :inst :pc :program :last :ptr :memory)
(defmulti execute :inst)
(defmethod execute \> [{pc :pc ptr :ptr :as env}] ;increment pointer
(merge env
{:pc (inc pc),
:ptr (inc ptr)}))
(defmethod execute \< [{pc :pc ptr :ptr :as env}] ;decrement pointer
(merge env
{:pc (inc pc),
:ptr (dec ptr)}))
(defmethod execute \+ [{pc :pc ptr :ptr mem :memory :as env}] ;increment value
(merge env
{:pc (inc pc),
:memory
(assoc mem ptr
(let [val (get mem ptr)]
(if (nil? val) 1 (inc val))))}))
(defmethod execute \- [{pc :pc ptr :ptr mem :memory :as env}] ;decrement value
(merge env
{:pc (inc pc),
:memory
(assoc mem ptr
(let [val (get mem ptr)]
(if (nil? val) -1 (dec val))))}))
(defmethod execute \. [{pc :pc ptr :ptr mem :memory :as env}] ;put char
(let [val (get mem ptr)]
(.print System/out (format "(%c%d)"
(if (nil? val) 0 val)
(if (nil? val) 0 val))))
(assoc env :pc (inc pc)))
(defmethod execute \, [{pc :pc ptr :ptr mem :memory :as env}] ;get char
(print *in*)
(merge
env
{:pc (inc pc),
:memory (assoc mem ptr (.read System/in))}))
(defmethod execute \[ [{pc :pc ptr :ptr
program :program mem :memory :as env}] ;while(*ptr){
(let [val (get mem ptr)]
(if (or (nil? val) (zero? val))
(loop [indexed
(drop pc
(map
#(cons %1 %2)
program
(iterate inc 0)))]
(if (= (first (first indexed)) \])
(assoc env :pc (inc (rest (first indexed))))
(recur (rest indexed))))
(assoc env :pc (inc pc)))))
(defmethod execute \] [{pc :pc ptr :ptr
program :program mem :memory :as env}] ;}
(let [val (get mem ptr)]
(if (not (or (nil? val) (zero? val)))
(loop [indexed
(reverse
(take pc
(map
#(list %1 %2)
program
(iterate inc 0))))]
(if (= (first (first indexed)) \[)
(assoc env :pc (inc (second (first indexed))))
(recur (rest indexed))))
(assoc env :pc (inc pc)))))
(defn load-instruction [{pc :pc program :program :as env}]
(assoc env :inst (nth program pc)))
(defn brainfuck [program]
(loop [env (struct env nil 0 program (count program) 0 {})]
(if (< (:pc env) (:last env))
(recur (execute (load-instruction env)))
'done)))
;;(brainfuck "+[>,.<]")
;;(brainfuck "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+.")
2010年7月29日木曜日
clojureでコンパイル
clojureのcompile関数をうまく動かすまでに結構手間取ったのでメモ
1. ソースの置かれているディレクトリ(パッケージのルートになるとこ)にクラスパスが通っている
2. カレントディレクトリからみた出力先(*compile-path*)ディレクトリにクラスパスが通っている
3. 出力先ディレクトリが存在する <- ここ重要
4. SLIME経由で使ってるなら、ただしくクラスパスが設定されるようになっているか注意する
2010年7月25日日曜日
ジンジャーエールを作る-その1
今日の昼食を食べた店で、自家製ジンジャーエールがあったので頼んでみたらおいしかった。自分でも作ってみたい、そしてそのジンジャーエールでモスコミュールを作りたい、と思った。レシピを調べて見たところ、割と皆さん自分の好きなように作っているっぽかったので、簡単そうなハチミツに付けるだけのものを試してみた。
材料は
- 新ショウガ 150g (スライス)
- はちみつ ショウガが浸るくらい
- シナモン 粉の奴を大さじ1杯
これだけ。こいつを炭酸水で割るとジンジャーエールが出来上がるらしい。シナモンが多すぎるような気がするが、入れてしまったものはしかたない。これらを瓶の中にぶち込んで冷蔵庫で放置する。
果たして、まともに飲めるものができるのだろうか。
2010年7月18日日曜日
Emacs LispでファイルIOその2
open,closeを書いたのでついでに with-open-fileも書いてみた。
(defmacro with-open-file (clause &rest body)
(destructuring-bind
(direction filename stream)
(let ((tmp (reverse clause)))
(if (= (length tmp) 2)
(cons :input tmp)
tmp))
`(let ((,stream (open ,filename ,direction)))
(prog1
(progn
,@body)
(close ,stream)))))
McCLIMでグラフを書く
McCLIMでグラフを描画する。ノードが循環すると繰り返し処理をしようとして落ちるようだ。
(require :asdf)
(asdf:oos 'asdf:load-op :mcclim)
(in-package :clim-user)
(define-application-frame graph-frame ()
()
(:menu-bar t)
(:panes
(app :application
:min-width 200
:min-height 200
:scroll-bars nil
:display-time :command-loop
:display-function 'draw))
(:layouts
(default (horizontally () app))))
(define-graph-frame-command (com-quit :menu t) ()
(frame-exit *application-frame*))
(defstruct node (name "") (children nil))
(defparameter gl (let* ((2a (make-node :name "2A"))
(2b (make-node :name "2B"))
(2c (make-node :name "2C"))
(1a (make-node :name "1A" :children (list 2a 2b)))
(1b (make-node :name "1B" :children (list 2b 2c))))
(make-node :name "0" :children (list 1a 1b))))
(define-presentation-type node ())
(defun test-graph (root-node &rest keys)
(apply #'clim:format-graph-from-root gl
#'(lambda (node stream)
(clim:surrounding-output-with-border (stream :shape :underline)
(write-string (node-name node) stream)))
#'node-children
keys))
(defgeneric draw (frame stream))
(defmethod draw ((frame application-frame) stream)
(declare (ignore frame))
(test-graph gl :stream stream))
(defun run ()
(clim:run-frame-top-level (clim:make-application-frame 'graph-frame)))
McCLIMはPostScriptを出力する事もできるらしい。
(defun output-postscript (filename)
(with-open-file (out filename :direction :output)
(with-output-to-postscript-stream
(stream out
:header-comments '(:title "PostScript Test"))
(test-graph gl :stream stream))))
Emacs LispでファイルIO
Emacs Lispで、ファイルから入力する処理をCommonLispのノリで書こうとしたら・・・
>(require 'cl)
>(with-open-file (in "hoge.txt" :direction :input)
(with-open-file (out "fuga.txt" :direction :output)
(princ (read in) out)))
Debugger entered--Lisp error: (void-function with-open-file)
あれ?
>(open "hoge.txt")
Debugger entered--Lisp error: (void-function open)
・・・あれ?
ELispってファイルオープンしてストリームを作ることができないのか・・・。
調べて見たところ、streamとして使えるのは以下のとおりらしい。
- 入力
- buffer
- marker (バッファ内のマーカの位置)
- string
- function (2種類の呼び出し方を扱えるもの)
- t (ミニバッファ)
- nil (standard-input)
- symbol (関数定義)
- 出力
- buffer
- marker (バッファ内のマーカの位置)
- function (1つの文字を引数にして呼ばれる)
- t (エコー領域)
- nil (standard-output)
- symbol (関数定義)
つまりはバッファを介さないとファイル入出力ができないっぽい。
なので、open/closeでストリームを扱っているつもりになれる関数を書いてみた。
(require 'cl)
(setf *opening-stream-buffers*
(make-hash-table))
(defmacro with-default-values (binds &rest body)
`(progn
,@(mapcar
(lambda (bind)
`(unless ,(first bind)
(setf ,(first bind) ,(second bind))))
binds)
,@body))
(defun open (filename &optional direction)
(with-default-values
((direction :input))
(let ((buf (create-file-buffer filename)))
(when (eq direction :input)
(with-current-buffer buf
(insert-file-contents filename)))
(setf (gethash buf *opening-stream-buffers*) (list direction filename))
buf)))
(defun close (buf)
(when (eq (first (gethash buf *opening-stream-buffers*))
:output)
(with-current-buffer buf
(write-region
(point-min) (point-max)
(second (gethash buf *opening-stream-buffers*))))
(kill-buffer buf)))
2010年5月19日水曜日
ネストしたquasiquoteの悪夢
S式 -> Cのトランスレータを書こうと前々から思っていじってはいるが、結局うまい方法を思いつけずに挫折ということを繰り返している。
今の考えはマクロ -> make-instance -> emitという流れにしようというもの。とりあえずマクロとオブジェクトの定義部分を書こうとして、自分でも理解しきれないネストしたquasiquoteを書いたのでネタとして載せておく。
myパッケージは自分の使うOn LispやANSI Common Lispその他から拝借した関数などをまとめたパッケージ。
(cl:defpackage :trans
(:import-from :common-lisp &optional &rest &body &key))
(in-package :trans)
(cl:defun remove-lambda-keywords (lst)
(cl:mapcar
#'(cl:lambda (x)
(cl:car (my:mklist x)))
(cl:remove-if
#'(cl:lambda (x) (cl:member x '(&body &optional &key &rest)))
lst)))
(cl:defun make-accessor-sym (sym)
(my:symb sym "-OF"))
(cl:defun make-keyword (sym)
(cl:intern (my:mkstr sym) :keyword))
(cl:defun make-slot (arg)
`(,arg :accessor ,(make-accessor-sym arg)
:initarg ,(make-keyword arg)
:initform cl:nil))
;;引数のデフォルト値はnil
(cl:defmacro define-c-class (name (&rest args))
(cl:let ((args-symbols (remove-lambda-keywords args)))
`(cl:progn
(cl:defclass ,name ()
,(cl:mapcar #'make-slot args-symbols))
(cl:defmacro ,name (,@args)
`(cl:make-instance
',',name
,,@(cl:mapcan
#'(cl:lambda (arg)
`(,(make-keyword arg)
(cl:if (cl:listp ,arg)
`(list ,@,arg)
,arg)))
args-symbols))))))
(define-c-class if (test then &optional else))
(define-c-class block (&body body))
(define-c-class for (init test update &body body))
2010年5月18日火曜日
リーダマクロでlambdaを短縮する
Clojureでは無名関数を作るために用いるのは、lambdaでは無くfnという特殊式なため Common Lispより3文字短い。3文字程度なら良いのだけど、Clojureにはさらに無名関数のためのリーダマクロが用意されている。
;;この式が
#(list %1 %2)
;;こうなる(イメージ)
(fn [%1 %2] (list %1 %2))
Clojureに心引かれる箇所は色々あるけれど、このリーダマクロなら多少は自分で書いてみることができるのでは無いかと思ったので、試しに書いてみた。
展開されるようにした。また、引数は%nではなく$nで表現した。
(defun dollar-symbol-p (sym)
(and (symbolp sym) (char= #\$ (char (symbol-name sym) 0))))
(defun dollar-symbol-index (sym)
(and (dollar-symbol-p sym)
(parse-integer
(symbol-name sym)
:start 1 :junk-allowed t)))
(defun short-lambda-reader (stream ch1 ch2)
(declare (ignore ch1 ch2))
(let* ((body (read-delimited-list #\} stream t))
(dollars (remove-if-not #'dollar-symbol-p (my:flatten body)))
(rest-p (find "$R" dollars :test #'string= :key #'symbol-name))
(largest
(apply #'max (or (remove nil (mapcar #'dollar-symbol-index dollars))
'(0)))))
(let ((args (loop :for i from 1 to largest
:collect (my:symb "$" i))))
`(lambda ,(if rest-p
`(,@args &rest ,rest-p)
`(,@args))
,@body))))
(defun enable-short-lambda-reader ()
(set-macro-character #\} (get-macro-character #\)))
(set-dispatch-macro-character #\# #\{ #'short-lambda-reader))
(enable-short-lambda-reader)
;;example
;;$1が第1引数を表す。$rは$nの中で最大のもの以降の残りの要素に束縛される。
(#{(list $1 $2 $4 $r)} 1 2 3 4 5 6)
=> (1 2 4 (5 6))
'#{(list $1 $2 $4 $r)}
=> (LAMBDA ($1 $2 $3 $4 &REST $R) (LIST $1 $2 $4 $R))
(remove-if #{(member $1 '(a b c))} '(a b c d e f g))
=>(D E F G)
(#{(mapcar #{(print $1) (mod $1 2)} (remove-if-not #'numberp $1))}
'(a b 1 2 3 4 f "hoge"))
1
2
3
4
=>(1 0 1 0)
うーん、結構見づらいような。 1つの式のみ書けるようにして、#{list $1}としたほうが見やすいかもしれない。
2010年4月19日月曜日
Clojure on AndroidでAlertDialog
Xperiaを買ったのでClojure on Androidで遊ぼうとしている。
JavaもClojureもAndroidも素人なのでいろんなとこで時間をくってるが、とりあえずボタンクリックでAlertDialogを表示するところまでいった。
(ns org.example.Test.AlertDialog
(:gen-class
:extends android.app.Activity
:implements (android.view.View$OnClickListener)
:exposes-methods {onCreate superOnCreate}))
(import '(android.app AlertDialog)
'(android.util Log))
(defn -onCreate [this #^android.os.Bundle bundle]
(.superOnCreate this bundle)
(.setContentView this org.example.Test.R$layout/main)
(let [btn (.findViewById this org.example.Test.R$id/Btn1)]
(Log/d "tag" (str "this is log:" (.toString btn)))
(.setOnClickListener btn this)))
(defn -onClick [this view]
(Log/d "tag" "this is log2:" view)
(let [al (new android.app.AlertDialog$Builder this)]
(doto al
(.setTitle "AlertDialog!")
(.setMessage "hoge!")
(.setCancelable true))
(.. al create show)))
Btn1はres/layout/main.xml中でandroid:id="@+id/Btn1"と定義したボタン。
ログの出力はandroid.util.Logクラスのstaticメソッドで行える。
ネストクラス(クラスの中で定義されたクラスなど)は/ではなく$で参照するらしい。
悪い例) android.app.AlertDialog.Builder
悪い例) android.app.AlertDialog/Builder
良い例) android.app.AlertDialog$Builder
2010年3月30日火曜日
自宅にある日本酒リスト(2010/03/30)
現在自宅にある日本酒一覧
- 九頭龍 大吟醸燗酒 (黒龍酒造株式会社/福井)
- 梵 特醸(磨き5割8分) (加藤吉平商店/福井)
- いづみ橋 とんぼラベル1号 (泉橋酒造株式会社/神奈川)
- 田ゆう 純米 (泉橋酒造株式会社/神奈川)
- 溪 純米吟醸 本生 (王祿酒造株式会社/島根)
- 溪 純米吟醸 にごり (王祿酒造株式会社/島根)
- 雪吟 吟醸純米生貯蔵酒 (桃川株式会社/青森)
九頭龍、いづみ橋、田ゆうは川崎の「地酒や たけくま酒店」にて購入。
溪は父親がどこからか購入してきた。
雪吟は大学の卒業式(学位授与式)後に後輩にもらった。
梵は大学の友人にもらった。
田ゆうは神奈川県海老名市にある泉橋酒造で作られたものだが、使用している米は川崎で取れたものとのこと。
2010年3月28日日曜日
ClojureでTwitter
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)
2010年3月27日土曜日
Clojure始めました2
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)))))
登録:
投稿 (Atom)