しらゆり公園プール

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

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

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

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

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

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

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 ではどうなんとか、いろいろ気になることはある。。。

ストリームのパス

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 を実装

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

次のように 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

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 でモードの実装

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}>