Hatena::Grouplisp

drybulbのLisp日記 RSSフィード

2007-08-18

[]12.5 10:18 はてなブックマーク - 12.5 - drybulbのLisp日記


(defsetf symbol-value set)

(defsetf car (lst) (new-car)
  `(progn (rplaca ,lst ,new-car)
	  ,new-car))

;; 
(mac (setf (car x) y))
(LET* ((#:G2251 X))
  (MULTIPLE-VALUE-BIND
      (#:G2252)
      Y
    (PROGN (RPLACA #:G2251 #:G2252) #:G2252)))




(defvar *cache* (make-hash-table))

(defun retrieve (key)
  (multiple-value-bind (x y) (gethash key *cache*)
    (if y
	(values x y)
	(cdr (assoc key *world*)))))

(defsetf retrieve (key) (val)
  `(setf (gethash ,key *cache*) ,val))

(setq *world* '((a . 2) (b . 16) (c . 50) (d . 20) (f . 12)))
(retrieve 'c)
;;=> 50 (#x32, #o62, #b110010)

(setf (retrieve 'n) 77)
;;=> 77 (#x4D, #o115, #b1001101)
(retrieve 'n)
;;=> 77, T

*world*
;;=> ((A . 2) (B . 16) (C . 50) (D . 20) (F . 12))

[]13.1 新しいユーティリティ 10:18 はてなブックマーク - 13.1 新しいユーティリティ - drybulbのLisp日記

(defun avg (&rest args)
  (/ (apply #'+ args) (length args)))

(defmacro avg (&rest args)
  `(/ (+ ,@args) ,(length args)))


;; 可半数が真なら真を返す
(defun most-of (&rest args)
  (let ((all 0)
	(hists 0))
    (dolist (a args)
      (incf all)
      (if a (incf hits)))
    (> hits (/ all 2))))

(defmacro most-of (&rest args)
  (let ((need (floor (/ (length args) 2)))
	(hits (gensym)))
    `(let ((,hits 0))
       (or ,@(mapcar #'(lambda (a)
			 `(and ,a (> (incf ,hits) ,need)))
		     args)))))

(most-of t t t t t nil nil t)
;=> T

;; 展開すると
(mac (most-of (a) (b) (c)))
;=>
;(LET ((#:G1744 0))
;  (OR (AND (A) (> (INCF #:G1744) 1))
;      (AND (B) (> (INCF #:G1744) 1))
;      (AND (C) (> (INCF #:G1744) 1))))

(mac (most-of nil t t))
;=>
;(LET ((#:G1752 0))
;  (OR (AND NIL (> (INCF #:G1752) 1))
;      (AND T (> (INCF #:G1752) 1))
;      (AND T (> (INCF #:G1752) 1))))


;; コンパイル時に分っている引数の利用
(defun nthmost (n lst)
  (nth n (sort (copy-list lst) #'>)))

(defmacro nthmost (n lst)
  (if (and (intergerp n) (< n 20))
      (with-gensyms (glst gi)
	(let ((syms (map0-n #'(lambda (x) (gensym)) n)))
	  `(let ((,glst ,lst))
	     (unless (< (length ,glst) ,(1+ n))
	       ,@(gen-start glst syms)
	       (dolist (,gi ,glst)
		 ,(nthmost-gen gi syms t))
	       ,(car (last syms))))))
      `(nth ,n (sort (copy-list ,lst) #'>))))

(defun gen-start (glst syms)
  (reverse
   (maplist #'(lambda (syms)
		(let ((var (gensym)))
		  `(let ((,var (pop ,glst)))
		     ,(nthmost-gen var (reverse syms)))))
	    (reverse syms))))

(defun nthmost-gen (var vars &optional long?)
  (if (null vars)
      nil
      (let ((else (nthmost-gen var (cdr vars) long?)))
	(if (and (not long?) (null else))
	    `(setq ,(car vars) ,var)
	    `(if (> ,var ,(car vars))
		 (setq ,@(mapcan #'list
				 (reverse vars)
				 (cdr (reverse vars)))
		       ,(car vars) ,var)
		 ,else)))))

(nthmost 2 '(2 7 2 1 3 9))
;;=> 3 (#x3, #o3, #b11)

[]14.1 アナフォリックな変種オペレータ 10:18 はてなブックマーク - 14.1 アナフォリックな変種オペレータ - drybulbのLisp日記

(defmacro aif (test-form then-form &optional else-form)
  `(let ((it ,test-form))
     (if it ,then-form ,else-form)))

(defmacro awhen (test-form &body body)
  `(aif ,test-form
	(progn ,@body)))

(defmacro awhile (expr &body body)
  `(do ((it ,expr ,expr))
       ((not it))
     ,@body))

(defmacro aand (&rest args)
  (cond ((null args) t)
	((null (cdr args)) (car args))
	(t `(aif ,(car args) (aand ,@(cdr args))))))

(defmacro acond (&rest clauses)
  (if (null clauses)
      nil
      (let ((cl1 (car clauses))
	    (sym (gensym)))
	`(let ((,sym ,(car cl1)))
	   (if ,sym
	       (let ((it ,sym)) ,@(cdr cl1))
	       (acond ,@(cdr clauses)))))))

;; さらなるアナフォリックなオペレータ
(defmacro alambda (parms &body body)
  `(labels ((self ,parms ,@body))
     #'self))

(defmacro ablock (tag &rest args)
  `(block ,tag
     ,(funcall (alambda (args)
		 (case (length args)
		   (0 nil)
		   (1 (car args))
		   (t `(let ((it ,(car args)))
			 ,(self (cdr args))))))
	       args)))


;; 無名再帰関数を書きたいときとはいつ?
(defun count-instances (obj lists)
  (labels ((instances-in (list)
	     (if list
		 (+ (if (eq (car list) obj) 1 0)
		    (instances-in (cdr list)))
		 0)))
    (mapcar #'instances-in lists)))

(count-instances 'a '((a b c) (d a r p a) (d a r) (a a)))
;;=> (1 2 1 2)


;; 無名再帰関数で階乗関数を表現
(alambda (x) (if (= x 0) 1 (* x (self (1- x)))))

;; alambda を使って count-instances と等価な関数
(defun count-instances (obj lists)
  (mapcar (alambda (list)
	    (if list
		(+ (if (eq (car list) obj) 1 0)
		   (self (cdr list)))
		0))
	  lists))

(count-instances 'a '((a b c) (d a r p a) (d a r) (a a)))
;;=> (1 2 1 2)

(setf edible (make-hash-table)
      (gethash 'olive-oil edible) t
      (gethash 'motor-oil edible) nil)
;;=> NIL
(gethash 'motor-oil edible)
;;=> NIL, T

(defun edible? (x)
  (multiple-value-bind (val found?) (gethash x edible)
    (if found?
	(if val 'yes 'no)
	'maybe)))

(mapcar #'edible? '(motor-oil olive-oil iguana))
;;=> (NO YES MAYBE)

;;多値を返すアナフォリックマクロ
(defmacro aif2 (test &optional then else)
  (let ((win (gensym)))
    `(multiple-value-bind (it ,win) ,test
       (if (or it ,win) ,then ,else))))

(defmacro awhen2 (test &body body)
  `(aif2 ,test
	 (progn ,@body)))

(defmacro awhile2 (test &body body)
  (let ((flag (gensym)))
    `(let ((,flag t))
       (while ,flag
	 (aif2 ,test
	       (progn ,@body)
	       (setq ,flag nil))))))

(defmacro acond2 (&rest clauses)
  (if (null clauses)
      nil
      (let ((cl1 (car clauses))
	    (val (gensym))
	    (win (gensym)))
	`(multiple-value-bind (,val ,win) ,(car cl1)
	   (if (or ,val ,win)
	       (let ((it ,val)) ,@(cdr cl1))
	       (acond2 ,@(cdr clauses)))))))


;; edible? を aif2 を使って表現
(defun edible? (x)
  (aif2 (gethash x edible)
	(if it 'yes 'no)
	'maybe))

(mapcar #'edible? '(motor-oil olive-oil iguana))
;;=> (NO YES MAYBE)

[]15.1 関数の構築 10:18 はてなブックマーク - 15.1 関数の構築 - drybulbのLisp日記

;; 汎用の関数生成マクロ
(defmacro fn (expr) `#',(rbuild expr))

(defun rbuild (expr)
  (if (or (atom expr) (eq (car expr) 'lambda))
      expr
      (if (eq (car expr) 'compose)
	  (build-compose (cdr expr))
	  (build-call (car expr) (cdr expr)))))

(defun build-call (op fns)
  (let ((g (gensym)))
    `(lambda (,g)
       (,op ,@(mapcar #'(lambda (f)
			  `(,(rbuild f) ,g))
		      fns)))))

(defun build-compose (fns)
  (let ((g (gensym)))
    `(lambda (,g)
       ,(labels ((rec (fns)
		      (if fns
			  `(,(rbuild (car fns))
			     ,(rec (cdr fns)))
			  g)))
		(rec fns)))))

;; 5.4
(funcall (compose #'list #'1+) 2)
;;=> (3)

(mac (fn (and integerp oddp)))
;; 等価
#'(lambda (x) (and (integerp x) (oddp x)))

;; 展開してみると
#'(LAMBDA (#:G1775) (AND (INTEGERP #:G1775) (ODDP #:G1775)))


(fn (compose list 1+ truncate))
;; 展開してみると
#'(LAMBDA (#:G1776) (LIST (1+ (TRUNCATE #:G1776))))

(fn (compose (lambda (x) (+ x 3)) trucate))
;; 展開してみると
#'(LAMBDA (#:G1790) ((LAMBDA (X) (+ X 3)) (TRUCATE #:G1790)))


;; 5.4 fif, fint, fun
(mapcar (fn (and integerp oddp)) ; fint相当
	'(c 3 p 0))
;;=> (NIL T NIL NIL)

(mapcar (fn (or integerp symbolp)) ; fun相当
	'(c 3 p 0-2))
;;=> (T T T T)

(map1-n (fn (if oddp 1+ identity)) 6) ; fif相当
;;=> (2 2 4 4 6 6)

(mapcar (fn (list 1- identity 1+))
	'(1 2 3))
;;=> ((0 1 2) (1 2 3) (2 3 4))

(remove-if (fn (or (and integerp oddp)
		   (and consp cdr)))
	   '(1 (a b) c (d) 2 3-4 (e f g)))
;;=> (C (D) 2 |3-4|)

[]15.2 Cdr部での再帰 10:18 はてなブックマーク - 15.2 Cdr部での再帰 - drybulbのLisp日記

;; リストでの再帰用マクロ
(defmacro alrec (rec &optional base)
  "cltl2 version"
  (let ((gfn (gensym)))
    `(lrec #'(lambda (it ,gfn)
	       (symbol-macrolet ((rec (funcall ,gfn)))
		 ,rec))
	   ,base)))

(defmacro alrec (rec &optional base)
  "cltl1 version"
  (let ((gfn (gensym)))
    `(lrec #'(lambda (it ,gfn)
	       (labels ((rec () (funcall ,gfn)))
		 ,rec))
	   ,base)))

(defmacro on-cdrs (rec base &rest lsts)
  `(funcall (alrec ,rec #'(lambda () ,base)) ,@lsts))

;; 5.5節 our-every を
(defun our-every (fn lst)
  (if (null lst)
      t
      (and (funcall fn (car lst))
	   (our-every fn (cdr lst)))))

(lrec #'(lambda (x f) (and (oddp x) (funcall f)))
      t)

(alrec (and (oddp it) rec) t)

(funcall (alrec (and (oddp it) rec) t)
	 '(1 3 5))
;;=> T

(sef (symbol-function 'our-length)
     (alrec (1+ rec) 0))

(defun our-length (lst)
  (on-cdrs (1+ rec) 0 lst))

;; 以下 on-cdrs を使用して定義する
(defun our-every (fn lst)
  (on-cdrs (and (funcall fn it) rec) t lst))

(our-every #'oddp '(3 3 5 9))
;;=> T

(defun our-copy-list (lst)
  (on-cdrs (cons it rec) nil lst))

(defun our-remove-duplicates (lst)
  (on-cdrs (adjoin it rec) nil lst))

(defun our-find-if (fn lst)
  (on-cdrs (if (funcall fn it) it rec) nil lst))

(defun our-some (fn lst)
  (on-cdrs (or (funcall fn it) rec) nil lst))

;; on-cdrs を使用して定義された新ユーティリティ
(defun unions (&rest sets)
  (on-cdrs (union it rec) (car sets) (cdr sets)))

(defun itersections (&rest sets)
  (unless (some #'null sets)
    (on-cdrs (intersection it rec) (car sets) (cdr sets))))

(defun differences (set &rest outs)
  (on-cdrs (set-difference rec it) set outs))

(defun maxmin (args)
  (when args
    (on-cdrs (multiple-value-bind (mx mn) rec
	       (values (max mx it) (min mn it)))
	     (values (car args) (car args))
	     (cdr args))))

;;; 和集合
(union '(a b) (union '(b c) '(c d)))
;;=> (A B C D)
;; ↓
(unions '(a b) '(b c) '(c d))
;;=> (D C A B)

;;; 積集合
(set-difference '(a b c d) '(a b))
;;=> (D C)

(differences '(a b c d e) '(a f) '(d))
;;=> (B C E)

;;; 最大と最小を返す関数
(maxmin '(3 4 12 8 5 1 7 6))
;;=> 12, 1

;;p.318に出てくる complie-cmds
(defun compile-cmds (cmds)
  (if (null cmds)
      'regs
      `(,@(car cmds) ,(compile-cmds (cdr cmds)))))
;; ↓
(defun compile-cmds (cmds)
  (on-cdrs `(,@it ,rec) 'regs cmds))

[]15.3 部分ツリーでの再帰 10:18 はてなブックマーク - 15.3 部分ツリーでの再帰 - drybulbのLisp日記

;; ツリーに対する再帰のためのマクロ
(defmacro atrec (rec &optional (base 'it))
  "ctlt2 version"
  (let ((lfn (gensym)) (rfn (gensym)))
    `(trec #'(lambda (it ,lfn ,rfn)
	       (symbol-macrolet ((left (funcall ,lfn))
				 (right (funcall ,rfn)))
		 ,rec))
	   #'(lambda (it) ,base))))

(defmacro on-trees (rec base &rest trees)
  `(funcall (atrec ,rec ,base) ,@trees))

;; 5.6節の関数を書き直す
(defun our-copy-tree (tree)
  (on-trees (cons left right) it tree))

(defun count-leaves (tree)
  (on-trees (+ left (or right 1)) 1 tree))

(defun flatten (tree)
  (on-trees (nconc left right) (mklist it) tree))

(defun rfind-if (fn tree)
  (on-trees (or left right)
	    (and (funcall fn it) it)
	    tree))

[]15.4 遅延評価 10:18 はてなブックマーク - 15.4 遅延評価 - drybulbのLisp日記

;; Schemeのfource, delay

(defconstant unforced (gensym))

(defstruct delay forced closure)

(defmacro delay (expr)
  (let ((self (gensym)))
    `(let ((,self (make-delay :forced unforced)))
       (setf (delay-closure ,self)
	     #'(lambda ()
		 (setf (delay-forced ,self) ,expr)))
       ,self)))

(defun force (x)
  (if (delay-p x)
      (if (eq (delay-forced x) unforced)
	  (funcall (delay-closure x))
	  (delay-forced x))
      x))

(let ((x 2))
  (setq d (delay (1+ x))))
;;=> #S(DELAY :FORCED #:G1859 :CLOSURE #<CLOSURE (LAMBDA #) {AE2A10D}>)
(force 'a)
;;=> A
(force d)
;;=> 3 (#x3, #o3, #b11)

[]16.1 省略 10:18 はてなブックマーク - 16.1 省略 - drybulbのLisp日記

(defmacro abbrev (short long)
  `(defmacro ,short (&rest args)
     `(,',long ,@args)))

(defmacro abbrevs (&rest names)
  `(progn
     ,@(mapcar #'(lambda (pair)
		   `(abbrev ,@pair))
	       (group names 2))))

(defmacro dbind (&rest args)
  `(destructuring-bind ,@args))

(defmacro mvbind (&rest args)
  `(multiple-value-bind ,@args))
;; ↓
(abbrev mvbind multiple-value-bind)

(abbrevs dbind destructuring-bind
	 mvbind multiple-value-bind
	 mvsetq multiple-value-setq)

[]16.2 属性 10:18 はてなブックマーク - 16.2 属性 - drybulbのLisp日記

(setf (get 'ball1 'color) 'red)
(defmacro color (obj)
  `(get ,obj 'color))

(color 'ball1)
;;=> RED

(setf (color 'ball1) 'green)
;;=> GREEN

;; アクセス用マクロの自動定義
(defmacro propmacro (propname)
  `(defmacro ,propname (obj)
     `(get ,obj ',',propname)))

(defmacro propmacros (&rest props)
  `(progn
     ,@(mapcar #'(lambda (p) `(propmacro ,p))
	       props)))

(propmacro color)
(color 'ball1)
;;=> GREEN

[]16.3 アナフォリックマクロ 10:18 はてなブックマーク - 16.3 アナフォリックマクロ - drybulbのLisp日記

;; a+ と alist の定義
(defmacro a+ (&rest args)
  (a+expand args nil))

(defun a+expand (args syms)
  (if args
      (let ((sym (gensym)))
	`(let* ((,sym ,(car args))
		(it ,sym))
	   ,(a+expand (cdr args)
		      (append syms (list sym)))))
      `(+ ,@syms)))

(defmacro alist (&rest args)
  (alist-expand args nil))

(defun alist-expand (args syms)
  (if args
      (let ((sym (gensym)))
	`(let* ((,sym ,(car args))
		(it ,sym))
	   ,(alist-expand (cdr args)
			  (append syms (list sym)))))
      `(list ,@syms)))


;; a+
(defun mass-cost (menu-price)
  (a+ menu-price (* it .05) (* it 3)))

(mass-cost 7.95)
;;=> 9.54

;; 展開すると
(mac (a+ menu-price (* it .05) (* it 3)))
;(LET* ((#:G1821 MENU-PRICE) (IT #:G1821))
;  (LET* ((#:G1822 (* IT 0.05)) (IT #:G1822))
;    (LET* ((#:G1823 (* IT 3)) (IT #:G1823))
;      (+ #:G1821 #:G1822 #:G1823))))


(alist 1 (+ 2 it) (+ 2 it))
;;=> (1 3 5)


;; アナフォリックマクロの自動生成
(defmacro defanaph (name &optional calls)
  (let ((calls (or calls (pop-symbol name))))
    `(defmacro ,name (&rest args)
       (anaphex args (list ',calls)))))

(defun anaphex (args expr)
  (if args
      (let ((sym (gensym)))
	`(let* ((,sym ,(car args))
		(it ,sym))
	   ,(anaphex (cdr args)
		     (append expr (list sym)))))
      expr))

(defun pop-symbol (sym)
  (intern (subseq (symbol-name sym) 1)))


(defanaph a+)
(defanaph alist)


;; さらに一般的な defanaph
(defmacro defanaph (name &key calls (rule :all))
  (let* ((opname (or calls (pop-symbol name)))
	 (body (case rule
		 (:all   `(anaphex1 args '(,opname)))
		 (:first `(anaphex2 ',opname args))
		 (:place `(anaphex3 ',opname args)))))
    `(defmacro ,name (&rest args)
       ,body)))

(defun anaphex1 (args call)
  (if args
      (let ((sym (gensym)))
	`(let* ((,sym ,(car args))
		(it ,sym))
	   ,(anaphex1 (cdr args)
		      (append call (list sym)))))
      call))

(defun anaphex2 (op args)
  `(let ((it ,(car args))) (,op it ,@(cdr args))))

(defun anaphex3 (op args)
  `(_f (lambda (it) (,op it ,@(cdr args))) ,(car args)))

;; asetf
(defmacro asetf (&rest args)
  (anaphex3 '(lambda (x y) y) args))


(defanaph alist)
(defanaph aif :rule :first)
(defanaph asetf :rule :place)

;; incf
(defmacro our-incf (place &optional (val 1))
  `(asetf ,place (+ it ,val)))

;; pull
(defmacro our-pull (obj place &rest args)
  `(asetf ,place (delete ,obj it ,@args)))

[]17.2 マクロ文字のディスパチン10:18 はてなブックマーク - 17.2 マクロ文字のディスパッチング - drybulbのLisp日記

(set-dispatch-macro-character #\# #\?
			      #'(lambda (stream char1 char2)
				  `#'(lambda (&rest ,(gensym))
				       ,(read stream t nil t))))

(mapcar #?2 '(a b c))
;;=> (2 2 2)
(mapcar #?4 '(a b c))
;;=> (4 4 4)

(eq (funcall #?'a) 'a)
;;=> T
(eq (funcall #?#'oddp) (symbol-function 'oddp))
;;=> T

[]17.3 デリミタ 10:18 はてなブックマーク - 17.3 デリミタ - drybulbのLisp日記

(set-macro-character #\] (get-macro-character #\)))

(set-dispatch-macro-character #\# #\[
   #'(lambda (stream char1 char2)
       (let ((accum nil)
	     (pair (read-delimited-list #\] stream t)))
	 (do ((i (ceiling (car pair)) (1+ i)))
	     ((> i (floor (cadr pair)))
	      (list 'quote (nreverse accum)))
	   (push i accum)))))

#[1 7]
;;=>(1 2 3 4 5 6 7)

;; 抽象化されたインターフェースを備えたデリミタリードマクロ
(defmacro defdelim (left right parms &body body)
  `(ddfn ,left ,right #'(lambda ,parms ,@body)))

(let ((rpar (get-macro-character #\) )))
  (defun ddfn (left right fn)
    (set-macro-character right rpar)
    (set-dispatch-macro-character #\# left
      #'(lambda (stream char1 char2)
	  (apply fn
		 (read-delimited-list right stream t))))))

;; p.55
(defun mapa-b (fn a b &optional (step 1))
  (do ((i a (+ i step))
       (result nil))
      ((> i b) (nreverse result))
    (push (funcall fn i) result)))

(defdelim #\[ #\] (x y)
  (list 'quote (mapa-b #'identity (ceiling x) (floor y))))

;; 関数合成用
(let ((f1 (compose #'list #'1+))
      (f2 #'(lambda (x) (list (1+ x)))))
  (equal (funcall f1 7) (funcall f2 7)))


;; 関数合成用リードマクロ
;; #{f1 f2 ... fn} は f1, f2, ..., fn を合成したものとして
;; 読み込まれる
(defdelim #\{ #\} (&rest args)
  `(fn (compose ,@args)))

(funcall #{list 1+} 7)
;(funcall (compose #'list #'1+) 7)
;;=> (8)

[]18.1 リストに対する分配 10:18 はてなブックマーク - 18.1 リストに対する分配 - drybulbのLisp日記

;;分配とは代入の一般化

[]18.2 他の構造 10:18 はてなブックマーク - 18.2 他の構造 - drybulbのLisp日記

;; シーケンス一般に対する分配オペレータ
(defmacro dbind (pat seq &body body)
  (let ((gseq (gensym)))
    `(let ((,gseq ,seq))
       ,(dbind-ex (destruc pat gseq #'atom) body))))

(defun destruc (pat seq &optional (atom? #'atom) (n 0))
  (if (null pat)
      nil
      (let ((rest (cond ((funcall atom? pat) pat)
			((eq (car pat) '&rest) (cadr pat))
			((eq (car pat) '&body) (cadr pat))
			(t nil))))
	(if rest
	    `((,rest (subseq ,seq ,n)))
	    (let ((p (car pat))
		  (rec (destruc (cdr pat) seq atom? (1+ n))))
	      (if (funcall atom? p)
		  (cons `(,p (elt ,seq ,n))
			rec)
		  (let ((var (gensym)))
		    (cons (cons `(,var (elt ,seq ,n))
				(destruc p var atom?))
			  rec))))))))

(defun dbind-ex (binds body)
  (if (null binds)
      `(progn ,@body)
      `(let ,(mapcar #'(lambda (b)
			 (if (consp (car b)) (car b)
			     b))
		     binds)
	 ,(dbind-ex (mapcan #'(lambda (b)
				(if (consp (car b)) (cdr b)))
			    binds)
		    body))))

(dbind (a b c) #(1 2 3)
  (list a b c))
;;=> (1 2 3)

(dbind (a (b c) d) '(1 #(2 3) 4)
  (list a b c d))
;;=> (1 2 3 4)

(dbind (a (b . c) &rest d) '(1 "fribble" 2 3 4)
  (list a b c d))
;;=> (1 #\f "ribble" (2 3 4))

(destruc '(a b c) 'seq #'atom)
;;=> ((A (ELT SEQ 0)) (B (ELT SEQ 1)) (C (ELT SEQ 2)))

(destruc '(a (b . c) &rest d) 'seq)
;;=> ((A (ELT SEQ 0))
;;    ((#:G1820 (ELT SEQ 1)) (B (ELT #:G1820 0)) (C (SUBSEQ #:G1820 1)))
;;    (D (SUBSEQ SEQ 2)))

(dbind-ex (destruc '(a (b . c) &rest d) 'seq) '(body))
;;=> (LET ((A (ELT SEQ 0)) (#:G1821 (ELT SEQ 1)) (D (SUBSEQ SEQ 2)))
;;     (LET ((B (ELT #:G1821 0)) (C (SUBSEQ #:G1821 1)))
;;       (PROGN BODY)))

;; 配列に対する分配
(defmacro with-matrix (pats ar &body body)
  (let ((gar (gensym)))
    `(let ((,gar ,ar))
       (let ,(let ((row -1))
		  (mapcan
		   #'(lambda (pat)
		       (incf row)
		       (setq col -1)
		       (mapcar #'(lambda (p)
				   `(,p (aref ,gar
					      ,row
					      ,(incf col))))
			       pat))
		   pats))
	 ,@body))))

(defmacro with-array (pat ar &body body)
  (let ((gar (gensym)))
    `(let ((,gar ,ar))
       (let ,(mapcar #'(lambda (p)
			 `(,(car p) (aref ,gar ,@(cdr p))))
		     pat)
	 ,@body))))

(dbind (a b c) (list 1 2))
;;>>Error

(setq ar (make-array '(3 3)))
;;=> #2A((0 0 0) (0 0 0) (0 0 0))
(for (r 0 2)
  (for (c 0 2)
    (setf (aref ar r c) (+ (* r 10) c))))
;;=> NIL

(with-matrix ((a b c)
	      (d e f)
	      (g h i)) ar
  (list a b c d e f g h i))
;;=> (0 1 2 10 11 12 20 21 22)

;; 対角成分だけ
(with-array ((a 0 0) (d 1 1) (i 2 2)) ar
  (values a d i))
;;=> 0, 11, 22


;; 構造体に対する分配
(defmacro with-struct ((name . fields) struct &body body)
  (let ((gs (gensym)))
    `(let ((,gs ,struct))
       (let ,(mapcar #'(lambda (f)
			 `(,f (,(symb name f) ,gs)))
		     fields)
	 ,@body))))

(defstruct visitor name title firm)
;;=> VISITOR
(setq theo (make-visitor :name "Theodebert"
			 :title 'king
			 :firm 'franks))
;;=> #S(VISITOR :NAME "Theodebert" :TITLE KING :FIRM FRANKS)
(with-struct (visitor- name firm title) theo
  (list name firm title))
;;=> ("Theodebert" FRANKS KING)

[]18.3 参照 10:18 はてなブックマーク - 18.3 参照 - drybulbのLisp日記

(defmacro with-places (pat seq &body body)
  (let ((gseq (gensym)))
    `(let ((,gseq ,seq))
       ,(wplac-ex (destruc pat gseq #'atom) body))))

(defun wplac-ex (binds body)
  (if (null binds)
      `(progn ,@body)
      `(symbol-macrolet ,(mapcar #'(lambda (b)
				     (if (consp (car b))
					 (car b)
					 b))
				 binds)
	 ,(wplac-ex (mapcan #'(lambda (b)
				(if (consp (car b))
				    (cdr b)))
			    binds)
		    body))))

(with-places (a b c) #(1 2 3)
  (list a b c))
;;=> (1 2 3)

(let ((lst '(1 (2 3) 4)))
  (with-places (a (b . c) d) lst
    (setf a 'uno)
    (setf c '(tre)))
  lst)
;;=> (UNO (2 TRE) 4)

[]18.4 マッチング 10:18 はてなブックマーク - 18.4 マッチング - drybulbのLisp日記

;; マッチング関数

(defun match (x y &optional binds)
  (acond2
   ((or (eql x y) (eql x '_) (eql y '_)) (values binds t))
   ((binding x binds) (match it y binds))
   ((binding y binds) (match x it binds))
   ((varsym? x) (values (cons (cons x y) binds) t))
   ((varsym? y) (values (cons (cons y x) binds) t))
   ((and (consp x) (consp y) (match (car x) (car y) binds))
    (match (cdr x) (cdr y) it))
   (t (values nil nil))))

(defun varsym? (x)
  (and (symbolp x) (eq (char (symbol-name x) 0) #\?)))

(defun binding (x binds)
  (labels ((recbind (x binds)
	     (aif (assoc x binds)
		  (or (recbind (cdr it) binds)
		      it))))
    (let ((b (recbind x binds)))
      (values (cdr b) b))))

(match '(p a b c a) '(p ?x ?y c ?x))
;;=> ((?Y . B) (?X . A)), T
(match '(p ?x b ?y a) '(p ?y b c a))
;;=> ((?Y . C) (?X . ?Y)), T
(match '(a b c) '(a a a))
;;=> NIL, NIL
(match '(p ?x) '(p ?x))
;;=> NIL, T
(match '(a ?x b) '(_ 1 _)) ; _ はワイルドカード
;;=> ((?X . 1)), T


;; 遲いマッチングオペレータ
(defmacro if-match (pat seq then &optional else)
  `(aif2 (match ',pat ,seq)
	 (let ,(mapcar #'(lambda (v)
			   `(,v (binding ',v it)))
		       (vars-in then #'atom))
	   ,then)
	 ,else))

(defun vars-in (expr &optional (atom? #'atom))
  (if (funcall atom? expr)
      (if (var? expr) (list expr))
      (union (vars-in (car expr) atom?)
	     (vars-in (cdr expr) atom?))))

(defun var? (x)
  (and (symbolp x) (eq (char (symbol-name x) 0) #\?)))


(defun abab (seq)
  (if-match (?x ?y ?x ?y) seq
	    (values ?x ?y)
	    nil))

(abab '(hi ho hi ho))
;;=> HI, HO
(abab '(hoge fuga hoge fuga))
;;=> HOGE, FUGA

;; 高速なマッチングオペレータ
(defmacro if-match (pat seq then &optional else)
  `(let ,(mapcar #'(lambda (v) `(,v ',(gensym)))
		 (vars-in pat #'simple?))
     (pat-match ,pat ,seq ,then ,else)))

(defmacro pat-match (pat seq then else)
  (if (simple? pat)
      (match1 `((,pat ,seq)) then else)
      (with-gensyms (gseq gelse)
	`(labels ((,gelse () ,else))
	   ,(gen-match (cons (list gseq seq)
			     (destruc pat gseq #'simple?))
		       then
		       `(,gelse))))))

(defun simple? (x) (or (atom x) (eq (car x) 'quote)))

(defun gen-match (refs then else)
  (if (null refs)
      then
      (let ((then (gen-match (cdr refs) then else)))
	(if (simple? (caar refs))
	    (match1 refs then else)
	    (gen-match (car refs) then else)))))

(defun match1 (refs then else)
  (dbind ((pat expr) . rest) refs
    (cond ((gensym? pat)
	   `(let ((,pat ,expr))
	      (if (and (typep ,pat 'sequence)
		       ,(length-test pat rest))
		  ,then
		  ,else)))
	  ((eq pat '_) then)
	  ((var? pat)
	   (let ((ge (gensym)))
	     `(let ((,ge ,expr))
		(if (or (gensym? ,pat) (equal ,pat ,ge))
		    (let ((,pat ,ge)) ,then)
		    ,else))))
	  (t `(if (equal ,pat ,expr) ,then ,else)))))

(defun gensym? (s)
  (and (symbolp s) (not (symbol-package s))))

(defun length-test (pat rest)
  (let ((fin (caadar (last rest))))
    (if (or (consp fin) (eq fin 'elt))
	`(= (length ,pat) ,(length rest))
	`(> (length ,pat) ,(- (length rest) 2)))))

;(caadar '((a (b))))

(if-match (?x 'a) seq
	  (print ?x)
	  nil)

(destruc '(?x 'a) 'g #'simple?)
;;=> ((?X (ELT G 0)) ('A (ELT G 1)))

;(match1 '(((quote a) (elt g 1))) '(print ?x) '<else function>)

[]19.1 データベース 15:09 はてなブックマーク - 19.1 データベース - drybulbのLisp日記

;; データベースの基本となる関数
(defun make-db (&optional (size 100))
  (make-hash-table :size size))

(defvar *default-db* (make-db))

(defun clear-db (&optional (db *default-db*))
  (clrhash db))

(defmacro db-query (key &optional (db '*default-db*))
  `(gethash ,key ,db))

(defun db-push (key val &optional (db *default-db*))
  (push val (db-query key db)))

(defmacro fact (pred &rest args)
  `(progn (db-push ',pred ',args)
	  ',args))

(fact painter reynolds joshua english)
;;=> (REYNOLDS JOSHUA ENGLISH)
(fact painter canale atonio venetian)
;;=> (CANALE ATONIO VENETIAN)
(db-query 'painter)
;;=> ((CANALE ATONIO VENETIAN) (REYNOLDS JOSHUA ENGLISH)), T

;; 1697年生まれのすべての画家
;;(and (painter ?x ?y ?z)
;;     (dates ?x 1697 ?w))

[]19.3 クエリインタプリタ 15:10 はてなブックマーク - 19.3 クエリインタプリタ - drybulbのLisp日記

(defmacro with-answer (query &body body)
  (let ((binds (gensym)))
    `(dolist (,binds (interpret-query ',query))
       (let ,(mapcar #'(lambda (v)
			 `(,v (binding ',v ,binds)))
		     (vars-in query #'atom))
	 ,@body))))

(defun interpret-query (expr &optional binds)
  (case (car expr)
    (and (interpret-and (reverse (cdr expr)) binds))
    (or (interpret-or (cdr expr) binds))
    (not (interpret-not (cadr expr) binds))
    (t (lookup (car expr) (cdr expr) binds))))

(defun interpret-and (clauses binds)
  (if (null clauses)
      (list binds)
      (mapcan #'(lambda (b)
		  (interpret-query (car clauses) b))
	      (interpret-and (cdr clauses) binds))))

(defun interpret-or (clauses binds)
  (mapcan #'(lambda (c)
	      (interpret-query c binds))
	  clauses))

(defun interpret-not (clause binds)
  (if (interpret-query clause binds)
      nil
      (list binds)))

(defun lookup (pred args &optional binds)
  (mapcan #'(lambda (x)
	      (aif2 (match x args binds) (list it)))
	  (db-query pred)))

(lookup 'painter '(?x ?y english))
;;=> (((?Y . JOSHUA) (?X . REYNOLDS)))

;; fact
(clear-db)
(fact painter hogarth wiiliam english)
(fact painter canale atonio venetian)
(fact painter reynolds joshua english)
(fact dates hogarth 1697 1772)
(fact dates canale 1697 1768)
(fact dates reynolds 1723 1792)

(interpret-query '(and (painter ?x ?y ?z)
		   (dates ?x 1697 ?w)))
;;=> (((?W . 1768) (?Z . VENETIAN) (?Y . ATONIO) (?X . CANALE))
;;    ((?W . 1772) (?Z . ENGLISH) (?Y . WIILIAM) (?X . HOGARTH)))

(with-answer (painter hogarth ?x ?y)
  (princ (list ?x ?y)))
;;(WIILIAM ENGLISH)
;;=> NIL

(with-answer (and (painter ?x _ _)
		  (dates ?x 1697 _))
  (princ (list ?x)))
;;(CANALE)(HOGARTH)
;;=> NIL

(with-answer (or (dates ?x ?y 1772)
		 (dates ?x ?y 1792))
  (princ (list ?x ?y)))
;;(HOGARTH 1697)(REYNOLDS 1723)
;;=> NIL

(with-answer (and (painter ?x _ english)
		  (dates ?x ?b _)
		  (not (and (painter ?x2 _ venetian)
			    (dates ?x2 ?b _))))
  (princ ?x))
;;REYNOLDS
;;=> NIL

[]19.5 クエリコンパイラ 15:09 はてなブックマーク - 19.5 クエリコンパイラ - drybulbのLisp日記

(defmacro with-answer (query &body body)
  `(with-gensyms ,(vars-in query #'simple?)
     ,(compile-query query `(progn ,@body))))

(defun compile-query (q body)
  (case (car q)
    (and (compile-and (cdr q) body))
    (or (compile-or (cdr q) body))
    (not (compile-not (cadr q) body))
    (lisp `(if ,(cadr q) ,body))
    (t (compile-simple q body))))

(defun compile-simple (q body)
  (let ((fact (gensym)))
    `(dolist (,fact (db-query ',(car q)))
       (pat-match ,(cdr q) ,fact ,body nil))))

(defun compile-and (clauses body)
  (if (null clauses)
      body
      (compile-query (car clauses)
		     (compile-and (cdr clauses) body))))

(defun compile-or (clauses body)
  (if (null clauses)
      nil
      (let ((gbod (gensym))
	    (vars (vars-in body #'simple?)))
	`(labels ((,gbod ,vars ,body))
	   ,@(mapcar #'(lambda (cl)
			 (compile-query cl `(,gbod ,@vars)))
		     clauses)))))

(defun compile-not (q body)
  (let ((tag (gensym)))
    `(if (block ,tag
	   ,(compile-query q `(return-from ,tag nil))
	   t)
	 ,body)))


(setq my-favorite-year 1723)
;;=> 1723 (#x6BB, #o3273, #b11010111011)
(with-answer (dates ?x my-favorite-year ?d)
  (format t "~A was born in my favorite year. ~%" ?x))
;;REYNOLDS was born in my favorite year. 
;;=> NIL

;; クエリコンパイラの用例
;; Hogarthという名字のすべての画家のファーストネームと国籍
(with-answer (painter 'hogarth ?x ?y)
  (princ (list ?x ?y)))
;;(WIILIAM ENGLISH)
;;=> NIL


;; ヴェネツィアのどの国家とも同じ年に生れていない英国人画家
(with-answer (and (painter ?x _ 'english)
		  (dates ?x ?b _)
		  (not (and (painter ?x2 _ 'venetian)
			    (dates ?x2 ?b _))))
  (princ ?x))
;;REYNOLDS
;;=> NIL

;; 1770-1800年間に死んだ全ての画家のラストネームと没年
(with-answer (and (painter ?x _ _)
		  (dates ?x _ ?d)
		  (lisp (< 1770 ?d 1800)))
  (princ (list ?x ?d)))
;;(REYNOLDS 1792)(HOGARTH 1772)
;;=> NIL

(with-answer (and (dates ?x ?b ?d)
		  (lisp (> (- ?d ?b) 70)))
  (format t "~A lived over 70 years.~%" ?x))
;;CANALE lived over 70 years.
;;HOGARTH lived over 70 years.
;;=> NIL

2007-07-30

[]11.4 反復 22:17 はてなブックマーク - 11.4 反復 - drybulbのLisp日記

;; 単純な反復用マクロ
(defmacro while (test &body body)
  `(do ()
       ((not ,test))
     ,@body))

(defmacro till (test &body body)
  `(do ()
       (,test)
     ,@body))

(defmacro for ((var start stop) &body body)
  (let ((gstop (gensym)))
    `(do ((,var ,start (1+ ,var))
	  (,gstop ,stop))
	 ((> ,var ,gstop))
       ,@body)))

;; 部分リストにわたる再帰のためのマクロ dolistの一般化
(defmacro do-tuples/o (parms source &body body)
  (if parms
      (let ((src (gensym)))
	`(prog ((,src ,source))
	    (mapc #'(lambda ,parms ,@body)
		  ,@(map0-n #'(lambda (n)
				`(nthcdr ,n ,src))
			    (1- (length parms))))))))

(defmacro do-tuples/c (parms source &body body)
  (if parms
      (with-gensyms (src rest bodfn)
	(let ((len (length parms)))
	  `(let ((,src ,source))
	     (when (nthcdr ,(1- len) ,src)
	       (labels ((,bodfn ,parms ,@body))
		 (do ((,rest ,src (cdr ,rest)))
		     ((not (nthcdr ,(1- len) ,rest))
		      ,@(mapcar #'(lambda (args)
				    `(,bodfn ,@args))
				(dt-args len rest src))
		      nil)
		   (,bodfn ,@(map1-n #'(lambda (n)
					 `(nth ,(1- n)
					       ,rest))
				     len))))))))))

(defun dt-args (len rest src)
  (map0-n #'(lambda (m)
	      (map1-n #'(lambda (n)
			  (let ((x (+ m n)))
			    (if (>= x len)
				`(nth ,(- x len) ,src)
				`(nth ,(1- x) ,rest))))
		      len))
	  (- len 2)))


(do-tuples/o (x y) '(a b c d)
  (princ (list x y)))
;;(A B)(B C)(C D)
;;=> NIL


;; 展開すると
(mac (do-tuples/o (x y) '(a b c d)
  (princ (list x y)))
(PROG ((#:G1894 '(A B C D)))
  (MAPC #'(LAMBDA (X Y) (PRINC (LIST X Y))) (NTHCDR 0 #:G1894)
        (NTHCDR 1 #:G1894)))

(do-tuples/c (x y) '(a b c d)
  (princ (list x y)))
;;(A B)(B C)(C D)(D A)
;;=> NIL

;; 展開すると
(mac (do-tuples/c (x y) '(a b c d)
       (princ (list x y))))
(LET ((#:G1924 '(A B C D)))
  (WHEN (NTHCDR 1 #:G1924)
    (LABELS ((#:G1926 (X Y)
               (PRINC (LIST X Y))))
      (DO ((#:G1925 #:G1924 (CDR #:G1925)))
          ((NOT (NTHCDR 1 #:G1925))
           (#:G1926 (NTH 0 #:G1925) (NTH 0 #:G1924))
           NIL)
        (#:G1926 (NTH 0 #:G1925) (NTH 1 #:G1925))))))


;; 引数が1個のときは dolist に縮退
(do-tuples/o (x) '(a b c) (princ x))
;;ABC
;;=> NIL

(do-tuples/c (x) '(a b c) (princ x))
;;ABC
;;=> NIL


(do-tuples/c (x y z) '(a b c d) (princ (list x y z)))
;;(A B C)(B C D)(C D A)(D A B)
;;=> NIL

(do-tuples/c (w x y z) '(a b c d) (princ (list w x y z)))
;;(A B C D)(B C D A)(C D A B)(D A B C)
;;=> NIL

;;展開すると
(mac (do-tuples/c (x y z) '(a b c d) (princ (list x y z))))
(LET ((#:G1937 '(A B C D)))
  (WHEN (NTHCDR 2 #:G1937)
    (LABELS ((#:G1939 (X Y Z)
               (PRINC (LIST X Y Z))))
      (DO ((#:G1938 #:G1937 (CDR #:G1938)))
          ((NOT (NTHCDR 2 #:G1938))
           (#:G1939 (NTH 0 #:G1938) (NTH 1 #:G1938) (NTH 0 #:G1937))
           (#:G1939 (NTH 1 #:G1938) (NTH 0 #:G1937) (NTH 1 #:G1937))
           NIL)
        (#:G1939 (NTH 0 #:G1938) (NTH 1 #:G1938) (NTH 2 #:G1938))))))

[]11.5 複数の値にわたる反復 22:17 はてなブックマーク - 11.5 複数の値にわたる反復 - drybulbのLisp日記

;; 多値に対応した do*
(defmacro mvdo* (parm-cl test-cl &body body)
  (mvdo-gen parm-cl parm-cl test-cl body))

(defun mvdo-gen (binds rebinds test body)
  (if (null binds)
      (let ((label (gensym)))
	`(prog nil
	    ,label
	    (if ,(car test)
		(return (progn ,@(cdr test))))
	    ,@body
	    ,@(mvdo-rebind-gen rebinds)
	    (go ,label)))
      (let ((rec (mvdo-gen (cdr binds) rebinds test body)))
	(let ((var/s (caar binds)) (expr (cadar binds)))
	  (if (atom var/s)
	      `(let ((,var/s ,expr)) ,rec)
	      `(multiple-value-bind ,var/s ,expr ,rec))))))

(defun mvdo-rebind-gen (rebinds)
  (cond ((null rebinds) nil)
	((< (length (car rebinds)) 3)
	 (mvdo-rebind-gen (cdr rebinds)))
	(t
	 (cons (list (if (atom (caar rebinds))
			 'setq
			 'multiple-value-setq)
		     (caar rebinds)
		     (third (car rebinds)))
	       (mvdo-rebind-gen (cdr rebinds))))))

(mvdo* ((x 1 (1+ x))
	((y z) (values 0 0) (values z x)))
    ((> x 5) (list x y z))
  (princ (list x y z)))
;;(1 0 0)(2 0 2)(3 2 3)(4 3 4)(5 4 5)
;;=> (6 5 6)

(defmacro mvpsetq (&rest args)
  (let* ((pairs (group args 2))
	 (syms (mapcar #'(lambda (p)
			   (mapcar #'(lambda (x) (gensym))
				   (mklist (car p))))
		       pairs)))
    (labels ((rec (ps ss)
	       (if (null ps)
		   `(setq
		     ,@(mapcan #'(lambda (p s)
				   (shuffle (mklist (car p))
					    s))
			       pairs syms))
		   (let ((body (rec (cdr ps) (cdr ss))))
		     (let ((var/s (caar ps))
			   (expr (cadar ps)))
		       (if (consp var/s)
			   `(multiple-value-bind ,(car ss) ,expr
			      ,body)
			   `(let ((,@(car ss) ,expr))
			      ,body)))))))
      (rec pairs syms))))

(defun shuffle (x y)
  (cond ((null x) y)
	((null y) x)
	(t (list* (car x) (car y)
		  (shuffle (cdr x) (cdr y))))))

(defmacro mvdo (binds (test &rest result) &body body)
  (let ((label (gensym))
	(temps (mapcar #'(lambda (b)
			   (if (listp (car b))
			       (mapcar #'(lambda (x)
					   (gensym))
				       (car b))
			       (gensym)))
		       binds)))
    `(let ,(mappend #'mklist temps)
       (mvpsetq ,@(mapcan #'(lambda (b var)
			      (list var (cadr b)))
			  binds
			  temps))
       (prog ,(mapcar #'(lambda (b var) (list b var))
		      (mappend #'mklist (mapcar #'car binds))
		      (mappend #'mklist temps))
	  ,label
	  (if ,test
	      (return (progn ,@result)))
	  ,@body
	  (mvpsetq ,@(mapcan #'(lambda (b)
				 (if (third b)
				     (list (car b)
					   (third b))))
			     binds))
	  (go ,label)))))

(mvdo ((x 1 (1+ x))
       ((y z) (values 0 0) (values z x)))
    ((> x 5) (list x y z))
  (princ (list x y z)))
;;(1 0 0)(2 0 1)(3 1 2)(4 2 3)(5 3 4)
;;=> (6 4 5)

;;展開すると
(mac (mvdo ((x 1 (1+ x))
       ((y z) (values 0 0) (values z x)))
    ((> x 5) (list x y z))
  (princ (list x y z))))

(LET (#:G2022 #:G2023 #:G2024)
  (MVPSETQ #:G2022 1 (#:G2023 #:G2024) (VALUES 0 0))
  (PROG ((X #:G2022) (Y #:G2023) (Z #:G2024))
   #:G2021
    (IF (> X 5) (RETURN (PROGN (LIST X Y Z))))
    (PRINC (LIST X Y Z))
    (MVPSETQ X (1+ X) (Y Z) (VALUES Z X))
    (GO #:G2021)))




(let ((w 0) (x 1) (y 2) (z 3))
  (mvpsetq (w x) (values 'a 'b) (y z) (values w x))
  (list w x y z))
;;=> (A B 0 1)

(shuffle '(a b c) '(1 2 3 4))
;;=> (A 1 B 2 C 3 4)

(mappend #'mklist '((a b c) d (e (f g) h) ((i)) j))
;;=> (A B C D E (F G) H (I) J)

[]11.6 マクロの必要性 22:17 はてなブックマーク - 11.6 マクロの必要性 - drybulbのLisp日記

;; if を関数として書く
(defun fnif (test then &optional else)
  (if test
      (funcall then)
      (if else (funcall else))))

;*[On Lisp]12.1 汎変数という概念
(setq lst '(a b c))
(setf (car lst) 500)
lst
;;=> (500 B C)

(defmacro toggle (obj)
  `(setf ,obj (not ,obj))) ;誤

(let ((lst '(a b c)))
  (toggle (car lst))
  lst)
;;=> (NIL B C)

(let ((lst '(t nil t))
      (i -1))
  (toggle (nth (incf i) lst))
  lst)
;;=> (T NIL T) ;何も変らない

;; そこで define-modify-macro
(define-modify-macro toggle () not)


(let ((lst '(t nil t))
      (i -1))
  (toggle (nth (incf i) lst))
  lst)
;;=> (NIL NIL T)

[]12.3 新しいユーティリティ 22:17 はてなブックマーク - 12.3 新しいユーティリティ - drybulbのLisp日記


;; 汎変数に対して機能するマクロ
(defmacro allf (val &rest args)
  (with-gensyms (gval)
    `(let ((,gval ,val))
       (setf ,@(mapcan #'(lambda (a) (list a gval))
		       args)))))

(defmacro nilf (&rest args) `(allf nil ,@args))

(defmacro tf (&rest args) `(allf t ,@args))

(defmacro toggle (&rest args)
  `(progn
     ,@(mapcar #'(lambda (a) `(toggle2 ,a))
	       args)))

(define-modify-macro toggle2 () not)

(setf x 1
      y 2) ;同時に設定可能
x ;=> 1 (#x1, #o1, #b1)
y ;=> 2 (#x2, #o2, #b10)

(setf x nil y nil z nil)
;;↓
(nilf x y z) ;全部 nil

(tf x y z) ;全部 t


;; 汎変数に対するリスト操作
(define-modify-macro concf (obj) nconc)

(define-modify-macro conc1f (obj)
  (lambda (place obj)
    (nconc place (list obj))))

(define-modify-macro concnew (obj &rest args)
  (lambda (palce obj &rest args)
    (unless (apply #'member obj place args)
      (nconc place (list obj)))))

;;破壊的な関数は下記のようにしなければいけない
(nconc x y)
;; ↓
(setf x (nconc x y))

[]12.4 さらに複雑なユーティリティ 22:17 はてなブックマーク - 12.4 さらに複雑なユーティリティ - drybulbのLisp日記

;;incf 一般化

;p.118
(setf (obj-dx o) (* (obj-dx o) factor))
;; ↓
(_f * (obj-dx o) factor)

(defmacro _f (op place &rest args)
  `(setf ,place (,op ,place ,@args))) ;誤り

;;define-modify-macro でも _f は作れない


(get-setf-method '(incf i))


;; setf上に作るさらに複雑なマクロ
(defmacro _f (op place &rest args)
  (multiple-value-bind (vars forms var set access)
      (get-setf-method place)
    `(let* (,@(mapcar #'list vars forms)
	    (,(car var) (,op ,access ,@args)))
       ,set)))

(defmacro pull (obj place &rest args)
  (multiple-value-bind (vars forms var set access)
      (get-setf-method place)
    (let ((g (gensym)))
      `(let* ((,g ,obj)
	      ,@(mapcar #'list vars forms)
	      (,(car var) (delete ,g ,access ,@args)))
	 ,set))))

(defmacro pull-if (test place &rest args)
  (multiple-value-bind (vars forms var set access)
      (get-setf-method place)
    (let ((g (gensym)))
      `(let* ((,g test)
	      ,@(mapcar #'list vars forms)
	      (,(car var) (delete-if ,g ,access ,@args)))
	 ,set))))

(defmacro popn (n place)
  (multiple-value-bind (vars forms var set access)
      (get-setf-method place)
    (with-gensyms (gn glst)
      `(let* ((,gn ,n)
	      ,@(mapcar #'list vars forms)
	      (,glst ,access)
	      (,(car var) (nthcdr ,gn ,glst)))
	 (prog1 (subseq ,glst 0 ,gn)
	   ,set)))))

2007-07-29

[]10.4 再帰 21:03 はてなブックマーク - 10.4 再帰 - drybulbのLisp日記

;; nth
; 正
(defun ntha (n lst)
  (if (= n 0)
      (car lst)
      (ntha (- n 1) (cdr lst))))

; 誤
(defmacro nthb (n lst)
  `(if (= ,n 0)
       (car ,lst)
       (nthb (- ,n 1) (cdr ,lst))))

(defmacro nthc (n lst)
  `(do ((n2 ,n (1- n2))
	(lst2 ,lst (cdr lst2)))
       ((= n2 0) (car lst2))))
(nthc 3 '(a b c d e))
;=> D

;さらに
(defmacro nthd (n lst)
  `(nth-fn ,n ,lst))

(defun nth-fn (n lst)
  (if (= n 0)
      (car lst)
      (nth-fn (- n 1) (cdr lst))))

;さらに
(defmacro nthe (n lst)
  `(labels ((nth-fn (n lst)
	      (if (= n 0)
		  (car lst)
		  (nth-fn (- n 1) (cdr lst)))))
     (nth-fn ,n ,lst)))


;; or

(defmacro ora (&rest args)
  (or-expand args))

(defun or-expand (args)
  (if (null args)
      nil
      (let ((sym (gensym)))
	`(let ((,sym ,(car args)))
	   (if ,sym
	       ,sym
	       ,(or-expand (cdr args)))))))


;さらに
(defmacro orb (&rest args)
  (if (null args)
      nil
      (let ((sym (gensym)))
	`(let ((,sym ,(car args)))
	   (if ,sym
	       ,sym
	       (orb ,@(cdr args)))))))

[]11.1 コンテキストの生成 21:03 はてなブックマーク - 11.1 コンテキストの生成 - drybulbのLisp日記

;;letの写経
(defmacro our-let (binds &body body)
  `((lambda ,(mapcar #'(lambda (x)
			 (if (consp x) (car x) x))
		     binds)
      ,@body)
    ,@(mapcar #'(lambda (x)
		  (if (consp x) (cadr x) nil))
	      binds)))

(setq x 'a)
x ;=> A
(our-let ((x 'b)) (list x)) ;=> (B)

(our-let ((x 1) (y 2))
  (+ x y))
;;=> 3 (#x3, #o3, #b11)

((lambda (x y) (+ x y)) 1 2)
;;=> 3 (#x3, #o3, #b11)

(defmacro when-bind ((var expr) &body body)
  `(let ((,var ,expr))
     (when ,var
       ,@body)))

(defmacro when-bind* (binds &body body)
  (if (null binds)
      `(progn ,@body)
      `(let (,(car binds))
	 (if ,(caar binds)
	     (when-bind* ,(cdr binds) ,@body)))))

(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar #'(lambda (s)
		     `(,s (gensym)))
		 syms)
     ,@body))

(when-bind* ((x (find-if #'consp '(a (1 2) b)))
	     (y (find-if #'oddp x)))
  (+ y 10))
;;=> 11 (#xB, #o13, #b1011) [2 times]

;; with-redraw では gensym 5
;; p.118

(defmacro with-redraw ((var objs) &body body)
  (with-gensyms (gob x0 y0 x1 y1)
    ...))


;; cond + let = condlet
(defmacro condlet (clauses &body body)
  (let ((bodfn (gensym))
	(vars (mapcar #'(lambda (v) (cons v (gensym)))
		      (remove-duplicates
		       (mapcar #'car
			       (mappend #'cdr clauses))))))
    `(labels ((,bodfn ,(mapcar #'car vars)
		,@body))
       (cond ,@(mapcar #'(lambda (cl)
			   (condlet-clause vars cl bodfn))
		       clauses)))))

(defun condlet-clause (vars cl bodfn)
  `(,(car cl) (let ,(mapcar #'cdr vars)
		(let ,(condlet-binds vars cl)
		  (,bodfn ,@(mapcar #'cdr vars))))))

(defun condlet-binds (vars cl)
  (mapcar #'(lambda (bindform)
	      (if (consp bindform)
		  (cons (cdr (assoc (car bindform) vars))
			(cdr bindform))))
	  (cdr cl)))

;(condlet (t (x (princ 'tt)) (y (princ 'bb)))
;	  ((= 1 1) (y (princ 'cc)) (x (princ 'd)))
;	  (t       (x (princ 'ee)) (z (princ 'f))))
;  (list x y z))

;(condlet ((= 1 1) (y (print 'cc)) (x (print 'd))
;	  (t      (x (print 'ee)) (z (print 'dd))))
;  (list x y z))

[]11.2 with-系マクロ 21:03 はてなブックマーク - 11.2 with-系マクロ - drybulbのLisp日記

;macroのみバージョン
(defmacro with-db (db &body body)
  (let ((temp (gensym)))
    `(let ((,temp *db*))
       (unwind-protect
	    (progn
	      (setq *db* ,db)
	      (lock *db*)
	      ,@body)
	 (progn
	   (release *db*)
	   (setq *db* ,temp))))))

;macroと関数
(defmacro with-db (db &body body)
  (let ((gbod (gensym)))
    `(let ((,gbod #'(lambda () ,@body)))
       (declare (dynamic-extent ,gbod))
       (with-db-fn *db* ,db ,gbod))))

(defun with-db-fn (old-db new-db body)
  (unwind-protect
       (progn
	 (setq *db* new-db)
	 (lock *db*)
	 (funcall body))
    (progn
      (release *db*)
      (setq *db* old-db))))

[]11.3 条件付き評価 21:03 はてなブックマーク - 11.3 条件付き評価 - drybulbのLisp日記

;;条件付き評価のためのマクロ
(defmacro if3 (test t-case nil-case ?-case)
  `(case ,test
     ((nil) ,nil-case)
     (?   ,?-case)
     (t   ,t-case)))

(defmacro nif (expr pos zero neg) ;p.89
  (let ((g (gensym)))
    `(let ((,g ,expr))
       (cond ((plusp ,g) ,pos)
	     ((zerop ,g) ,zero)
	     (t, neg)))))

(mapcar #'(lambda (x)
	    (nif x 'p 'z 'n))
	'(0 1 -1 0 -1))
;;=> (Z P N Z N)


;;条件付き評価のためのマクロ
(defmacro in (obj &rest choices)
  (let ((insym (gensym)))
    `(let ((,insym ,obj))
       (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
		     choices)))))

(defmacro inq (obj &rest args)
  `(in ,obj ,@(mapcar #'(lambda (a)
			  `',a)
		      args)))

(defmacro in-if (fn &rest choices)
  (let ((fnsym (gensym)))
    `(let ((,fnsym ,fn))
       (or ,@(mapcar #'(lambda (c)
			 `(funcall ,fnsym ,c))
		     choices)))))

(defmacro >case (expr &rest clauses)
  (let ((g (gensym)))
    `(let ((,g ,expr))
       (cond ,@(mapcar #'(lambda (cl) (>casex g cl)))
	     clauses))))

(defun >casex (g cl)
  (let ((key (car cl)) (rest (cdr cl)))
    (cond ((consp key) `((in ,g ,@key) ,@rest))
	  ((inq key t otherwise) `(t ,@rest))
	  (t (error "bad >case clause")))))

(in (foo) (bar) (baz))
(mac (in (foo) (bar) (baz)))
;;(LET ((#:G1818 (FOO)))
;;  (OR (EQL #:G1818 (BAR)) (EQL #:G1818 (BAZ))))

(inq operator + - *)
(mac (inq operator + - *))
;;(IN OPERATOR '+ '- '*)

2007-07-28

[]7.8 マクロスタイル 21:00 はてなブックマーク - 7.8 マクロのスタイル - drybulbのLisp日記

; and のマクロ定義
(defmacro our-and (&rest args)
  (case (length args)
    (0 t)
    (1 (car args))
    (t `(if ,(car args)
	    (our-and ,@(cdr args)))))) ;再帰的

(defmacro our-and-b (&rest args)
  (if (null args)
      t
      (labels ((expander (rest)
		 (if (cdr rest)
		     `(if ,(car rest)
			  ,(expander (cdr rest)))
		     (car rest))))
	(expander args))))

;マクロは効率性が最優先
;コンシングをさけること

[]7.9 マクロへの依存 21:00 はてなブックマーク - 7.9 マクロへの依存 - drybulbのLisp日記

(defmacro mac (x) `(1+ ,x))

(setq fn (complile nil `(lambda (y) (mac y))))

(defmacro mac (x) `(+ ,x 100))

(funcall fn 1)

[]7.10 関数からマクロ21:00 はてなブックマーク - 7.10 関数からマクロへ - drybulbのLisp日記

;1 本体が単一の式から成っている
(defun our-second (x) (cadr x))
; ↓
(defmacro our-second (x) `(cadr ,x))

; 上記条件を満していないとき
; 複数の式のとき
(defun noisy-second (x)
  (princ "Someone is taking a cadr!")
  (cadr x))
; ↓
(defmacro noisy-second (x)
  `(progn
     (princ "Someone is taking a cadr!")
     (cadr ,x)))

;2 パラメータリストにはパラメータの名前のみが含まれる
; 上記条件を満していないとき

(defun sum (&rest args)
  (apply #'+ args))
; ↓
(defmacro sum (&rest args)
  `(apply #'+ (list ,args)))
; ↓ さらにこうする
(defmacro sum (&rest args)
  `(+ ,@args))

(sum 1 2 3 4)
;=> 10 (#xA, #o12, #b1010)
(mac (sum 1 2 3 4))
;(+ 1 2 3 4)


; 3 パラメータ以外に、新しい変数を作らない
; 上記条件を満していないとき

(defun foo (x y z)
  (list x (let ((x y))
	    (list x z))))
; ↓
(defmacro foo (x y z)
  `(list ,x (let ((x ,y))
	      (list x ,z))))

;→マクロの再帰は10章以降を参照

[]7.11 シンボルマクロ 21:00 はてなブックマーク - 7.11 シンボルマクロ - drybulbのLisp日記

(symbol-macrolet ((hi (progn (print "Howdy")
			     1)))
  (+ hi 2))
;"Howdy" 

;=> 3 (#x3, #o3, #b11)
;→第15、第18

[]8 いつマクロを使うべきか 21:00 はてなブックマーク - 8 いつマクロを使うべきか - drybulbのLisp日記

; 関数で間に合うところにマクロを使うのはエレガントではない
; 人はマクロでどんなことを行うものなのか?


;*[On Lisp]8.1 他の手段では不可能なとき
(defun our-1+ (x) (+ 1 x))

(defmacro our-1+ (x) `(+ 1 ,x))

; whileはマクロでないと定義できない
(defmacro our-while (test &body body)
  `(do ()
       ((not ,test))
     ,@body))

; マクロにできて関数にできないこと2つ
; 1 マクロは引数の評価を制御できる
; 2 呼び出し側のコンテキスト内へ直に展開できる

[]8.2 マクロ関数どちらがよい? 21:01 はてなブックマーク - 8.2 マクロと関数どちらがよい? - drybulbのLisp日記

; マクロの短所
; マクロに apply や funcall を適用したい場合
(defmacro avg (&rest args)
  `(/ (+ ,@args) ,(length args)))

; lambda式で包む
(funcall #'(lambda (x y) (avg x y)) 1 3)
;=> 2 (#x2, #o2, #b10)
; 必ず使えるというわけではない

[]8.3 マクロの応用例 21:01 はてなブックマーク - 8.3 マクロの応用例 - drybulbのLisp日記

; defunについて第2章から

(defun foo (x) (* x 2))

(setf (symbol-function 'foo)
      #'(lambda (x) (* x 2)))

; our-defun の写経
(defmacro our-defun (name parms &body body)
  `(progn
     (setf (symbol-function ',name)
	   #'(lambda ,parms (block ,name ,@body)))
     ',name))

; move と scaleの写経
(defun move-objs (objs dx dy)
  (multiple-value-bind (x0 y0 x1 y1) (bounds objs)
    (dolist (o objs)
      (incf (obj-x o) dx)
      (incf (obj-y o) dy))
    (multiple-value-bind (xa ya xb yb) (bounds objs)
      (redraw (min x0 xa) (min y0 ya0)
	      (max x1 xb) (max y1 yb)))))

(defun scale-objs (objs factor)
  (multiple-value-bind (x0 y0 x1 y1) (bounds objs)
    (dolist (o objs)
      (setf (obj-dx o) (* (obj-dx o) factor)
	    (obj-dy o) (* (obj-dy o) factor)))
    (multiple-value-bind (xa ya xb yb) (bounds objs)
      (redraw (min x0 xa) (min y0 ya)
	      (max x1 xb) (max y1 yb)))))

; 3枚おろしにする
(defmacro with-redraw ((var objs) &body body)
  (let ((gob (gensym))
	(x0 (gensym)) (y0 (gensym))
	(x1 (gensym)) (y1 (gensym)))
    `(let ((,gob ,objs))
       (multiple-value-bind (,x0 ,y0 ,x1 ,y1) (bounds ,gob)
	 (dolist (,var ,gob) ,@body)
	 (multiple-value-bind (xa ya xb yb) (bounds ,gob)
	   (redraw (min ,x0 xa) (min ,y0 ya)
		   (max ,x1 xb) (max ,y1 yb)))))))

(defun move-objs (objs dx dy)
  (with-redraw (o objs)
    (incf (obj-x o) dx)
    (incf (obj-y o) dy)))

(defun scale-objs (objs factor)
  (with-redraw (o objs)
    (setf (obj-dx o) (* (obj-dx o) factor)
	  (obj-dy o) (* (obj-dy o) factor))))

[]9.1 マクロ引数の補足 21:01 はてなブックマーク - 9.1 マクロ引数の補足 - drybulbのLisp日記

; PASCAL風 for文 誤り
(defmacro for ((var start stop) &body body)
  `(do ((,var ,start (1+ ,var))
	(limit ,stop))
       ((> ,var limit))
     ,@body))

(for (x 1 4)
  (princ x))
;1234
;=> NIL

(for (limit 1 5)
  (princ limit))

(mac (for (limit 1 5)
       (princ limit)))

;=> 展開形
(DO ((LIMIT 1 (1+ LIMIT))
     (LIMIT 5))
    ((> LIMIT LIMIT))
  (PRINC LIMIT))

; おかしいという兆候を何も出さない
(let ((limit 5))
  (for (i 1 10)
    (when (> i limit)
      (princ i))))
;=> NIL

[]9.2 自由なシンボルの補足 21:01 はてなブックマーク - 9.2 自由なシンボルの補足 - drybulbのLisp日記

(defvar w nil)
(defmacro gripe (warning) ; 誤り
  `(progn (setq w (nconc w (list ,warning)))
	  nil))

(defun sample-ratio (v w)
  (let ((vn (length v)) (wn (length w)))
    (if (or (< vn 2) (< wn 2))
	(gripe "sample < 2")
	(/ vn wn))))

(let ((lst '(b)))
  (sample-ratio nil lst)
  lst)
;=> (B "sample < 2")

[]9.5 事前評価によって補足をさける 21:01 はてなブックマーク - 9.5 事前評価によって補足をさける - drybulbのLisp日記

; 本体をクロージャで包む for
(defmacro for ((var start stop) &body body)
  `(do ((b #'(lambda (,var) ,@body))
	(count ,start (1+ count))
	(limit ,stop))
       ((> count limit))
     (funcall b count)))

(for (x 1 4)
  (princ x))
;1234
(for (limit 1 5)
  (princ limit))
;12345

(let ((limit 0))
  (for (x 1 10)
    (incf limit x))
  limit)
;=> 55 (#x37, #o67, #b110111)

[]9.6 Gensymによって補足をさける 21:01 はてなブックマーク - 9.6 Gensymによって補足をさける - drybulbのLisp日記

(defmacro for ((var start stop) &body body)
  (let ((gstop (gensym)))
    `(do ((,var ,start (1+ ,var))
	  (,gstop ,stop))
	 ((> ,var ,gstop))
       ,@body)))

(for (x 1 4)
  (princ x))
;1234
(for (limit 1 5)
  (princ limit))
;12345

(let ((limit 0))
  (for (x 1 10)
    (incf limit x))
  limit)
;=> 55 (#x37, #o67, #b110111)

;*[On Lisp]10.4 再帰

;; nth
; 正
(defun ntha (n lst)
  (if (= n 0)
      (car lst)
      (ntha (- n 1) (cdr lst))))

; 誤
(defmacro nthb (n lst)
  `(if (= ,n 0)
       (car ,lst)
       (nthb (- ,n 1) (cdr ,lst))))

(defmacro nthc (n lst)
  `(do ((n2 ,n (1- n2))
	(lst2 ,lst (cdr lst2)))
       ((= n2 0) (car lst2))))
(nthc 3 '(a b c d e))
;=> D

;さらに
(defmacro nthd (n lst)
  `(nth-fn ,n ,lst))

(defun nth-fn (n lst)
  (if (= n 0)
      (car lst)
      (nth-fn (- n 1) (cdr lst))))

;さらに
(defmacro nthe (n lst)
  `(labels ((nth-fn (n lst)
	      (if (= n 0)
		  (car lst)
		  (nth-fn (- n 1) (cdr lst)))))
     (nth-fn ,n ,lst)))


;; or

(defmacro ora (&rest args)
  (or-expand args))

(defun or-expand (args)
  (if (null args)
      nil
      (let ((sym (gensym)))
	`(let ((,sym ,(car args)))
	   (if ,sym
	       ,sym
	       ,(or-expand (cdr args)))))))


;さらに
(defmacro orb (&rest args)
  (if (null args)
      nil
      (let ((sym (gensym)))
	`(let ((,sym ,(car args)))
	   (if ,sym
	       ,sym
	       (orb ,@(cdr args)))))))

2007-07-16

[]5.6 部分ツリーでの再帰 19:17 はてなブックマーク - 5.6 部分ツリーでの再帰 - drybulbのLisp日記


;; copy-list
(setq x '(a b)
      listx (list x 1))
;=> ((A B) 1)
x ;=> (A B)
listx ;;=> ((A B) 1)

(eq x (car (copy-list listx))) ;=> T

;; copy-tree
(eq x (car (copy-tree listx))) ;=> NIL

;; copy-tree の定義
(defun our-copy-tree (tree)
  (if (atom tree)
      tree
      (cons (our-copy-tree (car tree))
	    (if (cdr tree) (our-copy-tree (cdr tree))))))

;; ツリーの葉を数える
(defun count-leaves (tree)
  (if (atom tree)
      1
      (+ (count-leaves (car tree))
	 (or (if (cdr tree) (count-leaves (cdr tree)))
	     1))))

(count-leaves '((a b (c d)) (e) f))
;=> 10 (#xA, #o12, #b1010)
;atomが6 に nil が 4 (括弧1組につきnil1個)

(count-leaves '(a b))
;=> 3 (#x3, #o3, #b11)

;; すべてのアトムをリストにして返す関数
(flatten '((a b (c d)) (e) f ()))
;=> (A B C D E F)

;; 非効率なflatten を定義してみる
(defun flatten-2 (tree)
  (if (atom tree)
      (mklist tree)
      (nconc (flatten-2 (car tree))
	     (if (cdr tree) (flatten-2 (cdr tree))))))

(flatten-2 '((a b (c d)) (e) f ()))
;=> (A B C D E F)

;; find-ifの再帰版rfind-if
(defun rfind-if (fn tree)
  (if (atom tree)
      (and (funcall fn tree) tree)
      (or (rfind-if fn (car tree))
	  (if (cdr tree) (rfind-if fn (cdr tree))))))

(rfind-if (fint #'numberp #'oddp) '(2 (3 4) 5))
;=> 3 (#x3, #o3, #b11)
;誤字を見つけた addp -> oddp


;; ツリーに対して再帰を行う関数生成関数
;; tree traverser
(defun ttrav (rec &optional (base #'identity))
  (labels ((self (tree)
	     (if (atom tree)
		 (if (functionp base)
		     (function base tree)
		     base)
		 (funcall rec (self (car tree))
			  (if (cdr tree)
			      (self (cdr tree)))))))
    #'self))

; our-copy-tree
(ttrav #'cons)

; count-leaves
(ttrav #'(lambda (l r) (+ 1 (or r 1))) 1)

; flatten
(ttrav #'nconc #'mklist)
(funcall (ttrav #'nconc #'mklist) '(a (b c) (d (e f))))

;; ttrav はツリー全体を探索する
;; rfind-if などは探す対象が見付かった場合、探索を止めたい

;; より一般的なtrec
(defun trec (rec &optional (base #'identity))
  (labels
      ((self (tree)
	 (if (atom tree)
	     (if (functionp base)
		 (funcall base tree)
		 base)
	     (funcall rec tree
		      #'(lambda ()
			  (self (car tree)))
		      #'(lambda ()
			  (if (cdr tree)
			      (self (cdr tree))))))))
    #'self))

;; rfind-if を trec で表現
(funcall
 (trec #'(lambda (o l r) (or (funcall l) (funcall r)))
       #'(lambda (tree) (and (oddp tree) tree)))
 '(2 (3 4) 5))
;=> 3 (#x3, #o3, #b11)

[]7.1 マクロはどのように動作するか 19:17 はてなブックマーク - 7.1 マクロはどのように動作するか - drybulbのLisp日記


;; 引数をnilにするマクロ
(defmacro nil! (var)
  (list 'setq var nil))

(defmacro nil! (var)
  `(setq ,var nil))

[]7.2 バッククォート 19:17 はてなブックマーク - 7.2 バッククォート - drybulbのLisp日記


; when
(defmacro our-when (test &body body)
  `(if ,test
       (progn
	 ,@body)))

; カンマアット
(setq b '(1 2 3))
`(a ,b c)
;=> (A (1 2 3) C)

`(a ,@b c)
;=> (A 1 2 3 C)

; 上の等価
(cons 'a (append b (list 'c)))
;=> (A 1 2 3 C)

(defun greet (name)
  `(hello ,name))
(greet 'paul) ;=> (HELLO PAUL)

[]7.3 単純なマクロの定義 19:17 はてなブックマーク - 7.3 単純なマクロの定義 - drybulbのLisp日記


(member 'b  '(a b c) :test #'eq) ;=> (B C)

(memq 'b '(a b c)) ;をつくる


(memq   x  choices)
;      ↓  ↓
(member x  choices :test #'eq)


(defmacro memq (obj lst)
    `(member ,obj ,lst :test #'eq))
(memq 'b '(a b c)) ;=> (B C)

[]7.4 マクロ展開の確認 19:17 はてなブックマーク - 7.4 マクロ展開の確認 - drybulbのLisp日記


(pprint (macroexpand '(memq 'b '(a b c))))
(pprint (macroexpand-1 '(memq 'b '(a b c))))
;(MEMBER 'B '(A B C) :TEST #'EQ)


(defmacro mac (expr)
  `(pprint (macroexpand-1 ',expr)))
(mac (memq 'b '(a b c)))
;(MEMBER 'B '(A B C) :TEST #'EQ)

[]7.5 パラメータリストの分配 19:17 はてなブックマーク - 7.5 パラメータリストの分配 - drybulbのLisp日記


; gensym なしで dolist
(defmacro our-dolist ((var list &optional result) &body body)
  `(progn
     (mapc #'(lambda (,var) ,@body)
	   ,list)
     (let ((,var nil))
       ,result)))

(our-dolist (x '(a b c))
  (print x))
;A 
;B 
;C

(defmacro when-bind ((var expr) &body body)
  `(let ((,var ,expr))
     (when ,var
       ,@body)))

[]7.6 マクロモデル 19:17 はてなブックマーク - 7.6 マクロのモデル - drybulbのLisp日記


; our-defmacro の写経
(defmacro our-expander (name) `(get ,name 'expander))

(defmacro our-defmacro (name parms &body body)
  (let ((g (gensym)))
    `(progn
       (setf (our-expander ',name)
	     #'(lambda (,g)
		 (block ,name
		   (destructuring-bind ,parms (cdr ,g)
		     ,@body))))
       ',name)))

(defun our-macroexpand-1 (expr)
  (if (and (consp expr) (our-expander (car expr)))
      (funcall (our-expander (car expr)) expr)
      expr))


(mac (defmacro our-expander (name) `(get ,name 'expander)))

(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
  (SB-C::%DEFMACRO 'OUR-EXPANDER
                   #'(LAMBDA (#:WHOLE1816 #:ENVIRONMENT1817)
                       (DECLARE (IGNORE #:ENVIRONMENT1817))
                       (LET* ()
                         (LET ((#:ARGS1819 (CDR #:WHOLE1816)))
                           (UNLESS
                               (SB-INT:PROPER-LIST-OF-LENGTH-P #:ARGS1819
                                                               1 1)
                             (SB-KERNEL::ARG-COUNT-ERROR 'DEFMACRO
                                                         'OUR-EXPANDER
                                                         #:ARGS1819
                                                         '(NAME) 1 1)))
                         (LET* ((NAME (CAR (CDR #:WHOLE1816))))
                           (BLOCK OUR-EXPANDER `(GET ,NAME 'EXPANDER)))))
                   '(NAME) NIL '(MACRO-FUNCTION OUR-EXPANDER)))

[]7.7 プログラムとしてのマクロ 19:17 はてなブックマーク - 7.7 プログラムとしてのマクロ - drybulbのLisp日記


; setq と psetq
(let ((a 1))
  (setq a 2 b a)
  (list a b))
;=> (2 2)

(let ((a 1))
  (psetq a 2 b a)
  (list a b))
;=> (2 1)


; our-do の写経
(defmacro our-do (bindforms (test &rest result) &body body)
  (let ((label (gensym)))
    `(prog ,(make-initforms bindforms)
	,label
	(if ,test
	    (return (progn ,@result)))
	,@body
	(psetq ,@(make-stepforms bindforms))
	(go ,label))))

(defun make-initforms (bindforms)
  (mapcar #'(lambda (b)
	      (if (consp b)
		  (list (car b) (cadr b))
		  (list b nil)))
	  bindforms))

(defun make-stepforms (bindforms)
  (mapcan #'(lambda (b)
	      (if (and (consp b) (third b))
		  (list (car b) (third b))
		  nil))
	  bindforms))