perm filename LABELE[1,LMM] blob sn#013286 filedate 1972-11-18 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ") T) (LISPXPRIN1 (QUOTE 
"18-NOV-72  1:04:34") T) (LISPXTERPRI T))
(LISPXPRINT (QUOTE LABELERVARS) T)
(RPAQQ LABELERVARS ((FNS CHECKL COMB COMBCHECK CHECK LLABEL LABELM
LABEL1 LABEL1L COMB1 SIZE COMBINE CLASSES CLASSES2 CLASSIFY3 
CLASSIFYNODES CLASSIFYEDGES NODEMARK EDGEMARK LABEL1C MAKEMULT MAKENODES
MAKEEDGES LABELMULT LABEL0A LABELN LABELE UNCLASS LUNCLASS LLUNCLASS
LABELEDGES LABELFV LLABELNODES MAKEUNCLASSED) (VARS) (RECORD CHECKPERM)
(RECORD NPL) (RECORD CHECKVAL) (RECORD LABELING) (!RECORD NODETYPE)
(!RECORD MULTTYPE) (!RECORD EDGETYPE) (!RECORD COMBINATION) (!RECORD
UNCLASSED) (!RECORD OTHERTYPE)))
(DEFINEQ

(CHECKL
(LAMBDA (S SB NPL) (COND ((SETQ NPL (CHECK S SB NPL 0)) (COND ((REMPERMS
(NPLLEFT NPL)) (HELP "CHECKL ERROR" (LIST S SB NPL))) (T (LIST (LABELING
LABELED = S UNLABELED = SB LSTRUC = (REVERSE (OKPERMS (NPLLEFT NPL))))))))
(T NIL))))

(COMB
(LAMBDA (OBJ S SB NPL LABELS) (IF (ZEROP LABELS) THEN (CHECKL S (APPEND
SB OBJ) NPL) ELSEIF (EQP LABELS (LENGTH OBJ)) THEN (CHECKL (APPEND
OBJ S) SB NPL) ELSEIF (IGREATERP 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)))))

(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)))

(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))))

(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) **))))))

(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)
**))))))

(LABEL1
(LAMBDA (OBJECTS LABELS STRUC) (PROG (SZ SZC) (RETURN (IF (ZEROP LABELS)
THEN (LIST (LABELING UNLABELED = OBJECTS LSTRUC = STRUC)) ELSEIF (EQP
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))))))

(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 (IPLUS (SETQ SZC (SIZE (CAR OBJL))) (FOR NEW O IN (CDR
OBJL) IPLUS (SIZE O)))) (RETURN (FOR NEW I := ((MAX 0 (IDIFFERENCE
LABELS (IDIFFERENCE SZ SZC))) (MIN LABELS SZC)) FOR NEW L1 IN (LABEL1C
(CAR OBJL) I STRUC) FOR NEW L2 IN (LABEL1L (CDR OBJL) (IDIFFERENCE
LABELS I) (LSTRUC L1)) XLIST (LABELING FROM L2 LABELED = (COMBINE
(LABELED L1) **) UNLABELED = (COMBINE (UNLABELED L1) **))))))))

(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)))))

(SIZE
(LAMBDA (OBJECTS) (IF (MULTTYPE? OBJECTS) THEN (ITIMES (MULT OBJECTS)
(SIZE (UNMULTED OBJECTS))) ELSEIF (COMBINATION? OBJECTS) THEN (IPLUS
(SIZE (OBJ1 OBJECTS)) (SIZE (OBJ2 OBJECTS))) ELSEIF (OR (NODETYPE?
OBJECTS) (EDGETYPE? OBJECTS) (UNCLASSED? OBJECTS)) THEN (LENGTH (CDR
OBJECTS)) ELSE (HELP OBJECTS "BAD ARG IN SIZE") 0)))

(COMBINE
(LAMBDA (O1 O2) (IF (NOT O1) THEN O2 ELSEIF (NOT O2) THEN O1 ELSE
(COMBINATION OBJ1 = O1 OBJ2 = O2))))

(CLASSES
(LAMBDA (OBJECTS STRUC) (COND ((COMBINATION? OBJECTS) (NCONC (CLASSES
(OBJ1 OBJECTS)) (CLASSES (OBJ2 OBJECTS)))) ((NOT (UNCLASSED? OBJECTS))
(LIST OBJECTS)) (T (CLASSES2 (OBJECTS OBJECTS) STRUC)))))

