窓使いの憂鬱 Linux 対応版 を使っているのだけど、少々 Stumpwm と合相が悪い。電源ボタン等を押すと Stumpwm が落ちたりする。
いろいろといい機会なので SBCL で窓使いの憂鬱みたいなのを作ってみることにした。
sb-alien と cffi の両方を使ってしまっているけど、どちらかに統一したい。むしろ IOLib を使うこと検討すべきかも。なるべくライブラリを使わない方向がいいようにも思う。
root 権限が必要なため sudo sbcl したものに M-x slime-connect して開発している。 root 権限の sbcl に接続するのは、Stumpwm を走らせている sbcl に接続する以上に、落ち着かない。 sudo しなくてすむ方法がないものだろうか。
キーのリマップと SandS は実装した。あとは config.lisp に自分用の Dvorak 改の設定を書けば、何とか使えそうだ。
Climacs の find-file で次の対応。
C-i は 2 回連続で押さないと補完してくれない。なぜだろう？
そろそろ Emacs を卒業して、Common Lisp の世界で生活したい。
;;; -*- mode: lisp; indent-tabs: nil -*-
;;; (require :info.read-eval-print.climacs.ext)
(in-package :info.read-eval-print.climacs.ext)
(defun test ()
(format t "Hello World from new project info.read-eval-print.climacs.ext~%"))
(in-package :clim-internals)
(defun ext%normalize-so-far (so-far)
(reduce (lambda (acc x)
(ppcre:regex-replace (car x) acc (cadr x)))
`((".*//" "/") (".*/~/" ,(namestring (user-homedir-pathname))))
:initial-value so-far))
(assert (string= (ext%normalize-so-far "/tmp//a") "/a"))
(assert (string= (ext%normalize-so-far "/tmp/~/a") (q:str (namestring (user-homedir-pathname)) "a")))
(defun filename-completer (so-far mode)
(let* ((so-far (ext%normalize-so-far so-far))
(directory-prefix
(if (eq :absolute (car (pathname-directory (pathname so-far))))
""
(namestring #+sbcl *default-pathname-defaults*
#+cmu (ext:default-directory)
#-(or sbcl cmu) *default-pathname-defaults*)))
(full-so-far (concatenate 'string directory-prefix so-far))
(pathnames
(loop with length = (length full-so-far)
and wildcard = (format nil "~A*.*"
(loop for start = 0 ; Replace * -> \*
for occurence = (position #\* so-far :start start)
until (= start (length so-far))
until (null occurence)
do (replace so-far "\\*" :start1 occurence)
(setf start (+ occurence 2))
finally (return so-far)))
for path in
#+(or sbcl cmu lispworks) (directory wildcard)
#+openmcl (directory wildcard :directories t)
#+allegro (directory wildcard :directories-are-files nil)
#+cormanlisp (nconc (directory wildcard)
(cl::directory-subdirs dirname))
#-(or sbcl cmu lispworks openmcl allegro cormanlisp)
(directory wildcard)
when (let ((mismatch (mismatch (namestring path) full-so-far)))
(q:p path full-so-far mismatch)
(or (null mismatch) (= mismatch length)))
collect path))
(strings (mapcar #'namestring pathnames))
(first-string (car strings))
(length-common-prefix nil)
(completed-string nil)
(full-completed-string nil)
(input-is-directory-p (when (plusp (length so-far))
(char= (aref so-far (1- (length so-far))) #\/))))
(unless (null pathnames)
(setf length-common-prefix
(loop with length = (length first-string)
for string in (cdr strings)
do (setf length (min length (or (mismatch string first-string) length)))
finally (return length))))
(unless (null pathnames)
(setf completed-string
(subseq first-string (length directory-prefix)
(if (null (cdr pathnames)) nil length-common-prefix)))
(setf full-completed-string
(concatenate 'string directory-prefix completed-string)))
(case mode
((:complete-limited :complete-maximal)
(cond ((null pathnames)
(values so-far nil nil 0 nil))
((null (cdr pathnames))
(values completed-string (plusp (length so-far)) (car pathnames) 1 nil))
(input-is-directory-p
(values completed-string t (parse-namestring so-far) (length pathnames) nil))
(t
(values completed-string nil nil (length pathnames) nil))))
(:complete
;; This is reached when input is activated, if we did
;; completion, that would mean that an input of "foo" would
;; be expanded to "foobar" if "foobar" exists, even if the
;; user actually *wants* the "foo" pathname (to create the
;; file, for example).
(values so-far t so-far 1 nil))
(:possibilities
(values nil nil nil (length pathnames)
(loop with length = (length directory-prefix)
for name in pathnames
collect (list (subseq (namestring name) length nil)
name)))))))
(in-package :info.read-eval-print.climacs.ext)
;; C-i でも補完
(progn
(clim:define-gesture-name :complete :keyboard (:tab))
(clim:define-gesture-name :complete :keyboard (#\i :control) :unique nil))
Quicklisp を使う。
まだベータ http://www.quicklisp.org/beta/
http://beta.quicklisp.org/quicklisp.lisp からダウンロードする。
ダウンロードした quicklisp.lisp を Emacs で開く。
C-c C-l で quicklisp.lisp をロードする。
To continue, evaluate: (quicklisp-quickstart:install)
と repl に表示されるので、そのとおり実行する。
続いて (ql:add-to-init-file) を実行すると、~/.sbclrc に次のコードが追加される。
;;; The following lines added by ql:add-to-init-file:
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
これで Quicklisp にインストールと設定は完了。
次の SLIME 関係。
(ql:quickload "quicklisp-slime-helper") を実行するの次のように表示されるので、追加しておく。
To use, add this to your ~/.emacs:
(load (expand-file-name "~/quicklisp/slime-helper.el"))
以上、全て完了。
アップデートは次のとおり。
;; インストールしたものをアップデートする。
(ql:update-all-dists)
;; Quicklisp のアップデートする。
(ql:update-client)
自前のライブラリは Quicklisp 的にどうするのがいいんでしょう。とりあえず、いままでどおり ~/.sbclrc で asdf:*central-registry* に pushnew することにした。
Quicklisp 導入後の ~/.sbclrc はこんなのになった。
;;;;; -*-lisp-*-
;;デバッグ用セッティング
(declaim (optimize (debug 3) (safety 3) (compilation-speed 3)))
;;(declaim (optimize (debug 0) (safety 0) (speed 3) (space 0) (compilation-speed 0)))
;;; The following lines added by ql:add-to-init-file:
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(require :asdf)
;; fasl のバージョンが古い場合リコンパイルする
(defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file))
(handler-case (call-next-method o c)
(#+sbcl sb-ext:invalid-fasl
#+allegro excl::file-incompatible-fasl-error
#+lispworks conditions:fasl-error
#+cmu ext:invalid-fasl
#-(or sbcl allegro lispworks cmu) error ()
(asdf:perform (make-instance 'asdf:compile-op) c)
(call-next-method))))
;; ;; clbuild
;; (pushnew (translate-logical-pathname "home:clbuild;systems;")
;; asdf:*central-registry*)
;; ~/letter/lib 以下の asd を登録する。
(flet ((f (path)
(loop for path in (directory path)
do (let ((pd (pathname-directory path)))
(unless (member "_darcs" pd :test #'equal)
(pushnew (make-pathname :directory pd)
asdf:*central-registry*
:test #'equal))))))
(f "~/letter/lisp/lib/**/*.asd")
(f "~/letter/lisp/craft/**/*.asd"))
;; iko-yo
(pushnew "~/job/actindi/ikoyo/iko-yo-tool/" asdf:*central-registry*)
(defun climacs ()
"Climacs を起動する。"
(load (merge-pathnames ".climacs.lisp" (user-homedir-pathname))))
(defun maxima ()
"Maxima を起動する。"
(let ((*default-pathname-defaults*
(translate-logical-pathname "home:clbuild;source;maxima;src;")))
(load "maxima-build.lisp")
(maxima-load)
(cl-user::run)))
(require :swank)
(ql:quickload "series")
(series::install :implicit-map t)
(require :info.read-eval-print.repl-tw)
#+http\://informatimago.com/develop/lisp/index.html
(progn
(defparameter *informatimago-base* "~/letter/lisp/lib/com/informatimago/")
(mapc (lambda (p) (pushnew (make-pathname :name nil :type nil :version nil :defaults p)
asdf:*central-registry* :test #'equal))
(directory (merge-pathnames "**/*.asd" *informatimago-base* nil)))
(asdf:oos 'asdf:load-op :com.informatimago.common-lisp))
ついでに ~/.emacs の SLIM 関係はこう。
;;;;; quicklisp-slime-helper
(load (expand-file-name "~/quicklisp/slime-helper.el"))
;;;;;SLIME
(setq common-lisp-hyperspec-root "file:/usr/share/doc/hyperspec/")
;;(setq slime-communication-style :fd-handler)
;;(setq slime-communication-style :spawn)
;;(setq slime-communication-style :sigio)
(setq slime-net-coding-system 'utf-8-unix)
(setq slime-lisp-implementations
`((sbcl ("sbcl") :coding-system utf-8-unix)
(ccl ("/home/ancient/local/opt/ccl/lx86cl64")
:coding-system utf-8-unix)
;; (ccl ("/home/ancient/letter/lisp/clbuild/clbuild"
;; "--implementation" "ccl" "lisp")
;; :coding-system utf-8-unix)
(deb-sbcl ("/usr/bin/sbcl") :coding-system utf-8-unix)
(clisp ("/home/ancient/letter/lisp/clbuild/clbuild"
"--implementation" "clisp" "lisp")
:coding-system utf-8-unix)
(abcl ("my-abcl")
:coding-system utf-8-unix)
(acl ("/home/ancient/local/opt/acl82express/alisp")
:coding-system utf-8-unix)
(cmucl ("lisp"))))
;;(add-hook 'lisp-mode-hook
;; (lambda ()
;; (cond ((not (featurep 'slime))
;; (require 'slime)
;; (normal-mode)))))
(setq slime-truncate-lines nil)
(setq slime-enable-evaluate-in-emacs t)
(defun my-slime-complete-form ()
(interactive)
(condition-case nil
(slime-complete-form)
(error
(save-excursion
(insert
(multiple-value-bind (ops arg-indices points)
(slime-enclosing-form-specs)
(run-hook-with-args 'slime-autodoc-hook ops arg-indices points)
(multiple-value-bind (cache-key retrieve-form)
(slime-compute-autodoc-rpc-form ops arg-indices points)
(slime-eval retrieve-form))))))))
(add-to-list 'auto-mode-alist '("\\.asd$" . common-lisp-mode))
;;(add-path "~/letter/lisp/clbuild/source/slime")
;;(add-path "~/letter/lisp/clbuild/source/slime/contrib")
(eval-after-load "slime"
'(progn
(slime-setup '(slime-repl
slime-asdf
slime-fancy
slime-indentation
slime-references
slime-tramp
slime-banner))
(setq slime-complete-symbol*-fancy t)
(setq slime-complete-symbol-function 'slime-fuzzy-complete-symbol)
(setq slime-autodoc-use-multiline-p t)
(global-set-key [(control ?\;)] 'slime-selector)
(loop for (key command) in
'(([(control ?c) ?\;] slime-insert-balanced-comments)
([(control ?u) (control ?c) ?\;] slime-remove-balanced-comments)
([(control ?c) ?\;] slime-insert-balanced-comments)
("\C-j" slime-que-print-last-expression)
("\C-m" newline-and-indent)
("\C-u" universal-argument)
("\C-i" slime-indent-and-complete-symbol))
do (define-key slime-mode-map key command))
(setq lisp-indent-function 'cl-indent:function)
;; Series のためのインデント
(define-cl-indent '(mapping ((&whole 4 &rest (&whole 1 1 2)) &body)))
(define-cl-indent '(iterate ((&whole 4 &rest (&whole 1 1 2)) &body)))
(define-cl-indent '(producing ((&whole 4 &rest (&whole 1 1 2)) &body)))
;; defpackage も調整
(define-cl-indent '(defpackage (4 2)))
;; tramp
;;(push (slime-create-filename-translator :machine-instance "li31-15"
;; :remote-host "li31-15.members.linode.com"
;; :username "ancient")
;; slime-filename-translations)
(progn
(defun slime-que-print-last-expression (string)
"Evaluate sexp before point; print value into the current buffer"
(interactive (list (slime-last-expression)))
(slime-eval-async `(swank:eval-and-grab-output ,string)
(lambda (result)
(destructuring-bind (output value) result
(push-mark)
(or (bolp) (insert "\n"))
(let ((output-p (if (string= "" output) "" ";;-> ")))
(insert (concat output-p
(if (<= 5 (length output))
(substring (replace-regexp-in-string "^" ";; " output) 5)
output)))
(and output-p (or (bolp) (insert "\n")))
(insert (concat ";;=> " (if (<= 5 (length value))
(substring (replace-regexp-in-string "^" ";; " value) 5)
value))
"\n")))))))
;; g000001 さん作
(progn
(defun gcode-lookup ()
"カーソル位置のシンボルを Google Code で検索 (lisp 決め打ち)"
(interactive)
(browse-url
(format "http://www.google.com/codesearch?q=%s+lang:%s+file:\\.%s$&hl=ja&num=20"
(thing-at-point 'symbol) "lisp" "lisp")))
(define-key slime-mode-map
[(control ?c) (control ?d) ?g] 'gcode-lookup))))
(require 'slime-autoloads)
Quicklisp すごいな。登録されているプロジェクト数がもう 430 を越えてる。全部 REPL から操作できるのもすばらしい。
ありがとうございます。
~/.tc
;;; -*-emacs-lisp-*- This file is automatically created
(setq tcode-data-directory (expand-file-name "~/.tcode/"))
(setq tcode-site-data-directory tcode-data-directory)
(setq tcode-default-input-method "japanese-T-Code")
;; 前置型交ぜ書き
;; (setq tcode-use-prefix-mazegaki t)
;; ○句読点等の切り替え
;; 標準よりも組み合わせを増やし、かつ「(」や「)」も切り替えるようにする。
(defvar tcode-left-paren "（" "* 開き括弧")
(make-variable-buffer-local 'tcode-left-paren)
(defvar tcode-right-paren "）" "* 閉じ括弧")
(make-variable-buffer-local 'tcode-right-paren)
(setq tcode-switch-table-list
'(;; 全角系 デフォールト
((tcode-touten . "、")
(tcode-kuten . "。")
(tcode-left-paren . "（")
(tcode-right-paren . "）"))
;; 半角系
((tcode-touten . ", ")
(tcode-kuten . ". ")
(tcode-left-paren . "(")
(tcode-right-paren . ")"))
;; 2バイト系
((tcode-touten . "，")
(tcode-kuten . "．")
(tcode-left-paren . "（")
(tcode-right-paren . "）"))))
;;; ○句読点の自動切り替え
;; 切り替えの規準(正規表現)の指定
(setq tcode-kutouten-regexp-alist
(list '("[、。]" . 1)
(if (tcode-nemacs-p)
'("\\z[,.]" . 2)
'("\\cj[,.]" . 2))
'("[，．]" . 3)))
;; 切り替える主モードを指定(text-mode latex-mode)
(setq tcode-auto-identify-kutouten-mode-list
'(text-mode latex-mode hnf-mode))
;; バッファで最初に Tコードモードに入ったときに、
;; 句読点を自動的に切り替える。
(add-hook 'tcode-mode-hook 'tcode-auto-switch-kutouten)
;; EELLL でイメージを使わない。
(setq eelll-use-image nil)
;; ヘルプ用のウィンドウの大きさを自動的に調整する。
(setq tcode-adjust-window-for-help t)
;; isearch-printing-char: Symbol's function definition is void: isearch-last-command-char 対策
;; tc-sysdep.el の L231
(if (string-match "^\\(19\\|2[0123]\\)" emacs-version)
(progn
(defun tcode-redo-command (ch)
"キー CH を現在のキーマップで再実行する"
(setq unread-command-events
(cons (character-to-event ch) unread-command-events)))
(or (fboundp 'character-to-event)
(defun character-to-event (ch)
ch))
;; XEmacs
(or (fboundp 'isearch-last-command-char)
(defun isearch-last-command-char ()
last-command-char))
(or (boundp 'search-upper-case)
(setq search-upper-case 'not-yanks)))
;; NEmacs
(defun tcode-redo-command (ch)
"キー CH を現在のキーマップで再実行する"
(setq unread-command-char ch)))
;; キーボードのカスタマイズ
(setq tcode-key-layout-list
'(("quek" . (?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?0
?' ?( ?) ?p ?y ?f ?g ?c ?r ?l
?a ?o ?e ?u ?i ?d ?h ?t ?n ?s
?\; ?q ?j ?k ?x ?b ?m ?w ?v ?z
?! ?\@ ?# ?$ ?% ?^ ?& ?* ?< ?>
?\" ?, ?. ?P ?Y ?F ?G ?C ?R ?L
?A ?O ?E ?U ?I ?D ?H ?T ?N ?S
?L ?Q ?J ?K ?X ?B ?M ?W ?V ?Z
))))
(add-hook
'tcode-ready-hook
(lambda ()
(set-tcode-mode-key
"/" 'tcode-insert-ya-outset) ; 記号入力
(set-tcode-mode-key ; 片仮名変換
"$" 'tcode-katakana-preceding-chars)
;; モード切り替え時にヘルプ用のバッファを消す。
(setq tcode-auto-remove-help-count 1)
(add-hook 'tcode-toggle-hook
'tcode-auto-remove-help)
;; カーソルに色をつける
(and window-system
(tcode-enable-cursor-to-change-color)
(setq tcode-mode-on-cursor-color "Violet"))
;; org-mode 対応
(push 'org-self-insert-command tcode-input-command-list)
;; 独自キーマップ
(tcode-set-key-layout "quek")
;; 補完機能
(require 'tc-complete)
;; "\" を補完・確定に使う。
;;(tcode-set-key "\" 'tcode-mazegaki-complete-and-convert)
;; 1文字から補完する。
(setq tcode-complete-min-context-length 1)
;; ;; コントロールキーを伴わないモード切り替え
;; (global-set-key " " 'tcode-electric-space)
;; (global-set-key ")" 'tcode-electric-comma)
;; (tcode-set-key " " 'tcode-electric-space)
;; zap-to-char の拡張
(global-set-key "\M-z" 'tcode-zap-to-char)
))
;;; ●文字表を読んだ後に行う設定
;;; ○2ストローク以上のストロークのキー割り当て
(add-hook 'tcode-after-load-table-hook
(lambda ()
(when (eq tcode-input-method 'tcode)
;; Tコード用の設定
;; 表を一部変更する。
;; 0 1 2 3 4 5 6 7 8 9
;; 10 11 12 13 14 15 16 17 18 19
;; 20 21 22 23 24 25 26 27 28 29
;; 30 31 32 33 34 35 36 37 38 39
(tcode-set-action-to-table '(5 5) "です。")
(tcode-set-action-to-table '(5 6) "ます。")
(tcode-set-action-to-table '(5 7) "削")
;; QWERTY での「ke」に変数 tcode-left-paren を割り当てる。
(tcode-set-action-to-table '(27 12)
'tcode-left-paren)
;; QWERTY での「id」に変数 tcode-right-paren を割り当てる。
(tcode-set-action-to-table '(17 22)
'tcode-right-paren))))
(progn ;; フィルターによる拡張入力。
(defun my-t-code-filter (x)
(or (cdr (assoc x '((?で . "です。")
(?ま . "ます。")
(?し . "した。")
(?事 . "こと")
(?〜 . "から")
(?消 . "削")
(?願 . "お願いします。")
(?以 . "以上、")
(?メ . "read.eval.print@gmail.com")
(?住 . "横浜市泉区岡津町110-3 グレーシアパーク山手台 EAST 壱番館 412")
)))
x))
(setq tcode-input-filter-functions
'((tcode-katakana-mode . japanese-katakana)
((and (boundp 'tcode-bushu-prefix-list)
tcode-bushu-prefix-list)
. tcode-bushu-prefix-convert)
(tcode-alnum-2-byte . tcode-1-to-2)
(tcode-shift-state . my-t-code-filter)))
)
(defun quek-dupm-tcode-key-table ()
"(quek-dupm-tcode-key-table)"
(load "tc-tbl")
(remove-if
(lambda (x)
(or (string= " " (caadr x))
(string= "■" (caadr x))
(atom (caar x))))
(mapcar (lambda (x)
(list (list (mapcar (lambda (key)
(char-to-string (tcode-key-to-char key)))
(tcode-encode x)))
(list (char-to-string x))))
(apply 'concat (mapcar 'identity tcode-tbl)))))
この記事は 漢直 Advent Calendar : ATND の中のある 1 日です。
Eamcs での T-Code 入力 tc2 をちょっ便利にしてみます。
AZIK の特殊拡張では「ます」を「ms」、「こと」を「kt」、「から」を「kr」で打てます。これらを T-Code 打つと一文字 2 ストロークですから、それぞれ 4 ストロークで、 AZIK の倍の打鍵が必要になります。
tc2 でも AZIK と同様に 2 ストロークで入力できるようにしたいと思います。
tc2 には入力フィルタという仕組みがあり、打鍵の結果をいじることができます。
;; "-shift" 付のレイアウトを指定します。
(tcode-set-key-layout "qwerty-jis-shift")
(progn ;; フィルターによる拡張入力。
(defun my-t-code-filter (x)
(or (cdr (assoc x '((?で . "です。")
(?ま . "ます。")
(?し . "した。")
(?事 . "こと")
(?〜 . "から")
(?消 . "削")
(?願 . "お願いします。")
(?以 . "以上、")
(?メ . "foo.bar.baz@gmail.com")
(?住 . "横浜市中区上野町123-42")
)))
x))
(setq tcode-input-filter-functions
'((tcode-katakana-mode . japanese-katakana)
((and (boundp 'tcode-bushu-prefix-list)
tcode-bushu-prefix-list)
. tcode-bushu-prefix-convert)
(tcode-alnum-2-byte . tcode-1-to-2)
(tcode-shift-state . my-t-code-filter)))
)
これで、「ます。」は「Shift+ま」（「Md」）、「こと」は「Shift+事」（「Uf」）、「から」は「Shift+〜」（「<m」）で入力できるようになります。シフトキーは必要でするが 2 ストロークになりました。
また、「Shift+メ」でメールアドレスを入力したり、「Shift+住」で住所を入力したりするのもいいですね。
あまり興味を持ってもらえない Climacs の Dired ではあるが、ないと不便だと思うので実装した。まだ、一覧表示してファイルを開くことしかできない。
と、分からないところが多い。
ソースは github にあるけど、ここにも貼り付けておく。
;;; -*- mode: lisp; indent-tabs: nil -*-
(in-package :info.read-eval-print.climacs.dired)
(define-syntax-command-table dired-table :errorp nil
:inherit-from '(drei:movement-table climacs-gui:window-table))
;;;;;; presentation
;;(define-presentation-type dired ()
;; :inherit-from 't)
;;
;;(define-presentation-method presentation-typep (object (type dired))
;; (pathnamep object))
;;
;;(define-presentation-method present (object (type dired) stream
;; (view textual-view)
;; &key)
;; (let ((stat (sb-posix:stat (namestring object)))
;; (name (if (directory-pathname-p object)
;; (car (last (pathname-directory object)))
;; (file-namestring object))))
;; (format stream
;; " ~o ~a ~a ~6,d ~a ~a"
;; (sb-posix:stat-mode stat)
;; (file-author object)
;; (sb-posix:group-name (sb-posix:getgrgid (sb-posix:stat-gid stat)))
;; (sb-posix:stat-size stat)
;; (dt:|yyyy-mm-dd hh:mm| (dt:from-posix-time (sb-posix:stat-mtime stat)))
;; name)))
;;;; dired-syntax
(define-syntax dired-syntax (fundamental-syntax)
()
(:name "Dired")
(:command-table dired-table))
(defmethod name-for-info-pane ((syntax dired-syntax) &key pane)
(declare (ignore pane))
(format nil "Dired"))
(defmethod display-syntax-name ((syntax dired-syntax)
(stream extended-output-stream) &key pane)
(declare (ignore pane))
(princ "Dired" stream))
;;;; dired-mode
(define-syntax-mode dired-mode ()
((path :initarg :path))
(:documentation "A mode for Directory editing.")
(:applicable-syntaxes fundamental-syntax))
(defmethod syntax-command-tables append ((syntax dired-mode))
'(dired-table))
(defun ensure-pathname-for-dired (path)
(make-pathname :directory (namestring path)
:name :wild))
;;(defun make-buffer-contents (path)
;; (loop for x in (directory (ensure-pathname-for-dired path))
;; do (defmethod presentation-type-of ((object (eql x)))
;; 'dired)
;; nconc (list x #\Newline)))
(defun make-buffer-contents (path)
(str (namestring path) #\Newline
(trivial-shell:shell-command #"""ls -al #,(namestring path)""")))
(defun make-dired-buffer (path)
(let ((buffer (make-new-buffer)))
(insert-buffer-sequence buffer 0 (make-buffer-contents path))
(clear-undo-history buffer)
buffer))
(defun find-directory (path)
(cond ((null path)
(display-message "No file name given.")
(beep))
((not (directory-pathname-p path))
(display-message "~A is a not directory name." path)
(beep))
((not (probe-file path))
(display-message "~A is a not found." path)
(beep))
(t
(let* ((buffer (make-dired-buffer path))
(view (climacs-core::make-new-view-for-climacs
*esa-instance* 'textual-drei-syntax-view
:name (namestring path)
:buffer buffer)))
(unless (climacs-core::buffer-pane-p (current-window))
(climacs-core::other-window (or (find-if (^ typep _window 'climacs-core::climacs-pane)
(windows *esa-instance*))
(climacs-core::split-window t))))
(setf (offset (point buffer)) (offset (point view))
(syntax view) (make-syntax-for-view view 'dired-syntax)
(file-write-time buffer) nil
(needs-saving buffer) nil
(name buffer) (namestring path))
(enable-mode view 'dired-mode :path path)
(setf (current-view (current-window)) view)
(evaluate-attribute-line view)
(setf (filepath buffer) (pathname path)
(read-only-p buffer) t)
(beginning-of-buffer (point view))
buffer))))
(define-command (com-dired :name t :command-table esa-io-table)
((path 'pathname
:prompt "Dired (directory): "
:prompt-mode :raw
:default (esa-io::directory-of-current-buffer)
:default-type 'pathname
:insert-default t))
"Prompt for a directory name then edit that directory."
(handler-case (find-directory path)
(file-error (e)
(display-message "~a" e))))
(defun dired-find-file (path)
(unless path
(let* ((dir (slot-value (syntax (current-view)) 'path))
(mark (point))
(line (region-to-string (beginning-of-line (clone-mark mark))
(end-of-line (clone-mark mark)))))
(ppcre:register-groups-bind (d file)
("(.)(?:[^ ]+ +){7}(.*\)" line)
(setf path (merge-pathnames (str file (when (string= "d" d) "/")) dir)))))
(when path
(if (directory-pathname-p path)
(find-directory path)
(find-file path))))
(define-command (com-dired-find-file :name t :command-table dired-table)
((path 'pathname
:prompt "File: "
:prompt-mode :raw
:default-type 'pathname))
"Find file."
(dired-find-file path))
(set-key 'com-dired-find-file 'dired-table '((#\Newline)))
(set-key `(drei-commands::com-forward-line ,*numeric-argument-marker*) 'dired-table
'((#\n)))
(set-key `(drei-commands::com-backward-line ,*numeric-argument-marker*) 'dired-table
'((#\p)))
(set-key `(climacs-commands::com-kill-view (current-view)) 'dired-table
'((#\q)))
トゥルータイプフォントなら (require :mcclim-freetype) で日本語表示できていたが、ビットマップフォントで日本語表示する法方がようやく分った。
clim-clx::*clx-text-family+face-map* で "adobe-xxxxx" を使うようになっているのを "*-*" に変更してしまう。
フォントサイズの指定は Climacs でビットマップフォントを使った時のフォンサイズ変更 を参照。
(setq clim-clx::*clx-text-family+face-map*
'(:fix
("*-*"
(:roman "medium-r"
:bold "bold-r"
:italic "medium-o"
:bold-italic "bold-o"
:italic-bold "bold-o"))
:sans-serif
("*-*"
(:roman "medium-r"
:bold "bold-r"
:italic "medium-o"
:bold-italic "bold-o"
:italic-bold "bold-o"))
:serif
("*-*"
(:roman "medium-r"
:bold "bold-r"
:italic "medium-i"
:bold-italic "bold-i"
:italic-bold "bold-i"))))
McCLIM の CLX バックエンドの文字を描画する所に 1 行追加する。
Index: Backends/CLX/medium.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp,v
retrieving revision 1.91
diff -u -r1.91 medium.lisp
--- Backends/CLX/medium.lisp 15 Nov 2009 11:27:26 -0000 1.91
+++ Backends/CLX/medium.lisp 15 Dec 2010 12:03:10 -0000
@@ -1101,6 +1101,7 @@
(multiple-value-bind (halt width)
(xlib:draw-glyphs mirror gc x y string
:start start :end end
+ :size 16
:translate #'translate)))))))
(defmethod medium-buffering-output-p ((medium clx-medium))
cvs diff: Diffing Backends/Graphic-Forms
これで、ビットマップフォントでも日本語表示ができるようになった。
Climacs で T-Code で uim を使わずにと思っていたが、uim を使った方が楽だし便利だと思いなおす。
ということで mcclim-uim が T-Code では動かなかったのを修正した。
https://github.com/quek/mcclim-uim
(require :mcclim-uim) すれば Climacs（McCLIM）で uim が動くはず。
さて、だれか使う人いるのかな? SKK も動くはず。
何だか短いので Climacs のカスタマイズのコードでも載せておく。
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :mcclim)
(require :mcclim-freetype)
(require :climacs)
(require :mcclim-uim)
)
;; フォントを大きく。
(setf mcclim-truetype::*dpi* 96)
;; C-h をバックスペースにするために、C-h のキーストロークを削除。
(clim:remove-keystroke-from-command-table 'esa:help-table
'(:keyboard #\h 512)
:errorp nil)
;; C-h でバックスペース
(esa:set-key `(drei-commands::com-backward-delete-object
,clim:*numeric-argument-marker*
,clim:*numeric-argument-marker*)
'drei:deletion-table
'((#\h :control)))
;; C-m newline and indent
(esa:set-key 'drei-lisp-syntax::com-newline-indent-then-arglist
'drei-lisp-syntax:lisp-table
'((#\m :control)))
;; C-/ undo
(esa:set-key 'drei-commands::com-undo
'drei:editing-table
'((#\/ :control)))
;; C-i で補完
(esa:set-key 'drei-lisp-syntax::com-indent-line-and-complete-symbol
'drei-lisp-syntax:lisp-table
'((#\i :control)))
;; Climacs 起動
(climacs:climacs-rv :width 900 :height 1000 :new-process t)
Emacs の SLIME から Climacs 関係の関数を呼ぼうとすると、スペシャル変数が nil になっていて動いてくれない。
次のように clim:*application-frame* に Climacs のアプリケーションフレームをバインドし、 drei:with-bound-drei-special-variables を使うとスペシャル変数がバインドされてうまく動いてくれる。
もちろん、Climacs は動かしておく必要がある。
(defmacro with-climacs (&body body)
`(let ((clim:*application-frame* (clim:find-application-frame 'climacs-gui:climacs)))
(drei:with-bound-drei-special-variables (clim:*application-frame*)
,@body)))
(with-climacs
(values
(esa:current-buffer)
(drei:drei-instance)
(clim:point)
(or (drei-buffer:end-of-buffer-p (clim:point))
(drei-buffer:object-after (clim:point)))))
;;=> #<CLIMACS-GUI:CLIMACS-BUFFER size:78 {1005426701}>
;; #<CLIMACS-GUI:CLIMACS-PANE TEXTUAL-DREI-SYNTAX-VIEW {1005190AD1}>
;; #<DREI-BUFFER:DELEGATING-RIGHT-STICKY-MARK 50 {1005426731}>
;; #\(
以前、 uim を使って McCLIM で日本語入力 みたいなことをやっていた。
今回は Common Lisp だけでどうにかできないかと、あがいてみた。
(in-package :clim-user)
(use-package :climacs)
(use-package :climacs-gui)
(progn
(make-command-table 'tcode-table :errorp nil
:inherit-from '(drei:editor-table global-climacs-table))
(let (on)
(define-command (com-tcode-mode-toggle :name t :command-table global-climacs-table) ()
(when (setf on (not on))
(esa:simple-command-loop 'tcode-table on))))
(esa:set-key 'com-tcode-mode-toggle 'global-climacs-table '((#\\ :control)))
(macrolet ((m (k1 k2 c)
(let ((com-name (intern (format nil "com-tcode-key-~c-~c" k1 k2))))
`(progn
(define-command (,com-name :name t :command-table tcode-table) ()
(drei-core:insert-character ,c))
(esa:set-key ',com-name 'tcode-table '((,k1) (,k2)))))))
(m #\f #\u #\あ)
(m #\d #\e #\い)
(m #\f #\e #\う))
)
こんな感じで地味にできそうではある。
esa:simple-command-loop を使うのがいいかは分かってない。
マイナーモードというものが Climacs では見付けられなかったので、 esa:simple-command-loop を使ってみた。
今夜も Common Lisp の SERIES.
SERIES で scan-file 系は encapsulated と defS のどちらを使って実装すべきなんだろうか?
producing は with-open-file(unwind-protect) のために使えないと思うから、 encapsulated と defS のどちらかを使うんだろうと思うのだけれど。
あっ、defS の方の最後の ,external-format のところ、これでいいのか分からない。
(defun scan-line2-wrap (file name external-format body)
`(with-open-file (,file ,name :external-format ,external-format) ,body))
(defmacro scan-line2 (name &optional (external-format :default))
(let ((file (gensym)))
`(encapsulated #'(lambda (body)
(scan-line2-wrap ',file ',name ',external-format body))
(scan-fn t
(lambda () (read-line ,file nil))
(lambda (_) (declare (ignore _)) (read-line ,file nil))
#'null))))
;;(scan-line2 "~/.sbclrc")
;;(scan-line2 "~/.sbclrc" :utf-8)
;;(collect (scan-line2 "~/.sbclrc"))
;;(collect (scan-line2 "~/.sbclrc" :utf-8))
(series::defS scan-line (name &optional (external-format :default))
"(scan-line file-name &key (external-format :default))"
(series::fragl
((name) (external-format)) ((items t))
((items t)
(lastcons cons (list nil))
(lst list))
()
((setq lst lastcons)
(with-open-file (f name :direction :input :external-format external-format)
(loop
(cl:let ((item (read-line f nil)))
(unless item
(return nil))
(setq lastcons (setf (cdr lastcons) (cons item nil))))))
(setq lst (cdr lst)))
((if (null lst) (go series::end))
(setq items (car lst))
(setq lst (cdr lst)))
()
()
:context)
:optimizer
(series::apply-literal-frag
(cl:let ((file (series::new-var 'file)))
`((((external-format)) ((items t))
((items t))
()
()
((unless (setq items (read-line ,file nil))
(go series::end)))
()
((#'(lambda (code)
(list 'with-open-file
'(,file ,name :direction :input :external-format ,external-format)
code)) :loop))
:context)
,external-format))))
今日、千葉さんに producing を教えてもらったので、 cl-ppcre:split を series にしてみた。
どうも multiple-value-bind の中の setq は拾ってくれないらしく、ダミーの setq を書いて回避した。
これで Clojure の何でもシーケンスみたいに、何でもシリーズができそうだ。
(defun scan-re-split (regex string)
(declare (optimizable-series-function))
(producing (z) ((r regex) (s string) (scan-start 0) subseq-start subseq-end)
(loop
(tagbody
;; multiple-value-bind の中での setq は認識されないのでダミーで setq する。
(setq scan-start scan-start
subseq-start subseq-start
subseq-end subseq-end)
(multiple-value-bind (start end) (ppcre:scan r s :start scan-start)
(unless start
(if (< (length s) scan-start)
(terminate-producing)
(setq start (length s)
end (1+ start))))
(setq subseq-start scan-start
subseq-end start
scan-start end))
(next-out z (subseq s subseq-start subseq-end))))))
(assert (equal '("a" "b" "c") (collect (scan-re-split "/" "a/b/c"))))
(assert (equal '("") (collect (scan-re-split "/" ""))))
(assert (equal '("" "") (collect (scan-re-split "/" "/"))))
(assert (equal '("" "a") (collect (scan-re-split "/" "/a"))))
(assert (equal '("" "a" "") (collect (scan-re-split "/" "/a/"))))
(assert (equal '("" "" "a" "" "") (collect (scan-re-split "/" "//a//"))))
(assert (equal '("a" "b" "cc" "d") (collect (scan-re-split "\\s+" "a b cc
d"))))
(collect (scan-re-split "/" "a/b/c")) をマクロ展開すると次のようになる。
(COMMON-LISP:LET* ((#:OUT-1354 "a/b/c"))
(COMMON-LISP:LET ((#:SCAN-1349 0)
(#:SUBSEQ-1348 NIL)
(#:SUBSEQ-1347 NIL)
#:Z-1350
(#:LASTCONS-1344 (LIST NIL))
#:LST-1345)
(DECLARE (TYPE CONS #:LASTCONS-1344)
(TYPE LIST #:LST-1345))
(SETQ #:LST-1345 #:LASTCONS-1344)
(TAGBODY
#:LL-1355
(PROGN
(SETQ #:SCAN-1349 #:SCAN-1349)
(SETQ #:SUBSEQ-1348 #:SUBSEQ-1348)
(SETQ #:SUBSEQ-1347 #:SUBSEQ-1347))
(MULTIPLE-VALUE-CALL
#'(LAMBDA (&OPTIONAL (START) (END) &REST #:G12-1346)
(DECLARE (IGNORE #:G12-1346))
(IF START
NIL
(PROGN
(IF (< (LENGTH #:OUT-1354) #:SCAN-1349)
(GO SERIES::END)
(PROGN
(SETQ START (LENGTH #:OUT-1354))
(SETQ END (1+ START))))))
(PROGN
(SETQ #:SUBSEQ-1348 #:SCAN-1349)
(SETQ #:SUBSEQ-1347 START)
(SETQ #:SCAN-1349 END)))
(CL-PPCRE:SCAN "/" #:OUT-1354 :START #:SCAN-1349))
(SETQ #:Z-1350 (SUBSEQ #:OUT-1354 #:SUBSEQ-1348 #:SUBSEQ-1347))
(SETQ #:LASTCONS-1344 (SETF (CDR #:LASTCONS-1344) (CONS #:Z-1350 NIL)))
(GO #:LL-1355)
SERIES::END)
(CDR #:LST-1345)))
ImageMagick は便利。
repl へのアイコン表示用なので trivial-shell:shell-command での mogrify 呼出で十分。
これいタイムラインを眺めるにはひざの上の猫くらいのものができた。
https://github.com/quek/twitter-client
(defun %get-profile-image (image-url local-path)
(unless (probe-file local-path)
(ensure-directories-exist local-path)
(with-open-file (out local-path :direction :output :element-type '(unsigned-byte 8))
(write-sequence (drakma:http-request image-url) out))
;; ImageMagic に頼る。
(trivial-shell:shell-command #"""mogrify -resize 32x32 #,local-path""")))
(series::install :implicit-map t) していると collect-ignore の方がいいね。
(iterate ((x (scan-file "~/.sbclrc" #'read-line)))
(write-line x))
(collect-ignore (write-line (scan-file "~/.sbclrc" #'read-line)))
;; これはもうちょっと。。。
(defun query-message ()
(collect-fn 'string (constantly "") (^ format nil "~a~&~a" _a _b)
(until-if (^ string= "." (if (string= "\\q" _)
(return-from query-message nil)
_))
(scan-stream *terminal-io* #'read-line))))
Common Lisp で Twitter の User Streams の続きで、アイコンを表示できるようにした。
swank::eval-in-emacs を使うと Common Lisp から Emacs に eval させることができる。それを使って Emacs で (iimage-mode 1) を実行して表示させている。
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :series)
(require :cl-oauth)
(require :drakma)
(require :cl-json)
(require :quek)
(require :net-telent-date))
;; 対 drakma 用おまじない
(setf drakma:*drakma-default-external-format* :utf-8)
(pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)
(defpackage :repl-twitter-client
(:use :cl :series :quek)
(:shadowing-import-from :series let let* multiple-value-bind funcall defun)
(:export #:tweet
#:reply
#:timeline))
(in-package :repl-twitter-client)
(eval-when (:compile-toplevel :load-toplevel :execute)
(series::install :pkg :repl-twitter-client :implicit-map t))
(defparameter *profile-image-directory* (ensure-directories-exist "/tmp/repl-twitter-client-images/"))
(defun query-message ()
(string-right-trim
#(#\Space #\Cr #\Lf #\Tab)
(with-output-to-string (out)
(loop for line = (read-line *terminal-io*)
until (string= "." line)
if (string= "\\q" line)
do (return-from query-message nil)
do (write-line line out)))))
(macrolet ((m ()
(let ((sec (collect-first (scan-file "~/.twitter-oauth.lisp"))))
`(defparameter *access-token*
(oauth:make-access-token :consumer (oauth:make-consumer-token
:key ,(getf sec :consumer-key)
:secret ,(getf sec :consumer-secret))
:key ,(getf sec :access-key)
:secret ,(getf sec :access-secret))))))
(m))
(defun update (message &key reply-to)
(when message
(json:decode-json-from-string
(oauth:access-protected-resource
"http://api.twitter.com/1/statuses/update.json"
*access-token*
:request-method :post
:user-parameters `(("status" . ,#"""#,message #'求職中""")
,@(when reply-to `(("in_reply_to_status_id" . ,(princ-to-string reply-to)))))))))
(defun tweet ()
(let ((message (query-message)))
(update message)
message))
(defun reply (in-reply-to-status-id)
(let ((message (query-message)))
(update message :reply-to in-reply-to-status-id)
message))
(defun created-at-time (x)
(multiple-value-bind (s m h) (decode-universal-time (net.telent.date:parse-time x))
(format nil "~2,'0d:~2,'0d:~2,'0d" h m s)))
(defun print-tweet (json-string)
(ignore-errors
(json:with-decoder-simple-clos-semantics
(let ((json:*json-symbols-package* :repl-twitter-client))
(let ((x (json:decode-json-from-string json-string)))
(with-slots (text user id created--at) x
(with-slots (name screen--name profile--image--url id) user
(let ((path (get-profile-image id profile--image--url)))
(format
*query-io*
#"""~&#,path #,screen--name (#,name,) #,(created-at-time created--at) #,id,~&#,text,~%""")))))))))
(defun timeline ()
(bordeaux-threads:make-thread
(^ with-open-stream (in (oauth:access-protected-resource
"https://userstream.twitter.com/2/user.json"
*access-token*
:drakma-args '(:want-stream t)))
(loop for line = (read-line in nil)
while line
do (print-tweet line)))
:name "https://userstream.twitter.com/2/user.json"))
(defun local-profile-image-path (user-id profile-image-url)
(merge-pathnames (file-namestring (puri:uri-path (puri:uri profile-image-url)))
#"""#,*profile-image-directory*,/#,user-id,/"""))
(defun %get-profile-image (image-url local-path)
(unless (probe-file local-path)
(ensure-directories-exist local-path)
(with-open-file (out local-path :direction :output :element-type '(unsigned-byte 8))
(loop for i across (drakma:http-request image-url
:external-format-out :utf-8
:external-format-in :utf-8)
do (write-byte i out)))))
(defun refresh-repl ()
(sleep 0.1)
(swank::with-connection ((swank::default-connection))
(swank::eval-in-emacs '(save-current-buffer
(set-buffer (get-buffer-create "*slime-repl sbcl*"))
(save-excursion
(iimage-mode 1))))))
(defvar *profile-image-process*
(spawn (loop
(receive ()
((profile-image-url local-path)
(%get-profile-image profile-image-url local-path)
(refresh-repl))))))
(defun get-profile-image (user-id profile-image-url)
(let ((local-path (local-profile-image-path user-id profile-image-url)))
(send *profile-image-process* (list profile-image-url local-path))
local-path))
連日同じコードを貼り付けてるな。
昨日 の続きのようなもの。 SLIME の REPL にタイムラインを流しっぱなしにする。細かいことは ignore-errors でにぎりつぶす。
できたらアイコンも表示したいけど、Emacs での画像の表示方法が分からない。
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :series)
(require :cl-oauth)
(require :drakma)
(require :cl-json)
(require :quek))
;; 対 drakma 用おまじない
(setf drakma:*drakma-default-external-format* :utf-8)
(pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)
(defpackage :repl-twitter-client
(:use :cl :series :quek)
(:shadowing-import-from :series let let* multiple-value-bind funcall defun)
(:export #:tweet
#:timeline))
(in-package :repl-twitter-client)
(eval-when (:compile-toplevel :load-toplevel :execute)
(series::install :pkg :repl-twitter-client :implicit-map t))
(defun query-message ()
(string-right-trim
#(#\Space #\Cr #\Lf #\Tab)
(with-output-to-string (out)
(loop for line = (read-line *terminal-io*)
until (string= "." line)
if (string= "\\q" line)
do (return-from query-message nil)
do (write-line line out)))))
(macrolet ((m ()
(let ((sec (collect-first (scan-file "~/.twitter-oauth.lisp"))))
`(defparameter *access-token*
(oauth:make-access-token :consumer (oauth:make-consumer-token
:key ,(getf sec :consumer-key)
:secret ,(getf sec :consumer-secret))
:key ,(getf sec :access-key)
:secret ,(getf sec :access-secret))))))
(m))
(defun home-timeline ()
(json:decode-json-from-string
(oauth:access-protected-resource
"http://api.twitter.com/1/statuses/home_timeline.json"
*access-token*)))
(defun tweet (&optional (message (query-message)))
(when message
(json:decode-json-from-string
(oauth:access-protected-resource
"http://api.twitter.com/1/statuses/update.json"
*access-token*
:request-method :post
:user-parameters `(("status" . ,#"""#,message #'求職中"""))))
message))
(defun print-tweet (json-string)
(ignore-errors
(json:with-decoder-simple-clos-semantics
(let ((json:*json-symbols-package* :repl-twitter-client))
(let ((x (json:decode-json-from-string json-string)))
(with-slots (text user) x
(with-slots (name screen--name) user
(format *query-io* "~& ~%~a (~a)~&~a~%" screen--name name text))))))))
(defun timeline ()
(bordeaux-threads:make-thread
(^ with-open-stream (in (oauth:access-protected-resource
"https://userstream.twitter.com/2/user.json"
*access-token*
:drakma-args '(:want-stream t)))
(loop for line = (read-line in nil)
while line
do (print-tweet line)))
:name "https://userstream.twitter.com/2/user.json"))
