SERIES の encapsulated

Common Lisp の SERIES with-open-file 等の unwind-protect を使う場合はencapsulated を使うといいらしい？

encapsulated の第二引数で使えるのは SCAN-FN, SCAN-FN-INCLUSIVE, COLLECT-FNのいずれか。

よくわかってない。。。詳細は SERIES に添付の s-doc.txt を参照。

(require :series)
(use-package :series)

(defun scan-file-wrap (file name body)
  `(with-open-file (,file ,name :direction :input) ,body))

(defmacro simple-scan-file (name)
  (let ((file (gensym)))
    `(encapsulated #'(lambda (body)
                       (scan-file-wrap ',file ',name body))
                   (scan-fn t
                            (lambda ()
                              (read ,file nil))
                            (lambda (x)
                              (read ,file nil))
                            #'null))))

(let ((x (simple-scan-file "/tmp/b.txt")))
  (collect-sum (map-fn t (lambda (x) (* x x)) x)))

CL パッケージの最も長いシンボルを SERIES(series:collect-max)で

以前 CL パッケージで中で最も長いシンボルはどれか探すのを SERIES でやろうとした。そのとき series:collect-max の使い方をよく理解してなかった。第1引数に数値のシリーズをとるので、最大長は返せるけど、その最大長を持つシンボルは返せないと思っていた。

でも、第二引数に第一引数と対応するシンボルのシリーズを渡してやるとちゃっとシンボルの方を返してくれた。

この最大のものを返すといのは loop マクロが苦手としているところで、iterate なんかが上手に解決しているところ。SERIES でもきれいに書けてよかった。

(require :series)

(let* ((symbols (series:scan-symbols :cl))
       (lengths (series:map-fn t (lambda (symbol)
                                   (length (symbol-name symbol)))
                               symbols)))
  (series:collect-max lengths symbols))

Common Lisp で rgerp しようとした scratch

またそのうちちゃんとしよう。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :cl-fad)
  (require :cl-ppcre))

(setf *ed-functions*
      (list (lambda (x)
              (asdf:run-shell-command "emacsclient -n ~a" x))))

(defun ensure-pathname (x)
  (typecase x
    (pathname x)
    (string
       (parse-namestring
        (if (char= #\~ (char x 0))
            (concatenate 'string (namestring (user-homedir-pathname))
                         (subseq x 2))
            x)))))

(defclass grep-result ()
  ((pathname :initarg :pathname :accessor pathname-of)
   (line-number :initarg :line-number :accessor line-number-of)
   (line :initarg :line :accessor line-of)
   (base-dif :initarg :base-dir :accessor base-dir-of)))

(defmethod relative-path ((x grep-result))
  (concatenate 'string "./"
               (enough-namestring (pathname-of x) (base-dir-of x))))

(defmethod print-object ((x grep-result) stream)
  (format stream "~a:~a:~a"
          (relative-path x) (line-number-of x) (line-of x)))


(defun grep-file (pattern file dir)
  (with-open-file (in file)
    (loop for line = (read-line in nil)
          for i from 1
          while line
          if (cl-ppcre:scan pattern line)
            collect (make-instance 'grep-result
                         :pathname file
                         :line-number i
                         :line line
                         :base-dir dir))))

(defun rgrep (&optional pattern dir filter)
  (unless pattern
    (write-string "pattern: " *query-io*)
    (setf pattern (read-line *query-io*))
    (write-string "dir: " *query-io*)
    (setf dir (read-line *query-io*))
    (write-string "filter: " *query-io*)
    (setf filter (read-line *query-io*)))
  (let (result
        (dir (ensure-pathname dir)))
    (apply #'cl-fad:walk-directory
           dir
           (lambda (file)
             (handler-case (setf result
                                 (nconc result (grep-file pattern file dir)))
               (error (e)
                 (format  *error-output* "~a" e))))
           (when filter
             (list :test (lambda (file)
                           (cl-ppcre:scan filter (namestring file))))))
    (format t "-*- mode: grep; default-directory: \"~a\" -*-~&"
            dir)
    (loop for i in result
          do (format t "~a~&" i))
    result))

(rgrep "defmacro|defun"
       "~/letter/lisp/try/"
       "\\.lisp$")

;;(ed (ensure-pathname "~/.emacs"))

[Common Lisp] cl-blogger

Plato Wu さんの後押しがあり Muse で書いて Blogger にポストするプログラム を cl-blogger として Google Code にあげた。さらに Plato Wu さんはラベルを指定する機能も追加してくれた。ありがとうございます。

; labels: ラベル1, ラベル2 のように書くとラベルが指定できる。私自身もこの機能が欲しかった。

[Common Lisp] cl-win32ole で日時を扱えるようにした

cl-win32ole で日時を扱えるようにした。

Common Lisp になぜか使いやすい日時のデータ型がないので、それも作ってみた。

darcs get http://li31-15.members.linode.com/darcs/simple-date-time

以下、テスト用のコード。create-object の2番目の引数で GC 時に指定したメソッドを実行するようにした。下の例だと、(setf ex nil sheet nil) で参照のなくし、(gc :full t)するとquit が呼ばれる。

(require :cl-win32ole)
(use-package :cl-win32ole)

(progn
 (defparameter ex (create-object "Excel.Application" :quit))
 (setf (slot-value ex 'visible) t)
 (defparameter sheet
   (ole (slot-value ex 'workbooks)
        :open "/Users/ancient/Documents/a.xls" :worksheets :item 1))
 )

(print (ole sheet :range "A1:D1" :value))

(setf (ole sheet :range "A2:B2" :value) (list nil nil))
(setf (ole sheet :range "A2:B2" :value)
     (list
      (make-instance 'dt:date-time :year 1973 :month 4 :day 26
                     :hour 0 :minute 0 :second 0 :millisecond 0)
      (make-instance 'dt:date-time :year 1973 :month 4 :day 26
                     :hour 23 :minute 24 :second 25 :millisecond 26)))

(setf ex nil sheet nil)
(gc :full t)

[SLIME] sayoonara

SLIME を終了させるには SLIME の repl で

,sayoonara

と入力すればよかったのか。いまごろ気づいた。

もう M-x slime-quit-lisp はやめようw

[FreeMind] Linux での FreeMind で日本語フォント名をデフォルトに指定する

Linux 環境で FreeMind のデフォルトフォントを VL Pゴシック に指定したいときは~/.freemind/user.properties に次のように書く。

defaultfont = VL P\u30B4\u30B7\u30C3\u30AF