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  

　となります。
　長くなってきたので、インバージョンを定義する は、次回に。

　以上、如何でしょうか？