-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathMULTI-ALIST
239 lines (195 loc) · 12.2 KB
/
MULTI-ALIST
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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Jan-2025 19:34:13" {WMEDLEY}<lispusers>MULTI-ALIST.;15 12223
:EDIT-BY rmk
:CHANGES-TO (FNS MAPMULTI)
:PREVIOUS-DATE "25-Jan-2025 15:04:13" {WMEDLEY}<lispusers>MULTI-ALIST.;14)
(PRETTYCOMPRINT MULTI-ALISTCOMS)
(RPAQQ MULTI-ALISTCOMS
((MACROS GETMULTI PUTMULTI PUTMULTI-D PUTMULTI-NEW PUTMULTI-COUNT PUTMULTI-SUM REMOVEMULTI
REMOVEMULTIALL)
(MACROS FGETMULTI FPUTMULTI FPUTMULTI-D FPUTMULTI-NEW)
(FNS MAPMULTI MAPMULTI1 COLLECTMULTI)
(FNS GETMULTI.EXPAND PUTMULTI.EXPAND REMOVEMULTI.EXPAND)
(MACROS ADDTOMULTI)
(FNS ADDTOMULTI1)
(LOCALVARS . T)))
(DECLARE%: EVAL@COMPILE
(PUTPROPS GETMULTI MACRO (ARGS (GETMULTI.EXPAND 'SASSOC ARGS)))
(PUTPROPS PUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS)))
(PUTPROPS PUTMULTI-D MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL T)))
(PUTPROPS PUTMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS)))
(PUTPROPS PUTMULTI-COUNT MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC (APPEND ARGS '(1))
NIL NIL T)))
(PUTPROPS PUTMULTI-SUM MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL NIL T)))
(PUTPROPS REMOVEMULTI MACRO (ARGS (REMOVEMULTI.EXPAND ARGS)))
(PUTPROPS REMOVEMULTIALL MACRO (ARGS (REMOVEMULTI.EXPAND ARGS T)))
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS FGETMULTI MACRO (ARGS (GETMULTI.EXPAND 'FASSOC ARGS)))
(PUTPROPS FPUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))
(PUTPROPS FPUTMULTI-D MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS NIL T)))
(PUTPROPS FPUTMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))
)
(DEFINEQ
(MAPMULTI
[LAMBDA (MULTIALIST MAPFN) (* ; "Edited 29-Jan-2025 19:33 by rmk")
(* ; "Edited 25-Jan-2025 14:51 by rmk")
(* ; "Edited 16-Jan-2025 10:32 by rmk")
(* ; "Edited 6-Jan-2020 10:15 by rmk:")
(* ;; "MAPMULTI applies a mapping function of N args to each item in an N-way item in the multi-alist at MULTIALIST. If an item C is inserted by (PUTMULTI FOO A B C), then MAPFN should be a 3 argument function and it will be applied to A B C. The caller is responsible for making sure the arities of the index and the mapfn correspond.")
(DECLARE (SPECVARS MAPFN))
(LET ($$LISTFORARGS$$)
(DECLARE (SPECVARS $$LISTFORARGS$$))
(SETQ $$LISTFORARGS$$ (FOR I FROM 1 TO (NARGS MAPFN) COLLECT NIL))
(MAPMULTI1 MULTIALIST $$LISTFORARGS$$ (NARGS MAPFN])
(MAPMULTI1
[LAMBDA (SUBALIST ARGLIST NREMAINING) (* ; "Edited 25-Jan-2025 15:03 by rmk")
(* ; "Edited 22-Jan-2025 23:42 by rmk")
(* ; "Edited 16-Jan-2025 10:29 by rmk")
(* ; "Edited 6-Jan-2020 10:21 by rmk:")
(DECLARE (USEDFREE $$LISTFORARGS$$ MAPFN))
(if [AND (IGREATERP NREMAINING 1)
(LISTP (CAR (LISTP SUBALIST]
then
(* ;; "Still a list of alists.")
(for SI in SUBALIST do (RPLACA ARGLIST (CAR SI))
(MAPMULTI1 (CDR SI)
(CDR ARGLIST)
(SUB1 NREMAINING)))
else (for ITEM inside SUBALIST do (RPLACA ARGLIST ITEM)
(APPLY MAPFN $$LISTFORARGS$$])
(COLLECTMULTI
[LAMBDA (MULTIALIST MAPFN) (* ; "Edited 25-Jan-2025 15:00 by rmk")
(* ; "Edited 22-Jan-2025 23:44 by rmk")
(* ; "Edited 6-Jan-2020 10:15 by rmk:")
(LET ($$COLLECT)
(DECLARE (SPECVARS $$COLLECT))
(MAPMULTI MULTIALIST MAPFN)
$$COLLECT])
)
(DEFINEQ
(GETMULTI.EXPAND
[LAMBDA (ASSOCFN ARGS) (* ; "Edited 16-Jan-2025 10:27 by rmk")
(* ; "Edited 19-Jul-2020 00:38 by rmk:")
(* ; "Edited 22-Mar-2020 13:21 by rmk:")
(* ; "Edited 27-Feb-2020 13:44 by rmk:")
(* ; "Edited 30-Dec-2019 20:50 by rmk:")
(* ;; "If SUM, returns the value after the last argument, paired with PUTMULTISUM")
(IF (CDR ARGS)
THEN `(LET ($$CELL$$)
(DECLARE (LOCALVARS $$CELL$$))
,@[FOR ATAIL (HEAD _ (CAR ARGS)) ON (CDR ARGS)
COLLECT (PROG1 `[SETQ $$CELL$$ (CDR (,ASSOCFN ,(CAR ATAIL)
,HEAD]
(SETQ HEAD '$$CELL$$))]
$$CELL$$)
ELSE (CAR ARGS])
(PUTMULTI.EXPAND
[LAMBDA (ASSOCFN ARGS ALLOWREPEATS SINGLEVALUE SUM) (* ; "Edited 23-Jan-2025 09:40 by rmk")
(* ; "Edited 16-Jan-2025 10:18 by rmk")
(* ; "Edited 17-Aug-2020 14:09 by rmk:")
(* ;; "If ALLOWREPEATS, doesn't test (MEMBER) for preexisting values, just accumulates")
(* ;; "If SINGLEVALUE, new value smashes out old")
(* ;; "For SUM, the last argument is the increment to be added to the current value, and the incremented value is returned for PUTMULTISUM and for GETMULT")
(* ;; "")
(* ;; "We get the setf method so that any expressions in the form will be evaluated only once.")
(CL:MULTIPLE-VALUE-BIND
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
(CL:GET-SETF-METHOD (CAR ARGS))
(CL:IF (CDR ARGS)
`(LET*
,(FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF))
(DECLARE (LOCALVARS ,@TEMPVARS))
(LET
($$ARG1$$ $$ARG2$$)
(DECLARE (LOCALVARS $$ARG1$$ $$ARG2$$))
,@[FOR ATAIL (HEAD _ ACCESSFORM) ON ARGS WHILE (CDR ATAIL)
JOIN
(IF (AND SUM (NULL (CDDR ATAIL)))
THEN (POP ATAIL)
`[(CL:UNLESS ,HEAD (RPLACD $$ARG1$$ 0))
(SETQ $$ARG2$$ (ADD ,HEAD ,(CAR ATAIL]
ELSE
(PROG1 `[(SETQ $$ARG2$$ ,(CADR ATAIL))
,(IF (CDDR ATAIL)
THEN `[SETQ $$ARG1$$ (OR (,ASSOCFN $$ARG2$$ ,HEAD)
(CAR (CL:PUSH (CONS $$ARG2$$)
,HEAD]
ELSEIF ALLOWREPEATS
THEN `(push ,HEAD $$ARG2$$)
ELSEIF SINGLEVALUE
THEN `(RPLACD $$ARG2$$)
ELSE `(OR (MEMBER $$ARG2$$ ,HEAD)
(push ,HEAD $$ARG2$$]
(SETQ HEAD '(CDR $$ARG1$$)))]
$$ARG2$$))
(CAR ARGS))])
(REMOVEMULTI.EXPAND
[LAMBDA (ARGS ALLFLAG) (* ; "Edited 16-Jan-2025 10:34 by rmk")
(* ; "Edited 17-Aug-2020 15:12 by rmk:")
(* ; "Edited 17-May-2020 17:25 by rmk:")
(* ; "Edited 14-Feb-2020 11:24 by rmk:")
(* ; "Edited 25-Dec-2019 09:57 by rmk:")
(* ;; "If ALLFLAG, then all data after the last of ARGS, if any, is removed. That is, if there are 3 keys to the index, and REMOVEMULTIALL is invoked with 2 keys, then it's as if no entries were made for any of the third keys after those first two. In the case of REMOVEMULTIALL, it returns the previous tail.")
(* ;; "No point in distinguishing FASSOC from SASSOC here.")
(CL:MULTIPLE-VALUE-BIND
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
(CL:GET-SETF-METHOD (CAR ARGS))
(CL:IF (CDR ARGS)
`(LET*
,(FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF))
(DECLARE (LOCALVARS ,@TEMPVARS))
(LET
($$ARG1$$ $$ARG2$$)
(DECLARE (LOCALVARS $$ARG1$$ $$ARG2$$))
,@[FOR ATAIL (HEAD _ ACCESSFORM) ON ARGS WHILE (CDR ATAIL)
JOIN (PROG1 `[(SETQ $$ARG2$$ ,(CADR ATAIL))
,(IF (CDDR ATAIL)
THEN `(SETQ $$ARG1$$ (SASSOC $$ARG2$$ ,HEAD))
ELSEIF ALLFLAG
THEN `(CL:WHEN (SETQ $$ARG1$$ (SASSOC $$ARG2$$ ,HEAD))
(SETQ $$ARG2$$ (CDR $$ARG1$$))
(RPLACD $$ARG1$$))
ELSE `(AND (SETQ $$ARG2$$ (MEMBER $$ARG2$$ ,HEAD))
(RPLACD $$ARG1$$ (DREMOVE (SETQ $$ARG2$$ (CAR $$ARG2$$))
,HEAD]
(SETQ HEAD '(CDR $$ARG1$$)))]
$$ARG2$$))
(CAR ARGS))])
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS ADDTOMULTI MACRO [ARGS (CL:MULTIPLE-VALUE-BIND
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
(CL:GET-SETF-METHOD (CAR ARGS))
`(LET* [,@(FOR VF IN VALFORMS AS TV IN TEMPVARS
COLLECT (LIST TV VF))
($$KEYS ,(CADR ARGS]
(DECLARE (LOCALVARS $$KEYS ,@TEMPVARS))
(COND
[(LISTP $$KEYS)
(CL:UNLESS (SASSOC (CAR $$KEYS)
,ACCESSFORM)
(CL:PUSH (CONS (CAR $$KEYS))
,ACCESSFORM))
(ADDTOMULTI1 ,ACCESSFORM $$KEYS ,(CADDR ARGS]
(T (CL:SETF ,ACCESSFORM ,(CADDR ARGS])
)
(DEFINEQ
(ADDTOMULTI1
[LAMBDA (PLACE KEYS VAL) (* ; "Edited 22-Jan-2025 23:47 by rmk")
(* ; "Edited 17-Aug-2020 15:05 by rmk:")
(* ;; "This allows the keys to be provided in a single list rather than as separate arguments.")
(FOR I (P _ PLACE) IN KEYS DO [SETQ P (OR (SASSOC I P)
(CAR (PUSH (CDR P)
(CONS I] FINALLY (PUSH (CDR P)
VAL))
VAL])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1837 4449 (MAPMULTI 1847 . 2915) (MAPMULTI1 2917 . 3974) (COLLECTMULTI 3976 . 4447)) (
4450 10311 (GETMULTI.EXPAND 4460 . 5581) (PUTMULTI.EXPAND 5583 . 7995) (REMOVEMULTI.EXPAND 7997 .
10309)) (11461 12146 (ADDTOMULTI1 11471 . 12144)))))
STOP