多次元配列の各要素に対して関数を適用した結果を返すmap系関数を作成する場合、 make-arrayに:displaced-toキーワードを指定して作成したベクターに対してmap-intoを使うと簡潔に書けそうです。
(defun map-array! (fn array)
(let ((v (make-array (array-total-size array) :displaced-to array)))
(map-into v fn v))
array)
(asdf:load-system :alexandria)
(map-array! #'1+ (alexandria:copy-array #2A((1 2) (3 4))))
;; => #2A((2 3) (4 5))
以下、初めて知った多次元配列関連の関数
ABCLはJVM上で動作するCommon Lisp処理系なので、Javaのライブラリが利用できます。
(require :abcl-contrib)
(require :abcl-asdf)
(asdf:defsystem apache-poi
:components ((:mvn "org.apache.poi/poi/3.8")
(:mvn "org.apache.poi/poi-ooxml/3.8")))
(asdf:load-system 'apache-poi)
(defpackage :test-poi
(:use :cl :jss))
(in-package :test-poi)
(defun create-9x9 (path)
(let* ((wb (new 'xssfworkbook))
(sh (#"createSheet" wb)))
(dotimes (i 9)
(#"createRow" sh i))
(dotimes (i 9)
(dotimes (j 9)
(#"setCellValue" (#"createCell" (#"getRow" sh j) i)
(format nil "~A" (* (1+ i) (1+ j))))))
(#"write" wb (new 'fileoutputstream path))))
(create-9x9 "test.xlsx")
(defpackage asm (:use :cl :ccl) (:import-from :ccl defx86lapfunction)) (in-package :asm)まずは2つの整数を加算する関数を書いてみます。
;; add2という関数を定義します。 ;; 引数はaとbで、それぞれレジスタarg_yとarg_zを使って渡します。 ;; arg_yとarg_zはそれぞれRDIとRSIの別名です。 (defx86lapfunction add2 ((a arg_y) (b arg_z)) ;; 引数が2つかどうかチェックします。(lapmacro) (check-nargs 2) ;; RBPをスタックに積みます(スタックフレーム作成その1) (pushq (% rbp)) ;; RSPをRBPに設定(代入)します(スタックフレーム作成その2) (movq (% rsp) (% rbp)) ;; 引数同士を加算してbに保存します。 (addq (% a) (% b)) ;; スタックフレームを復元します(BPをSPにコピー,スタックからpopした値をBPにコピー) (leave) ;; b(arg_z)に保存した値を戻り値として関数を終了します。 (single-value-return)) ;; 実行します。 (add2 1 2) ;; => 3
(defx86lapfunction one? ((n arg_z)) (check-nargs 1) (pushq (% rbp)) (movq (% rsp) (% rbp)) (movq (% n) (% rax)) ;; 戻り値のデフォルト値として1(1である)を設定します。 (movq ($ '1) (% arg_z)) ;; RAXと測値1を比較します。 (cmpq ($ '1) (% rax)) ;; RAX==1の時, ENDラベルまでジャンプします。 (je END) ;; (RAX!=1の時) 戻り値に0(1でない)を設定します。 (movq ($ '0) (% arg_z)) ;; ENDラベル END (leave) (single-value-return)) ;; 実行 (one? 0) ;; => 0 (one? 1) ;; => 1 (one? 2) ;; => 0
(defx86lapfunction cpuid ((operation arg_z)) ;; 引数の数をチェック (check-nargs 1) ;; スタックフレーム作成 (pushq (% rbp)) (movq (% rsp) (% rbp)) ;; CPUIDで上書きされてしまうRBXを保存 (pushq (% rbx)) ;; CPUIDで取得する情報の種類をRAX(EAX)に保存 (unbox-fixnum operation rax) ;; CPUID命令実行 (cpuid) ;; 呼び出し結果をlispのfixnumに変換 (box-fixnum rbx rbx) ;; 多値で返すためにスタックに積む(2つ目) (pushq (% rbx)) ;; 退避していたRBXの値を復元 (movq (@ 8 (% rsp)) (% rbx)) (box-fixnum rax rax) ;; 多値で返すためにスタックに積む(1つ目) (movq (% rax) (@ 8 (% rsp))) (box-fixnum rcx rcx) ;; 多値で返すためにスタックに積む(3つ目) (pushq (% rcx)) (box-fixnum rdx rdx) ;; 多値で返すためにスタックに積む(4つ目) (pushq (% rdx)) ;; 戻り値の数を設定 (set-nargs 4) ;; 関数を終了して多値を返す (jmp-subprim .SPnvalret))
(defun u32->str (n)
(map 'string
(lambda (byte) (code-char (ldb byte n)))
(list (byte 8 0)
(byte 8 8)
(byte 8 16)
(byte 8 24))))
;; 実行
(multiple-value-bind (_ ebx ecx edx) (cpuid 0)
(format nil "~A~A~A"
(u32->str ebx)
(u32->str edx)
(u32->str ecx)))
;; => "GenuineIntel"
※ Lisp Advent Calendar 2日目でタグの話題がありましたが、CCLはポインタにタグが付いてるタイプのLispです。
なので、Lisp側から整数の1を渡したつもりでも機械語としてはタグの分(ここでは3bit)ずれた値になってしまいます。
box/unboxはこのずれを補正するための処理で、実際には掛け算やシフトが行われています。
Common Lispには、戻り値を作り出すために元々の構造を破壊する関数があります。
sort、stable-sort を除く破壊的な関数には対応する非破壊的な関数があるので、基本的には非破壊版を利用しておいたほうが良さそうです。
なお、破壊的関数の先頭に付く n は non-consing の略だそうです。
詳しくは 実践Common Lispの12章 あたりを見ると良いでしょう。
| 非破壊的 | 破壊的 | 概要 |
| sort | ソート | |
| stable-sort | 安定ソート | |
| reverse | nreverse | リストの反転 |
| append | nconc | リストの結合 |
| revappend | nreconc | リストの結合 |
| butlast | nbutlast | リストの末尾以外取得 |
| remove | delete | シーケンスの要素削除 |
| remove-if | delete-if | 条件に一致する要素削除 |
| remove-if-not | delete-if-not | 条件に一致しない要素削除 |
| remove-duplicates | delete-duplicates | 重複を削除 |
| union | nunion | 和集合 |
| intersection | nintersection | 積集合 |
| set-difference | nset-difference | 差集合 |
| set-exclusive-or | nset-exclusive-or | 対称差 |
| string-capitalize | nstring-capitalize | 単語の先頭を大文字、それ以外を小文字に変換 |
| string-downcase | nstring-downcase | 文字列を小文字に変換 |
| string-upcase | nstring-upcase | 文字列を大文字に変換 |
| subst | nsubst | 木構造(リスト)の要素を変更 |
| subst-if | nsubst-if | 木構造(リスト)の要素を変更 |
| subst-if-not | nsubst-if-not | 木構造(リスト)の要素を変更 |
| sublis | nsublis | 木構造(リスト)の要素を変更 |
| substitute | nsubstitute | シーケンスの要素を変更 |
| substitute-if | nsubstitute-if | シーケンスの要素を変更 |
| substitute-if-not | nsubstitute-if-not | シーケンスの要素を変更 |
Builderパターンは複雑なオブジェクトの生成を抽象化するデザインパターン。
BuilderパターンをD言語で書いてみます。
/* builderパターン */
import std.algorithm;
import std.string;
import std.stdio;
interface DocBuilder {
void makeTitle(string title);
void addContent(string content);
string getResult();
}
class HtmlBuilder : DocBuilder {
string title;
string[] contents;
override void makeTitle(string title) {
this.title = title;
}
override void addContent(string content) {
this.contents ~= content;
}
override string getResult() {
string fmt = "<html><head><title>%s</title></head><body>%s</body></html>";
string c = reduce!((a, b) => a ~ "<a>%s</a>".format(b))("", contents);
return fmt.format(title, c);
}
}
class TextBuilder : DocBuilder {
string title;
string[] contents;
override void makeTitle(string title) {
this.title = title;
}
override void addContent(string content) {
this.contents ~= content;
}
override string getResult() {
string list = "";
foreach(s; contents) {
list ~= "- " ~ s ~ "\n";
}
return "* " ~ title ~ "\n" ~ list;
}
}
class Director {
private DocBuilder builder;
this(DocBuilder builder) {
this.builder = builder;
}
string construct(string title, string[] contents) {
builder.makeTitle(title);
foreach(c; contents) {
builder.addContent(c);
}
return builder.getResult();
}
}
void main() {
auto d1 = new Director(new HtmlBuilder());
writeln(d1.construct("AAA", ["hello", "world"]));
auto d2 = new Director(new TextBuilder());
writeln(d2.construct("AAA", ["hello", "world"]));
}
> dmd builder.d > ./builder <html><head><title>AAA</title></head><body><a>hello</a><a>world</a></body></html> * AAA - hello - world
Common Lisp Advent Calendar 2012で iterate というloopマクロに似たイテレーションライブラリが紹介されていました。 (iterateを使ってloopマクロの呪縛から解き放たれる)
loopマクロと異なり拡張ができるようなので、 OOPのデザインパターンに出てくる(has-next/nextを使った)イテレーターパターンっぽいコードでループできるようにしてみました。
;; イテレーターパターンっぽいインターフェースと実装を定義
;; iterator-next メソッドと has-next-p メソッドを実装したクラスを定義する
(ql:quickload :cl-fad)
(ql:quickload :cl-annot)
(defpackage pattern.iterator
(:use :cl :cl-annot))
(in-package :pattern.iterator)
(enable-annot-syntax)
@export
(defgeneric has-next-p (obj))
@export
(defgeneric iterator-next (obj))
@export
(defclass <sequence-iterator> ()
((seq :initarg :seq)
(pos :initarg :pos :initform 0)))
(defmethod has-next-p ((obj <sequence-iterator>))
(with-slots (seq pos) obj
(< pos (length seq))))
(defmethod iterator-next ((obj <sequence-iterator>))
(with-slots (seq pos) obj
(prog1 (elt seq pos)
(incf pos))))
@export
(defun sequence-iterator (seq)
(make-instance '<sequence-iterator> :seq seq))
@export
(defclass <directory-walker> ()
((rest :initform nil)))
@export
(defun directory-walker (root)
(make-instance '<directory-walker> :root root))
(defmethod initialize-instance ((obj <directory-walker>) &key (root "./") &allow-other-keys)
(call-next-method)
(push (fad:canonical-pathname root) (slot-value obj 'rest)))
(defmethod has-next-p ((obj <directory-walker>))
(with-slots (rest) obj
(not (null rest))))
(defmethod iterator-next ((obj <directory-walker>))
(with-slots (rest) obj
(let ((path (pop rest)))
(when (fad:directory-exists-p path)
(setf rest (nconc (fad:list-directory path) rest)))
path)))
;; ドライバの実装
;; iterator-nextとhas-next-pを使ったループをiterateに組み込む。
(ql:quickload "iterate")
(ql:quickload :cl-fad)
(in-package :cl-user)
(defpackage test
(:use :cl :iterate :pattern.iterator))
(in-package :test)
;; IN-ITERATORというキーワードでイテレータパターン風の処理でループできるように拡張
(defmacro-driver (FOR var IN-ITERATOR obj)
(let ((gitr (gensym))
(kwd (if generate 'generate 'for)))
`(progn
(with ,gitr = ,obj)
(while (pattern.iterator:has-next-p ,gitr))
(,kwd ,var next (pattern.iterator:iterator-next ,gitr)))))
(iter (for x in-iterator (pattern.iterator:sequence-iterator '(1 2)))
(collect x))
;; => (1 2)
;; 以下のディレクトリ構成で実行
;; ./ (/home/kurohuku/tmp)
;; |- A.txt
;; |- B
;; | |- B1.txt
;; | |- B2.lisp
;; |- C.txt
(iter (for x IN-ITERATOR (directory-walker "./"))
(collect x))
;; => (#P"" #P"/home/kurohuku/tmp/A.txt" #P"/home/kurohuku/tmp/B/"
;; #P"/home/kurohuku/tmp/B/B1.txt" #P"/home/kurohuku/tmp/B/B2.lisp"
;; #P"/home/kurohuku/tmp/C.txt")
(iter (for x IN-ITERATOR (directory-walker "./"))
(when (string-equal (pathname-type x) "txt")
(collect x)))
;; => (#P"/home/kurohuku/tmp/A.txt" #P"/home/kurohuku/tmp/B/B1.txt"
;; #P"/home/kurohuku/tmp/C.txt")