春一番

春一番がふきました。すごい砂埃（？）で、窓から見える風景は雨の日のような視界でした。

さて、言語作りは順調に進んでいます。かなり Factor ライクになってしまいました。
スタックベースでパターンマッチング。
こんな感じです。ちなみに .) はドットリストを作る関数です。で ） はリストを作る関数です。

: each # seq quot --
  | ( x xs .) quot | x quot call xs quot each ;
  2dorp .

( 1 2 3 ) [ p ] each  # 1 2 3 を表示

: map # seq quot -- newseq
  nil (map) .

: (map) # seq quot acc -- newseq
  | ( x xs .) quot acc | xs quot ( x quot call acc .) (map) ;
  | _ _ acc | acc reverse .

( 1 2 3 ) [ dup * ] map  # ( 1 4 9 ) を返す

なんで私の興味はこうマイナーな方向に進んでいくんだろう、とすこし悩んだりもしましたが、自分が楽しければそれでいいや、とこれからも好きなようにやっていこうと思います。
JavaScript にしても Ruby にしてもあまり好きになれないんだもん。
コードを書いていて爽快感が感じられないのです。
Common Lisp や Erlang はささいなコードでも爽快感が感じられます。

Forth 系の言語を作ってる

Forth 系の言語ってかなり好きです。
The Log of the No22 さんところの「それは逆ポーランドじゃない」を読んで感動しました。
全てがスタックに対する関数であり、プログラムは関数の連結からなるという concatenative 言語。
すばらしい。
ということで、Forth 系の言語を作っています。
楽しいです。

Common Lisp : Weblocks がいい感じに仕上がってきています。

Common Lisp の継続ベース Web フレームワークである Weblocks がいい感じに仕上がってきています。
CLSQL を永続化のバックエンドとして使えるようになり、（簡単なものは）かなり簡単に書けるようになりました。
例のごとく簡単な TODO アプリケーションを作ってみます。

データベースは PostgreSQL を使います。あらかじめ PostgreSQL のユーザとデータベースを作成しておきます。テーブルの作成は必要ありません。
sudo -u postgres createuser -s -P ancient
CREATE DATABASE junk WITH ENCODING='UTF8' OWNER=ancient;

Weblocks 自体のインストールは依存するライブラリがたくさんあって大変ですが、がんばってインストールします。asdf-install を使うのが一番簡単だと思います。こちらのページを参考に。

TODO アプリケーションのコードは下に示しますが、だいたい次のような感じです。

1. CLSQL でテーブルに対応するクラス todo を定義。


2. todo クラスのグリッドビューとフォームビューを定義。scaffold というキーワードが出てきてますね。


3. PostgreSQL への接続定義。


4. Weblocks のアプリケーション定義。


5. エントリーポイントとなる init-user-session の定義。継続ベースだと入口が必要です。


6. Web サーバの開始と、テーブルの作成

やはり Common Lisp だとテーブルからクラスではなく、クラスからテーブルですね ;)

;;;;-*- mode: lisp; syntax: common-lisp; -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :weblocks)
  (require :clsql))

