McCLIMで接続するディスプレイを選択する

McCLIMはX11プロトコルをしゃべるためにCLXを利用しています。なのでディスプレイ番号などを指定するのは最終的にはCLXの役割です。

McCLIMからCLXのopen-displayがどのように呼ばれるかを眺めることで、接続するディスプレイを選択する方法がわかったような気分になりました。

(asdf:oos 'asdf:load-op :mcclim)

(sb-posix:getenv "DISPLAY")
;;=> ":0.0"

;; .Xauthorityを読み込み、 ホスト名、ディスプレイ番号、プロトコルに対応する
;; :authorization-nameと:authorization-dataを取得する
(xlib::get-best-authorization "localhost" 0 :local)
;; =>"MIT-MAGIC-COOKIE-1"
;; =>#(161 76 219 58 93 240 175 179 37 197 235 248 55 5 32 117)

;; CLIMがこの関数を呼ぶ際の引数は、clx-portのserver-pathスロットに
;; セットされている。デフォルトだとcar部にキーワードシンボル:clxが、
;; cdr部に属性リストがセットされる。
;; clx-portオブジェクトはfind-port関数の中で作られる。
;; find-portはserver-pathをオプショナル引数とするが、デフォルトでは
;; *default-server-path*が渡されるので、この値を設定すると好きなディスプレイに接続できそう。
;; server-pathの第一要素はシンボルで、属性リストの:server-path-parserに関数が設定されている
;; 必要がある。この関数をserver-pathを引数として呼び出した返り値がclx-portにセットされる。
;; server-pathがnilの場合、find-default-server-pathの返り値を
;; server-pathとして利用する。おそらくcar部に:clxが入ったリストが返るので、:clxの属性リスト
;; に設定されている関数を変更することでも接続するディスプレイを選ぶことが出来ると思われる。

(funcall (get :clx :server-path-parser) '(:clx))
;; => (:CLX :HOST "" :DISPLAY-ID 0 :SCREEN-ID 0 :PROTOCOL :LOCAL)

CLOSでオブジェクトのクラスを変更する

Common LispのオブジェクトシステムであるCLOSには、実行時にオブジェクトのクラスを変更する機能や、クラスを再定義するとそのクラスのオブジェクトが新しいクラスのオブジェクトへ変更されるという機能があるそうです。

それぞれの動作を制御するためのメソッドが update-instance-for-different-class と update-instance-for-redefined-class です。

ともに関数名が35文字で、Common Lispの仕様上最長の関数名です。ちなみに、変数名を含めれば least-positive-normalized-double-float などの38文字が最長であるようです。

;;;; update-instance-for-different-class
(defclass class-a ()
  ((a :accessor a-of :initarg :a)
   (b :accessor b-of :initarg :b))
  (:default-initargs :a 1 :b 2))

(defclass class-b ()
  ((a :accessor a-of :initarg :a)
   (c :accessor c-of :initarg :c))
  (:default-initargs :a 10 :c 30))

;; クラスclass-aのオブジェクトを作る。
(defvar obj (make-instance 'class-a))
(describe obj)
;; #<CLASS-A {DB18DD9}>
;;   [standard-object]
;; Slots with :INSTANCE allocation:
;;   A  = 1
;;   B  = 2

;; オブジェクトの暮らすをclass-bに変更する
;; スロット名が同じである場合、そのスロットの値はそのままのようだ
(change-class obj 'class-b)
(describe obj)
;; #<CLASS-B {E38F199}>
;;   [standard-object]
;; Slots with :INSTANCE allocation:
;;   A  = 1
;;   C  = #<unbound slot>

;; オブジェクトのクラスをclass-aに変更する。
;; キーワードパラメータ:bに値を渡す。
(change-class obj 'class-a :b 99)
(describe obj)
;; #<CLASS-A {E38F199}>
;;   [standard-object]
;; Slots with :INSTANCE allocation:
;;   A  = 1
;;   B  = 99

;;; オブジェクトを変換するメソッド
;;; 直接呼ぶことはしない。change-classが呼ばれたときに裏で呼ばれる。
(defmethod update-instance-for-different-class ((prev class-a) (new class-b) &key)
  (setf (a-of new) (a-of prev)
	(c-of new) (b-of prev)))

;; objのクラスをclass-bに変更する。
;; update-instance-for-different-classで定義したとおり、
;; class-aでのスロットbの値が、class-bでのスロットcにセットされた。
(change-class obj 'class-b)
(describe obj)
;; #<CLASS-B {E38F199}>
;;   [standard-object]
;; Slots with :INSTANCE allocation:
;;   A  = 1
;;   C  = 99

;;;; update-instance-for-redefined-class
(defclass class-c ()
  ((hoge :accessor hoge-of :initarg :hoge)
   (fuga :accessor fuga-of :initarg :fuga))
  (:default-initargs :hoge 'a :fuga 'b))

;; クラスclass-cのオブジェクトを作る
(defvar o (make-instance 'class-c))
(describe o)
;; #<CLASS-C {E0E2DA1}>
;;   [standard-object]
;; Slots with :INSTANCE allocation:
;;   HOGE  = A
;;   FUGA  = B

;; class-cを再定義する。
(defclass class-c ()
  ((hoge :accessor hoge-of :initarg :hoge))
  (:default-initargs :hoge 'c))

;; 再定義後、class-cのオブジェクトにアクセスすると、
;; 新しいクラスのオブジェクトへ変換される。
;; :default-initargsの値ではなく、
;; 古いクラスのスロットの値が使われるようだ。
(describe o)
;; #<CLASS-C {E405751}>
;;   [standard-object]
;; Slots with :INSTANCE allocation:
;;   HOGE  = A


(defclass class-c ()
  ((hoge :accessor hoge-of :initarg :hoge)
   (fuga :accessor fuga-of :initarg :fuga))
  (:default-initargs :hoge 'e :fuga 'f))

;; 再定義後のクラスへ変換する際に動作するメソッドを定義する。
(defmethod update-instance-for-redefined-class :before
    ((obj class-c) added deleted plist &key)
  (setf (fuga-of obj) 1000))

;; スロットfugaの値はupdate-instance-for-redefined-classで
;; セットした値になる。
(describe o)
;; #<CLASS-C {E4707B1}>
;;   [standard-object]
;; Slots with :INSTANCE allocation:
;;   HOGE  = A
;;   FUGA  = 1000

動的束縛なlabels

fletやlabelsはlexical bindingなので、定義した関数の名前は字面上現れる位置でないと利用できません。

>(defun hoge ()
   (print 3))
>(defun fuga ()
   (hoge))

>(fuga)
3

>(labels
   ((hoge ()
     (print 10)))
  (fuga))
3

変数ならばdeclareでspecial変数だと宣言すれば良いけれど、関数の場合どうすれば良いか分からなかったのでマクロを書いてみました。

(defun generic-function-p (x)
  #+SBCL (sb-pcl::generic-function-p x)
  #-SBCL nil)

(defmacro dynamic-labels
    ((&rest definitions) &body body)
  (let ((olds (mapcar #'(lambda (x)
			  (declare (ignore x))
			  (gensym))
		      definitions)))
    `(let ,(mapcar
	    #'(lambda (sym def)
		`(,sym ,(and (fboundp (car def)) (symbol-function (car def)))))
	    olds
	    definitions)
       ,@(mapcar
	  #'(lambda (def)
	      `(,(if (generic-function-p (car def))
		     `cl:defmethod
		     `cl:defun)
		 ,@def))
	  definitions)
       (unwind-protect
	    (progn
	      ,@body)
	 ,@(mapcar
	    #'(lambda (old def)
		`(if ,old
		     (setf (symbol-function ',(car def))
			   ,old)
		     (fmakunbound ',(car def))))
	    olds
	    definitions)))))

以下実行例。再定義時に警告が出るかもしれない。

>(dynamic-labels
   ((hoge () (print 10)))
  (fuga))
10

(Lisp (を書いて学ぶ) Ruby)

Peter Norvigせんせーの記事の邦訳、((Pythonで) 書く (Lisp) インタプリタ) を写経してみました。Rubyで。

class String
  def tokenize()
    return self.gsub(/(\(|\))/){|s| " " + s + " " }.split(' ');
  end
end

def parse(tokens)
  if(tokens.length == 0)
    raise "error"
  end
  tk = tokens.shift
  if(tk == "(")
    acc = []
    while ( (tk = tokens.shift) != ")")
      if(tk == "(")
        acc.unshift(parse(tokens.unshift(tk)))
      else
        acc.unshift(to_atom(tk))
      end
    end
    return acc.reverse
  elsif(tk == ")")
    raise "error"
  else
    return to_atom(tk)
  end
end

def eval(x, env = $global_env)
  if(x.is_a? Numeric)
    return x
  elsif (x.is_a? String)
    return env.find(x)[x]
  elsif(! (x.is_a? Array) )
    raise "Error"
  elsif(x[0] == 'quote')
    return x[1]
  elsif(x[0] == 'if')
    if ( eval(x[1],env) )
      return eval(x[2], env)
    else
      return eval(x[3], env)
    end
  elsif(x[0] == 'set!')
    return env.find(x[1]).store(x[1], eval(x[2], env))
  elsif(x[0] == 'define')
    return env.store(x[1], eval(x[2], env))
  elsif(x[0] == 'lambda')
    return Proc.new{| *args |
      r = nil
      ev = Env.new(env)
      x[1].each_index{|i|
        ev.store(x[1][i], args[i])
      }
      for s in x[2..-1] do
        r = eval(s, ev)
      end
      r
    }
  elsif(x[0] == 'begin')
    val = []
    x[1..-1].each{|s|
      val = eval(s, env)
    }
    return val
  else
    exps = x.collect{|s| eval(s, env)}
    return exps[0].call(*exps[1..-1])
  end
end

def to_atom(x)
  if ( /^\d+$/ =~ x )
    return x.to_i
  elsif ( /^\d*\.\d+$/ =~ x)
    return x.to_f
  else
    return x
  end
end

class Env < Hash
  @outer = nil
  def initialize(outer = nil)
    @outer = outer
    super()
  end
  def find(key)
    if( self.member?(key) )
      return self
    elsif( @outer )
      return @outer.find(key)
    else
      return nil
    end
  end
end

$global_env = Env.new()
$global_env.store("+", Proc.new{|x, y| x + y })

print parse("(a 2 (b c d))".tokenize()),"\n"
print eval(parse("2".tokenize())),"\n"
print eval(parse("(+ 2 3)".tokenize())),"\n"
print eval(parse("((lambda (a b) (+ a b)) 10 20)".tokenize())),"\n"
print eval(parse("(define a 2)".tokenize())),"\n"
print eval(parse("a".tokenize())),"\n"
print eval(parse("(set! a 10)".tokenize())),"\n"
print eval(parse("a".tokenize())),"\n"

メモ

• to_i は文字列が数字でない場合0を返す。先頭が数字なら、可能なぶんだけ数値にする。
• アスタリスクは可変長引数や配列の展開?を表す
• アットマークから始まるシンボルはメンバ変数
• ドルマークから始まるシンボルはグローバル変数
• 例外を投げるにはraiseを使う

Common Lispでexpect的ななにか

最近存在を知りましたが、鯖やってる人にはお馴染み?らしいexpectというプログラムが存在するそうです。

TCLで書かれたプログラムで、Passwordという文字列が表示されたらxxxを入力する、というような形で、対話的なコマンドを自動実行するために利用するものとのことです。

PerlやPython、Rubyなどにもそれっぽいライブラリが存在し、なんとGuileにまでexpect.scmというファイルにモジュールが存在します。

Common Lispにもあるよね・・・と思っていたら見つからないので、Guileのプログラムを一部パクって簡単なものを書いてみました。

(asdf:oos 'asdf:load-op :cl-ppcre)
(defpackage expect
  (:use :cl :cl-ppcre)
  (:export expect expect-strings))

(in-package expect)

(defmacro expect (port (&rest options) &body clauses)
  (let ((ch (gensym "ch"))
	(str (gensym "str"))
	(p (gensym "port"))
	(eof (gensym "eof"))
	(next (gensym "next")))
    `(let ((,p ,port)
	   (,str ""))
       (labels ((,next ()
		  (let ((,ch (read-char ,p nil ',eof)))
		    (unless (eq ',eof ,ch)
		      (setf ,str
			    (concatenate 'string ,str (string ,ch)))
		      (cond
			,@(mapcar
			   #'(lambda (clause)
			       `((funcall ,(car clause) ,str)
				 ,@(cdr clause)))
			   clauses)
			(T (,next)))))))
	 (,next)))))

(defmacro expect-strings (port (&rest options) &body clauses)
  (let ((syms (mapcar
                #'(lambda (_) (declare (ignore _)) (gensym))
                clauses))
	(s (gensym)))
    `(let ,(mapcar
	    #'(lambda (clause sym)
		`(,sym (lambda (,s)
			 (cl-ppcre:all-matches
			  ,(car clause)
			  ,s))))
	    clauses
	    syms)
       (expect ,port (,@options)
	 ,@(mapcar
	    #'(lambda (clause sym)
		`(,sym ,@(cdr clause)))
	    clauses
	    syms)))))

;;
(with-input-from-string (s "Hello,World")
  (expect-strings s ()
    ("Foo" (print 0))
    ("Hello" (print 1))
    ("World" (print 2))))

タイムアウトも入力文字ごとに関数を呼ぶ機能もありませんが、取り合えず読み込んだ文字列が正規表現にマッチすると処理が実行されるようになりました。

引数optionsは、後で何か付けたそうと思って書いたもので今は特に意味はありません。

それにしても、Guileのモジュール名のice-9って何なんでしょう。無駄に格好良く見えます。