perm filename CYCLIC[PAT,LMM] blob sn#097616 filedate 1974-04-15 generic text, type T, neo UTF8

(FILECREATED "15-APR-74 03:31:56" CYCLIC2) (LISPXPRINT (QUOTE CYCLIC2VARS) T) (RPAQQ CYCLIC2VARS ((FNS FVPARTITIONS FVPARTITION1 FVPART1) (FNS LOOPPARTITIONS LOOPPARTITIONS1 LPROWS CLPARTLP1 CLPARTITIONSL NEWNODES NEWNODES1 GRAPHON MINLOOPS MAXLOOPS ROWS) (FNS SUPERATOMPARTITIONS MAXUNSATL))) (DEFINEQ (FVPARTITIONS (LAMBDA (FV VL) (for FVP in (FVPARTITION1 FV (CDR VL) 1) bind FVR eachtime (SETQ FVR (ROWS FVP)) collect (create FVPARTITION NEWVL ← (for ROW in FVR as COL in (CONS NIL FVP) as V in VL collect (IPLUS V (SUMOF ROW) (IMINUS (SUMOF COL)))) FVR ← FVR)))) (FVPARTITION1 (LAMBDA (N VL S) (* Partition N into as many parts as length VL; with the Ith part having at most VL:I* (S+I) - Then partition the ith part according to FVPART1) (COND ((NULL VL) (LIST NIL)) (T (bind ((MAXI← (IMIN N (ITIMES (CAR VL) S)))) for I from (IMAX 0 (IDIFFERENCE N (TD (CDR VL) (ADD1 S)))) to MAXI eachtime (SETQ PARTREST (FVPARTITION1 (IDIFFERENCE N I) (CDR VL) (ADD1 S))) join (for FIRSTPART in (FVPART1 I (CAR VL) S) join (for RESTPART in PARTREST rcollect (CONS FIRSTPART RESTPART)))))))) (FVPART1 (LAMBDA (N MAXSUM MAXOCCUR) (* Partition N into parts of the form MAXOCCUR * I1 , MAXOCCUR-1 * I2 , MAXOCCUR-2 * I3 ... where the SUM of the I's is less than or equal to MAXSUM) (* WARNING: value may be RPLAC'ed) (COND ((ZEROP MAXOCCUR) (LIST NIL)) ((ZEROP N) (LIST (LISTOF MAXOCCUR 0))) (T (for I from (MAX 0 (IDIFFERENCE N (ITIMES MAXSUM (SUB1 MAXOCCUR)))) bind ((MAXI← (MIN MAXSUM (IQUOTIENT N MAXOCCUR)))) to MAXI join (for REST in (FVPART1 (IDIFFERENCE N (ITIMES I MAXOCCUR)) (IDIFFERENCE MAXSUM I) (SUB1 MAXOCCUR)) rcollect (CONS I REST))))))) ) (DEFINEQ (LOOPPARTITIONS (LAMBDA (NLOOPS VLIST) (* Returns a list of lists of LOOPPARTITIONs, sorted by NEWVL, for NLOOPS loops among the valence list VL; a LOOPPARTITION consists of a NEW.VALENCE.LIST (new valence list) , EDGELABELS (a composition list of number-of-bivalents) , and LOOPLABELS (a composition list of loop-types, where a loop-type is a composition list of number-of-bivalents) %. For example, the looplabels: ((((5 . 2) (3 . 2)) . 1) (((1 . 2)) . 3)) means that 1 node gets two loops with 5 bivalents and two loops with 3; and that three nodes get two loops with 1 bivalent (e.g. O=X=O)) (* LOOPPARTITIONS1 determines where the loops will go; LOOP.ARRAY.ROWS is a list ROWS:2 ROWS:3 ROWS:4 ... , where ROWS:i is a list: ((number of i valent nodes with no loops) (number of i valent nodes getting 1 loop) (number of i valent nodes getting 2 loops) ...) where the valence refers to the valence in the NEW graph) (for LPP in (LOOPPARTITIONS1 NLOOPS (CDDR VLIST) 4) bind LPROWS NEWVLIST when (GRAPHON (TRIMZEROS (SETQ NEWVLIST (CONS (SUMOF (CDAR (SETQ LPROWS (LPROWS LPP VLIST)))) (for X in (CDR LPROWS) collect (SUMOF X)))))) rcollect (for NBIVEDGES from 0 to MAXI bind ((MAXI← (MIN (IDIFFERENCE (CAR VLIST) NLOOPS) (IQUOTIENT (TD NEWVLIST 2) 2)))) join (for BIVPART in (NUMPARTITIONS (CAR VLIST) (IPLUS NLOOPS NBIVEDGES) 1 NIL) bind BIVPARTCL eachtime (SETQ BIVPARTCL (CLCREATE BIVPART)) join (for BIVEDGES in (CLPARTS BIVPARTCL NBIVEDGES) join (for LOOP.BIVALENTS in (CLPARTITIONSL (CLDIFF BIVPARTCL BIVEDGES) (TRIMNILS (CDRLIST LPROWS))) rcollect (create LOOPPARTITION LOOPVL ← NEWVLIST EDGELABELS ← BIVEDGES LOOPLABELS ← LOOP.BIVALENTS)))))))) (LOOPPARTITIONS1 (LAMBDA (P VL J) (* P is a number of loops; VL is a valencelist starting with J-valents; returns the partitions of number of loops among these nodes - a partition is of the form (j-valentpart j+1-valentpart ...) where each part is (number of single loops, number of double loops, ...)) (COND ((NULL VL) (LIST NIL)) (T (* PJ is the number of loops allocated to J-valents; MAXREST is the max number of loops that can go on the rest) (for PJ from (IMAX 0 ( IDIFFERENCE P (MAXREST (CDR VL) (ADD1 J)))) to MAXI bind ((MAXI← (IMIN P (ITIMES (SUB1 (IQUOTIENT J 2)) (CAR VL))))) bind RESTL eachtime (SETQ RESTL ( LOOPPARTITIONS1 (IDIFFERENCE P PJ) (CDR VL) (ADD1 J))) join (for THISPART1 in (FVPART1 PJ (CAR VL) (SUB1 (IQUOTIENT J 2))) bind THISPART eachtime (SETQ THISPART (TRIMZEROS (DREVERSE THISPART1))) join (for RESTPART in RESTL rcollect (CONS THISPART RESTPART)))))))) (LPROWS (LAMBDA (LPP VL) (* VL is a valencelist starting with bivalents - LPP is an output from LOOPPARTITIONS1: LPP:i+2 corresponds to VL:i, and is the list (number of single loops, number of double loops, ... for the i-valent nodes)) (SETQ VL (CONS (CAR VL) (CONS (CADR VL) (for V2 in (CDDR VL) as LOOPLST in LPP collect (IDIFFERENCE V2 (SUMOF LOOPLST)))))) (* This VL is now the valence list with the looped nodes removed) (for V in VL collect (CONS V (NEWNODES (PROG1 LPP (SETQ LPP (CDR LPP)))))))) (CLPARTLP1 (LAMBDA (CL ROW N) (COND ((NULL ROW) (LIST NIL)) ((ZEROP (CAR ROW)) (CLPARTLP1 CL (CDR ROW) (ADD1 N))) (T (for EP in (CLPARTS CL (ITIMES N (CAR ROW))) bind RPL eachtime (SETQ RPL (CLPARTLP1 (CLDIFF CL EP) (CDR ROW) (ADD1 N))) join (for EEP in (CLEQUALPARTS EP (CAR ROW) N) join (for RP in RPL collect (NCONC (CLCREATE EEP) RP)))))))) (CLPARTITIONSL (LAMBDA (CL LL) (* This function does much of the work of LOOPPARTITIONS - CL is a compositionlist of bivalents; LL is a list (l:2 l:3 l:4 ...) where l:i is the list (number of single loops, number of double loops , ...) for the i-valents; this function returns the list of possible ways of distributing those bivalents among those loops) (COND ((NULL LL) (LIST NIL)) (T (PROG ( RESULTS RESTPARTLIST) (for FIRSTPART in (CLPARTS CL (TD (CAR LL) 1)) do (* (TD L:I 1) is the number of total loops on the i-valents) (SETQ RESTPARTLIST (CLPARTITIONSL (CLDIFF CL FIRSTPART) (CDR LL))) (* Take away the ones going to the i-valent loops) (for THISPART in (CLPARTLP1 FIRSTPART (CAR LL) 1) do (* CLPARTLP1 partitions FIRSTPART among the single-loops, double-loops as specified in (CAR LL)) (for RP in RESTPARTLIST do (SETQ RESULTS (CONS (CONS THISPART RP) RESULTS))))) (RETURN RESULTS)))))) (NEWNODES (LAMBDA (LPP) (* LPP is a list: LPP:i-2 is a list for the old i+VALENCE nodes of the (number of single loops, number of double loops, ...) ; this function returns (number of VALENCE+2 nodes getting 1 loop, number of VALENCE+4 nodes getting 2 loops, ...)) (NEWNODES1 LPP 1))) (NEWNODES1 (LAMBDA (LPP J) (COND ((NULL LPP) NIL) (T (PROG ((TEM (NEWNODES1 (CDDR LPP) (ADD1 J))) (TEM2 (CAR (NTH (CAR LPP) J)))) (COND ((AND (NULL TEM) (OR (NULL TEM2) (ZEROP TEM2))) NIL) (T (CONS (OR TEM2 0) TEM)))))))) (GRAPHON (LAMBDA (VL) (SETQ VL (TRIMZEROS VL)) (AND (EVENP (TD VL 2)) (NOT (IGREATERP (ITIMES 2 (MAXDEG VL 2)) (TD VL 2)))))) (MINLOOPS (LAMBDA (VALENCELIST) (SETQ VALENCELIST (TRIMZEROS VALENCELIST)) (* Same as - max { 0 , w2+ (2M (W) -TD (W)) /2⎇) (MAX 0 (IPLUS 1 (LENGTH VALENCELIST) (IQUOTIENT (TD (CDR VALENCELIST) 3) -2))))) (MAXLOOPS (LAMBDA (VALENCELIST) (MIN (CAR VALENCELIST) (MAXREST (CDDR VALENCELIST) 4)))) (ROWS (LAMBDA (LL) (COND ((NULL LL) (QUOTE (NIL))) (T (CONS (CARLIST LL) (ROWS ( CDRLIST (CDR LL)))))))) ) (DEFINEQ (SUPERATOMPARTITIONS (LAMBDA (CL U) (PROG (CL1 SZ MXUI VI) (SETQ CL1 (for PR in CL when (EQ (VALENCE (CAR PR)) 1) collect PR)) (SETQ CL (CLDIFF CL CL1)) (SETQ SZ (CLCOUNT CL)) (RETURN (for PARTSIZE from 2 to SZ join (for VHAT in (CLPARTS CL PARTSIZE) bind REMATS eachtime (SETQ REMATS (APPEND CL1 (CLDIFF CL VHAT))) join (for #PARTS from (IQUOTIENT PARTSIZE 2) to 1 by -1 join (for PARTITION in ( CLPARTITIONSN VHAT #PARTS 2) bind VI MXUI eachtime (PROGN (SETQ VI (CLCREATE PARTITION)) (SETQ MXUI (MAXUNSATL VI (COND ((AND (NULL REMATS) (NULL (CDR PARTITION))) U))))) join (for UI in (NUMPARTITIONS' U 1 MXUI (collect CDR in VI)) rcollect (create SUPERATOMPARTITION SUPERATOMPARTS ← (CLCREATE (collect (CONS Y X) for X in (CLEXPAND VI) as Y in UI)) REMAININGATOMS ← REMATS)))))))))) (MAXUNSATL (LAMBDA (PC U) (* Note U is either NIL (normal) or it is equal to the unsaturation in the case where remats is NIL and there is only one part here) (for PARTNUM in PC collect (PROG (N TD M) (SETQ N (SETQ TD (SETQ M 0))) (for PR in (CAR PARTNUM) do (SETQ N (IPLUS N (CDR PR))) (SETQ TD (IPLUS TD (ITIMES (CDR PR) (VALENCE (CAR PR))))) (SETQ M (MAX M (VALENCE (CAR PR))))) (SETQ N (IDIFFERENCE (IPLUS 2 TD) (ITIMES 2 N))) (RETURN (IQUOTIENT (IPLUS N (MIN (COND ((AND U (EQ (ITIMES U 2) N)) 0) (T -1)) (IDIFFERENCE TD (ITIMES 2 M)))) 2)))))) ) STOP