perm filename URINE[1,LMM] blob
sn#029055 filedate 1973-03-14 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
T)
(LISPXPRIN1 (QUOTE "14-MAR-73 20:14:45")
T)
(LISPXTERPRI T))
(LISPXPRINT (QUOTE URINEVARS)
T)
(RPAQQ URINEVARS
((FNS COMPUTEU STRIPH CLCONTAINS SUPERATOMSIZES SUPERATOMSIZE
SUPERATOMCOMPS COMPOF MAKESATLIST URINESAT URINESAT1
CLSUM SUPERATOMUS EXPLAIN URINERINGS QREAD START URINE
MARKACTIVESITES)
(VARS COMP1 COMP2 COMP3 COMP4)
(RECORD SATLIST)
(EDITMACRO QW)
(PROP EXPLAINATION URINERINGS)))
(DEFINEQ
(COMPUTEU
[LAMBDA (CL)
(QUOTIENT (COMPUTEFV 0 CL)
2])
(STRIPH
[LAMBDA (CL)
(FOR NEW X IN CL WHEN (NOT (EQ (QUOTE H)
(CAR X)))
XLIST X])
(CLCONTAINS
[LAMBDA (CLSMALL CL)
(PROG (FOR-VALUE Y LIST*X X)
(SETQ FOR-VALUE T)
(SETQ LIST*X CLSMALL)
LOOP*1
(COND
((NOT LIST*X)
(GO RETURN)))
(SETQ X (CAR LIST*X))
(SETQ Y (CDR (ASSOC (CAR X)
CL)))
(COND
([NOT (SETQ FOR-VALUE (AND Y (NOT (LESSP Y (CDR X]
(RETURN FOR-VALUE)))
NEXT*1
NEXT*Y
NEXT*X
(SETQ LIST*X (CDR LIST*X))
(GO LOOP*1)
RETURN
(RETURN FOR-VALUE])
(SUPERATOMSIZES
[LAMBDA NIL
(GSET (QUOTE SUPERATOMSIZES)
(PROG (FOR-VALUE LIST*S S)
(SETQ LIST*S SUPERATOMLIST)
LOOP*1
(COND
((NOT LIST*S)
(GO RETURN)))
(SETQ S (CAR LIST*S))
(SETQ FOR-VALUE (CONS (SUPERATOMSIZE S)
FOR-VALUE))
NEXT*1
NEXT*S
(SETQ LIST*S (CDR LIST*S))
(GO LOOP*1)
RETURN
(RETURN FOR-VALUE)))
(GSET (QUOTE SUPERATOMSIZES)
(INTERSECTION SUPERATOMSIZES SUPERATOMSIZES])
(SUPERATOMSIZE
[LAMBDA (S)
(FOR NEW C IN (COND
((STRUCTURE? S)
(CTABLE S))
(T S))
PLUS 1])
(SUPERATOMCOMPS
[LAMBDA NIL
(GSET (QUOTE SUPERATOMCOMPS)
(MAPCAR (GROUPBY (FUNCTION SUPERATOMSIZE)
SUPERATOMLIST)
(FUNCTION (LAMBDA (X)
(CONS (CAR X)
(MAPCAR (CDR X)
(FUNCTION COMPOF])
(COMPOF
[LAMBDA (SUP)
(CLCREATE (FOR NEW N IN (COND
((STRUCTURE? SUP)
(CTABLE SUP))
(T SUP))
XLIST
(ATOMTYPE (MARKERS N])
(MAKESATLIST
[LAMBDA NIL
[IF (NOT SUPERATOMLIST)
THEN (LOAD (QUOTE URINESUPERATOMS))
[PRINT (CONCAT "LIST OF ALREADY AVAILABLE SUPERATOMS --"
(SETQ SUPERATOMLIST
(CDR (SASSOC (QUOTE VARS)
URINESUPERATOMSVARS]
(SETQ SUPERATOMLIST (FOR X IN SUPERATOMLIST
WHEN (EQ (RP X)
(QUOTE YES))
XLIST
(EVAL X]
(GSET (QUOTE FINDSUPERATOMLIST)
(FOR NEW X
IN SUPERATOMLIST XLIST
(SATLIST SAU =(COMPUTEU (CONS (CONS (QUOTE H)
(VALENCE X))
(COMPOF X)))
SACL =(COMPOF X)
SATOM = X)))
(QUOTE FINDSUPERATOMLIST-IS-NOW-SET])
(URINESAT
[LAMBDA (CL U)
(PROG (A B C)
(SETQ A (MAPCAR (URINESAT1 CL U SUPERATOMUS)
(FUNCTION CLCREATE)))
[SETQ A
(FOR NEW PART
IN A XLIST
(MAPCAR PART
(FUNCTION (LAMBDA (X)
(CONS (FOR NEW ZZ IN FINDSUPERATOMLIST
WHEN (EQP (CAR X)
(SAU ZZ))
XLIST
(CONS (CAR X)
(SACL ZZ)))
(CDR X]
(RETURN (FOR NEW B IN A FOR NEW Z IN (GROUPRADS B)
WHEN (CLCONTAINS (SETQ C (CLSUM (CDRLIST Z)))
CL)
XLIST
(CONS (CLCREATE Z)
(CLDIFF CL C])
(URINESAT1
[LAMBDA (CL U L)
(PROG (A B)
(RETURN (COND
((ZEROP U)
(LIST NIL))
(T (FOR L ON L AS NEW X IS (CAR L)
WHEN (AND (NOT (GREATERP X U))
(SETQ A (URINESAT1 CL (DIFFERENCE
U X)
L)))
APPEND
(FOR NEW Z IN A XLIST (CONS X Z])
(CLSUM
[LAMBDA (LL)
(FOR NEW X IN LL FOR NEW L IN X FOR NEW I :=(1 (CDR L))
CLINSERT
(CAR L])
(SUPERATOMUS
[LAMBDA NIL
(PROG (A)
(GSET (QUOTE SUPERATOMUS)
(INTERSECTION (SETQ A (FOR NEW Z
IN FINDSUPERATOMLIST XLIST
(SAU Z)))
A])
(EXPLAIN
[LAMBDA (FORM)
(COND
[(STRUCLIST? FORM)
(CONS (QUOTE LIST)
(CONS (QUOTE WITH)
(COND
((NOT EXPLAINALL)
(FINDSUBLISTS FORM))
(T (FOR NEW X IN (CDDR FORM)
AS NEW I :=(1 9999)
APPEND
(LIST "
#" I (EXPLAIN X]
[(STRUCFORM? FORM)
(COND
((GETP (CADR FORM)
(QUOTE EXPLAINATION))
(APPLY (GETP (CADR FORM)
(QUOTE EXPLAINATION))
(CDDR FORM)))
(T (HELP "NO EXPLAINATION AVAILABLE" (CADR FORM]
[(STRUCTURE? FORM)
(COND
[(EQ (LASTNODE# FORM)
2)
(LIST [ATOMTYPE (MARKERS (CAR (CTABLE FORM]
(BONDING (FOR NEW X
IN (NBRS (CAR (CTABLE FORM)))
WHEN (NOT (EQ X (QUOTE FV)))
IPLUS 1))
(ATOMTYPE (MARKERS (CADR (CTABLE FORM]
(T (≠QUOTE (STRUCTURE # ≠
(CAAR (SETQ DRAWLIST
(CONS (CONS (SETQ STRUCNUM
(ADD1 STRUCNUM))
FORM)
DRAWLIST)))
DRAWN BELOW]
(T (≠QUOTE (STRUCTURE # ≠
(CAAR (SETQ DRAWLIST
(CONS (CONS (SETQ STRUCNUM
(ADD1 STRUCNUM))
FORM)
DRAWLIST)))
DRAWN BELOW])
(URINERINGS
[LAMBDA (U CL)
(FOR NEW X IN FINDSUPERATOMLIST
WHEN (AND (EQP U (SAU X))
(EQUAL CL (SACL X)))
XLIST
(SATOM X])
(QREAD
[LAMBDA (FILE)
(PROGN (INFILE FILE)
(PROG1 (READ FILE T)
(CLOSEF FILE])
(START
[LAMBDA (NUM)
(PROG (CL U)
(IF (NOT FINDSUPERATOMLIST)
THEN (UNCOLLECT)
(MAKESATLIST)
(RECOLLECT))
(FOR NUM :=(1 (COND
(NUM NUM)
(T 1)))
DO (SETQ CL (RP "CL"))
(SETQ U (RP "U"))
[COND
((ATOM CL)
(SETQ CL (EVAL CL]
(TIME (EDITE (CAR (MOLECULES CL U)))
1 0])
(URINE
[LAMBDA NIL
(PROG NIL
(MAKESATLIST)
(SUPERATOMCOMPS)
(SUPERATOMSIZES)
(SUPERATOMUS)
[ADVISE (QUOTE SUPERATOMPARTITIONS)
(QUOTE BEFORE)
(QUOTE (RETURN (URINESAT CL U]
[ADVISE (QUOTE MOLECULES)
(QUOTE BEFORE)
(QUOTE (COND
((NOT U)
(SETQ U (COMPUTEU CL))
(SETQ CL (STRIPH CL]
[ADVISE (QUOTE RINGS)
(QUOTE BEFORE)
(QUOTE (RETURN (URINERINGS U CL]
(TURNOFF (QUOTE URINERINGS))
(TURNOFF (QUOTE MOLECULES))
(PUT (QUOTE URINERINGS)
(QUOTE EXPLAINATION)
(QUOTE URINERINGS])
(MARKACTIVESITES
[LAMBDA (STRUC NODES)
(STRUCTURE
FROM STRUC CTABLE =(MAPCAR (CTABLE STRUC)
(F/L (X)
(COND
((MEMBER (NODENUM X)
NODES)
X)
(T (REMOVE ' FV X])
)
(RPAQQ COMP1 ((C . 11)
(H . 12)
(N . 2)
(O . 2)))
(RPAQQ COMP2 ((C . 11)
(H . 12)
(N . 2)
(O . 3)))
(RPAQQ COMP3 ((C . 9)
(H . 11)
(N . 1)
(O . 2)))
(RPAQQ COMP4 ((C . 9)
(H . 11)
(N . 1)
(O . 3)))
(DEFLIST(QUOTE(
(SATLIST (SAU SACL SATOM))
))(QUOTE RECORD))
(RECORD (QUOTE SATLIST))
(DEFLIST(QUOTE(
[QW (QW NIL
(IF (STRUCFORM? (##))
((BIND (E (SETQ #1 (GETFILENAM (QUOTE OUTPUT)))
T)
(E (OUTFILE #1))
(E (PRINT (LIST (##))
#1))
(E (CLOSEF #1))
(S #2)
UP MARK ↑
(E (DSUBST (≠QUOTE (STRUCFORM QREAD ≠ #1))
#2
(##))
T)
←← 1]
))(QUOTE EDITMACRO))
[EDITE (GETP (QUOTE QW)
(QUOTE EDITMACRO))
(QUOTE ((COMS (##]
(DEFLIST(QUOTE(
(URINERINGS NIL)
))(QUOTE EXPLAINATION))
STOP