perm filename CYCOME.LSP[4,LMM] blob
sn#037467 filedate 1973-05-06 generic text, type T, neo UTF8
(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)