(DEFPROP CYCOMDFNS
(CYCOMDFNS CHECKL COMB COMBCHECK CHECK LLABEL LABELM LABEL1
LABEL1L COMB1 FIXUPGROUP FINDNEWGROUP
FINDNEWGROUP1 FINDPERMS POSSIMS CONNECTIVITY
GROUPCOUNT FOUND? FINDGROUPEDGES IMAGE
FINDGROUPNODES SIZE TD M22 MAXREST
LOOPPARTITIONS1 JLIST LPROWS LOOPPARTITIONS)
VALUE)
(DEFPROP
CHECKL
(LAMBDA
(S SB NPL)
(IF (SETQ NPL (CHECK S SB NPL 0.0))
THEN
(IF (REMPERMS (NPLLEFT NPL))
THEN
(PRINT (LIST (QUOTE CHECKL)
(QUOTE ERROR:)
S SB NPL))
NIL ELSE
(LIST (LABELING LABELED = S UNLABELED = SB LSTRUC =
(REVERSE (OKPERMS (NPLLEFT NPL))))))
ELSE NIL))
EXPR)
(DEFPROP COMB (LAMBDA (OBJ S SB NPL LABELS)
(IF (ZEROP LABELS)
THEN
(CHECKL S (APPEND SB OBJ)
NPL)
ELSEIF
(EQUAL LABELS (LENGTH OBJ))
THEN
(CHECKL (APPEND OBJ S)
SB NPL)
ELSEIF
(GREATERP LABELS (LENGTH OBJ))
THEN NIL ELSE
(APPEND (COMBCHECK (CDR OBJ)
(CONS (CAR OBJ)
S)
SB NPL (SUB1 LABELS))
(COMBCHECK (CDR OBJ)
S
(CONS (CAR OBJ)
SB)
NPL LABELS))))
EXPR)
(DEFPROP COMBCHECK (LAMBDA (OBJ S SB NPL LABELS)
(IF (SETQ NPL (CHECK S SB NPL LABELS))
THEN
(COMB (DIFF OBJ (LABELEDSOFAR NPL))
(LABELEDSOFAR NPL)
SB
(NPLLEFT NPL)
(LABELSLEFT NPL))
ELSE NIL))
EXPR)
(DEFPROP CHECK
(LAMBDA (S SB NPL LABELS)
(PROG (NEWNPL OBJ POBJ OK)
(SETQ OK (OKPERMS NPL))
(SETQ NPL (REMPERMS NPL))
L1
(IF (NULL NPL)
THEN
(RETURN (CHECKVAL LABELEDSOFAR = S NPLLEFT
=
(NPL OKPERMS = OK
REMPERMS = NEWNPL)
LABELSLEFT = LABELS)))
(SETQ OBJ (OBJ (CAR NPL)))
(SETQ POBJ (POBJ (CAR NPL)))
L3
(IF (NULL OBJ)
THEN
(GO L8)
ELSEIF
(MEMBER (CAR OBJ)
S)
THEN
(GO L4)
ELSEIF
(MEMBER (CAR OBJ)
SB)
THEN
(GO L5))
L6
(SETQ NEWNPL (CONS (CHECKPERM FROM
(CAR NPL)
OBJ = OBJ POBJ =
POBJ)
NEWNPL))
L2
(SETQ NPL (CDR NPL))
(GO L1)
L9
(SETQ NEWNPL NIL)
L8
(SETQ OK (CONS (ORIGPERM (CAR NPL))
OK))
(GO L2)
L4
(IF (MEMBER (CAR POBJ)
S)
THEN
(GO L7)
ELSEIF
(MEMBER (CAR POBJ)
SB)
THEN
(RETURN NIL)
ELSEIF
(MINUSP (SETQ LABELS (SUB1 LABELS)))
THEN
(RETURN NIL))
(SETQ S (CONS (CAR POBJ)
S))
(SETQ NPL (APPEND NEWNPL NPL))
(IF (NULL (CDR OBJ))
THEN
(GO L9))
(SETQ NEWNPL (LIST (CHECKPERM FROM
(CAR NPL)
OBJ =
(CDR OBJ)
POBJ =
(CDR POBJ))))
(GO L2)
L7
(SETQ OBJ (CDR OBJ))
(SETQ POBJ (CDR POBJ))
(GO L3)
L5
(IF (MEMBER (CAR POBJ)
S)
THEN
(GO L2)
ELSEIF
(MEMBER (CAR POBJ)
SB)
THEN
(GO L7))
(GO L6)))
EXPR)
(DEFPROP LLABEL
(LAMBDA
(OBJECTS LABELS STRUC)
(IF (NULL LABELS)
THEN
(LIST (LABELING LSTRUC = STRUC))
ELSE
(FOR NEW L1 IN (LABELM (CAR OBJECTS)
(CAR LABELS)
STRUC)
FOR NEW L2 IN (LLABEL (CDR OBJECTS)
(CDR LABELS)
(LSTRUC L1))
XLIST
(LABELING FROM L2 LABELED = (CONS (LABELED L1)
**)))))
EXPR)
(DEFPROP LABELM
(LAMBDA
(OBJECTS LABELS STRUC)
(IF (NULL LABELS)
THEN
(LIST (LABELING UNLABELED = OBJECTS LSTRUC = STRUC))
ELSE
(FOR NEW L1 IN (LABEL1 OBJECTS (CAR LABELS)
STRUC)
FOR NEW L2 IN (LABELM (UNLABELED L1)
(CDR LABELS)
(LSTRUC L1))
XLIST
(LABELING FROM L2 LABELED = (CONS (LABELED L1)
**)))))
EXPR)
(DEFPROP LABEL1
(LAMBDA
(OBJECTS LABELS STRUC)
(PROG (SZ)
(RETURN (IF (ZEROP LABELS)
THEN
(LIST (LABELING UNLABELED = OBJECTS
LSTRUC = STRUC))
ELSEIF
(EQUAL LABELS (SETQ SZ (SIZE OBJECTS)))
THEN
(LIST (LABELING LABELED = OBJECTS LSTRUC
= STRUC))
ELSEIF
(GREATERP LABELS SZ)
THEN NIL ELSEIF
(NULL (CDR (SETQ OBJECTS (CLASSES
OBJECTS
STRUC))))
THEN
(LABEL1C (CAR OBJECTS)
LABELS STRUC)
ELSE
(LABEL1L OBJECTS LABELS STRUC)))))
EXPR)
(DEFPROP
LABEL1L
(LAMBDA
(OBJL LABELS STRUC)
(IF (NULL OBJL)
THEN
(IF (ZEROP LABELS)
THEN
(LIST (LABELING LSTRUC = STRUC))
ELSE NIL)
ELSEIF
(ZEROP LABELS)
THEN
(LIST (LABELING LSTRUC = STRUC UNLABELED =
(PROG (R)
(FOR NEW O IN OBJL DO (SETQ
R
(COMBINE O R)))
(RETURN R))))
ELSE
(PROG (SZ SZC)
(SETQ SZ (PLUS (SETQ SZC (SIZE (CAR OBJL)))
(FOR NEW O IN (CDR OBJL)
PLUS
(SIZE O))))
(RETURN (FOR NEW I := ((MAX 0.0 (DIFFERENCE
LABELS
(DIFFERENCE SZ SZC)))
(MIN LABELS SZC))
FOR NEW L1 IN (LABEL1C (CAR OBJL)
I STRUC)
FOR NEW L2 IN (LABEL1L (CDR OBJL)
(DIFFERENCE LABELS
I)
(LSTRUC L1))
XLIST
(LABELING FROM L2 LABELED =
(COMBINE (LABELED L1)
**)
UNLABELED = (COMBINE
(UNLABELED L1)
**)))))))
EXPR)
(DEFPROP COMB1
(LAMBDA (OBJ LAB UNL PERMS LABELS)
(IF (ZEROP LABELS)
THEN
(LIST (LABELING LABELED = LAB UNLABELED = UNL
LSTRUC = PERMS))
ELSEIF
(EQUAL LABELS (LENGTH OBJ))
THEN
(LIST (LABELING LABELED = (APPEND OBJ LAB)
UNLABELED = UNL LSTRUC = PERMS))
ELSE
(NCONC (COMB1 (CDR OBJ)
(CONS (CAR OBJ)
LAB)
UNL PERMS (SUB1 LABELS))
(COMB1 (CDR OBJ)
LAB
(CONS (CAR OBJ)
UNL)
PERMS LABELS))))
EXPR)
(DEFPROP
FIXUPGROUP
(LAMBDA
(STRUC)
(REPLACE (GROUP STRUC)
(FINDNEWGROUP
STRUC
(CLASSIFYNODES
(PROG (X)
(SETQ X (NODES STRUC))
(FOR NEW NL IN (CAR (GROUP STRUC))
DO
(SETQ X (DIFF X NL)))
(RETURN X))
STRUC))))
EXPR)
(DEFPROP
FINDNEWGROUP
(LAMBDA
(STRUC NEWORBITS)
(PROG (NEWOBJ)
(SETQ NEWOBJ (FOR NEW ORB IN NEWORBITS XLIST FIRST
(CAR (GROUP STRUC))
(REVERSE ORB)))
(RETURN (CONS NEWOBJ
(FOR NEW P IN (FINDNEWGROUP1 STRUC NEWORBITS)
WHEN
(NOT (EQUAL NEWOBJ (CDR P)))
XLIST
(CDR P))))))
EXPR)
(DEFPROP FINDNEWGROUP1
(LAMBDA (STRUC NEWORBITS)
(FOR NEW P IN (GROUP STRUC)
NCONC FIRST NIL
(FINDPERMS (CAR NEWORBITS)
NEWORBITS
(CONS NIL P)
(CONS NIL (CAR (GROUP STRUC)))
STRUC)))
EXPR)
(DEFPROP
FINDPERMS
(LAMBDA
(NODES CLASSES IMS MAPPED STRUC)
(IF (NULL CLASSES)
THEN
(LIST IMS)
ELSEIF
(NULL NODES)
THEN
(FINDPERMS (CADR CLASSES)
(CDR CLASSES)
(CONS NIL IMS)
(CONS NIL MAPPED)
STRUC)
ELSE
(FOR NEW Y IN (POSSIMS (CAR NODES)
(CAR CLASSES)
IMS MAPPED STRUC)
NCONC FIRST NIL (FINDPERMS (CDR NODES)
CLASSES
(CONS (CONS Y (CAR IMS))
(CDR IMS))
(CONS (CONS (CAR NODES)
(CAR MAPPED))
(CDR MAPPED))
STRUC))))
EXPR)
(DEFPROP POSSIMS
(LAMBDA (X CLASS IMS MAPPED STRUC)
(FOR NEW Y IN CLASS WHEN (NOT (MEMBER Y
(CAR IMS)))
WHEN
(FOR NEW ML IN MAPPED AS NEW IL IN IMS FOR NEW
M IN ML AS NEW I IN IL AND
(EQUAL (CONNECTIVITY Y I STRUC)
(CONNECTIVITY X M STRUC)))
XLIST Y))
EXPR)
(DEFPROP CONNECTIVITY (LAMBDA (X Y STRUC)
(FOR NEW Z IN (NBRS (FINDCTE X STRUC))
WHEN
(EQUAL Z Y)
PLUS 1.0))
EXPR)
(DEFPROP GROUPCOUNT
(LAMBDA
(L)
(PROG NIL (SETQ L (GROUPBY (QUOTE CDR)
(CLCREATE L)))
(RETURN (FOR NEW I :=
((FOR NEW X IN L MAX (CAR X))
1.0 -1.0)
XLIST
(CARLIST (LMASSOC I L NIL))))))
EXPR)
(DEFPROP FOUND? (LAMBDA
(NODE GROUP)
(FOR NEW NL IN (CAR GROUP)
AS NEW N := (1.0 INFINITY)
DO
(IF (MEMBER NODE NL)
THEN
(RETURN (CONS N NL)))))
EXPR)
(DEFPROP
FINDGROUPEDGES
(LAMBDA
(EDGES STRUC)
(PROG
(G)
(IF (NOT (FOR NEW EDGE IN EDGES AND (AND (FOUND? (NODE1 EDGE)
(GROUP STRUC))
(FOUND? (NODE2 EDGE)
(GROUP STRUC)))
))
THEN
(FIXUPGROUP STRUC)
ELSE NIL)
(SETQ G (GROUP STRUC))
(RETURN
(NPL
OKPERMS = (LIST (CAR G))
REMPERMS =
(FOR NEW P IN (CDR G)
XLIST
(CHECKPERM ORIGPERM = P OBJ = EDGES POBJ =
(FOR NEW EDGE IN EDGES LIST
(ORDPAIR (IMAGE (NODE1 EDGE)
(CAR G)
P)
(IMAGE (NODE2 EDGE)
(CAR G)
P)))))))))
EXPR)
(DEFPROP IMAGE
(LAMBDA (NODE MAPPED IMAGES)
(FOR NEW ML IN MAPPED AS NEW IL IN IMAGES FOR NEW M
IN ML AS NEW I IN IL WHEN (EQUAL NODE M)
DO
(RETURN I)))
EXPR)
(DEFPROP
FINDGROUPNODES
(LAMBDA
(OBJECTS STRUC)
(PROG
(FOUND)
L1
(SETQ FOUND (FOUND? (CAR OBJECTS)
(GROUP STRUC)))
(IF
(NOT FOUND)
THEN
(FIXUPGROUP STRUC)
ELSE
(RETURN
(NPL OKPERMS = (LIST (CAR (GROUP STRUC)))
REMPERMS =
(FOR NEW P IN (CDR (GROUP STRUC))
XLIST
(CHECKPERM ORIGPERM = P OBJ = (CDR FOUND)
POBJ = (CAR (NTH P (CAR FOUND))))))))
(GO L1)))
EXPR)
(DEFPROP SIZE
(LAMBDA (OBJECTS)
(IF (MULTTYPE? OBJECTS)
THEN
(TIMES (MULT OBJECTS)
(SIZE (UNMULTED OBJECTS)))
ELSEIF
(COMBINATION? OBJECTS)
THEN
(PLUS (SIZE (OBJ1 OBJECTS))
(SIZE (OBJ2 OBJECTS)))
ELSEIF
(OR (NODES? OBJECTS)
(EDGES? OBJECTS)
(UNCLASSED? OBJECTS))
THEN
(LENGTH (CDR OBJECTS))
ELSE
(PRINT (CONS OBJECTS
(QUOTE (BAD ARG TO SIZE)))
0.0)))
EXPR)
(DEFPROP TD (LAMBDA (VL J)
(IF (NOT VL)
THEN 0.0 ELSE (PLUS (TIMES J (CAR VL))
(TD (CDR VL)
(ADD1 J)))))
EXPR)
(DEFPROP M22 (LAMBDA (N)
(SUB1 (QUOTIENT N 2.0)))
EXPR)
(DEFPROP MAXREST (LAMBDA (VL J)
(FOR NEW X IN (CDR VL)
AS NEW K := ((ADD1 J)
INFINITY)
PLUS
(TIMES X (M22 K))))
EXPR)
(DEFPROP LOOPPARTITIONS1
(LAMBDA
(P VL J)
(IF (NOT VL)
THEN
(LIST NIL)
ELSE
(FOR NEW PJ := ((MAX 0.0 (DIFFERENCE P (MAXREST VL J)))
(MIN P (TIMES (M22 J)
(CAR VL))))
AS NEW RESTL IS (LOOPPARTITIONS1 (DIFFERENCE
P PJ)
(CDR VL)
(ADD1 J))
FOR NEW THISPART IN (FVPART1 PJ (CAR VL)
(M22 J))
FOR NEW RESTPART IN RESTL XLIST (CONS THISPART
RESTPART))))
EXPR)
(DEFPROP JLIST (LAMBDA
(LL N)
(IF (NOT LL)
THEN NIL ELSEIF (NOT (CDR LL))
THEN
(LIST (CAR (NTH (CAR LL)
N)))
ELSE
(CONS (CAR (NTH (CAR LL)
N))
(JLIST (CDDR LL)
(ADD1 N)))))
EXPR)
(DEFPROP
LPROWS
(LAMBDA
(LPP VL)
(PROG2 (SETQ LPP (CONS NIL LPP))
(FOR NEW S := (4.0 INFINITY)
AS NEW V IN (CONS (CAR VL)
(FOR NEW V2 IN (CDR VL)
AS NEW PL IN LPP LIST
(DIFFERENCE V2 (PLUSLIST
PL))))
AS LPP IS (IF LPP THEN (CDR LPP)
ELSE NIL)
LIST
(CONS V (JLIST LPP (M22 S))))))
EXPR)
(DEFPROP LOOPPARTITIONS
(LAMBDA (P VL)
(FOR NEW LPP IN (LOOPPARTITIONS1 P (CDDR VL)
4.0)
AS NEW ROWS IS (LPROWS LPP VL)
FOR NEW K := (0.0 (TD (CDR VL)
3.0))
FOR NEW BP IN (NUMPARTITIONS (CAR VL)
(PLUS P K)
1.0 999999.0)
AS NEW CLBP IS (CLCREATE BP)
FOR NEW EL IN (CLPARTS CLBP K)
FOR NEW LPL IN (CLPARTITIONSL (CLDIFF CLBP EL)
(CDRLIST ROWS))
XLIST
(LOOPPARTITION LOOPVL =
(CONS (PLUSLIST (CDAR ROWS))
(MAPCAR (QUOTE PLUSLIST)
(CDR ROWS)))
EDGELABELS = EL LOOPLABELS = LPL)
))
EXPR)
STOP