-
Notifications
You must be signed in to change notification settings - Fork 0
/
generalized-variables.lisp
111 lines (92 loc) · 2.94 KB
/
generalized-variables.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
;(defmacro toggle (obj)
; `(setf ,obj (not ,obj))) ;wrong
;(define-modify-macro toggle () not)
(defmacro toggle (&rest args)
`(progn
,@(mapcar #'(lambda (a) `(toggle2 ,a))
args)))
(define-modify-macro toggle2 () not)
(defmacro allf (val &rest args)
(let ((gval (gensym)))
`(let ((,gval ,val))
(setf ,@(mapcan #'(lambda (a) (list a gval))
args)))))
(defmacro tf (&rest args) `(allf t ,@args))
(defmacro nilf (&rest args) `(allf nil ,@args))
(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 (place obj &rest args)
(unless (appply #'member obj place args)
(nconc place (list obj)))))
(defmacro _f (op place &rest args)
(multiple-value-bind (vars forms var set access)
(get-setf-expansion 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-expansion place)
(let ((g (gensym)))
`(let* ((,g ,obj)
,@(mapcar #'list vars forms)
(,(car var) (delete ,g ,access ,@args)))
,set))))
(define-modify-macro pull2 (obj &rest args)
(lambda (seq obj &rest args)
(apply #'delete obj seq args)))
(defmacro pull-if (test place &rest args)
(multiple-value-bind (vars forms var set access)
(get-setf-expansion place)
(let ((g (gensym)))
`(let* ((,g ,test)
,@(mapcar #'list vars forms)
(,(car var) (delete-if ,g ,access ,@args)))
,set))))
(defmacro with-gensyms (syms &body body)
`(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms)
,@body))
(defmacro popn (n place)
(multiple-value-bind (vars forms var set access)
(get-setf-expansion 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)))))
(defmacro sortf (op &rest places)
(let* ((meths (mapcar #'(lambda (p)
(multiple-value-list
(get-setf-expansion p)))
places))
(temps (apply #'append (mapcar #'third meths))))
`(let* ,(mapcar #'list
(mapcan #'(lambda (m)
(append (first m)
(third m)))
meths)
(mapcan #'(lambda (m)
(append (second m)
(list (fifth m))))
meths))
,@(mapcon #'(lambda (rest)
(mapcar
#'(lambda (arg)
`(unless (,op ,(car rest) ,arg)
(rotatef ,(car rest) ,arg)))
(cdr rest)))
temps)
,@(mapcar #'fourth meths))))
(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))