perm filename CYCOMF.LSP[DEN,LMM] blob sn#037468 filedate 1973-05-19 generic text, type T, neo UTF8

(DEFPROP CYCOMFFNS
 (CYCOMFFNS ORDPAIR
	    EDGEMARK
	    LABEL1C
	    MAKEMULT
	    MAKENODES
	    MAKEEDGES
	    LABELMULT
	    LABEL0A
	    LABELN
	    LABELE
	    UNCLASS
	    LUNCLASS)
VALUE)

(DEFPROP ORDPAIR
 (LAMBDA (X1 X2) (IF (LEQ X1 X2) THEN (CONS X1 X2) ELSE (CONS X2 X1)))
EXPR)

(DEFPROP EDGEMARK
 (LAMBDA (EDG) (ORDPAIR (NODEMARK (NODE1 EDG)) (NODEMARK (NODE2 EDG))))
EXPR)

(DEFPROP 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
      (NODES? OBJECTS)
      THEN
      (LABELN (NODENUMS OBJECTS) LABELS STRUC)
      ELSEIF
      (EDGES? OBJECTS)
      THEN
      (LABELE (NODEPRS OBJECTS) LABELS STRUC)
      ELSEIF
      (MULTTYPE? OBJECTS)
      THEN
      (LABELMULT (MULT OBJECTS) (UNMULTED OBJECTS) LABELS STRUC)
      ELSE
      (LABELUNDEFINEDSTRUC OBJECTS LABELS STRUC)))
EXPR)

(DEFPROP MAKEMULT
 (LAMBDA (M OBJ) (IF (ZEROP M) THEN NIL ELSEIF (EQUAL M 1.) THEN OBJ ELSE (MULTTYPE MULT = M UNMULTED = OBJ)))
EXPR)

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

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

(DEFPROP 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 (DIFFERENCE MULTS (CAR PR)) X)))))
EXPR)

(DEFPROP 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
		 =
		 (MAKEFN **)
		 UNLABELED
		 =
		 (MAKEFN (DIFF OBJECTS (LABELED L)))
		 LSTRUC
		 =
		 (STRUCTURE FROM STRUC GROUP = (LSTRUC L)))))
EXPR)

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

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

(DEFPROP UNCLASS
 (LAMBDA(OBJECTS)
  (IF (NOT OBJECTS)
      THEN
      NIL
      ELSEIF
      (UNCLASSED? OBJECTS)
      THEN
      (OBJECTS OBJECTS)
      ELSEIF
      (NODES? OBJECTS)
      THEN
      (NODENUMS OBJECTS)
      ELSEIF
      (EDGES? 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
      (PRINT (CONS OBJECTS (QUOTE (ERROR ARG TO UNCLASS))) NIL)))
EXPR)

(DEFPROP LUNCLASS
 (LAMBDA (LOBJ) (MAPCAR (QUOTE UNCLASS) LOBJ))
EXPR)