(DEFPROP CYCOMEFNS
 (CYCOMEFNS CLPARTITIONSL
	    CLPARTLP1
	    KLOOPEDRINGS
	    ATTACHBIVS&LOOPS
	    PUTLOOPS
	    PUTBIVN
	    PUTBIVS
	    PUTBIVE
	    COMBINE
	    CLASSES
	    CLASSES2
	    CLASSIFY3
	    CLASSIFYNODES
	    CLASSIFYEDGES
	    NODEMARK)
VALUE)

(DEFPROP CLPARTITIONSL
 (LAMBDA(CL LL)
  (IF (NOT LL)
      THEN
      (LIST NIL)
      ELSE
      (FOR NEW
	   FP
	   IN
	   (CLPARTS CL (PLUSLIST (CAR LL)))
	   AS
	   NEW
	   RPL
	   IS
	   (CLPARTITIONSL (CLDIFF CL FP) (CDR LL))
	   FOR
	   NEW
	   TP
	   IN
	   (CLPARTLP1 FP (CAR LL) 1.)
	   FOR
	   NEW
	   RP
	   IN
	   RPL
	   XLIST
	   (CONS TP RP))))
EXPR)

(DEFPROP CLPARTLP1
 (LAMBDA(CL ROW N)
  (IF (NOT ROW)
      THEN
      (LIST NIL)
      ELSEIF
      (ZEROP (CAR ROW))
      THEN
      (CLPARTLP1 CL (CDR ROW) (ADD1 N))
      ELSE
      (FOR NEW
	   EP
	   IN
	   (CLPARTS CL (TIMES N (CAR ROW)))
	   AS
	   NEW
	   RPL
	   IS
	   (CLPARTLP1 (CLDIFF CL EP) (CDR ROW) (ADD1 N))
	   FOR
	   NEW
	   EEP
	   IN
	   (CL=PARTS EP (CAR ROW) N)
	   FOR
	   NEW
	   RP
	   IN
	   RPL
	   XLIST
	   (APPEND (CLCREATE EEP) RP))))
EXPR)

(DEFPROP KLOOPEDRINGS
 (LAMBDA(P VL)
  (IF (ZEROP P)
      THEN
      (NOLOOPEDRINGS VL)
      ELSE
      (FOR NEW
	   LOOPPART
	   IN
	   (LOOPPARTITIONS P VL)
	   FOR
	   NEW
	   STRUC
	   IN
	   (NOFV-RINGS (LOOPVL LOOPPART))
	   NCONC
	   FIRST
	   NIL
	   (ATTACHBIVS&LOOPS (EDGELABELS LOOPPART) (LOOPLABELS LOOPPART) STRUC))))
EXPR)

(DEFPROP ATTACHBIVS&LOOPS
 (LAMBDA(EL LL STRUC)
  (IF (NOT EL)
      THEN
      (FOR NEW
	   L2
	   IN
	   (LLABELNODES STRUC (LCDRLIST LL))
	   XLIST
	   (PUTLOOPS (COPYSTRUC (LSTRUC L2)) (LCARLIST LL) (LABELED L2)))
      ELSE
      (FOR NEW
	   L1
	   IN
	   (LABELEDGES STRUC (CDRLIST EL))
	   FOR
	   NEW
	   L2
	   IN
	   (LLABELNODES (LSTRUC L1) (LCDRLIST LL))
	   XLIST
	   (PUTLOOPS (PUTBIVS (COPYSTRUC (LSTRUC L2)) (CARLIST EL) (LABELED L1)) (LCARLIST LL) (LABELED L2)))))
EXPR)

(DEFPROP PUTLOOPS
 (LAMBDA(STRUC LPS LNODES)
  (PROG2 (FOR NEW
	      LOBJ
	      IN
	      LNODES
	      AS
	      NEW
	      LLABS
	      IN
	      LPS
	      FOR
	      NEW
	      OBJ
	      IN
	      LOBJ
	      AS
	      NEW
	      LAB
	      IN
	      LLABS
	      FOR
	      NEW
	      LPPR
	      IN
	      LAB
	      FOR
	      NEW
	      I
	      :=
	      (1. (CDR LPPR))
	      FOR
	      NEW
	      NODE
	      IN
	      OBJ
	      DO
	      (SETQ STRUC (PUTBIVN STRUC NODE (CAR LPPR))))
	 STRUC))
EXPR)

(DEFPROP PUTBIVN
 (LAMBDA(STRUC NODE NBIVS)
  (IF (ZEROP NBIVS)
      THEN
      STRUC
      ELSE
      (PROG (B)
	    (SETQ B (BIVCHAIN NBIVS))
	    (CONNECT (CAR (CTABLE B)) (SETQ NODE (FINDCTE NODE (CTABLE STRUC))))
	    (CONNECT (CAR (LAST (CTABLE B))) NODE)
	    (NCONC (CTABLE STRUC) (CTABLE B))
	    (REPLACE (LASTNODE# STRUC) (LASTNODE# B))
	    (RETURN STRUC))))
EXPR)

(DEFPROP PUTBIVS
 (LAMBDA (S L LST) (PROG2 (FOR NEW X IN LST AS NEW N IN L FOR NEW E IN X DO (PUTBIVE S E N)) S))
EXPR)

(DEFPROP PUTBIVE
 (LAMBDA(S E N)
  (IF (ZEROP N)
      THEN
      S
      ELSE
      (PROG (B N1 N2)
	    (SETQ B (BIVCHAIN N))
	    (CONNECT (CAR (CTABLE B)) (SETQ N1 (FINDCTE (CAR E) (CTABLE S))))
	    (CONNECT (CAR (LAST (CTABLE B))) (SETQ N2 (FINDCTE (CDR E) (CTABLE S))))
	    (DISCONNECT N1 N2)
	    (NCONC (CTABLE S) (CTABLE B))
	    (REPLACE (LASTNODE# S) (LASTNODE# B))
	    (RETURN S))))
EXPR)

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

(DEFPROP CLASSES
 (LAMBDA(OBJECTS STRUC)
  (IF (COMBINATION? OBJECTS)
      THEN
      (NCONC (CLASSES (OBJ1 OBJECTS)) (CLASSES (OBJ2 OBJECTS)))
      ELSEIF
      (NOT (UNCLASSED? OBJECTS))
      THEN
      (LIST OBJECTS)
      ELSE
      (CLASSES2 (OBJECTS OBJECTS) STRUC)))
EXPR)

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

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

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

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

(DEFPROP NODEMARK
 (LAMBDA (NODE) (PROG2 (SETQ NODE (FINDCTE NODE SSTRUC)) (CONS (NODEVALENCE NODE) (MARKERS NODE))))
EXPR)