From 1f329af42f842214c494c7903b659b9c65f34a60 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Fri, 8 Aug 2025 13:53:58 -0700 Subject: [PATCH] GETMULTI in MULTI-ALIST is a Place --- library/MULTI-ALIST | 218 ++++++++++++++++++++++++++++++++++++++ library/MULTI-ALIST.LCOM | Bin 0 -> 4392 bytes library/MULTI-ALIST.TEDIT | Bin 0 -> 10908 bytes 3 files changed, 218 insertions(+) create mode 100644 library/MULTI-ALIST create mode 100644 library/MULTI-ALIST.LCOM create mode 100644 library/MULTI-ALIST.TEDIT diff --git a/library/MULTI-ALIST b/library/MULTI-ALIST new file mode 100644 index 000000000..7df2a3a52 --- /dev/null +++ b/library/MULTI-ALIST @@ -0,0 +1,218 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED " 8-Aug-2025 12:59:32"  +{DSK}kaplan>Local>medley3.5>working-medley>library>MULTI-ALIST.;2 11013 + + :EDIT-BY rmk + + :CHANGES-TO (VARS MULTI-ALISTCOMS) + (MACROS GETMULTI FGETMULTI GETMULTI-PAIR REMOVEMULTI REMOVEMULTIALL FGETMULTI-PAIR) + (FNS GETMULTI.EXPAND) + + :PREVIOUS-DATE "10-Jul-2025 12:37:33" +{DSK}kaplan>Local>medley3.5>working-medley>library>MULTI-ALIST.;1) + + +(PRETTYCOMPRINT MULTI-ALISTCOMS) + +(RPAQQ MULTI-ALISTCOMS + ((MACROS GETMULTI GETMULTI-PAIR PUSHMULTI PUTMULTI PUSHMULTI-NEW REMOVEMULTI REMOVEMULTIALL) + (MACROS FGETMULTI FGETMULTI-PAIR FPUSHMULTI FPUTMULTI FPUSHMULTI-NEW) + (FNS MAPMULTI MAPMULTI1 COLLECTMULTI) + (FNS GETMULTI.EXPAND PUTMULTI.EXPAND) + (MACROS ADDTOMULTI) + (FNS ADDTOMULTI1) + (LOCALVARS . T))) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS GETMULTI MACRO [ARGS `(CDR (GETMULTI-PAIR ,@ARGS]) + +(PUTPROPS GETMULTI-PAIR MACRO (ARGS (GETMULTI.EXPAND 'SASSOC ARGS))) + +(PUTPROPS PUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS))) + +(PUTPROPS PUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL T))) + +(PUTPROPS PUSHMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS))) + +(PUTPROPS REMOVEMULTI MACRO [ARGS `(CHANGE [GETMULTI ,@(for ATAIL on ARGS while (CDR ATAIL) + collect (CAR ATAIL] + (REMOVE ,(CAR (LAST ARGS)) + DATUM]) + +(PUTPROPS REMOVEMULTIALL MACRO (ARGS `(RPLACD (GETMULTI-PAIR ,@ARGS) + NIL))) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS FGETMULTI MACRO [ARGS `(CDR (FGETMULTI-PAIR ,@ARGS]) + +(PUTPROPS FGETMULTI-PAIR MACRO (ARGS (GETMULTI.EXPAND 'FASSOC ARGS))) + +(PUTPROPS FPUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS))) + +(PUTPROPS FPUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS))) + +(PUTPROPS FPUSHMULTI-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 8-Aug-2025 12:55 by rmk") + (* ; "Edited 14-Jun-2025 09:47 by rmk") + (* ; "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:") + + (* ;; "This returns the last (key . rest) cell (like ASSOC)") + + `(LET [($$CELL$$ ,(CAR ARGS] + (DECLARE (LOCALVARS $$CELL$$)) + ,@(for ATAIL on (CDR ARGS) collect (if (CDR ATAIL) + then `(SETQ $$CELL$$ (CDR (,ASSOCFN + ,(CAR ATAIL) + $$CELL$$))) + else `(,ASSOCFN ,(CAR ATAIL) + $$CELL$$]) + +(PUTMULTI.EXPAND + [LAMBDA (ASSOCFN ARGS ALLOWREPEATS SINGLEVALUE CHANGE) (* ; "Edited 8-Jul-2025 12:52 by rmk") + (* ; "Edited 14-Jun-2025 09:44 by rmk") + (* ; "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 CHANGE, the last argument is the change expression to be evaluated, with the current value denoted by the atom DATUM") + + (* ;; "") + + (* ;; "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)) + (if (CDR ARGS) + then + (LET + ((VALBINDINGS (FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF))) + EXPANSION) + (SETQ EXPANSION + `(LET + ($$ARG1$$ $$ARG2$$) + (DECLARE (LOCALVARS $$ARG1$$ $$ARG2$$)) + ,@[FOR ATAIL (HEAD _ ACCESSFORM) ON ARGS WHILE (CDR ATAIL) + JOIN + (IF (AND CHANGE (NULL (CDDR ATAIL))) + THEN (POP ATAIL) + [AND NIL `((CL:UNLESS ,HEAD (RPLACD $$ARG1$$ 0)) + (SETQ $$ARG2$$ (ADD ,HEAD ,(CAR ATAIL] + `[(SETQ $$ARG2$$ ,(SUBST HEAD 'DATUM (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 `(CL:SETF ,HEAD $$ARG2$$) + ELSE `(OR (MEMBER $$ARG2$$ ,HEAD) + (push ,HEAD $$ARG2$$] + (SETQ HEAD '(CDR $$ARG1$$)))] + $$ARG2$$)) + (CL:IF VALBINDINGS + `(LET* ,VALBINDINGS (DECLARE (LOCALVARS ,@TEMPVARS)) + ,EXPANSION) + EXPANSION)) + else (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 (2233 4845 (MAPMULTI 2243 . 3311) (MAPMULTI1 3313 . 4370) (COLLECTMULTI 4372 . 4843)) ( +4846 9101 (GETMULTI.EXPAND 4856 . 6174) (PUTMULTI.EXPAND 6176 . 9099)) (10251 10936 (ADDTOMULTI1 10261 + . 10934))))) +STOP diff --git a/library/MULTI-ALIST.LCOM b/library/MULTI-ALIST.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..9c05f28ac28a91b502cdaa8e048dfa42958d541d GIT binary patch literal 4392 zcmb_f-EZ606(^~FpzIPzt`VeqD9(f|yDTO_Bqht%3PV>EWznWchNRp$4QjZN8wGaa zz-iDH!+;fiX#aq{?xpA-ptv*8pzZXsKVdILfxQiV=+m%=VK42@z5J9C2MLfMQOI-e z`JIpZJLg=Ip4qn?v)Z?8vuZhg7vAuwu|+pbs8~*D`nDB#6?nrpX)mN*dqLc#feC6| zk!8XV4BQr)J*dEHmEONu)#_RkRIS}yYwKDCNae=S?Yp-Q_s4K_2RF%o=mlGUd~0-X z|M=ee!QS1&y*umn(T%;s_1pX7!~Ku-T66uwqvL~HcWzcA$@<}~_m20DKVBb>?9i%G z^e(LZUQ-q<*4t{Mt*@bl_m1~doBJQ#J-+vwHf)$7SFf2@J?iw}7W&d3**4_8uGMN4 z81H?6zRpL(u^X+5@>C%|w-7;9>#7cIvuB0X?hYK^J^;CG45+hV2G!67vQ7N}a(OY_ zVW0pRQp0zHG-&82;isaiM=c+GbLeiHTtELzZClQC_*Mk%I~ih}Mg`iQZ*E)eD5&<3 z1yE7z)y?~dDGBseTi2i8p{t5Kq+aB2ySFM68%RBhpVLAC59)B~5~E1p^{KxRT)G4n zsDNsHM*(5=B|(r%MS;E|;Gct%_Tr}XpTEAgwRE*Jh-9y_h2nSi>AB&geEplvgMVC` z{&RTw+v$G=qU#KZ+gCwb1&3LH_i#w{CG>|xv z=s8cqT+(9&^!1z=CAmYnu|ZKFYpI3QK*GtSB$H(E`~+x%27znfsUhOt3y64=dCq^R zI4PGW4)-w&8`X&(D zHK@(&HQlZ#vNxLVOGy$M5S2M{AwbgD<~FrQCUOL8(|y}FJ#4x`M5XyuiC>-*gcqsE z`OSYydoK;x`Ck*i*_0$n{FaWTFCK`0nps<=?yuZp;k59%xO;Kto-ds4xJyfuzkSEk z$8*Pjs9mba?)ly2!k^t`>8m~5#O3^SF>~(@5wFIThS?cdEbR{d!_sEDb!dhIw}%YWTPtw){=Et4D^27l_7;s%b_Gk+9Cl3~tGfv<{?||$ zE>i{_M|7l9uQQ=H3I?F9HNl`h_O(WaqqSCc-dde9oIB4UeLqY+Cr z4R9EYhM=iAk2Dn{WL2ct)#s4wH6RokBM~!^i`b|S!5Pp z8>@4#x;FQUIVPCmAazv14D*^z09q~ij53YmO>HTFEi*FB@{q}8+UtdGJQtD@)&Of3 zOLWWJVI}I>)G%2us}%&HKs%)+X;3(ot*#}NU+)&hYZm9o>3M6sIVm&YOk!nwb^3!q zG|Vk;hiUgDIC#Tw2M50AOW6^{ znwdaFiJVcg2BCtjnIM$syIywd!5N14Dj>*<07&=B$i*uUXD69YBDwy%4x91;;yfNI z%ElaC0+Gx^65+?^p1|eY%2GLpvycIJ3Y_>Ho)rdgU@qn=b&8YaSrO-xm1EZ#spnT= zNV5+-@#OuZW1t~L=kSw*AJ&Hx`~r!NiZ3W2-#9uv+`sVw3bE%!LbMJfGRlymC1O+T z%JE@Fjg6gYo*y|su?imVs?X}bm$@1dAV(CI%mv)Eb{-GO+9FB!JOX$Y*wa(5AGMq$ z_#E}Jik)}u4DLM<=o!fOM4Y&9JvHyn2Fp6bd~`S|d296WyP4m|s$C0bGzrb2$8UBh z#Ltdl072;DcMsHtdZnak1x3t)g$$cn&>j9 zrLiYG098EYKllJ1c;O538@%!fR8eNFefk`ATXRh%1rJOjS-sD`uD#Db`}AhqAI1l- zZ*Db1f6Z$=V&OuN&uHCp*E$CBw)5(6)k5d(?-efq8d$R?{hUCrL+~PK@v}+X>XA9qTy9Fnh$5m+7LWL z6{YEn82fC+>f8b$L#}XQ_*xgnL+eGjpw87cuF@ui4W4M3J0-vNOiWl8-j<5 z`h9vmj-RRhXgH7QSfoTP7GJXdhu1zb|%x2R^3B<+p*dM1c(abJB32jCLn(AuRbw($@$+c3H$+&8mfw%2NwhtT)nmWq zb!k5tC$j_!KZQvoqvbcnJBbvvHF-v-PjQ#~Xg=y=-g4 z4eISy%Y9lYF$Rl|mU)&8hfL{9SeD9Vx?QH*<;-p4waU3tG0v#6HeQri*sfHt!A<$+ zi&!?EE+p-mY|Flyqdul6zBK;bJRbLAvyG69-T)g{>Ol(kZmDb)E*1Ks$eDdciToj7 zx(tM{$YoB^5qYST1Tek%L|V3Lc>#$sFjcA&@j|;gO`5H=ig$L{$Ix*OSZ>(-Kxra2 zcc#&4mBsdYc`Sh;p-CbDNLcpsNaGY{-W~QRQ}^%3ZhHZP%0(r^IUHRq?M} zbHR-b&FzFA?N(QbR7LNY3jRzLA7Mgjs8$cOKZd(#2AY@caMM(P$sg0kgSC$92k4T6Xdl6hI5rFu3=@LSU8VdPCy+&`dr>k~&jyn;MmGRP=A6tz z#<{rYG+OsDeXFyTHF@G>54E+H_gGFIIlwrJqzdR0=VPes#ZjN>G=-1mgAr>sotv(t2Phuf*(5L-qgUxXpL|%m;{%`;?KOGdM$crh|nl?#rs>FF#eg%J`1SZ^{Pf*(U(zpqbo;`33X z-3q&YtJV%Y)sJQo00U|VJi0Te3oH$H({DaiUH=15HQbt~f_CVJe!HdW-XkB+)K`%m zZw5&^xkz!*;z{Z%xe-FLd_vYjySK~$l@B&IAE7>w9?U(Mfl-p<35K@e6iLR|sy4k% z%p_*2k{klm{KQo)H8_v&$5TD_=m8AKWivMRB;b)#C09JzIm3f%irq5>lNkq@3tdk0 zDGSxbB=XW!D6=BUV-(F$&XRiXVYO6l*nOamN5>pZ5Xe%y#BV2r9B($Ap8|d>WO~JE z9Wwk!?Em7 z(Bu31Cc@6ca!Ikmo&a&|c;qUBb<&hC7P~gR#b(q22Ee*F^W`1Wr))(4Mx1+9>)Ywko@Ud(W?_OPBC}1$wFf_VpX;op*20%7*9Gp-H67 zL-@3VF=eaO!UEU9cV}I_v%aow-MFJ}-mZ`v#L#;ZilDd-mUnNf^;@^q?Q7RG3+=hh z5N|77yjdXE8G>Aj;SleIM=R|h&}O^+psUIcx7@m_c`X?B;Cv155wex;7Llw4ekTMB ze(RCn_3t%3)owIY*JELJ09z=}9Smw9paIA#=eO(EFr&ygx7n^EDuojzXyVn6W(foT zf!E&B;#=4hi#6{_$8B{v^#$JjttQ6$ZnI64v!}68ZzI8Zx_y=KN;xj&S%bND|f(70RSz(j`=bIUlV~-Sok%S!6o^7DU}zw z)w6!$T+AI3n){IN3(gy;rq|GnH~p5|boAl(R+()XJ+^~}jRP8Q6|3qVULHJRteG$|7;xNVw zv{Rb@DpUXB--z#o)W7X~O=EV7N`2-tlrrXN;<8c^5gn#F7>^Tm*Bs!MfI2Sj9t)^GS>z780D{{ga zCjR^7FtO!Gs5;(rlG!6w8>VCJ8zy#>Z{TA?WAtyoOpv$;2O}bf{3i9Uq|uT@O^Tdg ze3C{*%4K{C`oBv8SNIV=fw@3=g-fJ}V)@E!+m$X^xFTw-G%4q~WGVE-s##uoi_8V7 zD~2MP>6{#^*rLL@mH34yvGbWW5CfCb7;3Xvl2hzA)K ztW0r9Op@hChGGmDK3v6e&967XOt(qCGK1Pb6og*wT6*58{)hJT(+a1f_m#C{pO8NVQRqEy$l5 zo@HC6wth$!O7n9>!;vL^9bTf0$~r2x>4bGlP$I>cJk74KAxPO9{Fqj2KvZ%?GS4Sl zq~b82{(+B9ZdTd9A|bC16X_u}LA>PRKvo+*10dlvm>nHJu>hz~wg3aLA=$*yBvnZb z7g%i6R_FovM1{mBUyvqdQeg~3LSe2%s6ep}ODZW1ijMdDcsN^)6vX8aDcJhbtsmq3 znXDJ8jX~IC$qxo`jbJbU;U$F#OYMEc9}-)JyS2Tf_qJh`ae?kj2o#o?gHO~g>g0#4 zXL=_wTXGmt&%X?Xu@H^RByhz9XJrgQIF1iRQJmgM>5