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

勝手に 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 での色（フェイス）の設定

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

Climacs でビットマップフォントを使った時のフォンサイズ変更

ビットマップフォントを使うというより X のフォント描画を使う場合のフォントサイズは clim-clx::*clx-text-sizes* で指定する。

参考: McCLIM (Climacs) でビットマプフォン使って日本語を表示する

;; X のフォント描画を使う場合のフォント設定
(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"))))

;; ビットマップでのフォントサイズを 2 ずつ大きくする。
(setq clim-clx::*clx-text-sizes*
  '(:normal         16
    :tiny           10
    :very-small     12
    :small          14
    :large          20
    :very-large     22
    :huge           26))

X のフォント描画を使う場合は、次が必要になるかと。

;;; ビットマップフォントで日本語表示するために一行追加する。
(in-package :clim-clx)
(defmethod medium-draw-text* ((medium clx-medium) string x y
                              start end
                              align-x align-y
                              toward-x toward-y transform-glyphs)
  (declare (ignore toward-x toward-y transform-glyphs))
  (with-transformed-position ((sheet-native-transformation (medium-sheet medium))
                              x y)
    (with-clx-graphics (medium)
      (when (characterp string)
        (setq string (make-string 1 :initial-element string)))
      (when (null end) (setq end (length string)))
      (multiple-value-bind (text-width text-height x-cursor y-cursor baseline)
          (text-size medium string :start start :end end)
        (declare (ignore x-cursor y-cursor))
        (unless (and (eq align-x :left) (eq align-y :baseline))
          (setq x (- x (ecase align-x
                         (:left 0)
                         (:center (round text-width 2))
                         (:right text-width))))
          (setq y (ecase align-y
                    (:top (+ y baseline))
                    (:center (+ y baseline (- (floor text-height 2))))
                    (:baseline y)
                    (:bottom (+ y baseline (- text-height)))))))
      (let ((x (round-coordinate x))
            (y (round-coordinate y)))
        (when (and (<= #x-8000 x #x7FFF)
                   (<= #x-8000 y #x7FFF))
          (multiple-value-bind (halt width)
              (xlib:draw-glyphs mirror gc x y string
                                :start start :end end
                                :size 16 ; この一行を追加
                                :translate #'translate)))))))

Climacs の find-file を改善

Climacs の find-file で次の対応。

• /home/user01//tmp を /tmp に
• /tmp/~/foo を /home/user01/foo に
• Tab だけではなく C-i でも補完

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

Climacs の Dired

あまり興味を持ってもらえない Climacs の Dired ではあるが、ないと不便だと思うので実装した。まだ、一覧表示してファイルを開くことしかできない。

• command-table, syntax, mode の関係?
• 色の付け方は?
• Presenttation を使うべきか?

と、分からないところが多い。

ソースは 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)))

McCLIM (Climacs) でビットマプフォン使って日本語を表示する

トゥルータイプフォントなら (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 で uim T-Code

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)

Climacs で T-Code

以前、 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 を使ってみた。