fletとlabels
CommonLispのfletとlabels的なものを(あらかじめ使えるものはlambdaしかない状況で)自分で実装する必要が出てきたので、その際のメモ。
なお、以下では煩雑になるためfuncall呼び出しの記述を省略している(実際にはScheme処理系で動作確認を行っていた)。
let
flet、labelsの前にまずはlambdaを使ったletの実現方法を考える。
;; 以下のように変換可能 (let ((a 10) (b 20) (c 30)) (list a b c)) ↓ ((lambda (a b c) (list a b c)) 10 20 30)) ; => (10 20 30)
flet
上のようにしてletが使えると仮定した場合、fletと同じ機能を実現するのは簡単。
;; 単に変数に(lambda ...)を束縛すれば良い (let ((hello (lambda (x) (list 'hello x)))) (hello 'world)) ; => (HELLO WORLD)
labels
これがlabels(ローカル関数の再帰呼び出しが可能)になると少し難しくなる。
以下、fletと同様の方法で試した場合。
;; フィボナッチ数を計算 (let ((fib (lambda (n) (if (< n 2) n ;; fibの再帰呼び出し (+ (fib (- n 2)) (fib (- n 1))))))) (fib 10)) ; => ERROR: 再帰呼び出し部分でfib関数が見つからないと云われる
fib変数に束縛したlambdaの本体のコンテキストからは、fib変数が見つからないため、エラーとなる。
再帰呼び出しに使用するfib関数を明示的に引数を渡すようにすれば、問題は解決する。
(let ((fib (lambda (n fib) ; 第二引数に常にfib関数を渡すようにする (if (< n 2) n (+ (fib (- n 2) fib) (fib (- n 1) fib)))))) (fib 10 fib)) ; => 55
ただ、上の方法の引数の形が変わってしまうのが難点。
若干複雑にはなるが、以下のようにクロージャを使って再帰関数を持ち回すようにすれば、引数及び本体の形はほぼ変わらないので、マクロなどで生成するのは楽になる(ように思う)。
(let ((fib-rec (lambda (fib-rec) ; 再帰関数を引数に渡す (lambda (n) (let ((fib (fib-rec fib-rec))) ; 再帰関数の情報を埋め込んだfib関数を返す (if (< n 2) n (+ (fib (- n 2)) (fib (- n 1))))))))) (let ((fib (fib-rec fib-rec))) ; 再帰関数の情報を埋め込んだfib関数を返す (fib 10))) ; => 55
これでローカル関数の再帰呼び出しはできるようになったのでは、マクロを使ってシンタックスを整えれば、labelsが実現できることになる。
- -
以前に、何でCommonLispにはfletとlabelsの二つがあるのか、とかOcamlでletとlet recが分かれているか、とか少し疑問に思ったことがあったように思うけど、少し理由が分かった気がする。
マインスイーパー
端末上で動作するマインスイーパーをCommonLisp(SBCL)で実装してみた。
github: cl-mine-0.0.2
端末操作
端末操作部分のソースコードは以下のような感じ。
基本的には端末のエスケープシーケンスで(カーソル移動や画面クリア、文字色等の)制御を行っている。
ただ、キー入力をリアルタイムで取得可能にするのはエスケープシーケンスでは無理そうだったので、その部分はtcsetattr等のシステムコール(?)を使用している。
(defpackage console (:use :common-lisp :sb-alien) (:shadow :common-lisp format) (:export with-raw-mode clear move set-pos format newline formatln style)) (in-package :console) ;;; types ;;; (deftype direction () '(member :up :down :left :right)) ; カーソル移動の方向 (deftype color () '(member :black :red :green :yellow :blue :magenta :cyan :white :normal)) ; 文字色、背景色 ;;; constants ;;; (defparameter +ESC+ (common-lisp:format nil "~c[" (code-char #8r33))) ; エスケープシーケンスの開始文字列 (defparameter +STDIN_FD+ (sb-sys:fd-stream-fd sb-sys:*stdin*)) ; 標準入力のファイルディスクリプタ ;;; internal functions ;;; ;; 文字色のコード値を取得 (defun color-code (color) (declare (color color)) (ecase color (:black 30) (:red 31) (:green 32) (:yellow 33) (:blue 34) (:magenta 35) (:cyan 36) (:white 37) (:normal 39))) ;; cfmakeraw関数(キー入力リアルタイム取得用)はsb-posixパッケージに存在しないようなので読み込む (define-alien-routine ("cfmakeraw" %cfmakeraw) void (termios* (* t))) (defun cfmakeraw () (let ((termios (sb-posix::allocate-alien-termios))) (%cfmakeraw termios) (unwind-protect (sb-posix::alien-to-termios termios) (sb-posix::free-alien-termios termios)))) ;;; exported functions ;;; ;; 標準のformat関数の薄いラッパー (defmacro format (control-string &rest format-arguments) `(progn (common-lisp:format t ,control-string ,@format-arguments) (force-output))) ;; 改行付きのformat関数 (defmacro formatln (control-string &rest format-arguments) `(progn (format ,control-string ,@format-arguments) (newline))) ;; 改行: tcsetattr関数にcfmakerawの戻り値を渡した場合(rawモード?)、改行には #\Newlineと#\Return の両方が必要 (defun newline () (format "~c~c" #\Newline #\Return)) ;; 文字色、背景色、太字、下線、文字色背景色反転、等を指定した文字列を返す (defun style (x &key (color :normal) (bgcolor :normal) bold inverse underline) (declare (color color bgcolor)) (common-lisp:format nil "~a~{~d;~}~d;~dm~a~a0m" +ESC+ (remove nil (list (and bold 1) (and underline 4) (and inverse 7))) (color-code color) (+ (color-code bgcolor) 10) x +ESC+)) ;; 上下左右へのカーソル移動 (defun move (direction &optional (delta 1)) (declare (direction direction)) (when (plusp delta) (format "~a~d~a" +ESC+ delta (ecase direction (:up "A") (:down "B") (:left "D") (:right "C"))))) ;; 画面クリア。lineがtの場合はカーソル行のみをクリア。 (defun clear (&key line) (if line (format "~a2K" +ESC+) (format "~a2J" +ESC+))) ;; 任意の位置へのカーソル移動 (defun set-pos (x y) (format "~a~d;~dH" +ESC+ y x)) ;; 端末をrawモード(?)に切り替えてbodyを評価する (defmacro with-raw-mode (&body body) (let ((old (gensym))) `(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) (let ((,old (sb-posix:tcgetattr +STDIN_FD+))) (unwind-protect (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) (sb-posix:tcsetattr +STDIN_FD+ sb-posix:tcsadrain (cfmakeraw)) ,@body) (sb-posix:tcsetattr +STDIN_FD+ sb-posix:tcsanow ,old))))))
例えば、端末内をカーソル移動できるようにする場合は、以下のようなコードとなる。
;; 'e': ↑ ;; 'd': ↓ ;; 's': ← ;; 'f': → ;; 'c': exit (console:with-raw-mode (loop (case (read-char) (#\e (console:move :up)) (#\d (console:move :down)) (#\s (console:move :left)) (#\f (console:move :right)) (#\c (return)))))
簡単なUIならこれで十分かもしれない。
N-Queen: 高速化
こちらの記事に刺激を受けて、以前に実装したN-Queenを高速化してみた(Common Lisp版のみ)。
(defvar *fastest* '(optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (deftype max-board-size () '(mod #x100)) (declaim (inline check)) ; inline宣言を追加 (defun check (row queens &optional (r 1) &aux (q (car queens))) (declare #.*fastest* (max-board-size r row q)) (or (null queens) (and (/= q (+ row r) (- row r)) (check row (cdr queens) (1+ r))))) ;; dolistの亜種 ;; - リストの走査時に各要素を変数に束縛するのと同時に、走査中の要素を除いたリストも変数に束縛する ;; ※ 先頭要素は走査対象外 (defmacro dolist2 ((x but-x list) &body body) (multiple-value-bind (recur prev cur next) (values #1=(gensym) #1# #1# #1#) `(let ((,but-x ,list)) (labels ((,recur (,prev &aux (,cur (cdr ,prev))) (when ,cur (destructuring-bind (,x . ,next) ,cur (setf (cdr ,prev) ,next) (locally ,@body) (setf (cdr ,prev) ,cur) (,recur ,cur))))) (,recur ,but-x))))) #| ex: > (dolist2 (x but-x '(:head 1 2 3 a b c)) (print `(:x ,x :but-x ,but-x))) (:X 1 :BUT-X (:HEAD 2 3 A B C)) (:X 2 :BUT-X (:HEAD 1 3 A B C)) (:X 3 :BUT-X (:HEAD 1 2 A B C)) (:X A :BUT-X (:HEAD 1 2 3 B C)) (:X B :BUT-X (:HEAD 1 2 3 A C)) (:X C :BUT-X (:HEAD 1 2 3 A B)) --> NIL |# (defun n-queen (n) (declare #.*fastest* (max-board-size n)) (nlet-acc self (queens (rows (cons :head (loop FOR i FROM 0 BELOW n COLLECT i)))) (if (null (cdr rows)) ; rows == '(:head) (accumulate queens) (dolist2 (row rest-rows rows) (when (check row queens) (self (cons row queens) rest-rows))))))
erl-creole: ユニコード文字列とマルチバイト列の変換ライブラリ
少し必要になったのでErlangでユニコード文字列と各種エンコーディングのマルチバイト列(バイナリ)の相互変換を行うモジュールを作成した。
github: erl-creole-0.0.1
- UTF-8, Shift_JIS, CP932, EUC-JP, eucJP-ms, JIS(ISO-2022-JP), ISO-2022-JP-1
使用例
%% 入力文字列 > S = "Unicode (ユニコード) とは、世界中の多くのコンピュータ上の文字列を一貫した方法で符号化し、表現し、扱うためのコンピュータ業界の標準である。". %% EUC-JPに変換 > creole:from_string(S, eucjp). <<"Unicode (\æ\Ë\³¡¼\É) ¤È¤Ï¡¢À¤³釗Ãæ¤Î¿¤¯¤Î\³\ó\Ô\塼\¿¾å¤Îʸ»úÎó¤ò°ì´Ó¤·¤¿ÊýË¡¤ÇÉä¹æ²½¤·¡¢É½¸½¤·¡¢°·¤釗¤¿¤á¤Î\³\ó\Ô\å¡"...>> %% JIS(ISO-2022-JP)に変換 > Bin = creole:from_string(S, jis). <<"Unicode (\e$B%f%K%3!<%I\e(B) \e$B$H$O!\"@$3&Cf$NB?$/$N%3%s%T%e!<%?>e$NJ8;zNs$r0l4S$7$?J}K!$GId9f2=$7!\"I=8=$7!\"07$&$?$a$N"...>> %% バイト列からユニコード文字列に変換 > creole:to_string(Bin, jis). [85,110,105,99,111,100,101,32,40,12518,12491,12467,12540, 12489,41,32,12392,12399,12289,19990,30028,20013,12398,22810, 12367,12398,12467,12531,12500|...] > io:format("~ts~n", [creole:to_string(Bin, jis)]). Unicode (ユニコード) とは、世界中の多くのコンピュータ上の文字列を一貫した方法で符号化し、表現し、扱うためのコンピュータ業界の標準である。 ok %% 変換不能なバイト列がある場合は、デフォルトでは "?" が代わりに使用される > io:format("~ts~n", [creole:to_string(<<"Unicode (\e$B%~^s^sjaf*(asf7aK%3!<%I">>, jis)]). Unicode (??潁潁裃罟?癈羞疔コード ok %% "?"の代わりに"_"を使用 > io:format("~ts~n", [creole:to_string(<<"Unicode (\e$B%~^s^sjaf*(asf7aK%3!<%I">>, jis, creole:replace($_))]). Unicode (__潁潁裃罟_癈羞疔コード ok
*1:ユニコードと他のエンコーディングのコードポイントの対応は主に http://source.icu-project.org/repos/icu/data/trunk/charset/data/ucm/ を参考にさせてもらった。
文字列/バイト列用のハッシュ関数ライブラリ
A Hash Function for Hash Table Lookupに載っているハッシュ関数(Jenkins Hash)をCommon Lispで実装した。
github: jenkins-hash(0.0.2)
作成の主な動機は以下の二つ:
おそらくSBCL以外の処理系でも動くと思うけど、動作は未確認。
使用例
以下、使用例。
;;;; SBCL-1.0.51-64bit ;;; 【文字列】 ;; 文字列からハッシュ値を算出 (jenkins-hash:hash-string "ハッシュ関数") --> 3188986421 ; 一つのキーに対して二つのハッシュ値(32bit)を返す 2167986557 ;; パラメータ(seed1,seed2)を替えて別のハッシュ値を算出 (jenkins-hash:hash-string "ハッシュ関数" :seed1 13 :seed2 44444) --> 2402597428 3323692532 ;; 範囲指定 (jenkins-hash:hash-string "ハッシュ関数" :start 2 :end 4) --> 58741211 888923469 ;;; 【バイト列】 ;; バイト列からハッシュ値を算出 (jenkins-hash:hash-octets (sb-ext:string-to-octets "ハッシュ関数")) --> 1523938354 936250363 ;; sxhash関数だと配列を与えた場合、全て同じハッシュ値になってしまう (sxhash (sb-ext:string-to-octets "ハッシュ関数")) --> 518591303 (sxhash (sb-ext:string-to-octets "別の値")) --> 518591303 ;;; 【複数のハッシュ値】 ;; nth-hash関数を使って、任意個のハッシュ値を安価に生成可能 ;; ※ 内部的にはDoubleHashingを用いて生成している => 可算一つと乗算一つで算出可能 ;; 一つのキーに対する10個の異なるハッシュ値を取得する (defun hash10 (key) (multiple-value-bind (h1 h2) (jenkins-hash:hash-string key) ;; 最初の二つはそのまま使って、残りはnth-hash関数で生成する `(,h1 ,h2 . ,(loop FOR i FROM 2 BELOW 10 COLLECT (jenkins-hash:nth-hash i h1 h2))))) (hash10 "ハッシュ関数") --> (3188986421 2167986557 3229992239 1103011500 3270998057 1144017318 3312003875 1185023136 3353009693 1226028954)
N-Queen (Haskell + Common Lisp)
Etsukata blog: Haskellでlist monadを使ってN-Queens問題を解いてみました を見たのをきっかけに久しぶりにN-Queen問題を解くプログラムをHaskellで書いてみた。
---- ファイル名: nqueen.hs ---- コンパイル: ghc -O2 -o nqueen nqueen.hs # Glasgow Haskell Compiler, Version 7.0.3 import System -- クイーンの配置: リスト内のオフセットが列を、値が行を表す type Queens = [Int] -- N-Queenを解く: ボードのサイズを受け取り、全ての解答(可能な配置のリスト)を返す nQueens :: Int -> [Queens] nQueens n = solve n [] where solve 0 queens = [queens] -- 最後の列: 全てのクイーンを配置できた solve col queens = -- 途中の列: 全ての行に対して配置可能かを調べ、可能なら次の列に進む concat $ map (solve (col-1) . (:queens)) $ filter (check queens 1) [0..(n-1)] -- クイーンが配置可能かどうか調べる check :: Queens -> Int -> Int -> Bool check [] _ _ = True check (q:qs) r row -- rは対角線上の(チェックすべき)クイーンの位置を知るための変数 | q /= row && q /= row+r && q /= row-r = check qs (r+1) row | otherwise = False -- メイン関数 main = do args <- getArgs let size = (read $ head args)::Int let rlt = nQueens size putStrLn $ show . length $ rlt
実行結果:
$ ./nqueen 12 14200
処理時間
冒頭で挙げた記事のもの(Etsutaka)、および、Common Lisp版(後述)との処理速度の比較。
| 処理時間(サイズ=11) | 処理時間(サイズ=12) | 処理時間(サイズ=13) | |
|---|---|---|---|
| nqueen(Haskell:本記事) | 0.080秒 | 0.424秒 | 2.592秒 |
| nqueen(Haskell:Etsutaka) | 0.132秒 | 0.736秒 | 4.424秒 |
| nqueen(Common Lisp) | 0.071秒 | 0.375秒 | 2.289秒 |
この中ではCommon Lisp版が一番速くなっているけど、Haskellで効率の良いプログラムの書き方とかが全く分かっていないので、その辺を把握してちゃんと書けばHaskell版はもっと速くなるかもしれない。
Common Lisp版
Common Lisp版のソースコード。
内容的には N-Queen(1) - sileの日記 に最適化宣言を加えただけ。
(defvar *fastest* '(optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (deftype max-board-size () '(mod #x100)) (defun check (row queens &optional (r 1)) (declare #.*fastest* (max-board-size r row)) (or (null queens) (and (/= (the max-board-size (car queens)) row (+ row r) (- row r)) (check row (cdr queens) (1+ r))))) (defun n-queen (n) (declare #.*fastest* (max-board-size n)) (nlet-acc self (queens (col n)) (if (zerop col) (accumulate queens) (dotimes (row n) (when (check row queens) (self (cons row queens) (1- col)))))))
;; SBCL-1.0.51 > (n-queen 4) --> ((2 0 3 1) (1 3 0 2)) > (time (length (n-queen 12))) Evaluation took: 0.401 seconds of real time 0.400025 seconds of total run time (0.400025 user, 0.000000 system) [ Run times consist of 0.012 seconds GC time, and 0.389 seconds non-GC time. ] 99.75% CPU 800,068,094 processor cycles 13,926,400 bytes consed --> 14200
ビットリバース
割合汎用的な、整数のビットを前後反転する関数を作成してみた。
2の乗数サイズの任意の整数型のビット反転が可能。
// 反転例 bit_reverse(0x0000FFFF) => 0xFFFF0000
// 実装 // バイト単位での変換表 const unsigned char REV_BYTE[]={ 0,128,64,192,32,160,96,224,16,144, 80,208,48,176,112,240,8,136,72,200, 40,168,104,232,24,152,88,216,56,184,120,248,4,132,68,196,36,164,100,228, 20,148,84,212,52,180,116,244,12,140,76,204,44,172,108,236,28,156,92,220, 60,188,124,252,2,130,66,194,34,162,98,226,18,146,82,210,50,178,114,242, 10,138,74,202,42,170,106,234,26,154,90,218,58,186,122,250,6,134,70,198, 38,166,102,230,22,150,86,214,54,182,118,246,14,142,78,206,46,174,110,238, 30,158,94,222,62,190,126,254,1,129,65,193,33,161,97,225,17,145,81,209, 49,177,113,241,9,137,73,201,41,169,105,233,25,153,89,217,57,185,121,249, 5,133,69,197,37,165,101,229,21,149,85,213,53,181,117,245,13,141,77,205, 45,173,109,237,29,157,93,221,61,189,125,253,3,131,67,195,35,163,99,227, 19,147,83,211,51,179,115,243,11,139,75,203,43,171,107,235,27,155,91,219, 59,187,123,251,7,135,71,199,39,167,103,231,23,151,87,215,55,183,119,247, 15,143,79,207,47,175,111,239,31,159,95,223,63,191,127,255}; // リバースクラス template <int BYTE_SIZE> struct bit_rev { static const int HALF_SIZE = BYTE_SIZE/2; static const int HALF_BITS = HALF_SIZE*8; // BYTE_SIZEが1以外なら、上位ビットと下位ビットに再帰的に処理を適用した後に、二つを入れ替える template <typename T> static T reverse(T n) { return (bit_rev<HALF_SIZE>::reverse(n) << HALF_BITS) | (bit_rev<HALF_SIZE>::reverse(n>>HALF_BITS)); } }; // BYTE_SIZEが1ならテーブルを参照して、バイトを変換する template <> struct bit_rev<1> { template <typename T> static T reverse(T n) { return REV_BYTE[n&0xFF]; } }; // インターフェース関数 template <typename T> T bit_reverse(T n) { return bit_rev<sizeof(T)>::reverse(n); }
サンプルコマンド:
/** * ファイル名: rev.cc * コンパイル: g++ -o rev rev.cc */ #include <iostream> /* bit_reverse関数定義 */ int main() { unsigned char n08 = 0x0F; unsigned short n16 = 0x009F; unsigned int n32 = 0x0000699F; unsigned long long n64 = 0x00000000666699FF; std::cout.setf(std::ios::hex, std::ios::basefield); std::cout.setf( std::ios::showbase ); std::cout << "n08: " << (long long)n08 << " => " << (long long)bit_reverse(n08) << std::endl; std::cout << "n16: " << (long long)n16 << " => " << (long long)bit_reverse(n16) << std::endl; std::cout << "n32: " << (long long)n32 << " => " << (long long)bit_reverse(n32) << std::endl; std::cout << "n64: " << (long long)n64 << " => " << (long long)bit_reverse(n64) << std::endl; return 0; }
実行結果:
$ ./rev n08: 0xf => 0xf0 n16: 0x9f => 0xf900 n32: 0x699f => 0xf9960000 n64: 0x666699ff => 0xff99666600000000
自分の環境で軽く試した感じでは、ビット演算のみを使用して手書きで最適化したものと同等以上の速度が出ていた。
