letter

しらゆり公園プール

2011-07-17T00:21:00.001+09:00

娘としらゆり公園プールに行ってきた。

こども用プールと 25m プールがある。入り口は別々になっていて行き来はできないみたいだった。 1時間 100 円とお安いのが嬉しい。

娘はけのびも、頭までもぐるのもできない状態だったが、 2 時間かけて水中ジャンケンとけのびができるようになった。極端に臆病なんだよね。あと何度行けば泳げるようになるかな。自転車もこのあいだようやく乗れるようになったくらいだからな。がんばれ小学 3 年生。

日焼けと筋肉疲労でぐったりだ。ひさしぶりに泳いだのは気持ちよかった。

ところで、『エレガントな問題解決』に載っていた箱を線でつなぐ問題を娘があっという間にといたのには驚いた。たまたまなのか、小学生くらいの方が柔軟なのか。その後、さらに応用問題を自分で作ってた。

cl-win32ole に空の配列を作る関数 empty-array を追加

2011-07-17T00:02:00.001+09:00

cl-win32ole に issue をいただいたので対応。

nil を false に変換していたので空の配列を作る方法がなかった。安易に関数 empty-array を作った。

次のコードの後から 2 行目。

(asdf:oos 'asdf:load-op :cl-win32ole)
(use-package :cl-win32ole)

#|
Dim aNodePath(0)
Set oServM = CreateObject("com.sun.star.ServiceManager")
Set oConfP = oServM.createInstance("com.sun.star.configuration.ConfigurationProvider")
Set aNodePath(0) = oServM.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
aNodePath(0).Name = "nodepath"
aNodePath(0).Value = "/org.openoffice.Setup/Product"

Set oRegAccess = oConfP.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath)

sOOVersion = oRegAccess.getByName("ooSetupVersionAboutBox")

MsgBox sOOVersion
|#

(let* ((sm (create-object "com.sun.star.ServiceManager"))
       (cp (ole sm :createInstance "com.sun.star.configuration.ConfigurationProvider"))
       (np (ole sm :Bridge_GetStruct "com.sun.star.beans.PropertyValue")))
  (with-slots (name value) np
    (setf name "nodepath")
    (setf value "/org.openoffice.Setup/Product")
    (let ((ra (ole cp :createInstanceWithArguments
                   "com.sun.star.configuration.ConfigurationAccess"
                   (list np))))
      (let ((v (ole ra :getByName "ooSetupVersionAboutBox")))
        (ole (create-object "WScript.Shell") :popup v)))))

#|
Dim aNoArgs()
set oServiceManager = CreateObject("com.sun.star.ServiceManager")
set oDesktop = oServiceManager.createInstance("com.sun.star.frame.Desktop")
set oDoc = oDesktop.loadComponentFromURL("file:///C:/demo.odt", "_blank", 0, aNoArgs)
|#
(let* ((sm (create-object "com.sun.star.ServiceManager"))
       (dt (ole sm :createInstance "com.sun.star.frame.Desktop"))
       (doc (ole dt :loadComponentFromURL
                 "file:///C:/demo.odt"
                 "_blank"
                 0
                 (empty-array))))
  doc)

マルチスレッドな処理系だと動かないとか、64bit ではどうなんとか、いろいろ気になることはある。。。

ストリームのパス

2011-07-09T23:04:00.001+09:00

pathname でとれたのね。

(setq x (open "/tmp/foo" :direction :output))
;;=> #<SB-SYS:FD-STREAM for "file /tmp/foo" {100A91F581}>

(pathname x)
;;=> #P"/tmp/foo"

(close x)
;;=> T

(pathname x)
;;=> #P"/tmp/foo"

PAIProlog に atom-characters/2, string-atom/2, string-list/2 を実装

2011-07-03T21:55:00.001+09:00

atom-characters/2, string-atom/2, string-list/2 を実装した。

https://github.com/quek/paiprolog

