perm filename CYCOMA.LSP[3,LMM] blob
sn#037464 filedate 1973-04-21 generic text, type T, neo UTF8
(DEFPROP CYCOMAFNS
(CYCOMAFNS MAXLIST
TWICE
CARLIST
CDRLIST
LCARLIST
LCDRLIST
DIFF
PLUSLIST
LMASSOC
NUMPARTITIONS
CLPARTITIONS
CLPARTS
CL=PARTS
CLDIFF
CLCOUNT
CLPARTITIONSN
CLCREATE
CLINSERT
CLEXPAND
GENRAD
GENRADS
GENRADLIST
GENRADLIST1
GROUPRADS
GROUPRADS1
VALENCE
GENMOL
NUMPARTITIONS*
GROUPBY
FVPARTITION1
FVPART1
MINLOOPS
MAXLOOPS)
VALUE)
(DEFPROP MAXLIST
(LAMBDA (L) (FOR NEW X IN L MAX X))
EXPR)
(DEFPROP TWICE
(LAMBDA (X) (PLUS X X))
EXPR)
(DEFPROP CARLIST
(LAMBDA (L) (FOR NEW X IN L LIST (CAR X)))
EXPR)
(DEFPROP CDRLIST
(LAMBDA (L) (FOR NEW X IN L LIST (CDR X)))
EXPR)
(DEFPROP LCARLIST
(LAMBDA (L) (FOR NEW X IN L LIST (CARLIST X)))
EXPR)
(DEFPROP LCDRLIST
(LAMBDA (L) (FOR NEW X IN L LIST (CDRLIST X)))
EXPR)
(DEFPROP DIFF
(LAMBDA (L1 L2) (FOR NEW X IN L1 WHEN (NOT (MEMBER X L2)) XLIST X))
EXPR)
(DEFPROP PLUSLIST
(LAMBDA (L) (FOR NEW X IN L PLUS X))
EXPR)
(DEFPROP LMASSOC
(LAMBDA (X Y VAL) (PROG2 (FOR NEW PR IN Y DO (IF (EQUAL (CAR PR) X) THEN (RETURN (SETQ VAL (CDR PR))))) VAL))
EXPR)
(DEFPROP NUMPARTITIONS
(LAMBDA(N NUMPARTS MINPART MAXPART)
(IF (EQUAL NUMPARTS 1.)
THEN
(IF (OR (GREATERP MINPART N) (LESSP MAXPART N)) THEN NIL ELSE (LIST (LIST N)))
ELSE
(FOR NEW
I
:=
((MAX MINPART (DIFFERENCE N (TIMES (SUB1 NUMPARTS) MAXPART))) (MIN MAXPART (QUOTIENT N NUMPARTS)))
FOR
NEW
RESTPART
IN
(NUMPARTITIONS (DIFFERENCE N I) (SUB1 NUMPARTS) I MAXPART)
LIST
(CONS I RESTPART))))
EXPR)
(DEFPROP CLPARTITIONS
(LAMBDA(CL PARTSIZES)
(IF (NULL PARTSIZES)
THEN
(LIST NIL)
ELSEIF
(NULL (CDR PARTSIZES))
THEN
(LIST (LIST CL))
ELSEIF
(ZEROP (CAR PARTSIZES))
THEN
(MAPCAR (FUNCTION (LAMBDA (X) (CONS NIL X))) (CLPARTITIONS CL (CDR PARTSIZES)))
ELSEIF
(EQUAL (CAR PARTSIZES) (CADR PARTSIZES))
THEN
(PROG (N THISPART)
(SETQ N 1.)
(SETQ THISPART (CAR PARTSIZES))
(FOR PARTSIZES ON (CDR PARTSIZES) WHILE (EQUAL (CAR PARTSIZES) THISPART) DO (SETQ N (ADD1 N)))
(IF (NULL PARTSIZES) THEN (RETURN (CL=PARTS CL N THISPART)))
(RETURN
(FOR NEW
BIGPART
IN
(CLPARTS CL (TIMES N THISPART))
AS
NEW
RESTPARTSLIST
IS
(CLPARTITIONS (CLDIFF CL BIGPART) PARTSIZES)
FOR
NEW
LITTLEPARTS
IN
(CL=PARTS BIGPART N THISPART)
FOR
NEW
RESTPARTS
IN
RESTPARTSLIST
XLIST
(APPEND LITTLEPARTS RESTPARTS))))
ELSE
(FOR NEW
PART
IN
(CLPARTS CL (CAR PARTSIZES))
FOR
NEW
PARTS
IN
(CLPARTITIONS (CLDIFF CL PART) (CDR PARTSIZES))
XLIST
(CONS PART PARTS))))
EXPR)
(DEFPROP CLPARTS
(LAMBDA(CL PARTSIZE)
(IF (ZEROP PARTSIZE)
THEN
(LIST NIL)
ELSEIF
(NULL (CDR CL))
THEN
(LIST (LIST (CONS (CAAR CL) PARTSIZE)))
ELSE
(PROG (SIZE)
(SETQ SIZE (DIFFERENCE PARTSIZE (CLCOUNT (CDR CL))))
(RETURN
(FOR NEW
X
:=
((MAX SIZE 1.) (MIN PARTSIZE (CDAR CL)))
FOR
NEW
PART
IN
(CLPARTS (CDR CL) (DIFFERENCE PARTSIZE X))
XLIST
FIRST
(IF (LESSP 0. SIZE) THEN NIL ELSE (CLPARTS (CDR CL) PARTSIZE))
(CONS (CONS (CAAR CL) X) PART))))))
EXPR)
(DEFPROP CL=PARTS
(LAMBDA(CL NPARTS PARTSIZE)
(IF (NULL (CDR CL))
THEN
(SETQ CL (LIST (CONS (CAAR CL) PARTSIZE)))
(LIST (FOR NEW I := (1. NPARTS) XLIST CL))
ELSE
(FOR NEW
X
IN
(NUMPARTITIONS (CDAR CL) NPARTS 0. PARTSIZE)
FOR
NEW
Y
IN
(CLPARTITIONS (CDR CL) (FOR NEW XX IN X LIST (DIFFERENCE PARTSIZE XX)))
XLIST
(FOR NEW XX IN X AS NEW YY IN Y LIST (IF (ZEROP XX) THEN YY ELSE (CONS (CONS (CAAR CL) XX) YY))))))
EXPR)
(DEFPROP CLDIFF
(LAMBDA(CL1 CL2)
(IF (NULL CL2)
THEN
CL1
ELSEIF
(EQUAL (CAR CL1) (CAR CL2))
THEN
(CLDIFF (CDR CL1) (CDR CL2))
ELSEIF
(EQ (CAAR CL1) (CAAR CL2))
THEN
(CONS (CONS (CAAR CL1) (DIFFERENCE (CDAR CL1) (CDAR CL2))) (CLDIFF (CDR CL1) (CDR CL2)))
ELSE
(CONS (CAR CL1) (CLDIFF (CDR CL1) CL2))))
EXPR)
(DEFPROP CLCOUNT
(LAMBDA (CL) (FOR NEW X IN CL PLUS (CDR X)))
EXPR)
(DEFPROP CLPARTITIONSN
(LAMBDA(CL N MINPARTSIZE MAXPARTSIZE)
(FOR NEW
PARTSIZES
IN
(NUMPARTITIONS (CLCOUNT CL) N MINPARTSIZE MAXPARTSIZE)
NCONC
FIRST
NIL
(CLPARTITIONS CL PARTSIZES)))
EXPR)
(DEFPROP CLCREATE
(LAMBDA (L) (PROG (CL) (FOR NEW X IN L DO (SETQ CL (CLINSERT X CL))) (RETURN CL)))
EXPR)
(DEFPROP CLINSERT
(LAMBDA(ITEM CL)
(IF (NOT CL)
THEN
(LIST (CONS ITEM 1.))
ELSEIF
(EQUAL ITEM (CAAR CL))
THEN
(REPLACE (CDR (CAR CL)) (ADD1 (CDR (CAR CL))))
CL
ELSEIF
(LEQ ITEM (CAAR CL))
THEN
(CONS (CONS ITEM 1.) CL)
ELSE
(REPLACE (CDR CL) (CLINSERT ITEM (CDR CL)))))
EXPR)
(DEFPROP CLEXPAND
(LAMBDA (CL) (FOR NEW PR IN CL FOR NEW I := (1. (CDR PR)) LIST (CAR PR)))
EXPR)
(DEFPROP GENRAD
(LAMBDA(CL)
(IF (AND (NULL (CDR CL)) (EQUAL (CDAR CL) 1.))
THEN
(PERMRADS (CAAR CL) NIL T)
ELSE
(FOR NEW
OLDCL
ON
CL
AS
NEW
CENTER
IS
(CAAR OLDCL)
AS
NEW
NEWCL
IS
(CLDIFF CL (LIST (CONS CENTER 1.)))
FOR
NEW
DEGREE
:=
(1. (MIN (CLCOUNT NEWCL) (SUB1 (VALENCE CENTER))))
FOR
NEW
RADS
IN
(GENRADS NEWCL DEGREE)
NCONC
FIRST
NIL
(PERMRADS CENTER RADS T))))
EXPR)
(DEFPROP GENRADS
(LAMBDA(CL N)
(IF (NULL CL)
THEN
(LIST NIL)
ELSE
(FOR NEW PARTITION IN (CLPARTITIONSN CL N 1. (CLCOUNT CL)) NCONC FIRST NIL (GENRADLIST PARTITION))))
EXPR)
(DEFPROP GENRADLIST
(LAMBDA (CLLIST) (GROUPRADS (GENRADLIST1 (CLCREATE CLLIST))))
EXPR)
(DEFPROP GENRADLIST1
(LAMBDA (CLCL) (FOR NEW CLNUMPAIR IN CLCL LIST (CONS (GENRAD (CAR CLNUMPAIR)) (CDR CLNUMPAIR))))
EXPR)
(DEFPROP GROUPRADS
(LAMBDA(RADCLIST)
(IF (NULL RADCLIST)
THEN
(LIST NIL)
ELSE
(GROUPRADS1 (CAAR RADCLIST) (CDAR RADCLIST) (GROUPRADS (CDR RADCLIST)))))
EXPR)
(DEFPROP GROUPRADS1
(LAMBDA(RADLIST N RADSLIST)
(IF (ZEROP N)
THEN
RADSLIST
ELSE
(FOR RADLIST
ON
RADLIST
FOR
NEW
RADS
IN
(GROUPRADS1 RADLIST (SUB1 N) RADSLIST)
LIST
(CONS (CAR RADLIST) RADS))))
EXPR)
(DEFPROP VALENCE
(LAMBDA (AT) (COND ((NUMBERP AT) AT) ((ATOM AT) (GET AT (QUOTE VALENCE))) (T (FREEVALENCESIZE AT))))
EXPR)
(DEFPROP GENMOL
(LAMBDA(CL)
(PROG (MINDEG RESULT NATOMS)
(IF (EQUAL 1. (SETQ NATOMS (CLCOUNT CL)))
THEN
(RETURN (PERMRADS (CAAR CL) NIL NIL))
ELSEIF
(ZEROP (REMAINDER NATOMS 2.))
THEN
(FOR NEW
PART
IN
(CL=PARTS CL 2. (QUOTIENT NATOMS 2.))
FOR
NEW
RADS
IN
(GENRADLIST PART)
DO
(SETQ RESULT (APPEND (PERMRADS NIL RADS NIL) RESULT)))
(SETQ MINDEG 3.)
ELSE
(SETQ MINDEG 2.))
(SETQ NATOMS (SUB1 NATOMS))
(FOR NEW
PAIR
IN
CL
AS
NEW
CENTER
IS
(CAR PAIR)
AS
NEW
NEWCL
IS
(CLDIFF CL (LIST (CONS CENTER 1.)))
FOR
NEW
DEG
:=
(MINDEG (MIN (VALENCE CENTER) NATOMS))
FOR
NEW
P
IN
(CLPARTITIONSN NEWCL DEG 1. (QUOTIENT NATOMS 2.))
FOR
NEW
RADS
IN
(GENRADLIST P)
DO
(SETQ RESULT (NCONC (PERMRADS CENTER RADS NIL) RESULT)))
(RETURN RESULT)))
EXPR)
(DEFPROP NUMPARTITIONS*
(LAMBDA(U MN MAXIMA OCCURLIST)
(IF (NULL (CDR OCCURLIST))
THEN
(NUMPARTITIONS U (CAR OCCURLIST) MN (CAR MAXIMA))
ELSE
(FOR NEW
FIRST
:=
((FIX+
(MAX MN
(DIFFERENCE
U
(FOR NEW
X
IN
(CDR MAXIMA)
AS
NEW
Y
IN
(CDR OCCURLIST)
PLUS
FIRST
(TIMES (SUB1 (CAR OCCURLIST)) (CAR MAXIMA))
(TIMES X Y)))))
(MIN (CAR MAXIMA) (QUOTIENT (DIFFERENCE U (PLUSLIST (CDR OCCURLIST))) (CAR OCCURLIST))))
FOR
NEW
REST
IN
(IF (EQUAL (CAR OCCURLIST) 1.)
THEN
(NUMPARTITIONS* (DIFFERENCE U FIRST) 1. (CDR MAXIMA) (CDR OCCURLIST))
ELSE
(NUMPARTITIONS* (DIFFERENCE U FIRST) FIRST MAXIMA (CONS (SUB1 (CAR OCCURLIST)) (CDR OCCURLIST))))
XLIST
(CONS FIRST REST))))
EXPR)
(DEFPROP GROUPBY
(LAMBDA(FN L)
(IF (NULL L)
THEN
NIL
ELSE
(PROG (FNX GROUPCDR X)
(SETQ GROUPCDR (GROUPBY FN (CDR L)))
(IF (NULL (SETQ X (LMASSOC (SETQ FNX (FN (CAR L))) GROUPCDR NIL)))
THEN
(RETURN (CONS (LIST FNX (CAR L)) GROUPCDR))
ELSE
(NCONC X (LIST (CAR L)))
(RETURN GROUPCDR)))))
EXPR)
(DEFPROP FVPARTITION1
(LAMBDA(N VL S)
(COND ((NULL VL) (LIST NIL))
(T
(PROG (SUMREST)
(SETQ SUMREST (FOR NEW X IN (CDR VL) AS NEW SP := ((ADD1 S) 9999999.) PLUS (TIMES SP X)))
(RETURN
(FOR NEW
I
:=
((MAX 0. (DIFFERENCE N SUMREST)) (MIN N (TIMES (CAR VL) S)))
AS
NEW
PARTREST
IS
(FVPARTITION1 (DIFFERENCE N I) (CDR VL) (ADD1 S))
FOR
NEW
FIRSTPART
IN
(FVPART1 I (CAR VL) S)
FOR
NEW
RESTPART
IN
PARTREST
XLIST
(CONS FIRSTPART RESTPART)))))))
EXPR)
(DEFPROP FVPART1
(LAMBDA(N MAXSUM MAXOCCUR)
(COND ((ZEROP MAXOCCUR) (LIST NIL))
(T
(FOR NEW
I
:=
((MAX 0. (DIFFERENCE N (TIMES MAXSUM (SUB1 MAXOCCUR)))) (MIN MAXSUM (QUOTIENT N MAXOCCUR)))
FOR
NEW
REST
IN
(FVPART1 (DIFFERENCE N (TIMES I MAXOCCUR)) (DIFFERENCE MAXSUM I) (SUB1 MAXOCCUR))
XLIST
(CONS I REST)))))
EXPR)
(DEFPROP MINLOOPS
(LAMBDA(VALENCELIST)
(MAX 0.
(PROG (MXV TD)
(SETQ TD (SETQ MXV 0.))
(FOR NEW
X
IN
(CDR VALENCELIST)
AS
NEW
VALENCE
:=
(3. 999999.)
WHEN
(NOT (ZEROP X))
DO
(IF (GREATERP VALENCE MXV) THEN (SETQ MXV VALENCE))
(SETQ TD (PLUS (TIMES X VALENCE) TD)))
(RETURN (QUOTIENT (DIFFERENCE MXV TD) 2.)))))
EXPR)
(DEFPROP MAXLOOPS
(LAMBDA(VALENCELIST)
(MIN (CAR VALENCELIST) (FIX+ (FOR NEW W IN (CDDR VALENCELIST) AS NEW J := (2. 99999.) PLUS (TIMES 0.5 W J)))))
EXPR)