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日記

l

[]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日記

Statement

[]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))