Archive for 2010年7月|Monthly archive page
newLISP で On Lisp する．．．第１４章（その２の続き）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
さて、第１４章 アナフォリックマクロ の 失敗 から 多値を返すアナフォリックマクロ の残りです（multiple-value-bind は、onnewlisp.lsp に定義してあります）。
(define-macro (awhen2)
; (awhen test-form &body body)
(letex (_test-form (args 0)
_body (cons 'begin (1 (args))))
(aif2 _test-form _body)))
(define-macro (awhile2)
; (awhile2 test &body body)
(letex (_flag (gensym)
_test (args 0)
_body (cons 'begin (1 (args))))
(let (_flag true)
(while _flag
(aif2 _test _body (setq _flag nil))))))
(define-macro (acond2)
; (acond &rest clauses)
(if (null? (args))
nil
(letex (_cl1st (args 0 0)
_clrest (cons 'begin (1 (args 0)))
_acondrest (cons 'acond2 (1 (args)))
_val (gensym)
_win (gensym))
(multiple-value-bind (_val _win) _cl1st
(if (or _val _win)
(let (it _val) _clrest)
_acondrest)))))
ファイル用ユーティリティ で使われている Common Lisp の read に相当するのは、newLISP では read-expr です。ただし、引数は、文字列です（gensym は newlisp-utility.lsp に、values は onnewlisp.lsp に定義してあります）。
(context 'MAIN:read-expr2)
(setq g (gensym))
(define (read-expr2:read-expr2 str)
(setq $0 g)
(let (val (read-expr str))
(if-not (= $0 g) (values val $0))))
(context MAIN)
(define-macro (do-file)
; (do-file filename &body body)
(letex (_str (gensym)
_file (args 0)
_body (cons 'begin (1 (args))))
(let (_str (read-file _file))
(awhile2 (read-expr2 _str)
_body
(setq _str ($0 _str))))))
関数read-expr2 の返す値は、文字列から読み取った式と読み取った文字数です。組込read-expr は、文字列の最初の式のみを取り出します。そして、システム変数 $0 に読み取った文字数が入ります。エラーもしくは、EOF の時は、$0 は変わりません。関数先頭で $0 に gensym で生成したシンボルを入れておき、エラーもしくは、EOF の判定に使っています。“On Lisp”本書の例に習って、gensym によるシンボル生成は、一回で済むようにしています。
マクロdo-file では、読み取った文字列を切り取り、残りの文字列を関数read-expr2 に渡しています。システム変数 $0 が表に出ているのは、awhile2 を使っているから。
awhile2 を使わずに、multiple-value-bind を使って
(define-macro (do-file)
; (do-file filename &body body)
(letex (_str (gensym)
_pos (gensym)
_flag (gensym)
_file (args 0)
_body (cons 'begin (1 (args))))
(let (_str (read-file _file)
_flag true)
(while _flag
(multiple-value-bind (it _pos) (read2 _str)
_body
(if _pos
(setq _str (_pos _str))
(setq _flag nil)))))))
とすれば、システム変数$0 は、read-expr2 内に隠れます。
そして、第１４章 アナフォリックマクロ の 最後、参照の透明性 につながります（笑）。
ここに書かれている、参照の透明性は、常に頭に入れておきたいものです。というのは、これを考えておかないと、思わぬバグを引き起こすからです。
例えば、newLISP の組込find では、システム変数が使えます。
> (find nil '(2 3 6) (fn (x y) (oddp y))) 1 > $0 3 > (find nil '(2 4 6) (fn (x y) (oddp y))) nil > $0 3
これは、（b）に反する例かもしれません。断っておきますが、newLISP が悪いといっているわけではありません。$0 は、システム変数ですから、保障された内容ではありません。使うのは自己責任です。上記の例では、2番目の検索で検出されなかったので、$0 が更新されなかっただけのこと。システム内の高速化を考えれば、リーズナブルな仕様です。使う側ではそのリスクを負わなければなりません。
なぜ、これを例に出したのか？それは、私だけかもしれませんが、この手のことは、よく実装しがちだからです。書いた時は、そのことを覚えているのですが、しばらく経ってから使った時、思うように動かないのは、大抵こういうことだったりするからです。内部変数ではよいとしても、表に出てくる値に対しては、参照の透明性を考慮しておくべきでしょう。
くどいようですが、$0 は、内部変数です。使う方の責任です。ちなみに、find で $0 の代わりに、$it は使えません。当たり前か。ということで、前に実装した find-if は、システム変数を使う場合、次のように実装すべきでしょう。
(define (find-if func lst)
(and (find nil lst (fn (x y) (func y)))
$0))
実は、これを出したかっただけだったりして（汗）。
閑話休題、第１４章 アナフォリックマクロ のまとめです。
- newLISP でも、アナフォリックマクロは可能ですし、役に立ちます。
- newLISP では、空リストと nil は、区別されます。ただし、if 文では、どちらも 偽（true の逆）です。
- newLISP でも、参照の透明性は、常に頭に入れておくべきでしょう。
以上、如何でしょうか？
newLISP で On Lisp する．．．第１４章（その２）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
今回は、第１４章 アナフォリックマクロ の 失敗 から、シンボル nil について（cdr は、newlisp-utility.lsp に定義してあります）、
> (cdr '(a)) () > cdr rest<406AFE> > (rest '(a)) () >
newLISP では、空リストが nil ではありませんが、
> (not (rest '(a))) true > (if (rest '(a)) "true" "nil") "nil" >
if 文では、偽（true の逆）として扱われます。
> (= 1 0) nil >
そして、述語で偽（true の逆）は nil になります。
newLISP に find-if は、ありませんが、前回定義した find-if を使えば（oddp と null は、newlisp-utility.lsp に定義してあります）、
> find-if (lambda (func lst) (let (it (find nil lst (lambda (x y) (func y)))) (if it (lst it) B))) > (find-if oddp '(2 4 6)) nil > (find-if null '(2 nil 6)) nil >
関数 find-if は、失敗を nil で表します。上の例で、検索したものが nil の場合、見分けが付きません。
しかし、newLISP の組込関数で、失敗以外で nil を返すのは、驚くほど少ないのです。
> (find nil '(2 4 6) (fn (x y) (oddp y))) nil > (find nil '(2 nil 6) (fn (x y) (null? y))) 1 >
組込find は、検索しますが、戻り値は、リストの位置です。nil が返ったら間違いなく失敗です。
例外は、first や nth 。しかし、これらは、失敗で nil を返すことはありません。エラーですから（苦）。newLISP の組込関数の少なさは、ここまで配慮されて、慎重に選ばれた結果なのかもしれません。
また、newLISP には、ドット対がないので
> (setq synonyms '((yes ture)(no nil))) ((yes ture) (no nil)) > (assoc 'no synonyms) (no nil) > (setq synonyms '((yes ture)(no))) ((yes ture) (no)) > (assoc 'no synonyms) (no) > (assoc 'maybe synonyms) nil >
と、なります。前回使ったnewLISP組込lookup は、検索の失敗と、検索したものが nil だった場合が同一になる稀有の例かもしれません。
> (setq synonyms '((yes ture)(no nil))) ((yes ture) (no nil)) > (lookup 'yes synonyms 1) ture > (lookup 'no synonyms 1) nil > (lookup 'maybe synonyms 1 'N/A) N/A >
それでも、上記のように、検索失敗時に返すシンボルを指定することで、回避できます。
この手のオプションは、Common Lisp の多くの組込アクセス関数に備わっています。find-if に付いていないのは、むしろ例外？ だから、“On Lisp”本書の例としては、取り上げられた？
また、newLISP には、member-if がありませんが、本書程度の例なら、組込member を使って
> (member nil '(2 nil 6)) (nil 6) >
となり、曖昧さは排除できます。
そして、多値。
newLISP には、多値も無く、hash も gethash もありませんが、nii と空リストは異なり、context があります。
> (new Tree 'edible) edible > (edible "olive-oil" true) true > (edible "motor-oil" '()) () > (edible "olive-oil") true > (edible "motor-oil") ()
３通りを判別する関数は（defun は、newlisp-utility.lsp に定義してあります）、
(defun edible? (x)
(let (val (edible x))
(if val
'yes
(if (nil? val) 'maybe 'no))))
となり、
> (map edible? '("motor-oil" "olive-oil" "iguana"))
(no yes maybe)
動作は、“On Lisp”本書と同じように見えます。
get も newLISP にはありませんが、ここでは定義しません。
多値を返すアナフォリックマクロ の実装に入ります。とはいっても、newLISP には、多値はありませんので、前に実装したものを使います。gethash のような多値を返す関数の無いnewLISP では、あまり意味がありませんけど。
まず aif2 から（multiple-value-bind は、onnewlisp.lsp に定義してあります）、
(define-macro (aif2)
; (aif2 test &optional then else)
(letex (_win (gensym)
_test (args 0)
_then (second (args))
_else (third (args)))
(multiple-value-bind (it _win) _test
(if (or it _win) _then _else))))
動作確認用に多値を返す gethash を用意します（values は、onnewlisp.lsp に定義してあります）。
(defun gethash (key ctx)
(aif (ctx (term key))
(values it true)
(if (nil? it)
(values nil nil)
(values it true))))
そして、前述の edible? は、次のように書けます。
(defun edible2? (x)
(aif2 (gethash x edible)
(if it 'yes 'no)
'maybe))
動作はというと、
> (map edible2? '(motor-oil olive-oil iguana)) (no yes maybe) >
見た目は、edible? と変わりませんけどね（笑）。
さて、長くなってきたので、多値を返すアナフォリックマクロ の残りからは、次回以降に。
以上、如何でしょうか？
newLISP で On Lisp する．．．第１４章（その１）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp に定義してあります。）
第１４章 アナフォリックマクロ です。
V.10.0以降の newLISP では、setf などで使えるアナフォリックなシステム変数 $it が導入されています。
まずは、Common Lisp の標準オペレータのアナフォリックな変種 から、
（third は、newlisp-utility.lsp で定義してあります。）
(define-macro (aif)
; (aif test-form then-form &optional else-form)
(letex (_test-form (args 0)
_then-form (args 1)
_else-form (third (args)))
(let (it _test-form)
(if it _then-form _else-form))))
上記マクロ aif は、“On Lisp”本書に沿ったマクロです。
しかし、newlisp-utility.lsp には、macro の aif が定義されています。
(module "macro.lsp")
(macro (aif S A B)
(let (it S)
(if it A B))))
どちらを使っても、結果は同じですが、どちらか一方しか使えません。ご注意を。
お薦めは、macro の aif です（笑）。
さて、このマクロを使えば、組込find で find-if がすっきり書けます（defun は、newlisp-utility.lsp に定義してあります）。
(defun find-if (func lst)
(aif (find nil lst (fn (x y) (func y)))
(lst it)))
動作は（oddp は、newlisp-utility.lsp に定義してあります）、
> (find-if oddp '(2 3 4)) 3 >
もちろん、次のマクロ
(define-macro (awhen)
; (awhen test-form &body body)
(letex (_test-form (args 0)
_body (cons 'begin (1 (args))))
(aif _test-form _body)))
を使って
(defun find-if (func lst)
(awhen (find nil lst (fn (x y) (func y)))
(lst it)))
でもかまいません。
マクロawhile には、do ではなくnewLISP の組込while を使います。
(define-macro (awhile)
; (awhile expr &body body)
(letex (_expr (args 0)
_body (cons 'begin (1 (args))))
(while (setq it _expr)
_body)))
使い方はというと、
> (let (x '(apple orange melon)) (awhile (pop x) (print "eat ") (println it) ) x) eat apple eat orange eat melon ()
そして、マクロaand は、
(define-macro (aand)
; (aand &rest args)
(if (args)
(letex (_len (length (args))
_1st (args 0)
_rest (cons 'aand (1 (args))))
(cond ;((zero? _len) nil)
((= _len 1) _1st)
(true (aif _1st _rest))))
true)
)
前の“On newLISP”の頃、newLISP組込の and は、引数無しで nil を返しましたが、現在では、Common Lisp と同じ、真（true）を返します。
さて、動作は( lookup は、newLISPでは、組込です）、
> [cmd]
(setq person '((marry ((Address ((City NewYork) (Street "123 Main Street")))(Job "Engineer")))
(john ((Address ((City Chicago) (Street "124 Main Street")))(Job "Desinger")))))
[/cmd]
((marry ((Address ((City NewYork) (Street "123 Main Street"))) (Job "Engineer")))
(john ((Address ((City Chicago) (Street "124 Main Street"))) (Job "Desinger"))))
> (aand (lookup 'marry person) (lookup 'Address it) (lookup 'City it))
NewYork
> (aand (lookup 'marry person) (lookup 'Address it) (lookup 'Street it))
"123 Main Street"
> (aand (lookup 'john person) (lookup 'Address it))
((City Chicago) (Street "124 Main Street"))
> (aand (lookup 'john person) (lookup 'Job it))
"Desinger"
>
そして、マクロacond は、再帰的にマクロを呼び出しています。
(define-macro (acond)
; (acond &rest clauses)
(if (null? (args))
nil
(letex (_cl1st (args 0 0)
_clrest (cons 'begin (1 (args 0)))
_acondrest (cons 'acond (1 (args)))
_sym (gensym))
(let (_sym _cl1st)
(if _sym
(let (it _sym) _clrest)
_acondrest)))))
さらなるアナフォリックなオペレータ からは、（labels は、newlisp-utility.lsp に定義してあります）
(define-macro (alambda)
; (alambda parms &body body)
(letex (_funcbody (append '(_self) (list (args 0)) (1 (args))))
(labels (_funcbody)
_self)))
現在の newLISP では、self は 組込関数なので、変数_self とアンダースコアを付けてあります。
それを除けは、マクロlabels があるので、実装は簡単です（i- は、newlisp-utility.lsp に定義してあります） 。
> ((alambda (x) (if (= x 0) 1 (* x (_self (i- x))))) 3) 6 >
“On Lisp”本書の例count-instances を定義すると、
(defun count-instances (obj lists)
(map (alambda (lst)
(if lst
(+ (if (= (first lst) obj) 1 0)
(_self (rest lst)))
0))
lists))
そして、動作は、
> (count-instances 'a '((a b c) (d a r p a) (d a r) (a a))) (1 2 1 2)
さて、newLISPには、block も return もないので、ablock の代わりに、abegin を定義します（笑）。
(define-macro (abegin)
; (abegin &rest args)
(letex (_args (args))
((alambda (exprs)
(case (length exprs)
(0 nil)
(1 (eval (first exprs)))
(t (let (it (eval (first exprs)))
(_self (rest exprs))))))
'_args)))
ポイントは、最後の行のクォート（’）。
いかにも命令型の例（笑）を、
> [cmd]
(abegin
(println "ho ")
(println (string it 1 ))
(println (string it 2 ))
(println (string it 3 ))
nil)
[/cmd]
ho
ho 1
ho 12
ho 123
nil
>
失敗 からは、次回のお楽しみ（笑）。
以上、如何でしょうか？
UTF-8 版 newLISP.dll を Visual C++ で使う（続き）
newLISP.dll を使った CLR コンソール アプリケーション。
前回は直接起動しましたが、今回は、DOS窓（コンソール）から起動してみました。
コードページは、932 ですから、日本語コードは Shift-JIS のはず。
でも、日本語コードが UTF-8 に見えます。
コードページ 932 の DOS 窓でも UTF-8 は使え、それは、アプリケーション次第ってこと？
ちにみに、”anni.lsp” は、
(define (get-anniversary-from-wiki day)
(letn (str (get-url (string "http://ja.wikipedia.org/wiki/"
(day 0)
"%E6%9C%88"
(day 1)
"%E6%97%A5"))
str1 (replace "\n" str ""))
(when (find "記念日・年中行事</span></h2>(.*)関連項目" str1 0)
(letn (tmp $1
pos (find "<h2>" tmp)
kday (0 pos tmp)
kparse (xml-parse kday (+ 1 2 4))
res '())
(dolist (kp kparse)
(dolist (k (kp 2))
(let ((tmp "") (ddpos (ref "dd" k)))
(dolist (x (ref-all "TEXT" k))
(when (and ddpos (< ddpos x)) (push "\n " tmp -1) (setq ddpos nil))
(inc (x -1))
(push (k x) tmp -1))
(unless (null? tmp)
(push tmp res -1)))))
res))))
(define (jnow)
(now (- ((now) 9))))
(setq today-ani (get-anniversary-from-wiki (1 2 (jnow))))
(when today-ani
(dolist (x today-ani)
(if (starts-with x "\n") (print x) (silent (print (string "\n・" x)))))
(println))
こんな感じ。ただし、UTF-8 コードで保存してあります。日本語の Windows では、Shift-JIS が標準ですから、注意して下さい（笑）。
基本的には、前の blog で紹介した、“newLISPで Wikipedia を参照する．．．応用編”から、UTF-8 → Shift-JIS変換 を外したものです。
ちなみに、”anni.lsp” を UTF-8版newLISP で実行すると、
文字化けします。こちらが当然なのですが、、、
DOS 窓の不器用さを嘆くべきか？ CLR コンソール アプリケーション の器用さを讃えるべきか？
いずれにせよ、Windows の DOS窓で UTF-8 が使えるのうれしい話です。
以上、如何でしょうか？
newLISP で On Lisp する．．．第１３章（続き）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp に定義してあります。）
第１３章 コンパイル時の計算処理 の 例：Bézier曲線 です。
、そのままマクロにするのではなく、第６章 ネットワーク のコンパイルのように、Bézier曲線計算プログラムをコンパイルして関数を返すマクロにします。ついでに比較用の通常関数も用意します（笑）。
先ずは、関数版から、
(define (genbez-f x0 y0 x1 y1 x2 y2 x3 y3)
(let (_gx0 x0 _gy0 y0 _gx1 x1 _gy1 y1 _gx3 x3 _gy3 y3)
(let (cx (mul (sub _gx1 _gx0) 3)
cy (mul (sub _gy1 _gy0) 3)
px (mul (sub x2 _gx1) 3)
py (mul (sub y2 _gy1) 3))
(let (bx (sub px cx)
by (sub py cy)
ax (sub _gx3 px _gx0)
ay (sub _gy3 py _gy0))
(setf (*pts* 0 0) _gx0 (*pts* 0 1) _gy0)
(map (fn (n) (letn (u (mul n *du*)
u2 (mul u u)
u3 (pow u 3))
(setf (*pts* n 0)
(add (mul ax u3)
(mul bx u2)
(mul cx u)
_gx0)
(*pts* n 1)
(add (mul ay u3)
(mul by u2)
(mul cy u)
_gy0))))
(sequence 1 (i- *segs*)))
(setf (*pts* *segs* 0) _gx3
(*pts* *segs* 1) _gy3)))))
本書のマクロと、ほとんど一緒です。
そして、コンパイルした関数を返すマクロです。
(define-macro (make-genbez)
(letex (_vars (flat (transpose
(list '(_gx0 _gy0 _gx1 _gy1 _gx2 _gy2 _gx3 _gy3)
'(x0 y0 x1 y1 x2 y2 x3 y3))))
_body (cons 'begin
(map (fn (n) (letn (u (mul n *du*)
u2 (mul u u)
u3 (pow u 3))
(list 'setf (list '*pts* n 0)
(list 'add (list 'mul 'ax u3)
(list 'mul 'bx u2)
(list 'mul 'cx u)
'_gx0)
(list '*pts* n 1)
(list 'add (list 'mul 'ay u3)
(list 'mul 'by u2)
(list 'mul 'cy u)
'_gy0))))
(sequence 1 (i- *segs*)))))
(fn (x0 y0 x1 y1 x2 y2 x3 y3)
(let _vars
(let (cx (mul (sub _gx1 _gx0) 3)
cy (mul (sub _gy1 _gy0) 3)
px (mul (sub _gx2 _gx1) 3)
py (mul (sub _gy2 _gy1) 3))
(let (bx (sub px cx)
by (sub py cy)
ax (sub _gx3 px _gx0)
ay (sub _gy3 py _gy0))
(setf (*pts* 0 0) _gx0 (*pts* 0 1) _gy0)
_body
(setf (*pts* *segs* 0) _gx3
(*pts* *segs* 1) _gy3)))))))
戻り値の展開式はλ式になっていますので、こうやって使います。
(setq f (make-genbez))
では、計算時間を比較して見てみましょう。
> (define *segs* 20)
20
> (define *du* (div (i- 0) *segs*))
-0.05
> (define *pts* (array (i+ *segs*) 2))
((nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil)
(nil nil))
> (setq f (make-genbez))
(lambda (x0 y0 x1 y1 x2 y2 x3 y3)
(let (_gx0 x0 _gy0 y0 _gx1 x1 _gy1 y1 _gx2 x2 _gy2 y2 _gx3 x3 _gy3 y3)
(let ((cx (mul (sub _gx1 _gx0) 3)) (cy (mul (sub _gy1 _gy0) 3)) (px (mul (sub _gx2
_gx1) 3))
(py (mul (sub _gy2 _gy1) 3)))
(let ((bx (sub px cx)) (by (sub py cy)) (ax (sub _gx3 px _gx0)) (ay (sub _gy3
py _gy0)))
(setf (*pts* 0 0) _gx0 (*pts* 0 1) _gy0)
(begin
(setf (*pts* 1 0) (add (mul ax -0.000125) (mul bx 0.0025) (mul cx -0.05) _gx0)
(*pts* 1 1)
(add (mul ay -0.000125) (mul by 0.0025) (mul cy -0.05) _gy0))
(setf (*pts* 2 0) (add (mul ax -0.001) (mul bx 0.01) (mul cx -0.1) _gx0) (*pts*
2 1)
(add (mul ay -0.001) (mul by 0.01) (mul cy -0.1) _gy0))
:
（途中略）
:
(setf (*pts* 18 0) (add (mul ax -0.729) (mul bx 0.81) (mul cx -0.9) _gx0) (*pts*
18 1)
(add (mul ay -0.729) (mul by 0.81) (mul cy -0.9) _gy0))
(setf (*pts* 19 0) (add (mul ax -0.857375) (mul bx 0.9025) (mul cx -0.95) _gx0)
(*pts* 19 1)
(add (mul ay -0.857375) (mul by 0.9025) (mul cy -0.95) _gy0)))
(setf (*pts* *segs* 0) _gx3 (*pts* *segs* 1) _gy3)))))
> (time (genbez-f 0 0 1 1 2 1 3 0) 1000)
187.5
> (time (f 0 0 1 1 2 1 3 0) 1000)
62.5
>
計算時間がほぼ 1/3 になりました。コンパイルしたかいがあります（笑）。
しかし、以前は、ほぼ半分だったのですが、、、newLISP 内部も最適化されている？
さて、第１３章 コンパイル時の計算処理 のまとめです。
- newLISP には、コンパイル機能がありません。
- 従って、newLISP では、計算処理をコンパイル時にずらす手法は、そのままでは、あまり意味がありません。
- しかし、newLISP でも、計算処理をコンパイル時にずらす手法を使って展開した式を関数化すれば、計算時間を削減できます。
以上、如何でしょうか？
newLISP で On Lisp する．．．第１３章
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp に定義してあります。）
第１３章 コンパイル時の計算処理 です。といっても、newLISP には、コンパイルがありませんけどね。
まずは、新しいユーティリティ から。
平均値の例は、こうなります。（defun は、newlisp-utility.lsp に定義してあります）
(defun avg ()
; (avg &rest args)
(div (apply add (args)) (length (args))))
(define-macro (avg-m)
; (avg-m &rest args)
(letex (_sum (cons 'add (args))
_len (length (args)))
(div _sum _len)))
試すまでも無いですが、
> (avg 1 2 3 4 5 6) 3.5 > (avg-m 1 2 3 4 5 6) 3.5 > (apply avg (sequence 1 1000)) 500.5 > (apply avg-m (sequence 1 1000)) 500.5 > (time (apply avg (sequence 0 1000)) 1000) 375 > (time (apply avg-m (sequence 0 1000)) 1000) 531.25 >
当たり前ですが、マクロの方が遅くなります。
次のスクリプトは、（gensym は、newlisp-utility.lsp に定義してあります）
(defun most-of ()
; (most-of &rest args)
(let (all 0 hits 0)
(dolist (a (args))
(inc all)
(if a (i+ hits)))
(> hits (/ all 2))))
(define-macro (most-of-m)
; (most-ofm &rest args)
(let (_temp (gensym)
_need (/ (length (args)) 2)
_args (args))
(letex (_body
(cons 'or
(map (fn (_a) (list 'and _a
(list '> (list 'i+ _hits) _need)))
_args))
_hits _temp)
(let (_hits 0) _body))))
こんな感じ。
マクロでは、計算部分が全て（引数分）、letex 内で展開式を作り、_body に収めています。
これも、動作を見るまでもないですが、例によってマクロは展開式で見てみます（t は、newlisp-utility.lsp に定義してあります）。
> (most-of t nil t t)
true
> (most-of-m true nil true true)
(let (gensym1 0)
(or (and true (> (i+ gensym1) 2))
(and nil (> (i+ gensym1) 2))
(and true (> (i+ gensym1) 2))
(and true (> (i+ gensym1) 2))))
>
マクロの展開式の方は、出力されたものを見やすく整形しています。
さて、次のマクロの前に、maplist が newLISP には無いので実装します（hayashi は、newlisp-utility.lsp に定義してあります）。
(defun maplist (f)
(let ((lsts (args))(res))
(dotimes (i (apply min (map length lsts)))
(push (apply f (map (hayashi slice i) lsts)) res -1))
res))
と言っても、newlisp-utility.lsp に定義してあります。
準備が出来たところで、（car、cdr、mklist、null は、newlisp-utility.lsp に定義してあります）
(defun nthmost (n lst)
(nth n (sort (copy lst) >)))
(define-macro (nthmost-m n lst)
(if (and (integer? n) (< n 20))
(let (_syms (mklist (gensym (i+ n))))
(letex (_lst lst
_gen-start (cons 'begin (gen-start '_glst _syms))
_symsrest _syms
_nthmost-gen (nthmost-gen '_gi _syms t)
_lastsym (last _syms))
(let (_glst _lst)
(unless ())))
(defun gen-start (glst syms)
(reverse
(maplist (fn (_syms)
(let (var (gensym))
(list 'let (list var (list 'pop glst))
(nthmost-gen var (reverse _syms)))))
(reverse syms))))
(defun nthmost-gen (var vars long?)
(if (null vars)
nil
(let (else (nthmost-gen var (1 vars) long?))
(if (and (not long?) (null else))
(list 'setq (vars 0) var)
(list 'if
(list '> var (vars 0))
(append '(setq)
(mappend list (chop (reverse (copy vars)))
(1 (reverse (copy vars))))
(list (vars 0))
(list var))
else)))))
といったところ。
“On Lisp” 本書の例では、map0-n と gensym で 引数の数＋１個の変数を作り出しています。newlisp-utility.lsp に定義してある gensym は、引数の数分だけ変数を作り出す仕様です。そこが違っていますが、展開結果は、同等です。
例によってマクロは展開式で見てみましょう。
> (nthmost 0 '(2 1 3))
3
> (nthmost 1 '(2 1 3))
2
> (nthmost 2 '(2 1 3))
1
> (nthmost-m 0 '(2 1 3))
(let (_glst '(2 1 3))
(unless ( _gi gensym2)
(setq gensym2 _gi) nil))) gensym2)
> (nthmost-m 1 '(2 1 3))
(let (_glst '(2 1 3))
(unless ( gensym8 gensym6)
(setq gensym7 gensym6 gensym6 gensym8)
(setq gensym7 gensym8))))
(dolist (_gi _glst)
(if (> _gi gensym6)
(setq gensym7 gensym6 gensym6 _gi)
(if (> _gi gensym7)
(setq gensym7 _gi) nil)))) gensym7)
> (nthmost-m 2 '(2 1 3))
(let (_glst '(2 1 3))
(unless ( gensym17 gensym13)
(setq gensym14 gensym13 gensym13 gensym17)
(setq gensym14 gensym17)))
(let (gensym16 (pop _glst))
(if (> gensym16 gensym13)
(setq gensym15 gensym14 gensym14 gensym13 gensym13 gensym16)
(if (> gensym16 gensym14)
(setq gensym15 gensym14 gensym14 gensym16)
(setq gensym15 gensym16)))))
(dolist (_gi _glst)
(if (> _gi gensym13)
(setq gensym15 gensym14 gensym14 gensym13 gensym13 _gi)
(if (> _gi gensym14)
(setq gensym15 gensym14 gensym14 _gi)
(if (> _gi gensym15)
(setq gensym15 _gi) nil))))) gensym15)
>
ここまでは、newLISP に、コンパイル機能が無いので、あまり意味がありません。
そこで、例：Bézier曲線 では、そのままマクロにするのではなく、第６章 ネットワークのコンパイル のように、Bézier曲線計算プログラムをコンパイルして関数を返すマクロにします、、、次回に（笑）。
以上、如何でしょうか？
newLISP で On Lisp する．．．第１２章（その２の続き）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp と onnewlisp.lsp に定義してあります。）
第１２章 汎変数 の最後、インバージョンを定義する です。
ここに出てくる defsetf も newLISP には、ありません。もちろん、setf の機能が変わることもありません。これで終わりにしても良かったのですが、その２ で示したようにマクロ sortf もできることがわかったし、やるだけやってみようということで、お付き合い下さい。
先ずは、defsef 改め、マクロdefsetf-i から、
(define *inversion-flag* nil)
(define-macro (defsetf-i fname vars)
(letex (_fname fname
_vars (append vars (args 0))
_addf (list 'if '*inversion-flag* (args 1) (nth 1 (eval fname))))
(setf (nth 0 _fname) '_vars)
(setf (nth 1 _fname) '_addf)))
追加のマクロを関数に直接埋め込みます。それを取り出すためのフラグも用意します。 gensym の生成は入れていません。
そして、defsetf-i で定義した部分を呼び出す setf 改め、マクロ setf-i です。
(define-macro (setf-i)
(setq *inversion-flag* true)
(letex (_body (eval (append (args 0) (mklist (args 1)))))
(begin
(setq *inversion-flag* nil)
'_body)))
フラグ *inversion-flag* を true に切り替えて、defsetf-iで定義したマクロを取り出します。もちろん、フラグ *inversion-flag* は nil に戻しておきます。
さて動作です。関数retrieve を用意します（defun は newlisp-utility.lsp に、values は onnewlisp.lsp に定義してあります）。
(defun retrieve (key)
(let (x (*cache* (string key)))
(if x (values x true)
(lookup key *world*)))) ; or (rest (assoc key *world*)))))
毎度おなじみ、hash の代わりに context を使っています。newLISP組込lookup は、assoc がリストを返すのに対し、そのリストの cdr部（newLISP では、rest）を返します。多値にも対応しておきます。
> (new Tree '*cache*) *cache* > (setq *world* '((a 2) (b 16) (c 50) (d 20) (f 12))) ((a 2) (b 16) (c 50) (d 20) (f 12)) > (retrieve 'c) 50 > (retrieve 'n) nil > (setf (retrieve 'n) 77) 77 > (retrieve 'n) nil >
ここで、マクロdefsetf-i の出番です。
(defsetf-i retrieve (key) (val)
(letex (_x (string key) _y val)
(unless (*cache* _x) (*cache* _x 0)) (setf (*cache* _x) _y)))
本体の記述は、マクロのそれです。
そして、マクロsetf-i の動作です（multiple-value-list と multiple-value-bind は onnewlisp.lsp に定義してあります）。
> (retrieve 'n)
nil
> (setf (retrieve 'n) 77)
77
> (retrieve 'n)
nil
> (setf-i (retrieve 'n) 77)
77
> (retrieve 'n)
77
> (multiple-value-list (retrieve 'n))
(77 true)
> (multiple-value-list (retrieve 'c))
(50)
> (*cache*)
(("n" 77))
> *world*
((a 2) (b 16) (c 50) (d 20) (f 12))
> (multiple-value-bind (v b) (retrieve 'n) (list v b))
(77 true)
> (multiple-value-bind (v b) (retrieve 'c) (list v b))
(50 nil)
> (*cache*)
(("n" 78))
>
といった具合です。
ようやく、第１２章 汎変数 のまとめです。
- newLISP でも、適切なインバージョンを定義することは可能です。
- newLISP では、macro.lsp を使えば、参照を返すことが可能です。
以上、如何でしょうか？
newlisp-utility.lsp と onnewlisp.lsp
既にお気付きと思いますが、本 blog で度々使っている defun や labels 等が定義されている newlisp-utility.lsp を About と同じように、この Web サイトのページにしました。最上部のタブをクリックすれば開きます。以前の場所にも、置いてありますが、以降は、こちらをお使い下さい。
また、“On newLISP” でよく使う関数やマクロで newlisp-utility.lsp に無いものは、 同様にページ化した onnewlisp.lsp の方に追加していきます。
あわせてお使い下さい。
以上、ご報告まで。
newLISP で On Lisp する．．．第１２章（その２）
（この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp に定義してあります。）
第１２章 汎変数 の 更に複雑なユーティリティ から。
Common Lisp のマクロ incf は、newLISP では、 組込 ++ (または、浮動小数点用の inc）になります。
> (++ 1) 2 > (setq x 1) 1 > (++ x) 2 > x 2 > (setq x '(1 2)) (1 2) > (++ (x 1) 2) 4 > x (1 4) >
先頭の例のように、Common Lisp の incf と違って、即値にも対応しています。
さて、setf の上に作る更に複雑なマクロ は、次のようになります。
(define-macro (_f op)
; (_f op place &rest args)
(letex (_place (args 0)
_args (append (list op) '($it) (1 (args))))
(setf _place _args)))
(define-macro (pull)
; (pull obj place)
(letex (_x (gensym)
_place (args 1)
_obj (args 0))
(setf _place (let (_x $it) (replace _obj _x)))))
(define-macro (pull-if)
; (pull test place)
(letex (_x (gensym)
_place (args 1)
_test (args 0))
(setf _place (let (_x $it) (find-all nil _x $it (fn (x y) (not (_test y))))))))
(define-macro (popn)
; (popn n place &rest args)
(letex (_x (gensym)
_place (args 1)
_n (args 0))
(let (_y)
(setf _place (let (_x $it)
(setq _y (0 _n _x))
(if (< _n (length _x))
(_n _x) '())))
_y)))
マクロ_f は、“On Lisp” 本書にある誤り例の ,place を $it に置き換えたものです。第１２章（その１）で見たように、newLISP では、これで十分なはずです。
マクロpull の動作は、
> (let (x '(1 2 (a b) 3)) (println (pull 2 x)) x) (1 (a b) 3) (1 (a b) 3) > (let (x '(1 2 (a b) 3)) (println (pull '(a b) x)) x) (1 2 3) (1 2 3) >
そして、マクロpull-if は、
> (let (x '(0 1 2 3 4 5)) (println (pull-if oddp x)) x) (0 2 4) (0 2 4) > (let (x '(0 1 2 3 4 5)) (println (pull-if (curry = 2) x)) x) (0 1 3 4 5) (0 1 3 4 5) >
さらに、マクロpopn の動作は、
> (let (x '(a b c d e f g)) (println (popn 3 x)) x) (a b c) (d e f g) >
となります。全て、$it を使って、適切なインバージョンになっているはず。
さてと、 更に複雑なユーティリティ 最大の難関、マクロ sortf です。
(defun add-c-1st (lst)
(labels ((add/c (x) (if (symbol? x) (letex (_x x) ''_x) x)))
(if (atom? lst) (add/c lst)
(begin (setf (first lst) (add/c $it)) lst))))
(define-macro (sortf op)
(letn (_vars (map (fn (x) (if (list? x) ((curry map eval) x) (eval x))) (map add-c-1st (args)))
_vals (sort (map eval (map eval _vars)) op))
(letex (_body (cons 'setf (apply append (transpose (list _vars _vals)))))
'_body)))
予め断っておきますが、現段階で、適切なインバージョンが行われるのは、インデックス機能だけです。マクロがこれだけで済んでいるのは、ソートを組込sort に任せているからです。
> (setq x 1 y 2 z 3) 3 > (sortf > x y z) 1 > (list x y z) (3 2 1) > (setq i 0 x 2 ar '(2 1 2) lst '(3 1 1)) (3 1 1) > (sortf > x (ar (inc i)) (lst (dec i))) 1 > x 3 > ar (2 2 2) > lst (1 1 1) >
あと、nth や first 等のインバージョンを追加すればいいのですが、ここは、出来るということを示せればいいかな、ということで（汗）。さらりと書いていますが、newLISP でここまで出来るとは思ってみませんでした。newLISP には、get-setf-method なんてありませんからね。
最後の例を、例によって、展開式で見てみると、
> (setq i 0 x 2 ar '(2 1 2) lst '(3 1 1)) (3 1 1) > (sortf > x (ar (++ i)) (lst (-- i))) (setf x 3 (ar 1) 2 (lst 0) 1) > (sortf
となります。
長くなってきたので、インバージョンを定義する は、次回に。
以上、如何でしょうか？
newLISP で On Lisp する．．．第１２章（その１の続き）
Filed under: On newLISP | タグ: allf, conc1f, concf, concnew, nilf, tf, toggles
コメントを残す （この blog は、“short short story または 晴耕雨読な日々”からの引越してきたもの。スクリプトは、newLISP V10.2.1 以降で動作するように書き直しています。
defun 等の newLISP組込関数に無い関数は、特に断らない限り、newlisp-utility.lsp に定義してあります。）
さて、第１２章 汎変数 は、番外編を挟んで その１ の続きです（笑）。
新しい ユーティリティ のインバージョンも、define-modify-macro のない newLISP では、自前で展開します（笑）。
先ずは、汎変数に対して機能するマクロ から、（mappend は、newlisp-utility.lsp で定義してあります。）
(define-macro (allf)
; (allf val &rest args)
(let (_val (args 0))
(letex (_body (cons 'setf (mappend (fn (a) (list a _val)) (1 (args)))))
_body)))
(define-macro (nilf)
; (nif (&rest args))
(letex (_body (flat (list 'allf 'nil (args))))
_body))
(define-macro (tf)
; (tf (&rest args))
(letex (_body (flat (list 'allf 'true (args))))
_body))
(define-macro (toggles)
; (toggles &rest args)
(letex (_toggles (cons 'begin (map (fn (a) (list 'toggle a)) (args))))
_toggles))
“On Lisp”本書のマクロtoggle は、toggles と名前を変え、その１ で定義した
(define-macro (toggle)
(letex (_obj (args 0))
(setf _obj (not $it))))
を内部で使っています。
動作は、
> (list a b c) (nil nil nil) > (allf 1 a b c) 1 > (list a b c) (1 1 1) > (nilf a b c) nil > (list a b c) (nil nil nil) > (tf a b c) true > (list a b c) (true true true) > (toggle b) nil > (list a b c) (true nil true) > (toggles a b c) nil > (list a b c) (nil true nil) >
こんな感じ。
そして、 汎変数に対するリスト操作 は、
(define-macro (concf)
(letex (_place (args 0)
_obj (args 1))
(setf _place (append $it _obj))))
(define-macro (conc1f)
(letex (_place (args 0)
_obj (args 1))
(push _obj _place -1) ; or (setf _place (append $it (list _obj)))
))
(define-macro (concnew)
(letex (_place (args 0)
_obj (args 1))
(unless (find _obj _place)
(push _obj _place -1) ; or (setf _place (append $it (list _obj)))
)))
となります。
conc1f と concnew には、newLISP組込push を使っています。setf を使ったバージョンは、コメントにしてあります。お好みで、どうぞ。push の引数の最後の -1 は、push 先をリストの末尾に指定するインデックス機能です。これが使えるので、Common Lisp のように push して最後に reverse することは、newLISP ではしなくて済みます。しかも、先頭に付加するのと同じくらいの速さに最適化してある優れものです。もちろん、対の pop にもインデックス機能が使えます。
動作は、
> (setq lst '(a (b 1) c)) (a (b 1) c) > (concf lst '(2)) (a (b 1) c 2) > (concf (lst 1) '(2)) (b 1 2) > lst (a (b 1 2) c 2) > (conc1f lst 3) (a (b 1 2) c 2 3) > (conc1f (lst 1) 3) (b 1 2 3) > lst (a (b 1 2 3) c 2 3) > (concnew lst 2) 3 > lst (a (b 1 2 3) c 2 3) > (concnew lst 4) (a (b 1 2 3) c 2 3 4) > (concnew (lst 1) 3) 3 > lst (a (b 1 2 3) c 2 3 4) > (concnew (lst 1) 4) (b 1 2 3 4) > lst (a (b 1 2 3 4) c 2 3 4) >
こんな感じ。
さて、newLISP の宣伝（push と pop）をしたところで、新たなる問題点です。
concnew では、オブジェクトの有無を検索するために、変数_place が push （または setf）動作の前に評価されています。つまり、複数回の評価に関わる問題 が発生するということ。
> (setq lst '(a (b 1) (c 2))) (a (b 1) (c 2)) > (let (i 0) (concnew (nth (++ i) lst) 2)) (c 2 2) > lst (a (b 1) (c 2 2)) >
concnew 以外は、$it の使用で評価を一回で済ませていましたが、こればっかりは、お手上げ？
もちろん、そのなことはありません。
(define-macro (concnew)
(letex (_place (args 0)
_obj (args 1))
(setf _place (let (_x $it)
(if (find _obj _x) _x
(append _x (list _obj)))))))
と、定義すれば、
> (setq lst '(a (b 1) (c 2))) (a (b 1) (c 2)) > (let (i 0) (concnew (nth (++ i) lst) 2)) (b 1 2) > lst (a (b 1 2) (c 2)) > (let (i 0) (concnew (nth (++ i) lst) 2)) (b 1 2) > lst (a (b 1 2) (c 2)) >
このように、複数回の評価に関わる問題 を回避できます。
$it を let 文で変数 _x に割り当てているのは、評価に使う関数で $it を変更する関数が使われることを考えての記述です。今回のマクロでは、_x を $it で置き換えても動作します。
さて、define-modify-macro がある Common Lisp の方が、この点では、一日の長があります。
今回の勝負、どちらも一長一短で引き分け？（笑）
更に複雑なユーティリティ は、次回に。
以上、如何でしょうか？
新リスプな日々 