perm filename EXAMPL.SG[DEN,LMM] blob
sn#069192 filedate 1973-10-31 generic text, type T, neo UTF8
(FILECREATED "31-OCT-73 3:07:36" S-EXAMPLE)
(LISPXPRINT (QUOTE EXAMPLEVARS)
T)
(RPAQQ EXAMPLEVARS
((* Stuff for doing examples - Again, this needs work.
Problems are vagaries of UNDONLSETQ's, and the use of
ADVISE by EXAMPLE to select how to selectively turn things
off)
(FNS EXAMPLE SELECT SELECTL SELECTLL EDGES EXAMPLELLABELNODES
EXAMPLELABELFV EXAMPLELABELEDGES 1ATRAND SPLIT)
(VARS (EXAMPLEFIXED))
(USERMACROS RX X DE)))
(* Stuff for doing examples - Again, this needs work. Problems are
vagaries of UNDONLSETQ's, and the use of ADVISE by EXAMPLE to select
how to selectively turn things off)
(DEFINEQ
(EXAMPLE
[LAMBDA (X)
(COND
((STRUCTURE? X)
X)
[(STRUCLIST? X)
(EXAMPLE (1ATRAND (CDDR X]
((NOFORMIN X)
X)
(EXAMPLEFIXED (PROG (Y)
(EDITE X (QUOTE (RX)))
(SETQ Y (GENAPPLY X FIXEDFNLIST))
[COND
((NOT (EQUAL X Y))
(SETQ Y (EXAMPLE Y]
(RETURN Y)))
(T (UNDONLSETQ (PROG (Y (EXAMPLEFIXED T))
[ADVISE [OR (GETP (CAR (FETCH FORM OF X))
(QUOTE DESCENDANTS))
(UNION (CAR (FETCH FORM OF X))
(QUOTE (
SUPERATOMPARTITIONS MOLECULES SUPERATOMS RINGS RINGSKELETONS NOFVRINGS
DAISIES NUMPARTITIONS BIVALENTPARTITIONS
KLOOPEDRINGS PERMRADS GENMOL]
(QUOTE AFTER)
(QUOTE (RETURN (LIST (1ATRAND !VALUE]
[ADVISE (QUOTE LABELEDGES)
(QUOTE BEFORE)
(QUOTE (RETURN (EXAMPLELABELEDGES
STRUC LABELS]
[ADVISE (QUOTE LABELFV)
(QUOTE BEFORE)
(QUOTE (RETURN (EXAMPLELABELFV
STRUC LABELS]
[ADVISE (QUOTE LLABELNODES)
(QUOTE BEFORE)
(QUOTE (RETURN (EXAMPLELLABELNODES
STRUC LLABELS]
[SETQ X (CONS (QUOTE DONE)
(COPY (EXAMPLE X]
(ERROR!)))
(COND
((EQ (CAR X)
(QUOTE DONE))
(CDR X))
(T (ERROR!])
(SELECT
[LAMBDA (L N)
(NLEFT L N])
(SELECTL
[LAMBDA (OBJ LNUM)
(PROG (X)
(AND LNUM (CONS [CAR (SETQ X (SPLIT OBJ (CAR LNUM]
(SELECTL (CDR X)
(CDR LNUM])
(SELECTLL
[LAMBDA (LOBJ LLNUM)
(AND LOBJ LLNUM (CONS (SELECTL (CAR LOBJ)
(CAR LLNUM))
(SELECTLL (CDR LOBJ)
(CDR LLNUM])
(EDGES
[LAMBDA (STRUC)
(FOR CT IN (fetch CTABLE of STRUC) FOR N
IN (fetch NBRS of CT)
WHEN (NOT (IGREATERP (fetch NODENUM of CT)
N))
XLIST
(CONS (fetch NODENUM of CT)
N])
(EXAMPLELLABELNODES
[LAMBDA (STRUC LLABELS)
(LIST (create LABELING LABELED←(SELECTLL (LISTBYVALENCE STRUC)
LLABELS)
LSTRUC←(create STRUCTURE reusing STRUC (SETQ GROUP
NIL])
(EXAMPLELABELFV
[LAMBDA (STRUC LABELS)
(LIST (create LABELING (SETQ LABELED (SELECTL (COLLECTFV STRUC)
LABELS))
LABELS
(SETQ LSTRUC (create STRUCTURE reusing STRUC GROUP←
NIL])
(EXAMPLELABELEDGES
[LAMBDA (STRUC LABELS)
(LIST (create LABELING LABELED←(SELECTL (EDGES STRUC)
LABELS)
LSTRUC←(create STRUCTURE reusing STRUC GROUP← NIL])
(1ATRAND
[LAMBDA (L)
(CAR (NTH L (RAND 1 (LENGTH L])
(SPLIT
[LAMBDA (L N)
(* Returns a pair of lists,
(l1 . l2) WHERE l1 is a list of elements of L, of
length N, and l2 is the REMAINDER)
(COND
((NULL L)
(LIST NIL))
((ZEROP N)
(CONS NIL L))
((EQ N (LENGTH L))
(LIST L))
[(NOT (IGREATERP (RAND 1 (LENGTH L))
N))
([LAMBDA (Z)
(RPLACA Z (CONS (CAR L)
(CAR Z]
(SPLIT (CDR L)
(SUB1 N]
(T ([LAMBDA (Z)
(RPLACD Z (CONS (CAR L)
(CDR Z]
(SPLIT (CDR L)
N])
)
(RPAQ EXAMPLEFIXED)
[ADDTOVAR USERMACROS (RX NIL MARK
[LCL (LPQ F STRUCFORM UP
(I 1 (EXAMPLE (## 1]
←←)
(X NIL RX UP (I 1 (EXAMPLE (## 1)))
1)
(DE NIL (ORR ((E (DRAW (EXAMPLE (##))
T)
T))
(E (QUOTE (can't draw]
(ADDTOVAR EDITCOMSA DE X RX)
STOP