(CLASSES2
(LAMBDA (OBJECTS STRUC) (PROG NIL (SETQ OBJECTS (GROUPCOUNT OBJECTS))
(RETURN (FOR NEW O IN (CDR OBJECTS) AS NEW M := (2 999999) FOR NEW
O2 IN (CLASSIFY3 O STRUC) XLIST FIRST (CLASSIFY3 (CAR OBJECTS) STRUC)
(MAKEMULT M O2))))))

(CLASSIFY3
(LAMBDA (OBJECTS STRUC) (PROG (N E OTH) (FOR NEW X IN OBJECTS DO (IF
(NUMBERP X) THEN (SETQ N (CONS X N)) ELSEIF (AND (NUMBERP (CAR X))
(NUMBERP (CDR X))) THEN (SETQ E (CONS X E)) ELSE (SETQ OTH (CONS X
OTH)))) (RETURN (NCONC (MAPCAR (CLASSIFYNODES N STRUC) (FUNCTION 
MAKENODES)) (NCONC (MAPCAR (CLASSIFYEDGES E STRUC) (FUNCTION MAKEEDGES))
(IF OTH THEN (LIST (OTHERTYPE OTHOBJECTS = OTH)) ELSE NIL)))))))

(CLASSIFYNODES
(LAMBDA (NODES SSTRUC) (CDRLIST (GROUPBY (FUNCTION NODEMARK) NODES))))

(CLASSIFYEDGES
(LAMBDA (EDGES SSTRUC) (CDRLIST (GROUPBY (FUNCTION EDGEMARK) EDGES))))

(NODEMARK
(LAMBDA (NODE) (PROGN (SETQ NODE (FINDCTE NODE SSTRUC)) (CONS (
NODEVALENCE NODE) (MARKERS NODE)))))

(EDGEMARK
(LAMBDA (EDGE) (ORDPAIR (NODEMARK (NODE1 EDGE)) (NODEMARK (NODE2 EDGE))))
)

(LABEL1C
(LAMBDA (OBJECTS LABELS STRUC) (IF (ZEROP LABELS) THEN (LIST (LABELING
UNLABELED = OBJECTS LSTRUC = STRUC)) ELSEIF (EQUAL LABELS (SIZE OBJECTS))
THEN (LIST (LABELING LABELED = OBJECTS LSTRUC = STRUC)) ELSEIF (
NODETYPE? OBJECTS) THEN (LABELN (NODENUMS OBJECTS) LABELS STRUC) ELSEIF
(EDGETYPE? OBJECTS) THEN (LABELE (NODEPRS OBJECTS) LABELS STRUC) ELSEIF
(MULTTYPE? OBJECTS) THEN (LABELMULT (MULT OBJECTS) (UNMULTED OBJECTS)
LABELS STRUC) ELSE (LABELUNDEFINEDSTRUC OBJECTS LABELS STRUC))))

(MAKEMULT
(LAMBDA (M OBJ) (IF (ZEROP M) THEN NIL ELSEIF (EQP M 1) THEN OBJ ELSE
(MULTTYPE MULT = M UNMULTED = OBJ))))

(MAKENODES
(LAMBDA (NODES) (IF (NOT NODES) THEN NIL ELSE (NODETYPE NODENUMS =
NODES))))

(MAKEEDGES
(LAMBDA (EDGES) (IF (NOT EDGES) THEN NIL ELSE (EDGETYPE NODEPRS =
EDGES))))

(LABELMULT
(LAMBDA (MULTS UNMULTED LABELS STRUC) (FOR NEW P IN (NUMPARTITIONS
LABELS (SIZE UNMULTED) 0 MULTS) AS NEW CLP IS (CLCREATE P) FOR NEW
L IN (LABELM UNMULTED (CDRLIST CLP) STRUC) XLIST (LABELING FROM L
LABELED = (FOR NEW X IN ** AS NEW PR IN CLP COMBINE FIRST NIL (MAKEMULT
(CAR PR) X)) UNLABELED = (FOR NEW X IN (LABELED L) AS NEW PR IN CLP
COMBINE FIRST NIL (MAKEMULT (IDIFFERENCE MULTS (CAR PR)) X))))))

(LABEL0A
(LAMBDA (OBJECTS STRUC NPL LABELS MAKEFN) (FOR NEW L IN (IF (NOT (
REMPERMS NPL)) THEN (COMB1 OBJECTS NIL NIL (OKPERMS NPL) LABELS) ELSE
(COMB OBJECTS NIL (DIFF (OBJ (CAR (REMPERMS NPL))) OBJECTS) NPL LABELS))
XLIST (LABELING FROM L LABELED = (APPLY* MAKEFN **) UNLABELED = (APPLY*
MAKEFN (DIFF OBJECTS (LABELED L))) LSTRUC = (STRUCTURE FROM STRUC
GROUP = (LSTRUC L))))))

