(FILECREATED "25-FEB-82 21:23:09" <NEWLISP>CLISPENG.;1 9325
changes to: CLISPENGCOMS)
(* Copyright (c) 1982 by Xerox Corporation)
(PRETTYCOMPRINT CLISPENGCOMS)
(RPAQQ CLISPENGCOMS ((FNS CLISPIFYIS CLISPIFYIS1)
(PROP CLISPIFYISPROP ARRAYP ATOM EQUAL FLOATP LISTP NLISTP LITATOM MINUSP NUMBERP SMALLP
STRINGP TAILP GT LT MEMBER MEMB)
(SPECVARS FORM LST CLTYP0 OPR0)
(GLOBALVARS LCASEFLG CLISPIFYENGLSHFLG)
(DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
CLISPIFY))))
(DEFINEQ
(CLISPIFYIS
[LAMBDA (FORM PROP) (* wt: "24-MAR-78 15:07")
(AND CLISPIFYENGLSHFLG (NEQ OPR0 (QUOTE :))
(NEQ CLTYP0 (QUOTE IS))
(PROG (MATCHUP PHRASE SUBJ PLURALFLG SEGFLG TEM)
(COND
((LISTP PROP)
(* For most cases, PROP is an atom, namely the name of the KEY for the is phrase. but for some, there can be several
alternatives. e.g. suppose (A is the last element of B) translates to (EQ A (CAR (LAST B))) and
(A is the first element of B) to (EQ A (CAR B)) then EQ will have a CLISPIFYISPROP property of
(LAST FIRST))
[SOME PROP (FUNCTION (LAMBDA (PROP)
(SETQ TEM (CLISPIFYIS FORM PROP]
(RETURN TEM)))
(SETQ PROP (GETPROP PROP (QUOTE CLISPISFORM)))
LP (COND
([NULL (SETQ MATCHUP (CLISPIFYMATCHUP (CADDR PROP)
FORM
(CAR PROP]
(COND
((SETQ PROP (CDDDR PROP))
(GO LP)))
(RETURN NIL)))
(SETQ PHRASE (CADR PROP))
[COND
(NEGFLG (SETQ PHRASE (CONS (CAR PHRASE)
(COND
([SETQ TEM (CDDDR (GETPROP (CADR PHRASE)
(QUOTE CLISPISPROP]
(* e.g. negation of HAS is DOESN'T HAVE)
(APPEND TEM (CDDR PHRASE)))
(T (CONS (CADR PHRASE)
(COND
((EQ (CAR (SETQ PHRASE (CDDR PHRASE)))
(QUOTE NOT))
(* E.g. (NOT (NLISTP X)) clispifyies to (X IS A LIST) because the dobule negation
gets removed here.)
(CDR PHRASE))
(T (CONS (QUOTE NOT)
PHRASE]
FACTOR
(COND
[(OR (NULL CLISPISTATE)
(NULL OPR0)
(NEQ TAIL (CDR (fetch TAIL of CLISPISTATE]
([AND (EQ PROP (fetch PROP of CLISPISTATE))
(EQ NEGFLG (fetch NEGFLG of CLISPISTATE))
(EQ (fetch OBJ of MATCHUP)
(fetch OBJ of (fetch MATCHUP of CLISPISTATE]
(* Factor onrelation (AND (NUMBERP X) (NUMBERP Y)))
(* New SUBJ. Will be clispified at CLISPIFY2a below. Thus if this is the third factoring, SUBJ would no be
(AND (AND X Y) Z) but this goes to (X and Y and Z) which is what is wanted.)
(SETQ SUBJ (LIST (CAR PARENT)
(fetch SUBJ of (fetch MATCHUP of CLISPISTATE))
(fetch SUBJ of MATCHUP)))
(replace SUBJ of MATCHUP with SUBJ)
(SETQ LST (APPEND (fetch LST of CLISPISTATE)))
(* LST is bound in clipify1. it is the clispified results being assembbled. Since the previous clause is being
incorporated into the curren one, we backup LST to the value it had as of the previous is phrase.)
(SETQ PLURALFLG T)
(* For MAPCONC below.)
(SETQ SEGFLG (fetch SEGFLG of CLISPISTATE))
(* Indicates whether it is ok to remove parens or not, i.e. SEGFLG = T means ok. We cannot remove parens if there
was a non-is form before this one, e.g. (AND X (NUMBERP Y) (NUMBER Z)) cannot go to (X and Y and Z are nummers) but
instead must go to (X and (Y and Z are numbers)))
(replace TAIL of CLISPISTATE with TAIL)
(* needed to notice if there were any non-is phrases intervening between last one and this one, e.g.
(AND (NUMBERP X) Y (NUMBERP Z)) mustgo to (X is a number and Y and Z is a number))
(replace MATCHUP of CLISPISTATE with MATCHUP)
(GO SKIP))
((EQUAL (fetch SUBJ of MATCHUP)
(fetch SUBJ of (fetch MATCHUP of CLISPISTATE)))
(* Factor on subject, e.g. (AND (NUMBERP X)
(ATOM X)))
(replace MATCHUP of CLISPISTATE with MATCHUP)
(SETQ PHRASE (CDDR PHRASE))
(* Deletes the subject and the is/are word.)
(SETQ MATCHUP (CDR MATCHUP))
(* removes the subject so that it isnt substituted for in call to clispifyis1
below)
(replace TAIL of CLISPISTATE with TAIL)
(GO SKIP)))
(SETQ CLISPISTATE (create CLISPISTATE
PROP ← PROP
NEGFLG ← NEGFLG
LST ←(APPEND LST)
SEGFLG ←[EQ TAIL (CDR (COND
(CLISPISTATE
(* See comment about SEGFLG above.)
(fetch TAIL
of CLISPISTATE))
(T PARENT]
TAIL ← TAIL
MATCHUP ← MATCHUP))
SKIP[AND (OR LCASEFLG PLURALFLG)
(SETQ PHRASE (MAPCONC PHRASE (FUNCTION (LAMBDA (X)
(* Goes through the phrase and replaces the canonical form by the aprorpriate
expressions for upper or lower case, singular or plural.)
(COND
([OR (FMEMB X (CAR PROP))
(NLISTP (SETQ TEM (GETPROP X (QUOTE CLISPISPROP]
(LIST X))
((NULL PLURALFLG)
(* lowercase singular.)
(LIST (CAR TEM)))
[(NULL (CDR TEM))
(* stored on the property list of these words under the CLISPISPROP property is a list of the form
(lower-sing upper-plural lower-plural) e.g. for ATOM the property is (atom ATOMS atoms) If there is no second and
third entry, means the singular and plural are the same. However, if the second or third entry are NIL, means they
are not present for plural. E.g. this is how A and AN disappear in plural.)
(LIST (COND
(LCASEFLG (CAR TEM))
(T X]
([SETQ TEM (COND
(LCASEFLG (CADDR TEM))
(T (CADR TEM]
(LIST TEM]
(SETQ NEGFLG NIL) (* Negation has already been taken care of earlier.)
(PROG (LST (CLTYP0 (QUOTE IS))
OPR0)
(SETQ PHRASE (CLISPIFYIS1 [MAPCAR MATCHUP (FUNCTION (LAMBDA (X)
(CONS (CAR X)
(CLISPIFY2A (CDR X]
PHRASE)))
[COND
[(NULL OPR0)
(SETQ SEG (COND
((NULL CLTYP0)
NIL)
((EQ CLTYP0 (QUOTE COND))
T)
((NLISTP CLTYP0)
(HELP))
([AND (EQ TAIL (CDR CLTYP0))
[OR (NULL (CDR TAIL))
(EQ (CAR (GETPROP (CADR TAIL)
(QUOTE CLISPWORD)))
(CAR (GETPROP (CAR CLTYP0)
(QUOTE CLISPWORD]
(NULL (SOME PHRASE (FUNCTION (LAMBDA (X)
(LISTP (GETPROP X (QUOTE CLISPWORD]
(* Says there is only one expression there so safe to remove parentehses, e.g. (IF A THEN (AND B C) ELSE D) The
reason for the SOME is that cant remve parens if any of the words in L are also operators, e.g. user writes
(WHILE (IGREATERP X COUNT) do --) can't remove parens because COUNT is also an operator)
T]
((NULL PLURALFLG)
(* Always safe to remove parens on simple singlur phras.)
(SETQ SEG T))
((NULL (SETQ SEG SEGFLG))
(* If we are not going to remove parens, we have to packup the operaaors.)
(SETQ PHRASE (CLISP3A PHRASE]
(RETURN PHRASE])
(CLISPIFYIS1
[LAMBDA (ALST $EXPR) (* wt: 13-FEB-76 20 34)
(* essentially an LSUBLIS, except it knows that it is always substituting for
atoms.)
(PROG (TEM)
(RETURN (COND
((NULL $EXPR)
NIL)
((NLISTP $EXPR)
(COND
((SETQ TEM (FASSOC $EXPR ALST))
(CDR TEM))
(T $EXPR)))
[(SETQ TEM (FASSOC (CAR $EXPR)
ALST))
(APPEND (CDR TEM)
(CLISPIFYIS1 ALST (CDR $EXPR]
(T (CONS (CLISPIFYIS1 ALST (CAR $EXPR))
(CLISPIFYIS1 ALST (CDR $EXPR])
)
(PUTPROPS ARRAYP CLISPIFYISPROP ARRAY)
(PUTPROPS ATOM CLISPIFYISPROP ATOM)
(PUTPROPS EQUAL CLISPIFYISPROP EQUAL)
(PUTPROPS FLOATP CLISPIFYISPROP FLOATING)
(PUTPROPS LISTP CLISPIFYISPROP LIST)
(PUTPROPS NLISTP CLISPIFYISPROP LIST)
(PUTPROPS LITATOM CLISPIFYISPROP LITERAL)
(PUTPROPS MINUSP CLISPIFYISPROP NEGATIVE)
(PUTPROPS NUMBERP CLISPIFYISPROP NUMBER)
(PUTPROPS SMALLP CLISPIFYISPROP SMALL)
(PUTPROPS STRINGP CLISPIFYISPROP STRING)
(PUTPROPS TAILP CLISPIFYISPROP TAIL)
(PUTPROPS GT CLISPIFYISPROP GREATER)
(PUTPROPS LT CLISPIFYISPROP LESS)
(PUTPROPS MEMBER CLISPIFYISPROP MEMBER)
(PUTPROPS MEMB CLISPIFYISPROP MEMB)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS FORM LST CLTYP0 OPR0)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS LCASEFLG CLISPIFYENGLSHFLG)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
CLISPIFY)
)
(DECLARE: DONTCOPY (PUTPROPS CLISPENG COPYRIGHT ("Xerox Corporation" 1982)))
(DECLARE: DONTCOPY
(FILEMAP (NIL (515 8301 (CLISPIFYIS 525 . 7689) (CLISPIFYIS1 7691 . 8299)))))
STOP