2009-09-15

requireのカスタムプロバイダ

lisp sbcl

lispにはrequireと言う関数があります。
モジュール名を指定することでそのモジュールをロードしてくれる、と言う関数です。

ちなみにrequire関数がモジュール名と実際にロードするファイルの関連付けする方法は処理系依存とのこと。自分はsbclでやったので他の処理系ではまた違う方法をとる必要があるとおもいます。

とりあえずはrequireの実装をみてみると・・・

(unless (member name *modules* :test #'string=)
  (cond (pathnames
	 (unless (listp pathnames) (setf pathnames (list pathnames)))
	 ;; ambiguity in standard: should we try all pathnames in the
	 ;; list, or should we stop as soon as one of them calls PROVIDE?
	 (dolist (ele pathnames t)
	   (load ele)))
	(t
	 (unless (some (lambda (p) (funcall p module-name))
		       *module-provider-functions*)
	   (require-error "Don't know how to ~S ~A."
			  'require module-name)))))

と言うコードがあります。
*modules*にすでにロードされたモジュールの一覧が入っているため、二度呼び出しても二重にロードされないようになっています。
condの一つ目のclosureはpathnamesが指定されていた場合なので今回は無視します。
二つ目のclosureが求めるところのようです。sbclの場合、sb-ext:*module-provider-functions*に入っている要素を一つずつ取り出してfuncallしています。
最終的にどのmodule-provider-functionもnon nilを返さなかった場合にrequire-errorとしています。
なので拡張する場合はsb-ext::*module-provider-functions*にモジュール名からloadする関数を用意してそれを登録してやればよさそうです。

そういうわけで作ってみたのが次の関数。

(require :cl-fad)
(defun my-module-provider-function (name)
  (let ((module-name (string-downcase (string name)))
	(dir (merge-pathnames (make-pathname
		      :directory '(:relative "source/vc/git/garbage/lisp"))
		     (user-homedir-pathname))))
    (let ((fasl-name (merge-pathnames 
		      (merge-pathnames 
		       (make-pathname :type sb-impl::*fasl-file-type*)
		       module-name) dir))
	  (lisp-name (merge-pathnames
		      (merge-pathnames 
		      (make-pathname :type "lisp")
		      module-name) dir))
	  (raw-name (merge-pathnames module-name dir)))
      (when (or (cl-fad:file-exists-p fasl-name)
		(cl-fad:file-exists-p lisp-name)
		(cl-fad:file-exists-p raw-name))
	(load raw-name)
	t))))

(push 'my-module-provider-function sb-ext:*module-provider-functions*)

自分の環境では ~/source/vc/git/garbage/lisp にlispコードをガシガシ書きなぐってるのでそこからloadしてくれると助かるのでそう作ってます。

で、このコードを ~/.sbclrcに書いておいて、slime起動させると・・・

; SLIME 2009-06-15
CL-USER> sb-ext:*module-provider-functions*
(MY-MODULE-PROVIDER-FUNCTION ASDF::MODULE-PROVIDE-ASDF
                             SB-IMPL::MODULE-PROVIDE-CONTRIB)

登録されています。

(defpackage :load-module-test
  (:use :cl)
  (:export :foo))

(in-package :load-module-test)

(defun foo ()
  (list :foo))

(provide :load-module-test)

テスト用に上記のコードを ~/source/vc/git/garbage/lisp/load-module-test.lisp として保存しておきます。

で、

CL-USER> *modules*
("SWANK-PRESENTATIONS" "SWANK-ARGLISTS" "SWANK-FANCY-INSPECTOR" "SWANK-FUZZY"
 "SWANK-C-P-C" "SWANK-PACKAGE-FU" "SWANK-ASDF" "SB-CLTL2" "SB-INTROSPECT"
 "SB-BSD-SOCKETS" "SB-EXECUTABLE" "SB-POSIX" "SB-GROVEL" "ASDF")
CL-USER> (require :load-module-test)
("LOAD-MODULE-TEST")
CL-USER> *modules*
("LOAD-MODULE-TEST" "SWANK-PRESENTATIONS" "SWANK-ARGLISTS"
 "SWANK-FANCY-INSPECTOR" "SWANK-FUZZY" "SWANK-C-P-C" "SWANK-PACKAGE-FU"
 "SWANK-ASDF" "SB-CLTL2" "SB-INTROSPECT" "SB-BSD-SOCKETS" "SB-EXECUTABLE"
 "SB-POSIX" "SB-GROVEL" "ASDF")
CL-USER> (load-module-test:foo)
(:FOO)
CL-USER>

と、この様に自分の必要なカスタムプロバイダが提供できるようになりました。

ちなみに・・・sbclのドキュメントのhttp://www.sbcl.org/1.0/manual/Customization-Hooks-for-Users.htmlに載ってたりします。

2009-07-28

行列演算

lisp

ちょいと3Dを勉強しなおしてるわけですが計算用の道具でよさげなのが手元にないのです。
maximaがいい感じなのですが検算用に使いづらい。一応ループや条件分岐などのロジックは書けるようなのですが、中途半端にlispっぽさを引きずってて馴染めそうに無いのです。

一応C++で書いた行列演算などのコードはあるのですがちょっと値をかえるだけでリコンパイルとかやってられんので（入力用のI／Fを作るのはもっとやってられなかった）手軽に実行できる言語とかでないかなぁ、と探した結果、lispに白羽の矢がたちました。

で、行列関連のコードを探したわけですが処理系依存してたりインストールが面倒そうだったり・・・

実際のところ、和、差、積、転置くらいが出来ればよく、逆行列とかもいらなかったので勉強かねて自分で実装してみました。
ほんとに出来るのは検算用の計算くらいです。

(defpackage :math.geometry
  (:use :cl)
  (:export :transpose
	   :add
	   :add-scalar
	   :sub
	   :sub-scalar
	   :multiply
	   :multiply-scalar
	   :column
	   :row
	   :element
	   :make-matrix
	   :make-scalar-matrix))

(in-package :math.geometry)

(defun make-matrix (row column)
  (loop repeat row collect (loop repeat column collect 0)))

#+test (tree-equal (make-matrix 3 4)
		   '((0 0 0 0)
		     (0 0 0 0)
		     (0 0 0 0)))

(defun make-scalar-matrix (size value)
  (loop for i below size
     collect (loop for j below size collect (if (eq i j) value 0))))

#+test (tree-equal (make-scalar-matrix 4 2)
		   '((2 0 0 0)
		     (0 2 0 0)
		     (0 0 2 0)
		     (0 0 0 2)))

(defun row (mat)
  (length mat))

#+test (and (equal (row '((0 0) (0 0))) 2)
	    (equal (row '((0 0 0) (0 0 0))) 2))

(defun column (mat)
  (let ((line (car mat)))
    (if (listp line)
	(length line)
	1)))

#+test (and (equal (column '((0 0) (0 0))) 2)
	    (equal (column '((0 0 0 0) (0 0 0 0))) 4))

(defun element (mat row column)
  (nth column (nth row mat)))

#+test (let ((mat '((1 2) (3 4))))
	 (and (equal (element mat 1 1) 4)
	      (equal (element mat 1 0) 3)
	      (equal (element mat 0 1) 2)
	      (equal (element mat 0 0) 1)))

(defun set-element (mat row column value)
  (setf (nth column (nth row mat)) value))

(defsetf element set-element)

#+test (let ((mat '((1 2 3) (4 5 6) (7 8 9))))
	 (progn
	   (setf (element mat 0 0) 11)
	   (setf (element mat 2 1) 16)
	   (setf (element mat 2 2) 19)
	   (tree-equal mat '((11 2 3)
			     (4 5 6)
			     (7 16 19)))))

(defun transpose (mat)
  (let* ((column (column mat))
	 (row (row mat))
	 (result (make-matrix column row)))
    (loop for i below row
       do (loop for j below column
	       do (setf (element result j i)
		      (element mat i j))))
    result))

#+test (and
	(tree-equal (transpose '((1 2) (3 4)))
		    '((1 3) (2 4)))
	(tree-equal (transpose '((1 2)))
		    '((1) (2))))

(defun add (lhs rhs)
  (unless 
      (and (eq (column lhs) (column rhs))
	   (eq (row lhs) (row rhs)))
    (error "not equals lhs and rhs column or/and row"))
  (let* ((column (column lhs))
	 (row (row lhs))
	 (result (make-matrix row column)))
    (loop for i below column
       do (loop for j below row
	     do (setf (element result j i)
		      (+ (element lhs j i)
			 (element rhs j i)))))
    result))

#+test (tree-equal (add '((1 2 3) (4 5 6)) '((7 8 9) (10 11 12)))
		   '((8 10 12) (14 16 18)))

(defun square-matrixp (mat)
  (eq (column mat) (row mat)))

#+test (and (square-matrixp (make-scalar-matrix 2 1))
	    (not (square-matrixp '((1 2 3) (4 5 6)))))

(defun add-scalar (lhs rhs)
  (unless (square-matrixp lhs)
    (error "not equals lhs's column and row"))
  (let ((rhs (make-scalar-matrix (column lhs) rhs)))
    (add lhs rhs)))

#+test (tree-equal 
	(add-scalar '((1 2) (3 4)) 5)
	'((6 2) (3 9)))

(defun sub (lhs rhs)
  (unless 
      (and (eq (column lhs) (column rhs))
	   (eq (row lhs) (row rhs)))
    (error "not equals lhs and rhs column or/and row"))
  (let* ((column (column lhs))
	 (row (row lhs))
	 (result (make-matrix row column)))
    (loop for i below column
       do (loop for j below row
	     do (setf (element result j i)
		      (- (element lhs j i)
			 (element rhs j i)))))
    result))

#+test (tree-equal (sub '((1 2 3) (4 5 6)) '((7 8 9) (10 11 12)))
		   '((-6 -6 -6) (-6 -6 -6)))

(defun sub-scalar (lhs rhs)
  (unless (square-matrixp lhs)
    (error "not equals lhs's column and row"))
  (let ((rhs (make-scalar-matrix (column lhs) rhs)))
    (sub lhs rhs)))

#+test (tree-equal 
	(sub-scalar '((1 2) (3 4)) 5)
	'((-4 2) (3 -1)))

(defun multiply (lhs rhs)
  (unless (eq (column lhs) (row rhs))
    (error "not equal lhs's column and rhs's row"))
  (let* ((column (column rhs))
	 (row (row lhs))
	 (max-k (column lhs))
	 (result (make-matrix row column)))
    (loop for j below column do
	 (loop for i below row do
	      (setf (element result i j)
		    (loop for k below max-k sum
			 (* (element lhs i k)
			    (element rhs k j))))))
    result))

#+test (and
	(tree-equal (multiply '((1 2) (3 4)) '((5 6) (7 8)))
		    '((19 22) (43 50)))
	(tree-equal (multiply '((5 6) (7 8)) '((1 2) (3 4)))
		    '((23 34) (31 46)))
	(tree-equal (multiply '((1 2) (3 4)) '((5) (6)))
		    '((17) (39))))

(defun multiply-scalar (lhs rhs)
  (unless (square-matrixp lhs)
    (error "not square matrix for lhs."))
  (multiply lhs (make-scalar-matrix (column lhs) rhs)))

#+test (tree-equal (multiply-scalar '((1 2) (3 4)) 5)
		   '((5 10) (15 20)))

・・・短けぇ!!
多少のエラーチェックを含んだ行列演算のコードがたった100行ちょいかぁ・・・
あ、でもC++で組んだ同レベルのコードも200行ちょいくらいだな。
それでも実装にかかった時間は断然lispの方が短いや。

で、こんな感じで検算用に使ってます。

(use-package :math.geometry)

(defun projection (left right top bottom near far)
  (let ((width_distance (- right left))
	(width_center (+ right left))
	(height_distance (- top bottom))
	(height_center (+ top bottom))
	(depth_distance (- far near))
	(depth_center (+ far near)))
    (let ((width_ratio (/ width_center width_distance))
	  (height_ratio (/ height_center height_distance))
	  (depth_ratio (/ depth_center depth_distance)))
      `((,(/ (* 2 near) width_distance) 0 0 0)
	(0 ,(/ (* 2 near) height_distance) 0 0)
	(,width_ratio ,height_ratio ,depth_ratio -1)
	(0 0 ,(/ (* -2 far near) depth_distance) 0)))))

(let ((proj (projection -1 1 1 -1 -1 -100)))
  (loop for v from -1 downto -100 collect
       (multiply `((1 0 ,v 1)) proj)))

とまあ、3D用の透視投影の検算したかっただけなんですけどね。

※ 行と列の扱いがおかしいところがいくつか散見されたので直したつもり。あくまでつもり(笑)

※ うがー、やっぱりダメな場所があった・・・elementの行と列が逆になってる・・・
俺みたいなおバカには関連メソッドは一ヶ所に強制的に書かせるクラス系の表記のほうがいいのかもしらん・・・

※ テストコードつきで上げ直した。これで一応動くはず・・・

2009-07-10

initializer_listもどきをc++03で実装してみる

c++

c++0xにはinitializer_listというPOD構造体や配列の初期化に使うような記述、

int ar[] = { 1, 2, 3, 4, 5, 6 };

と言うような表記で初期化することができます。
ですが、同じく配列のようにつかうstd::vectorなどはそういう初期化が出来ません。
現在策定中のc++0xでは規格が拡張され、配列の初期化の用な感じでコレクションクラスや普通のクラスなどの初期化が行えるようになります。

でも現行のc++03では出来ないので仕方なくちまちまとstd::copyしたりpush_backしたりするコードができあがります・・・

自分の精神衛生的にあまりよろしくなかったので少しあがいてみました。

まずはコード。

#include <iostream>
#include <algorithm>

template <typename value_type, int array_length>
struct array
{
    typedef value_type element_type[array_length];
    element_type elements;

    typedef value_type* iterator;
    typedef const value_type* const_iterator;

    int length() const
    {
        return array_length;
    }

    int size() const
    {
        return length();
    }

    iterator begin()
    {
        return &elements[0];
    }

    const_iterator begin() const
    {
        return &elements[0];
    }

    iterator end()
    {
        return &elements[0] + length();
    }

    const_iterator end() const
    {
        return &elements[0] + length();
    }

    value_type& operator[](int offset)
    {
        return elements[offset];
    }

    const value_type& operator[](int offset) const
    {
        return elements[offset];
    }

    value_type& front()
    {
        return elements[0];
    }

    const value_type& front() const
    {
        return elements[0];
    }

    value_type& last()
    {
        return elements[length() - 1];
    }

    const value_type& last() const
    {
        return elements[length() - 1];
    }

    array():
        elements()
    {}

    array(const array& source)
    {
        std::copy(source.begin(), source.end(), this->begin());
    }

    template <int other_array_length>
    array(const array<value_type, other_array_length>& source,
          const value_type& last = value_type()):
        elements()
    {
        std::copy(source.begin(), source.end(), this->begin());
        this->last() = last;
    }

    template <int other_array_length>
    array(const value_type& first,
          const array<value_type, other_array_length>& source):
        elements()
    {
        this->front() = first;
        std::copy(source.begin(), source.end(), this->begin() + 1);
    }
};

template <typename value_type, int array_length = 0>
struct initialize_list
{
    typedef array<value_type, array_length> array_type;
    typedef array<value_type, array_length+1> next_array_type;

    typedef typename array_type::iterator iterator;
    typedef typename array_type::const_iterator const_iterator;

    array_type arguments;

    initialize_list():
        arguments()
    {}

    initialize_list(const initialize_list<value_type, array_length-1>& head,
                    const value_type& last):
        arguments(head.get_arguments(), last)
    {}

    array_type get_arguments() const
    {
        return arguments;
    }

    const_iterator begin() const
    {
        return arguments.begin();
    }

    const_iterator end() const
    {
        return arguments.end();
    }

    initialize_list<value_type, array_length+1>
    operator,(const value_type& value) const
    {
        return initialize_list<value_type, array_length+1>(*this, value);
    }
};

struct output
{
public:
    void operator()(const int& value) const
    {
        std::cout << value << std::endl;
    }
};

class test_class
{
public:
    template <int length>
    test_class(const initialize_list<int, length>& init_list)
    {
        std::for_each(init_list.begin(), init_list.end(), output());
    }
};

void test_main()
{
    test_class tester = (initialize_list<int>(), 1, 2, 3, 4, 5);
}

int main()
{
    test_main();
    return 0;
}

initialize_listクラスのインスタンスで中に固定長配列を持っていてこれに初期化配列をつんでいく形になります。
で、initialize_list::operator, をオーバーロードしておいてその中で中の固定長配列が一つ分長いinitialize_listを作ってそれに以前の値をコピー、新しい値もケツにつんでは返す、を繰り返すことで実現しています。

arrayクラスはC++ nativeの配列かあまりにふがいないので多少の楽のためにラッピングしてるクラスです。こういう工夫すらないと戻り値で配列を返すことすら出来ないので・・・

compile time展開してくれるかなー？と期待してみたんですがダメでした。initialize_listが拡張していくところで見事に初期化とコピーのコードが入っていました@g++ 4.3.3 on ubuntu 9.04

右辺値代入とかあれば多少はマシになるのかもしれませんが右辺値代入がちゃんと使えるコンパイラを持ってくるとふつうにinitializer_listも使えるだろうしなぁ・・・

うーん、値保持用の配列をtemplateベースのlist構造つかえばもうちょいマシになるんだろうか・・・

2009-06-23

slimeでminibufferでの引数リストをすべて表示させる

lisp

emacs + slimeでminibufferに引数リストが表示されるのだが、デフォルトでは1行分しか表示されないため、引数が多い関数を使う場合にリファレンスを見ることになる。
hyperspec にのってるやつなら C-c C-d hでブラウザが立ち上がるのでそれほど苦でもないのだけどallegro serveとかだと結局C-.して確認してC-,して戻る、を繰り返すことになる。

いい加減面倒だったのでちょっとslimeを追いかけてみた。(良い子はちゃんとリファレンス見た方がいいよ!!

結果 slime-autodoc-use-multiline-p変数がnilの場合、単行表示にしているみたい。
なので.emacsに以下を追加。

(setq slime-autodoc-use-multiline-p t)

これで少しは楽になる。

2009-06-23

文字から文字コードを調べる

linux

ちょうど昨日の逆です。
例はやっぱり全角スペース。

$ echo -n '　' | od -t x1
0000000 e3 80 80
0000003

まぁこんな感じ。
これはlocaleがja_JP.utf-8なのでutf-8ででてます。別の文字コードや元のロケールが違う場合は途中にiconvなど挟んで変換してやればok。

$ echo -n '　' | iconv -f utf-8 -t sjis | od -t x1
0000000 81 40
0000002

2009-06-22

LinuxというかPosix環境で文字コードに該当する文字を調べる方法

linux

いままではrdpつかってwindowsのバイナリエディタを使ってたんですがふと思いついたのでメモ。別に大したことではないのだけど・・・

例えば 0x81 0x40のシーケンス(SJISでの全角スペース)とかを見たい場合

$ echo -e "\x81\x40" | lv -Is

別にページャはlvでなくても端末がちゃんと理解できるようにできればそれでいい。なので

$ echo -e "\x81\x40" | iconv -f sjis -t utf-8

とかでもおっけー。

文字コードの種類が分からない場合は？
lvの自動判別に任せるとかiconvの-fを何種類か試すとかするくらいしか・・・
これで文字確認するだけのためにrdesktop立ち上げなくてすむ・・・

2009-06-05

functor版tolower

c++

#include <locale>
#include <iostream>
#include <string>
#include <functional>
#include <algorithm>

int main()
{
	std::locale loc("ja_JP.UTF-8");
	const std::ctype<char>& cty = std::use_facet<std::ctype<char> >(loc);

	std::string str = "HELLO WORLD.";
	std::cout << str << std::endl;
	
	std::transform(str.begin(), str.end(),
				   str.begin(),
				   std::bind1st(std::mem_fun(&std::ctype<char>::tolower),
								&cty));

	std::cout << str << std::endl;

	const std::ctype<wchar_t>& wcty = std::use_facet<std::ctype<wchar_t> >(loc);
	
	std::wstring wstr = L"HELLO WORLD.";
	std::wcout << wstr << std::endl;
	
	std::transform(wstr.begin(), wstr.end(),
				   wstr.begin(),
				   std::bind1st(std::mem_fun(&std::ctype<wchar_t>::tolower),
								&wcty));

	std::wcout << wstr << std::endl;

	return 0;
}

ということでstl全開でtolowerするプログラムに変更してみた。
std::for_eachって副作用起こせないのね・・・
他の言語とごっちゃになってる・・・
あとcurryingしてるとやっぱり無理があるなぁ、と認識。
他の言語のsyntaxにくらべて書いてても読んでても分かりにくい。まぁ、慣れの問題なんだろうけど。