(LABELN
(LAMBDA (NODENUMS LABELS STRUC) (LABEL0A NODENUMS STRUC (FINDGROUPNODES
NODENUMS STRUC) LABELS (FUNCTION MAKENODES))))

(LABELE
(LAMBDA (EDGES LABELS STRUC) (LABEL0A EDGES STRUC (FINDGROUPEDGES
EDGES STRUC) LABELS (FUNCTION MAKEEDGES))))

(UNCLASS
(LAMBDA (OBJECTS) (IF (NOT OBJECTS) THEN NIL ELSEIF (UNCLASSED? OBJECTS)
THEN (OBJECTS OBJECTS) ELSEIF (NODETYPE? OBJECTS) THEN (NODENUMS OBJECTS)
ELSEIF (EDGETYPE? OBJECTS) THEN (NODEPRS OBJECTS) ELSEIF (MULTTYPE?
OBJECTS) THEN (FOR NEW M := (1 (MULT OBJECTS)) APPEND (UNCLASS (UNMULTED
OBJECTS))) ELSEIF (COMBINATION? OBJECTS) THEN (APPEND (UNCLASS (OBJ1
OBJECTS)) (UNCLASS (OBJ2 OBJECTS))) ELSE (HELP "BAD ARG TO UNCLASS"
OBJECTS) NIL)))

(LUNCLASS
(LAMBDA (LOBJ) (MAPCAR LOBJ (FUNCTION UNCLASS))))

(LLUNCLASS
(LAMBDA (LLOBJ) (MAPCAR LLOBJ (FUNCTION LUNCLASS))))

(LABELEDGES
(LAMBDA (STRUC LABELS) (FOR NEW L IN (LABELM (UNCLASSED OBJECTS =
(FOR NEW CT IN (CTABLE STRUC) FOR NEW N IN (NBRS CT) WHEN (LEQ (NODENUM
CT) N) XLIST (CONS (NODENUM CT) N))) LABELS STRUC) XLIST (LABELING
FROM L LABELED = (LUNCLASS **)))))

(LABELFV
(LAMBDA (STRUC LABELS) (FOR NEW L IN (LABELM (UNCLASSED OBJECTS =
(COLLECTFV STRUC)) LABELS STRUC) XLIST (LABELING FROM L LABELED =
(LUNCLASS **)))))

(LLABELNODES
(LAMBDA (STRUC LLABELS) (FOR NEW L IN (LLABEL (MAPCAR (LISTBYVALENCE
STRUC) (FUNCTION MAKEUNCLASSED)) LLABELS STRUC) XLIST (LABELING FROM
L LABELED = (LLUNCLASS **)))))

(MAKEUNCLASSED
(LAMBDA (X) (IF (NOT X) THEN NIL ELSE (UNCLASSED OBJECTS = X))))
)
(DEFLIST(QUOTE(
(CHECKPERM (OBJ POBJ . ORIGPERM))
))(QUOTE RECORD))

(RECORD (QUOTE CHECKPERM))
(DEFLIST(QUOTE(
(NPL (REMPERMS . OKPERMS))
))(QUOTE RECORD))

(RECORD (QUOTE NPL))
(DEFLIST(QUOTE(
(CHECKVAL (LABELEDSOFAR LABELSLEFT . NPLLEFT))
))(QUOTE RECORD))

(RECORD (QUOTE CHECKVAL))
(DEFLIST(QUOTE(
(LABELING (LABELED UNLABELED . LSTRUC))
))(QUOTE RECORD))

(RECORD (QUOTE LABELING))
(DEFLIST(QUOTE(
(NODETYPE NODENUMS)
))(QUOTE !RECORD))

(!RECORD (QUOTE NODETYPE))
(DEFLIST(QUOTE(
(MULTTYPE (MULT . UNMULTED))
))(QUOTE !RECORD))

(!RECORD (QUOTE MULTTYPE))
(DEFLIST(QUOTE(
(EDGETYPE NODEPRS)
))(QUOTE !RECORD))

(!RECORD (QUOTE EDGETYPE))
(DEFLIST(QUOTE(
(COMBINATION (OBJ1 . OBJ2))
))(QUOTE !RECORD))

(!RECORD (QUOTE COMBINATION))
(DEFLIST(QUOTE(
(UNCLASSED OBJECTS)
))(QUOTE !RECORD))

(!RECORD (QUOTE UNCLASSED))
(DEFLIST(QUOTE(
(OTHERTYPE OTHOBJECTS)
))(QUOTE !RECORD))

(!RECORD (QUOTE OTHERTYPE))
STOP