PAIPROLOG> (prolog-first (?x)
             (atom-characters ?x (#\H #\E #\L #\L #\O)))
HELLO
PAIPROLOG> (prolog-first (?x)
             (atom-characters ?x (#\H #\E #\L #\l #\O)))
|HELlO|
PAIPROLOG> (prolog-first (?x)
             (atom-characters hello ?x))
(#\H #\E #\L #\L #\O)
PAIPROLOG> (prolog-first (?x)
             (string-atom "hello" ?x))
|hello|
PAIPROLOG> (prolog-first (?x)
             (string-atom ?x hello))
"HELLO"
PAIPROLOG> (prolog-first (?x)
             (string-atom ?x |hello|))
"hello"
PAIPROLOG> (prolog-first (?x)
             (string-list "hello" ?x))
(#\h #\e #\l #\l #\o)
PAIPROLOG> (prolog-first (?x)
             (string-list ?x (#\h #\e #\L #\l #\o)))
"heLlo"

SERIES の producing の中での setf

2011-06-19T23:47:00.001+09:00

次のように SERIES の producing の中での setf を使うと (setf b (car a)) のところが (setf nil (car a)) になりエラーとなる。

(defun foo ()
  (declare (optimizable-series-function))
  (producing (z) ((a '(1 2 3)) b)
             (loop
               (tagbody
                  (if (endp a)
                      (terminate-producing))
                  (setf b (car a))
                  (setf a (cdr a))
                  (next-out z b)))))

(collect (foo))

s-code.lisp をながめると

;;;; 13. Allow `SETF like SETQ' in PRODUCING forms.

とあるのだけど、

        (cond ((and (consp f) (case (car f) ((setq) t))) ; setf removed for now
               (cl:multiple-value-bind (vars lastbind binds) (detangle2 (cdr f))
                 (unless (cdr lastbind)
                   (ers 50 "~%missing value in assignment: " f))
                 ;; setf still not supported - need to make caller setf-aware
                 (cl:let ((expr (cons 'setq ; should be setf
                                      (mapcan #'xform-assignment vars binds))))
                   ;;(format t "~s" expr)
                   (push expr revbody))))
              ...)

今はみたいなことになっている。

きっと何か問題があったんだろうけど、なんだろう？とりあえず、case のところだけ

(case (car f) ((setq setf) t))

にしてみたら上記の foo は動いたけど

(defun foo ()
  (declare (optimizable-series-function))
  (producing (z) ((a '(1 2 3)) (b (list nil)) c)
             (loop
               (tagbody
                  (if (endp a)
                      (terminate-producing))
                  (setf (car b) (car a))
                  (setf c b)
                  (setf a (cdr a))
                  (next-out z c)))))

みたいのは動かない。 ; should be setf のところを setf にしたら、 (SETQ NIL #:OUT-2) になってだめ。

ってところで力つきた。。。

[2011-06-21] ちょっとちがったので修正した。

SERIES を series:install して使うときの defpackage

2011-06-18T13:38:00.001+09:00

LET LET* MULTIPLE-VALUE-BIND FUNCALL DEFUN を shadowing import するので defpackage をラップするマクロがあると楽。

(defmacro sdefpackage (package &rest options)
  `(progn
     (defpackage ,package
       ,@options
       (:use :series)
       (:shadowing-import-from :series ,@series::/series-forms/))
     (series::install :pkg ,package :implicit-map t)))

change-class でモードの実装

2011-06-05T01:45:00.001+09:00

McCLIM の ESA では change-class を使ってバッファ（エディタ）のモードを実装している。それそまねて、少しコードを書いてみた。

ESA では "anonymous classes are the ugly child of CL" ということで、あえて無名クラスではなく defclass を eval するようにしている（ESA/utils.lisp）。私の方は何も考えず無名クラスでいってみようと思う。

有効にするモードをスーパークラスにし指定して standard-class を make-instance して、それに change-class する。多重継承大好き。

ところで、McCLIM のソースは MOP のいろんな機能を使っていておもしろい。

(in-package :info.read-eval-print.editor)

(defun anonymous-class-p (class)
  (null (class-name class)))

(defgeneric enable-mode (mode mode-to-enable &rest initargs)
  (:method (mode mode-to-enable &rest initargs)
    (let* ((current-class (class-of mode))
           (superclasses (cons(find-class mode-to-enable)
                              (if (anonymous-class-p current-class)
                                  (c2mop:class-direct-superclasses current-class)
                                  (list current-class))))
           (new-class (make-instance 'c2mop:standard-class
                                     :direct-superclasses superclasses)))
      (apply #'change-class mode new-class initargs))))

(defgeneric disable-mode (mode mode-to-disable &rest initargs)
  (:method (mode mode-to-disable &rest initargs)
    (let* ((current-class (class-of mode))
           (superclasses (remove (find-class mode-to-disable)
                                 (c2mop:class-direct-superclasses current-class)))
           (new-class (make-instance 'c2mop:standard-class
                                     :direct-superclasses superclasses)))
      (apply #'change-class mode new-class initargs))))

(defgeneric enabled-mode (mode)
  (:method (mode)
    (let ((class (class-of mode)))
      (if (anonymous-class-p class)
          (collect (class-name (scan (c2mop:class-direct-superclasses class))))
          (list (class-name class))))))

(defgeneric key-binding (mode keyseq)
  (:method-combination or))

(defclass* key-map ()
  ((map (make-hash-table :test #'equal))))

(defclass* mode ()
  ((name nil)
   (key-map (make-instance 'key-map))))

(defclass* fundamental-mode (mode)
  ())

(defclass* lisp-mode (mode)
  ())

(defclass* common-lisp-mode (lisp-mode)
  ())

(defclass* show-paren-mode (mode)
  ())

(defmethod print-object ((x mode) stream)
  (print-unreadable-object (x stream)
    (format stream "~a ~(~{~a~^ ~}~)" (name-of x) (enabled-mode x))))


(let ((x (make-instance 'fundamental-mode :name "*scratch*")))
  (print x)
  (enable-mode x 'common-lisp-mode)
  (print x)
  (enable-mode x 'show-paren-mode)
  (print x)
  (disable-mode x 'common-lisp-mode)
  (print x)
  (disable-mode x 'show-paren-mode)
  (print x))
;;->
;;   #<*scratch* fundamental-mode>
;;   #<*scratch* common-lisp-mode fundamental-mode>
;;   #<*scratch* show-paren-mode common-lisp-mode fundamental-mode>
;;   #<*scratch* show-paren-mode fundamental-mode>
;;   #<*scratch* fundamental-mode>
;;=> #<*scratch* fundamental-mode>

(let ((x (make-instance 'c2cl:standard-class
                        :direct-superclasses (list (find-class 'common-lisp-mode)
                                                   (find-class 'show-paren-mode)))))
  (print (c2mop:class-direct-superclasses x))
  (print (make-instance x :name "ま"))
  x)
;;->
;;   (#<STANDARD-CLASS COMMON-LISP-MODE> #<STANDARD-CLASS SHOW-PAREN-MODE>)
;;   #<ま (COMMON-LISP-MODE SHOW-PAREN-MODE)>
;;=> #<STANDARD-CLASS NIL {10048B11E1}>

change-class が便利

2011-05-15T19:31:00.001+09:00

CL-Gtk2 を触ってみたらとてもよかったので、エディタを使ってみている。

GtkSourceBuffer で編集対象をあつかうただが、オープンしたファイル名なども一緒に GtkSourceBuffer に持っていてほしい。

そこで change-class してみた。

GtkSourceBuffer は CL-Gtk2 では source-buffer クラスになっている。 source-buffer クラスを継承して欲しいスロットを持ったクラスを作る。 source-buffer のインスタンスができたところで、その作ったクラスに change-class する。

(defclass* buffer (source-buffer)
  ((view)
   (name nil)
   (file nil)
   (yank "AAAA")
   (digit-argument nil :accessor nil)
   (external-format :utf-8))
  (:metaclass gobject-class))

(change-class (make-instance 'source-buffer)
              'buffer
              :name "command buffer")

動的プロキシとかデリゲートとか意味ないな (特異メソッドはまた違う話しか) 。

MOP なら動的にスーパークラスを追加する手もあるかもしれない。

あっ、make-instance したのを change-class するのはひどい例だった。

Google Code Jam Qualification Round 2011

2011-05-08T15:04:00.001+09:00

参加した。

もちろん使用言語は Common Lisp

A Bot Trust

オレンジが仕事している間もブル一は仕事できる。まずは、 O の仕事と B の仕事をグルーピングしよう。 loop で書きかけたら、何だか書きにくい。再帰で書く。

あ、だめだ。 B 1 B 2 と連続していたら、O が仕事している間にできるのは、 B 1 の分だけだ。 (setf prev-sec 0) が必要。

ボタンを押す分を足すの忘れてる。 1+ 追加。

2ヵ所で (if (eq curr-robot 'o) とか判定してるのきたないな。。。ま、いいか。

うん、動いた。よさそう。

入力は、リーダがあってよかった。

Small も Larg もかわらないね。

;;;; Google Code Jam
;;;; Qualification Round 2011
;;;; A Bot Trust
;;;; Common Lisp
;;;; 46min


(defun grouping (x &optional acc last-color)
  (if (null x)
      (mapcar #'nreverse (nreverse acc))
      (let ((color (car x))
            (button (cadr x)))
        (if (eq color last-color)
            (push button (car acc))
            (push (list button) acc))
        (grouping (cddr x) acc color))))

(defun compute (seq)
  (loop with o-pos = 1
        with b-pos = 1
        for prev-sec = 0 then curr-sec
        for curr-robot = 'o then (if (eq curr-robot 'o) 'b 'o)
        for xs in seq
        for curr-sec = (loop for x in xs
                             sum (prog1
                                     (max 1 (- (1+ (abs (- x (if (eq curr-robot 'o) o-pos b-pos))))
                                               prev-sec))
                                   (setf prev-sec 0)
                                   (if (eq curr-robot 'o)
                                       (setf o-pos x)
                                       (setf b-pos x))))
        sum curr-sec))


(compute (grouping '(O 2 B 1 B 2 O 4)))
;;=> 6
(compute (grouping '(O 5 O 8 B 100)))
;;=> 100
(compute (grouping '(B 2 B 1)))
;;=> 4



(defun read-input ()
  (loop repeat (read)
        collect (loop repeat (read)
                      append (list (read) (read))) ))


(defun main ()
  (loop for x in (read-input)
        for i from 1
        do (format t "Case #~d: ~d~%" i (compute (grouping x)))))

(defun main-with-file (input-file)
  (let ((input-file (make-pathname :name (pathname-name input-file)
                                   :type (pathname-type input-file)
                                   :defaults "~/letter/lisp/try/google-code-jam/2011/a/qualification-round/")))
    (with-open-file (*standard-input* input-file)
      (with-open-file (*standard-output* (make-pathname :defaults input-file :type "out")
                                         :direction :output :if-exists :supersede)
        (main)))))

;;(main-with-file "A-small-attempt0.in")

(main-with-file "A-large.in")

B Magicka

えっと、、、複雑だな。

愚直にとけばいいのか。Q F が来たら T になる。あ、Q が残っちゃってる。 (setf acc (cons combine acc)) じゃなって (setf acc (cons combine (cdr acc))) だ。

愚直にといて Large でも問題ないみたい。

;;;; Google Code Jam
;;;; Qualification Round 2011
;;;; B Magicka
;;;; Common Lisp
;;;; 70min

(declaim (optimize (debug 3) (safety 3)))

(defun compute-combine (a b combines)
  (and a
       (loop for (x y z) in combines
             if (or (and (eq x a) (eq y b))
                    (and (eq x b) (eq y a)))
               do (return-from compute-combine z))
       nil))

(defun opposed-p (acc opposds)
  (loop for (x y) in opposds
        thereis (and (member x acc)
                     (member y acc))))

(defun compute (combines opposeds invokes)
  (loop with acc = nil
        for x in invokes
        for combine = (compute-combine (car acc) x combines)
        if combine
          do (setf acc (cons combine (cdr acc)))
        else
          do (push x acc)
        end
        if (opposed-p acc opposeds)
          do (setf acc nil)
        end
        finally (return (nreverse acc))))

(compute '() '() '(e a))
;;=> (E A)
(compute '((q r i)) '() '(r r q r))
;;=> (R I R)
(compute '((q f t)) '((q f)) '(f a q f d f q))
;;=> (F D T)
(compute '((e e z)) '((q e)) '(q e e e e r a))
;;=> (Z E R A)
(compute '() '((q w)) '(q w))
;;=> NIL


(defun str->sym (str)
  (loop for c across (string-upcase str)
        collect (intern (string c))))

(defun read-input ()
  (loop repeat (read)
        collect (list #1=(loop repeat (read)
                               collect (str->sym (read)))
                      #1#
                      (progn (read) (str->sym (read))))))


(defun main ()
  (loop for x in (read-input)
        for i from 1
        do (format t "Case #~d: [~{~a~^, ~}]~%" i (apply #'compute x))))

(defun main-with-file (input-file)
  (let ((input-file (make-pathname :name (pathname-name input-file)
                                   :type (pathname-type input-file)
                                   :defaults "~/letter/lisp/try/google-code-jam/2011/a/qualification-round/")))
    (with-open-file (*standard-input* input-file)
      (with-open-file (*standard-output* (make-pathname :defaults input-file :type "out")
                                         :direction :output :if-exists :supersede)
        (main)))))

;;(main-with-file "B-small-attempt0.in")

(main-with-file "B-large.in")

C Candy Splitting

これは logxor か。 2進にして縦にならべてみる。

NO になるのは、ある bit で 1 が奇数個の場合。各 bit 毎に 1 の数をかぞえればいいのか。一番大きな bit は integer-length でとれる。

いや、単に全部を logxor して 0 じゃなければ NO なんだ。 (not (zerop (apply #'logxor list)))

さて、どうやって分けるか。総当たりだときっと large でだめだよな。

うぅん、わかんない。先に D を見てみよう。と、D を見てみたが D もわからないので、また C に戻る。

もう一度2進で縦に並べたものをながめる。あれ、どこど分けてもいいんじゃないのか。どこで分けても xor で綺麗になる。本当か？本当っぽいな。これはひどい Patrick があまりにもかわいそうだろう。

何も考えず総当たりでやっても、全部一回目で当たりだから問題なかったんだ。

;;;; Google Code Jam
;;;; Qualification Round 2011
;;;; C Candy Splitting
;;;; Common Lisp
;;;; 2.5h

#|
5 + 4 = 1
7 + 9 = 14
50 + 10 = 56

#b0101  #b100  #b0001
(logxor #b0101  #b100)
;;=> 1
  #b0001
(logxor #b0111  #b1001)
;;=> 14
 #b1110
(logxor #b110010 #b1010)
;;=> 56
 #b111000



1 2 3 4 5 Case #1: NO

001
010
011
100
101


3 5 6     Case #2: 11

011
101
110

(logxor 5 6)
;;=> 3

011
101
110
100
100

|#

(defun no-p (list)
  (not (zerop (apply #'logxor list))))

(defun compute (list)
  (unless (no-p list)
    (let ((sorted (sort list #'<)))
      (apply #'+ (cdr sorted)))))

(compute '(1 2 3 4 5))
;;=> NIL
(compute ' (5 3 6))
;;=> 11

(defun read-input ()
  (loop repeat (read)
        collect (loop repeat (read)
                      collect (read))))


(defun main ()
  (loop for x in (read-input)
        for i from 1
        do (format t "Case #~d: ~:[NO~;~:*~d~]~%" i (compute x))))



(defun main-with-file (input-file)
  (let ((input-file (make-pathname :name (pathname-name input-file)
                                   :type (pathname-type input-file)
                                   :defaults "~/letter/lisp/try/google-code-jam/2011/a/qualification-round/")))
    (with-open-file (*standard-input* input-file)
      (with-open-file (*standard-output* (make-pathname :defaults input-file :type "out")
                                         :direction :output :if-exists :supersede)
        (main)))))

;;(main-with-file "C-small-attempt0.in")

(main-with-file "C-large.in")

D GoroSort

確率か。苦手だ。勉強が必要だなと思っているところ。

10 の -6 乗の精度って普通に float してもだめなんだ。 (float 1/3 0d0) と書くのか。

Goro の最適な戦略は何だろう。 Sample #3 の説明には 2 個ずつソートすると書いてある。全部まとめてソートした方がはやくないのか。

2 つずつのソートがベストだと仮定してやってみると Small で失敗。

3 1 2 のソートで考えてみよう。 2 つずつより 3 つまとめての方がはやいように思えるんだけど。。。いくら考えてもわからん。

Large の N は最大 1000 なんで、何か簡単に求める方法があるはず。。。

仕方ないシミュレートしてみよう。シミュレートの方法は入力のリストをそのソート済みのものと 1 要素ずつ比較して、一致しないものだけ collect して新しいリストを作る。できた新しいリストをシャッフルして、あとは空になるまで繰り返す。これで試めしてみると 2 1 4 3 を 2 つずつソートするのと全部まとめてソートするのでステップ数はかわらない。他にも色々試めしてみると、初期状態でソート済の位置にないものの個数がそのまま答えになっているっぽい。そんなものなのか。さっぱり理解できない。 Small やってみたら。通った。ならあってるんだろうと Large を提出。

;;;; Google Code Jam
;;;; Qualification Round 2011
;;;; D GoroSort
;;;; Common Lisp
;;;; 30min 13:00-


#|
(float 1/3 0d0)
;;=> 0.3333333333333333d0



(3 1 2)
---
a (1 2 3) 1/6
b (1 3 2) 1/2 * 1/2
b (2 1 3)
b (3 2 1)
c (2 3 1)
c (3 1 2)

N=3
(+ 1/6 1/12 1/12 1/12)
;;=> 5/12
(float (/ 1 5/12))
;;=> 2.4
|#

(defun shuffle (list)
  (let ((list (copy-list list)))
    (loop for len = (length list)
          while list
          collect (let ((n (nth (random len) list)))
                    (setf list (delete n list))
                    n))))

(defun count-sort-step (list sorted &optional (n 0))
  (loop for a in list
        for b in sorted
        if (/= a b)
          collect a into new-list
          and collect b into new-sorted
        finally (return
                  (if (null new-list)
                      n
                      (count-sort-step (shuffle new-list) new-sorted (1+ n))))))

#|

(simulate 1 2 3)
;;=> 0.0d0
(simulate 1 3 2)
;;=> 2.019098090190981d0
(simulate 3 1 2)
;;=> 2.996900309969003d0

(simulate 2 1 4 3)
;;=> 4.000099990001d0
(simulate 4 3 2 1)
;;=> 3.9836016398360163d0
(simulate 1 3 4 2)
;;=> 3.014898510148985d0
(simulate 1 4 3 2)
;;=> 2.0125987401259873d0


(simulate 1 2 3 4 5)
;;=> 0.0d0
(simulate 1 2 3 5 4)
;;=> 1.996000399960004d0
(simulate 1 3 2 5 4)
;;=> 3.978102189781022d0
(simulate 3 1 5 2 4)
;;=> 5.012198780121988d0

(simulate 3 1 5 2 6 4)
;;=> 6.052394760523947d0

(simulate 10 1 2 3 4 5 6 7 8 9)
;;=> 9.93890610938906d0




(4 3 2 1) 24
----
a (1 2 3 4) 1 1/24
b (1 2 4 3) 6 (* 6/24 1/2)
b (1 3 2 4)
b (1 4 3 2)
b (4 2 3 1)
b (3 2 1 4)
b (2 1 3 4)
c (1 3 4 2) 8 (* 8/24 5/12)
c (1 4 2 3)
c (3 2 4 1)
c (4 2 1 3)
c (4 1 3 2)
c (2 4 3 1)
c (2 3 1 4)
c (3 1 2 4)
d (2 1 4 3) 9
d (2 3 4 1)
d (2 4 1 3)
d (3 1 4 2)
d (3 4 1 2)
d (3 4 2 1)
d (4 1 2 3)
d (4 3 1 2)
d (4 3 2 1)

(+ 1/24 (* 6/24 1/2) (* 8/24 5/12))
;;=> 11/36
(float (/ 11/36))
;;=> 3.2727273


(2 1 4 3) => 4.000000
----
(2 1)
--
(1 2) 1/2
(2 1) 1/2

|#


(defun product (n &optional (acc 1))
  (if (zerop n)
      acc
      (product (1- n)
               (* n acc))))

#+(or)
(defun compute (array)
  (loop with sorted = (sort (copy-seq array) #'<)
        for x across array
        for i from 0
        if (= x (aref sorted i))
          count 1 into ok
        if (and (not (= x (aref sorted i)))
                (let ((pos (position x sorted :start (1+ i))))
                  (and pos
                       (= (aref sorted i) (aref array pos)))))
          count 1 into swap
        finally (return (values (+ (* 2 swap)
                                   (* 2 (max 0 (- (length array) ok (* swap 2) 1))))
                                (list :ok ok :swap swap :rest (- (length array) ok (* swap 2)))))))


(defun compute (array)
  (loop with sorted = (sort (copy-seq array) #'<)
        for a across array
        for b across sorted
        if (/= a b)
          count 1))

#|
(compute #(3))
;;=> 0
;;=> 0
;;   (:OK 1 :SWAP 0 :REST 0)
(compute #(2 4 1 3))
;;=> 4
;;=> 6
;;   (:OK 0 :SWAP 0 :REST 4)
(compute #(2 1 4 3))
;;=> 4
;;=> 4
;;   (:OK 0 :SWAP 2 :REST 0)
(compute #(2 1))
;;=> 2
;;=> 2
;;   (:OK 0 :SWAP 1 :REST 0)
(compute #(1 3 2))
;;=> 2
;;=> 2
;;   (:OK 1 :SWAP 1 :REST 0)
(compute #(3 1 2))
;;=> 3
;;=> 4
;;   (:OK 0 :SWAP 0 :REST 3)

|#

(defun read-input ()
  (loop repeat (read)
        collect (coerce (loop repeat (read)
                              collect (read))
                        'vector)))


(defun main ()
  (loop for x in (read-input)
        for i from 1
        do (format t "Case #~d: ~,6f~%" i (float (compute x) 1d0))))


(defun main-with-file (input-file)
  (let ((input-file (make-pathname :name (pathname-name input-file)
                                   :type (pathname-type input-file)
                                   :defaults "~/letter/lisp/try/google-code-jam/2011/a/qualification-round/")))
    (with-open-file (*standard-input* input-file)
      (with-open-file (*standard-output* (make-pathname :defaults input-file :type "out")
                                         :direction :output :if-exists :supersede)
        (main)))))

;;(main-with-file "D-small-attempt2.in")

(main-with-file "D-large.in")

おわってから

ぐちゃぐちゃなものをぐちゃぐちゃなまま書ける loop は便利。入力もリーダのおかげで (read) するだけ。動かしながら書ける。 Common Lisp でよかったw

D は srot しなくてよかったのね。 n 個がランダムにおさまるなら、 (loop repeat n sum (/ 1 n)) なんで 1 になるのか。朝おきてトイレで納得した。 Case #3 の説明は罠だよ。

Code Jam 2011 Statistics に統計情報がある。 C++ って人気あるんだ。続いて Java, Python, C#, C, Ruby みたい。 Common Lisp は "Lisp" になっているようだけど、26 人が使っている。 Common Lisp はこういうのにはとても向いてると思うんだけどなぁ。

http://www.go-hero.net/jam/11/lang/Lisp で他の人のコードを見ると、みんなきれいなコードを提出してるのね。

あれ、D の simulate の定義消しちゃってた。確しかこんなんだったような。

(defun simulate (&rest list)
  (loop with n = 10000
        repeat n
        sum (count-sort-step list (sort (copy-list list) #'<)) into total
        finally (return (float (/ total n) 1d0))))

うん、おもしろかった。

コンドルがとんできた

2011-04-29T23:10:00.001+09:00

誕生日プレゼントの Kindle が届いた。娘からは黄色いシャープペンシルをもらった。義父と義母からはいつもの靴下とケーキ。

ありがとう。

さて、Kindle すてき。タッチパネルのぞわぞわ感がだめなので、i なんとやタブレット系は選択したくない。本が好き。なので Kindle を選択。意味のわからない単語までカーソル移動はめんどうだけど、面画は美しい。お絵かきせんせいと同じレベルを想像していたので、想像をこえて美しかった。

Common Lisp 本の充実と、日本の Kindle Store のオープンをお祈りしてます。なぜか Prolog 本は充実してるみたい。

Common Lisp の feed パーサライブリありませんか？

2011-04-17T22:48:00.001+09:00

あまりよさそうなのが見つからなかったので、てきとうに作ってみた。これも 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)))))

DCG で JSON をパースする

2011-04-03T12:39:00.001+09:00

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

出社初日

2011-04-02T00:36:00.001+09:00

通勤電車にたじろいた。しかし、それが普通の感覚なんだよね。

明日から仕事

2011-03-31T16:15:00.001+09:00

思いがけず、3ヵ月間という長いインターバルになった。その間、先行が見えず無気力傾向にあった。せいぜい "Paradigms of Artificial Intelligence Programming" と "エージェントアプローチ人工知能" の半分を読んだくらい。あとは "大航海時代 Online" に手を出したりもした。この15ヵ月間ですっかり貯金がなくなったは痛いな。

Rucksack みたいなパーシステントシステムを作ろうとも思っていたけど、気力がついていかなかった。

明日からの仕事で一番気がかりなことは、入力。カスタマイズした Dvorak 配列で T-Code を使っている。それを Windows 環境でどうやって実現したらいいんだろうか。

そんな感じですが、元気に生きています。

PAIProlog

2011-02-23T02:25:00.001+09:00

Paradigms of Artificial Intelligence Programming (実用 Common Lisp) のコードに Christophe Rhodes さんが手を入れて PAIProlog として公開されている。

それに Allegro Prolog の <-- と prolog を実装してみた。すでにどこかにありそうなんだけどなぁ。。。と思いつつ。

<-- は同じ名前かつ同じ引数の数のものを再定義する。

prolog は Common Lisp から Prolog を使うためのマクロ。次のように lisp/2 経由で Common Lisp の変数にアクセスできる。

(let ((x 100) y)
  (prolog (lisp ?a x)
          (= ?a ?b)
          (lisp ? (setf y (+ ?b ?b x 1))))
  y)
;;=> 301

ソースは github に https://github.com/quek/paiprolog

prolog の方の実装は2重バッククオートを使った複雑なコードになってしまった。レキシカル変数にアクセスするためにマクロ展開時にクロージャを作るようにしたけど、もっと簡単に書けないかな？

(defun insert-deref (exp)
  (if (atom exp)
      (if (variable-p exp)
          `(deref ,exp)
          exp)
      (cons (insert-deref (car exp))
            (insert-deref (cdr exp)))))

(defun prolog-translate-goals (goals)
  (mapcar (lambda (goal)
            (if (starts-with goal 'lisp)
                (let ((vars (variables-in (last goal))))
                  ``(,@',(butlast goal)
                         (apply ,(lambda (,@vars)
                                   ,@(insert-deref (last goal)))
                                 ,',vars)))
                `',goal))
          goals))

(defmacro prolog (&rest goals)
  "Run Prolog in the surrounding Lisp environment
which is accessed from lisp functor.

(let ((x 100) y)
  (prolog (lisp ?a x)
          (= ?a ?b)
          (lisp ? (setf y (+ ?b ?b x 1))))
  y)
;;=> 301
"
  (let ((goals (replace-?-vars goals)))
    `(block prolog
       (clear-predicate 'top-level-query)
       (add-clause `((top-level-query)
                     ,,@(prolog-translate-goals goals)))
       (run-prolog 'top-level-query/0 #'ignore))))

カーネルが 2.6.37 になった

2011-02-18T21:52:00.001+09:00

Debian sid のカーネルが 2.6.37 になった。すると Stumpwm と cl-mayu が正常動作しなくなった。

Stumpwm は、http://comments.gmane.org/gmane.comp.window-managers.stumpwm.devel/2351 の件。パッチを適用したら動いた。

cl-mayu は /usr/include/linux/input.h の EV_VERSION の値が変っていたことによる。値を修正したら動いた。きっと窓使いの憂鬱 Linux 版も再コンパイルしないと動かないと思う。

Common Lisp で Web アプリを作るためのブランクプロジェクト

2011-02-17T23:01:00.001+09:00

何かの時に必要になるかもしれないと思い、 Common Lisp で Web アプリを作るためのブランクプロジェクトを作ってみた。

https://github.com/quek/hunchentoot-blank

Hunchentoot, CL-WHO, CLSQL を使ったブランクプロジェクト。

データベースには MySQL を使用。シェルから次のコマンドを実行してデータベースの作成が必要。

echo 'create database hunchentoot_blank default character set utf8;' | mysql -u root

次を実行して http://localhost:8888/ にアクセスする。

(require :hunchentoot-blank)
(hunchentoot-blank::start)

これだけではちょっと寂しいので、いつものようにソースを載せておく。

(in-package #:hunchentoot-blank)

(defparameter *default-directory*
  (pathname (directory-namestring #.(or *compile-file-truename*
                                        *load-truename*)))
  "このファイルがあるディレクトリ")

(defparameter *js-path* (merge-pathnames "js/" *default-directory*)
  "JavaScript 用ディレクトリ")
(defparameter *css-path* (merge-pathnames "css/" *default-directory*)
  "スタイルシート用ディレクトリ")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; DB
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
シェルから次のコマンドを実行してデータベースを作成してください。
echo 'create database hunchentoot_blank default character set utf8;' | mysql -u root
|#

(clsql-sys:file-enable-sql-reader-syntax)

(defparameter *connection-spec* '("localhost" "hunchentoot_blank" "root" "")
  "MySQL の接続情報。(DBサーバ DB名 ユーザ パスワード)")

(defmacro with-db (&body body)
  (alexandria:with-gensyms (res handler-done)
    `(clsql:with-database (clsql:*default-database*
                           *connection-spec*
                           :make-default t
                           :pool t
                           :encoding :utf-8
                           :database-type :mysql)
       ;; for debug
       (clsql-sys::start-sql-recording)
       (unwind-protect
            (let (,res (,handler-done t))
              ;; (clsql:execute-command "SET NAMES 'utf8'")
              (clsql-sys:with-transaction (:database clsql:*default-database*)
                ;; hunchentoot:redirect した場合の対応
                (catch 'hunchentoot::handler-done
                  (setf ,res (progn ,@body))
                  (setf ,handler-done nil)))
              (if ,handler-done
                  (throw 'hunchentoot::handler-done nil)
                  ,res))
         ;; for debug
         (clsql-sys::stop-sql-recording)))))
;;(with-db (clsql-sys:query "select 'あ'"))

(clsql-sys:def-view-class user ()
  ((id :accessor id
       :initarg :id
       :db-kind :key
       :db-constraints :auto-increment
       :type integer)
   (email :accessor email
          :initarg :email
          :db-constraints :unique
          :type string)
   (password :initarg :password
             :initarg :plain-password
             :type string)))

(defmethod initialize-instance :after ((user user)
                                        &key plain-password
                                        &allow-other-keys)
  "make-instance で :plain-password が指定されていた場合、
password に hash-password したものを設定する。"
  (when plain-password
    (setf (password user) plain-password)))

(defun hash-password (password)
  "パスワードのハッシュ関数"
  (ironclad:byte-array-to-hex-string
   (ironclad:digest-sequence
    :sha256
    (ironclad:ascii-string-to-byte-array password))))

(defmethod (setf password) (password (user user))
  "パスワードのハッシュをセットする。"
  (setf (slot-value user 'password) (hash-password password)))

(defun authenticate (email password)
  (let ((password (hash-password password)))
    (car
     (clsql:select 'user
                   :flatp t
                   :where [and [= [email] email] [= [password] password]]))))
;; (authenticate "user1@example.com" "password")

;; テーブル作成
(with-db
  (unless (clsql-sys:table-exists-p 'user)
    (clsql-sys:create-view-from-class 'user)
    'user))
#+テーブル削除
(progn
  (clsql-sys:drop-view-from-class 'user))

#+テストデータ作成
(with-db
  (let ((user (make-instance 'user :email "user1@example.com"
                             :plain-password "password")))
    (clsql-sys:update-records-from-instance user)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Web server
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setf
 ;; for utf-8
 hunchentoot:*hunchentoot-default-external-format* (flexi-streams:make-external-format :utf-8)
 hunchentoot:*default-content-type* "text/html; charset=utf-8"
 ;; for debug
 hunchentoot:*catch-errors-p* nil)

(setf hunchentoot:*dispatch-table*
      (list
       'hunchentoot:dispatch-easy-handlers
       (hunchentoot:create-folder-dispatcher-and-handler "/css/" *css-path*)
       (hunchentoot:create-folder-dispatcher-and-handler "/js/" *js-path*)))

(defvar *acceptor*)

(defun start (&optional (port 8888))
  "Web サーバ起動"
  (setf *acceptor* (hunchentoot:start
                    (make-instance 'hunchentoot:acceptor
                                   :port port))))

(defun stop ()
  "Web サーバ停止"
  (hunchentoot:stop *acceptor*))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ビュー
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *login-user* nil "ログインユーザ")

(defun login (user redirect-url)
  "ログイン処理"
  (setf *login-user* user)
  (when hunchentoot:*session*
    (hunchentoot:remove-session hunchentoot:*session*))
  (hunchentoot:start-session)
  (setf (hunchentoot:session-value 'login-user-id) (id user))
  (hunchentoot:redirect redirect-url))

(defun logout (redirect-url)
  "ログアウト処理"
  (when hunchentoot:*session*
    (hunchentoot:remove-session hunchentoot:*session*))
  (setf *login-user* nil)
  (hunchentoot:redirect redirect-url))

(setf *prologue* "<!DOCTYPE html>")
(setf *attribute-quote-char* #\")

(defmacro with-default-template ((&key (title "題名")
                                       (charset "UTF-8")) &body body)
  "ページのテンプレート"
  `(with-html-output-to-string (out nil :prologue t :indent t)
     (htm (:html :lang "ja"
                 (:head
                  (:meta :charset ,charset)
                  (:title ,title)
                  (:link :rel "stylesheet" :href"css/main.css" :media "all")
                  (:script :src "http://ajax.googleapis.com/ajax/libs/jquery/1/jquery.min.js"))
                 (:body ,@body)))))

(defun select-login-user ()
  (let ((login-user-id (hunchentoot:session-value 'login-user-id)))
    (when login-user-id
      (caar (clsql:select 'user
                          :where [= [id] login-user-id])))))

(defmacro with-login-user (&body body)
  `(let ((*login-user* (select-login-user)))
     ,@body))

(defmacro define-page (description lambda-list &body body)
  "ページ定義。

description
hunchentoot:define-easy-handler に加えて
ログインが必要な場合は :login-require-p t を指定する。

lambda-list
hunchentoot:define-easy-handler と同じ。"
  (let ((login-required-p (and (listp description)
                               (getf (cdr description) :login-require-p))))
    (when (listp description)
      (remf (cdr description) :login-require-p))
    `(hunchentoot:define-easy-handler ,description ,lambda-list
       (with-db
         (with-login-user
           ,@(when login-required-p
               `((unless *login-user*
                   ;; ログインしていな場合の処理
                   (hunchentoot:redirect "/"))))
           ,@body)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 各ページ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; トップページ
(define-page (%root :uri "/") ()
  (with-default-template (:title "トップ")
    (htm
     (:div :class "ba" "ブランクプロジェクト")
     (if *login-user*
         (htm (:div (str (email *login-user*))
                    " でログインしています。")
              (:div (:a :href "logout" "ログアウト")))
         (htm (:div (:a :href "login" "ログイン"))))
     (htm (:div (:a :href "/secret" "ログインが必要なページへのリンク"))))))

;;;; ログインページ
(define-page (%login :uri "/login") (email messages)
  (with-default-template (:title "ログイン")
    (htm
     (when messages
       (htm (:ul (loop for message in messages
                       do (htm (:li (str message)))))))
     (:form :action "authenticate" :method :post
            (:div "email"
                  (:input :type :text :name "email" :value email))
            (:div "パスワード"
                  (:input :type :password :name "password"))
            (:div (:input :type :submit :value "ログイン"))))))

;;;; 認証
(define-page (%authenticate :uri "/authenticate")
    ((email :init-form "") (password :init-form ""))
  (let (messages)
    (when (string= "" email)
      (push "email を入力してください。" messages))
    (when (string= "" password)
      (push "パスワードを入力してください。" messages))
    (if messages
        (%login :email email :messages (reverse messages))
        (let ((user (authenticate email password)))
          (if user
              (login user "/")
              (%login :email email))))))

;;;; ログアウト
(define-page (%logout :uri "/logout") ()
  (logout "/"))

;;;; ログインが必要なページ
(define-page (secrect :uri "/secret" :login-require-p t) ()
  (with-default-template (:title "秘密のページ")
   (htm (:p "このページはログインが必要なページです。"))))

progs

2011-02-08T15:49:00.001+09:00

たまにはこういうのもいいでしょう。

SERIES は次のようにネストしながら、横に長くなり過ぎる。

(collect
    (+ 10
       (choose-if #'oddp
                  (scan-range :upto 5))))
;;=> (11 13 15)

そこで、パイプ的な動きをするマクロを書いてみた。ネストせず、処理の順番どおり、縦に書ける。多値には対応せず。

(progs ()
  (scan-range :upto 5)
  (choose-if #'oddp)
  (+ 10)
  (collect))
;;=> (11 13 15)

(progs (x)
  (scan-range :upto 5)
  (choose-if #'oddp)
  (* x x)
  (collect))
;;=> (1 9 25)

(progs (choose-if)
  (scan-range :upto 5)
  (choose-if #'oddp)
  (- choose-if 10)
  (collect))
;;=> (-9 -7 -5)

(progs (x)
  (scan-symbols :cl)
  (collect-max (length (symbol-name x)) x))
;;=> LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT

定義はこれ。

(defun progs-body (var body)
  (let ((form (if (collect (choose-if (lambda (x) (eq var x))
                                      (scan-lists-of-lists-fringe (cdar body))))
                  (car body)
                  (append (car body) (list var)))))
    (if (endp (cdr body))
        form
        `(let ((,var ,form))
           ,(progs-body var (cdr body))))))

(defmacro progs ((&optional (var (gensym))) &body body)
  `(let ((,var ,(car body)))
     ,(progs-body var (cdr body))))

let に展開しているけど、 multiple-value-bind に展開すれば多値に対応できると思う。

Eternal September で Gnus を使って comp.lang.lisp を読む

2011-02-03T02:14:00.001+09:00

comp.lang.lisp を読むようにしようと思った。

ニュースサーバは Eternal September が使える。ありがたい。 http://eternal-september.org/ で登録する。

~/.gnus

(setq gnus-select-method '(nntp "news.eternal-september.org"))

~/.authinfo に External September から送られてきたメールに書いてある UserID と Password を書いておく。

machine news.eternal-september.org login UserID force yes password Password

Gnus は難しいが、以下の手順をしておけば、あとは Space キーだけで読める。必要に応じて C-c Tab で INFO が表示されるので読む。

M-x gnus
*Group* バッファが開いたら
^
*Server* バッファが開いたら nntp:news.eternal-september.org で
RET
しばらく待つとニュースグループの一覧が表示されるので comp.lang.lisp で
u
あるいは *Group* バッファで
U comp.lang.lisp
最初は未読が多過ぎるので
c
で全て即読にする。

comp.lang.forth と comp.lang.prolog も読んでみよう。

現在の optimize 指定を取得する

2011-01-26T13:30:00.001+09:00

SBCL 依存だけど sb-ext:describe-compiler-policy または sb-cltl2:declaration-information で取得できる。

(sb-ext:describe-compiler-policy)
;;->   Basic qualities:
;;   COMPILATION-SPEED = 1
;;   DEBUG = 3
;;   SAFETY = 3
;;   SPACE = 1
;;   SPEED = 1
;;   INHIBIT-WARNINGS = 1
;;     Dependent qualities:
;;   SB-C::CHECK-CONSTANT-MODIFICATION = 1 -> 3 (yes)
;;   SB-C::TYPE-CHECK = 1 -> 3 (full)
;;   SB-C::CHECK-TAG-EXISTENCE = 1 -> 3 (yes)
;;   SB-C::LET-CONVERSION = 1 -> 0 (off)
;;   SB-C:VERIFY-ARG-COUNT = 1 -> 3 (yes)
;;   SB-C::MERGE-TAIL-CALLS = 1 -> 0 (no)
;;   SB-C::INSERT-DEBUG-CATCH = 1 -> 3 (yes)
;;   SB-C::RECOGNIZE-SELF-CALLS = 1 -> 0 (no)
;;   SB-C::FLOAT-ACCURACY = 1 -> 3 (full)
;;   SB-C:INSERT-STEP-CONDITIONS = 1 -> 3 (full)
;;   SB-C::COMPUTE-DEBUG-FUN = 1 -> 3 (yes)
;;   SB-C::PRESERVE-SINGLE-USE-DEBUG-VARIABLES = 1 -> 3 (yes)
;;   SB-C::INSERT-ARRAY-BOUNDS-CHECKS = 1 -> 3 (yes)
;;   SB-C::STORE-XREF-DATA = 1 -> 3 (yes)
;;   SB-C:STORE-COVERAGE-DATA = 1 -> 0 (no)
;;
;;=>

(sb-cltl2:declaration-information 'optimize)
;;=> ((COMPILATION-SPEED 1) (DEBUG 3) (SAFETY 3) (SPACE 1) (SPEED 1)
;;    (INHIBIT-WARNINGS 1) (SB-C::CHECK-CONSTANT-MODIFICATION 1)
;;    (SB-C::TYPE-CHECK 1) (SB-C::CHECK-TAG-EXISTENCE 1) (SB-C::LET-CONVERSION 1)
;;    (SB-C:VERIFY-ARG-COUNT 1) (SB-C::MERGE-TAIL-CALLS 1)
;;    (SB-C::INSERT-DEBUG-CATCH 1) (SB-C::RECOGNIZE-SELF-CALLS 1)
;;    (SB-C::FLOAT-ACCURACY 1) (SB-C:INSERT-STEP-CONDITIONS 1)
;;    (SB-C::COMPUTE-DEBUG-FUN 1) (SB-C::PRESERVE-SINGLE-USE-DEBUG-VARIABLES 1)
;;    (SB-C::INSERT-ARRAY-BOUNDS-CHECKS 1) (SB-C::STORE-XREF-DATA 1)
;;    (SB-C:STORE-COVERAGE-DATA 1))

CLIM ベースの IRC クライアント beirc

2011-01-15T05:38:00.001+09:00

今年は CLIM-desktop を流行っているようなので、 @g000001 さんから #Lisp_Scheme できいた、 CLIM ベースのクライアント beirc を使ってみました。

インストールは Quicklisp で。

(ql:quickload "beirc")

起動はレプルから。

(beirc:beirc)

使い方（コマンド）は CLiki のページが詳しいようですが、次の2つのコマンドがあれば何とかなるでしょう。

/Connect server nick
/Join channel

~/.beirc.lisp に設定情報を書いおけば起動時に自動的にサーバに接続してくれたりします。また日本語まわりの設定もそのファイルに書いておけばいいかと思います。

~/.beirc.lisp

(in-package :beirc)

;; フォント
(require :mcclim-freetype)

;; uim での日本語入力 https://github.com/quek/mcclim-uim
(require :mcclim-uim)

;;; variables.lisp を参照。

;; 自動的に接続するサーバ
(setq *auto-connect-list* '("irc.freenode.net"))
;; 自動的に join するチャンネル
(setq *auto-join-alist* '(("irc.freenode.net" . ("#lisp" "#Lisp_Scheme"))))

;; ニックネーム
(setq *default-nick* "quek")
(setq *default-realname* "Yoshinori Tahara")

(setq *hyperspec-base-url* "file://localhost/usr/share/doc/hyperspec/")
(setq *default-web-browser* "/usr/bin/opera")

ただ、SBCL だとちょっと問題があるので ~/.sbclcr にその対策もかねて、 beirc 起動用の関数を書いておきます。

(defun beirc ()
  "beirc を起動す2。"
  (require :beirc)
  (eval (read-from-string "
(progn (setf beirc:*beirc-user-init-file* \"~/.beirc.lisp\")
       (beirc:beirc))
")))

mcclim-uim の微妙さをがまんしてもらえれば、普通に使えます。

ところで CLIM-desktop を見ると Backtrace Dialog, Restarts Dialog とか McCLIM の機能としてあるんですね。

Common Lisp でパッケージのニックネームを変える

2011-01-11T01:42:00.001+09:00

rename-package を使う。

(defun set-package-nicknames (package &rest nicknames)
  (rename-package package (package-name package) nicknames))

(defpackage :foo
  (:nicknames :bar))

(values (package-name :foo) (package-nicknames :foo))
;;=> "FOO"
;;   ("BAR")

(set-package-nickname :foo :baz :baha)
;;=> #<PACKAGE "FOO">

(values (package-name :foo) (package-nicknames :foo))
;;=> "FOO"
;;   ("BAHA" "BAZ")

(set-package-nickname :foo)
;;=> #<PACKAGE "FOO">

(values (package-name :foo) (package-nicknames :foo))
;;=> "FOO"
;;   NIL

Climacs に Switch To View Other Window と Find File Other Window を実装

2011-01-09T08:57:00.001+09:00

勝手に github に fork して Climacs をいじることにしてみた。 McCLIM も github に勝手に fork した。

https://github.com/LaPingvino/Climacs もあるので、そのうち Pull Request できたらいいと思う。

Emacs の switch-to-buffer-other-window と find-file-other-window 相当を実装した。

window-commands.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Commands for switching/find-file in other window

(define-command (com-switch-to-view-other-window :name t :command-table window-table)
    ((view 'view :default (or (cadr (views *application-frame*)) (any-view))))
  "Prompt for a view name and switch to that view in other window.
If the a view with that name does not exist, create a buffer-view
with the name and switch to it. Uses the name of the next
view (if any) as a default."
  (when (= 1 (length (windows *application-frame*)))
    (com-split-window-horizontally t))
  (com-other-window)
  (com-switch-to-view view))

(set-key `(com-switch-to-view-other-window ,*unsupplied-argument-marker*)
         'window-table
         '((#\x :control) (#\4) (#\b)))

(define-command (com-find-file-other-window :name t :command-table window-table)
    ((filepath 'pathname
               :prompt "Find File in other window: "
               :prompt-mode :raw
               :default (esa-io::directory-of-current-buffer)
               :default-type 'pathname
               :insert-default t))
  "Prompt for a filename then edit that file in other window.
If a buffer is already visiting that file, switch to that
buffer. Does not create a file if the filename given does not
name an existing file."
  (when (= 1 (length (windows *application-frame*)))
    (com-split-window-horizontally t))
  (com-other-window)
  (esa-io:com-find-file filepath))

(set-key `(com-find-file-other-window ,*unsupplied-argument-marker*)
         'window-table
         '((#\x :control) (#\4) (#\f)))

Climacs での色（フェイス）の設定

2011-01-06T14:46:00.001+09:00

climacs:climacs-rv で起動すると黒背景になる。でも、デフォルトの色付が合わない。そんな場合は次のように各 drawing-options を変更する。

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; lisp height
;;;; climacs:climacs-rv で起動するとデフォルトのフェイスが合わないので。
(in-package :drei-lisp-syntax)

(setf
 *string-drawing-options* (make-drawing-options :face (make-face :ink +light-salmon+))
 *comment-drawing-options* (make-drawing-options :face (make-face :ink +chocolate1+))
 *keyword-drawing-options* (make-drawing-options :face (make-face :ink +light-steel-blue+))
 *special-variable-drawing-options* (make-drawing-options :face (make-face :ink +light-goldenrod+))
 *special-operator-drawing-options* (make-drawing-options
                                     :face (make-face :ink +cyan1+
                                                      :style (make-text-style nil :bold nil))))

simple-date-time のパッチをもらった

2011-01-06T11:29:00.001+09:00

たまたま #lisp に接続したら Axioplase さんから simple-date-time について質問された。昨日 Axioplase さんから RFC 2822 のフォーマットで出力するパッチのメールをもらった。この件ではいろいろ嬉しい驚きがあった。

数ヶ月ぶりに #lisp したまさにその時に質問されたこと。
simple-date-time を使っている人がいたこと。
パッチのメールが綺麗な日本語だったこと。

Axioplase さんありがとうございました。

simple-date-time は cl-win32ole を作るときに日時クラスが必要になって、でちっあげたもの。はなはだ効率の悪い実装になっている。アルゴリズムとか無視だし。申し訳ないです。