(defpackage #:todo
  (:use #:common-lisp #:weblocks #:clsql)
  (:export #:start))

(in-package :todo)

;;; CLSQL のビュークラス定義。モデル定義。
(def-view-class todo ()
  ((id :accessor id :db-kind :key :db-constraints (:not-null :unique)
       :type integer)
   (content :initarg :content :accessor content :db-constraints :not-null
            :type (varchar 80))
   (done :initarg :done :accessor done-p :type boolean)))

;;; Weblocks の Grid ビュー定義。
(defview todo-grid-view (:type grid :inherit-from '(:scaffold todo))
  (id :hidep t))

;;; Weblocks の Form ビュー定義。
(defview todo-form-view (:type form :inherit-from '(:scaffold todo))
  (id :hidep t))

;;; CLSQL への接続定義。Postgresql に接続する。
(defstore *sql-store* :clsql '("localhost" "junk" "ancient" "password")
          :database-type :postgresql)

;;; Weblocks のアプリケーション定義。
(defwebapp 'todo-application
    :description "簡単な TODO アプリケーションです。")

;;; Weblocks のいわばエントリポイント。
(defun init-user-session (comp)
  (setf (weblocks:composite-widgets comp)
        (make-instance 'gridedit
                       :name 'todo-grid
                       :data-class 'todo
                       :sort '(id . :asc)
                       :view 'todo-grid-view
                       :item-form-view 'todo-form-view)))

;;; Weblocks を開始して、TODO テーブルを作成する。
(defun start ()
  ;; Weblocks の開始。
  (start-weblocks :port 8080)
  (setf hunchentoot:*catch-errors-p* nil) ; エラー時はデバッガが起動するように
  ;; TODO テーブルの作成
  (ignore-errors (create-view-from-class 'todo)))

;;; TODO テーブルの削除
;;(drop-view-from-class 'todo)

Common Lisp : cl-win32ole Excel UsedRange

Excel に書かれたテーブル仕様書から clsql:def-view-class でテーブルクラスを作り、clsql-sys:create-view-from-class で Postgresql 上にテーブルを作成しました。
Excel から clsql:def-view-class 定義を作るのにはもちろん cl-win32ole を使いました。
最初は Excel のセルを1つずつ見ていかないとだめかな、めんどうだなぁ、と思っていたのですが。
値の入っているセルの範囲を取得できる UsedRange という便利なメソッドを見つけました。
これで、Excel シート上のデータを一括で Lisp のリストとして取得できます。
あとは、Lisp でのリスト操作なので楽々でした♪
UsedRange とっても便利です。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :cl-win32ole)
  (use-package :cl-win32ole))

(defun excel-contents (path)
  (let ((excel (create-object "Excel.Application")))
    (unwind-protect
         (ole excel :workbooks :open path
              :worksheets :item 1
              :usedRange :value)
      (ole excel :quit))))

Factor : 日本語入力の調査 -- **とり**あえずまとめ

Linux 環境で Factor UI での日本語入力ですが、なんとか次のようなパッチで可能となります。
64bit 環境だと XwcLookupString がうまく動いていなかったのでその辺も対応しています。
できたらフォントまわりも設定可能にしたかったのですが、フォントをコピーすれば表示可能なのでやめました。

diff -ur factor-org/extra/x11/xim/xim.factor factor/extra/x11/xim/xim.factor
--- factor-org/extra/x11/xim/xim.factor 2007-12-13 08:58:21.000000000 +0900
+++ factor/extra/x11/xim/xim.factor     2008-02-01 22:09:28.000000000 +0900
@@ -7,9 +7,15 @@
 
 SYMBOL: xim
 
+: (init-xim) ( classname medifier -- im )
+   XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
+   dpy get f rot dup XOpenIM ;
+
 : init-xim ( classname -- )
-    dpy get f rot dup XOpenIM
-    [ "XOpenIM() failed" throw ] unless* xim set-global ;
+   dup "" (init-xim)
+   [ nip ]
+   [ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
+   xim set-global ;
 
 : close-xim ( -- )
     xim get-global XCloseIM drop f xim set-global ;
@@ -32,11 +38,11 @@
 SYMBOL: keysym
 
 : prepare-lookup ( -- )
-    buf-size "ulong" <c-array> keybuf set
+    buf-size "uint" <c-array> keybuf set
     0 <KeySym> keysym set ;
 
 : finish-lookup ( len -- string keysym )
-    keybuf get swap c-ulong-array> >string
+    keybuf get swap c-uint-array> >string
     keysym get *KeySym ;
 
 : lookup-string ( event xic -- string keysym )
diff -ur factor-org/extra/x11/xlib/xlib.factor factor/extra/x11/xlib/xlib.factor
--- factor-org/extra/x11/xlib/xlib.factor       2007-12-13 08:58:21.000000000 +0900
+++ factor/extra/x11/xlib/xlib.factor   2008-02-01 21:53:44.000000000 +0900
@@ -1339,10 +1339,28 @@
 
 FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
 
+! !!! category of setlocale
+: LC_ALL      0 ; inline
+: LC_COLLATE  1 ; inline
+: LC_CTYPE    2 ; inline
+: LC_MONETARY 3 ; inline
+: LC_NUMERIC  4 ; inline
+: LC_TIME     5 ; inline
+
+FUNCTION: char* setlocale ( int category, char* name ) ;
+
+FUNCTION: Bool XSupportsLocale ( ) ;
+
+FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ;
+
 SYMBOL: dpy
 SYMBOL: scr
 SYMBOL: root
 
+: init-locale ( -- )
+   LC_ALL "" setlocale [ "setlocale() failed" throw ] unless
+   XSupportsLocale [ "XSupportsLocale() failed" throw ] unless ;
+
 : flush-dpy ( -- ) dpy get XFlush drop ;
 
 : x-atom ( string -- atom ) dpy get swap 0 XInternAtom ;
@@ -1353,6 +1371,7 @@
     ] unless* ;
 
 : initialize-x ( display-string -- )
+    init-locale
     dup [ string>char-alien ] when
     XOpenDisplay check-display dpy set-global
     dpy get XDefaultScreen scr set-global

factor/fonts/Makefile

MONO=/usr/share/fonts/truetype/vlgothic/VL-Gothic-Regular.ttf
PRO=/usr/share/fonts/truetype/vlgothic/VL-PGothic-Regular.ttf


all :
        ln -fs $(PRO) Vera.ttf
        ln -fs $(PRO) VeraBI.ttf
        ln -fs $(PRO) VeraBd.ttf
        ln -fs $(PRO) VeraIt.ttf
        ln -fs $(MONO) VeraMoBI.ttf
        ln -fs $(MONO) VeraMoBd.ttf
        ln -fs $(MONO) VeraMoIt.ttf
        ln -fs $(MONO) VeraMono.ttf
        ln -fs $(PRO) VeraSe.ttf
        ln -fs $(PRO) VeraSeBd.ttf
        ls -l