(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
                     T)
         (LISPXPRIN1 (QUOTE "20-FEB-73 01:33:37")
                     T)
         (LISPXTERPRI T))
(DEFINEQ

(TRANSORSET
  [LAMBDA NIL
    (PROG (CURRENTFN)
          (COND
            ((EQ (QUOTE NOBIND)
                 (EVALV (QUOTE TRANSFORMATIONS)))
              (RPAQ TRANSFORMATIONS)
              (RPAQ USERNOTES)
              (RPAQ UDRS)))

          (* CURRENTFN must be bound in the outer PROG so that 
          errors don't change its setting to NIL.
          LISPXHIST must be bound in the inner PROG so that 
          the initialization above will go on the history-list 
          with the call to TRANSORSET, not with the first 
          input to it. The normal return from TRANSORSET is 
          via a RETFROM in TRANSEXIT.
          The ERSETQ returns only from a control E or error.)


      OUTER
          (ERSETQ (PROG (LISPXHIST)
                    LP  (SETQ LISPXUSERFN T)    (* See LISPXUSERFN.)
                        (PROMPTCHAR (QUOTE +)
                                    T LISPXHISTORY)
                        (LISPX (LISPXREAD T)
                               (QUOTE +))
                        (GO LP)))
          (CLEARBUF T)
          (GO OUTER])

(TRANSORINPUTP
  [LAMBDA (A B)

          (* TRANSORSET has a feature whereby any random edit 
          commands typed to the + sign will be accepted as 
          part of the transformation for CURRENTFN.
          See LISPXUSERFN. TRANSORINPUTP has to decide if the 
          input looks like edit commands.
          If so, return T. A is the first thing on the input 
          line, B is a list (possibly NULL) of all the other 
          inputs on that line.)


    (PROG NIL

          (* The following test for edit input is more 
          stringent than the DWIM test which causes LISPX to 
          edit the nearest reasonable thing.
          Numbers, e.g., are not caught by DWIM because they 
          do not cause errors. However, some mistakes will not 
          be noticed by this test. Typing BO as if an atomic 
          editcommand is not legal edit input but will pass 
          this test if there is something else on the line.
          Hopefully that will not matter much.)


          (COND
            ((AND (NULL A)
                  (NULL B))                     (* True only for extra 
                                                paren's and NIL's.)
              (RETURN))
            ((EQ A (QUOTE PP))
              (RETURN)))
          (RETURN (OR (SMALLP A)
                      [AND (LITATOM A)
                           (OR (FMEMB A EDITCOMSA)
                               (AND B (FMEMB A EDITCOMSL]
                      (AND (LISTP A)
                           (OR (SMALLP (CAR A))
                               (AND (LITATOM (CAR A))
                                    (FMEMB (CAR A)
                                           EDITCOMSL])

(LISPXUSERFN
  [LAMBDA (A B)
    (PROG (INLINE)
          (COND
            ((NEQ LISPXID (QUOTE +))

          (* We would like to turn off the LISPXUSERFN 
          checking when user isn't typing to the + sign.
          So check here and turn it off, and in TRANSORSET set 
          LISPXUSERFN to T on every input.)


              (SETQ LISPXUSERFN)
              (RETURN))
            ((NULL (TRANSORINPUTP A B))

          (* Not random editcommands, so let LISPX handle it 
          normally. All the other TRANSORSET stuff is 
          implemented as vanilla LISPXMACROS so don't have to 
          worry about it here.)


              (RETURN)))
          (SETQ INLINE (CONS (COPY A)
                             (COPY B)))

          (* Always copy the works, since it will be put onto 
          the property list and will likely be edited and 
          added to a lot during the next few history events 
          and we don't want to show this on the history list.
          I.e. show input as typed in, so a REDO does what one 
          expects.)


          (AND (LITATOM A)
               (NULL (FMEMB A EDITCOMSA))
               (FMEMB A EDITCOMSL)
               (SETQ INLINE (LIST INLINE)))

          (* Convert an input line such as 
          "BO 4 5 <carriage return>" to simply be 
          (BO 4 5).)


          (COND
            ((NULL CURRENTFN)
              (ERROR (QUOTE 
                "YOU MUST SPECIFY A FUNCTION WITH THE 'FN' COMMAND")
                     (QUOTE "BEFORE TRANSFORMATIONS CAN BE STORED")
                     T)))
          (RUMARK INLINE CURRENTFN)
          (/PUT CURRENTFN (QUOTE XFORM)
                (/NCONC (GETP CURRENTFN (QUOTE XFORM))
                        INLINE))
          (AND (LISTP LISPXHIST)
               (FRPLACA LISPXHIST CURRENTFN))

          (* I want to show where these TRANSFORMATIONS went 
          on history list in case user gets confused;
          but I don't want to be printing it at him each time 
          around the loop. The only way to avoid printing is 
          to RETFROM out of LISPX; but if I do that, I have to 
          put the 'value' on the history myself.)


          (RETFROM (QUOTE LISPX])

(RUMARK
  [LAMBDA (XFORM FN)
    (AND (LISTP XFORM)
         (EDITFINDP XFORM (QUOTE (REMARK --))
                    T)
         (EDITE (LIST XFORM)
                (QUOTE ((LPQ F (REMARK --)
                             (E (RUMARK1)
                                T])

(RUMARK1
  [LAMBDA NIL
    (PROG ((CALL (CAR L))
           RNAME TEXT)
          (COND
            ((NLISTP (CDR CALL))                (* Illegally formed;
                                                complain.)
              (PRIN1 (QUOTE "
WARNING - BADLY FORMED REMARK: ")
                     T)
              (PRINT CALL T))
            ([AND (NULL (CDDR CALL))
                  (LITATOM (SETQ RNAME (CADR CALL]
                                                (* Standard use of named
                                                remark: (REMARK REMNAME)
)
              )
            ([OR [LISTP (CDR (SETQ TEXT (CDR CALL]
                 (LISTP (SETQ TEXT (CADR CALL]

          (* The user may type (REMARK RANDOM TEXT) or 
          (REMARK (RANDOM TEXT)). Either way, we make it into 
          a named remark and add star and %% as necessary.)


              [/RPLACD CALL (LIST (SETQ RNAME (GENREMNAM FN]
                                                (* FN is picked up free 
                                                from RUMARK.)
              (OR (EQ (CAR TEXT)
                      (QUOTE *))
                  (SETQ TEXT (CONS (QUOTE *)
                                   TEXT)))
              [OR (EQ (CADR TEXT)
                      (QUOTE %%))
                  (FRPLACD TEXT (CONS (QUOTE %%)
                                      (CDR TEXT]
              (/RPLACA (QUOTE USERNOTES)
                       (CONS (LIST RNAME TEXT)
                             USERNOTES])

(TRANSUNDER
  [NLAMBDA (TSETFN FLG)

          (* This function is used by the TRANSORSET commands 
          implemented as LISPXMACROS, to do initial checks.
          Abort if not at + sign, and make sure that every 
          element of the input line is atomic, unless FLG=T 
          (for the TEST command, the only one at present which 
          can legally take a non-atomic arg.))


    (COND
      ((NEQ (EVALV (QUOTE LISPXID))
            (QUOTE +))
        (LISPXUNREAD (QUOTE (REDO -1)))
        (TRANSORSET))
      (T [OR FLG (MAPC LISPXLINE (FUNCTION (LAMBDA (X)
                           (COND
                             ((NOT (LITATOM X))
                               (ERROR (QUOTE "ARG NOT LITATOM:")
                                      X T]
         (APPLY* TSETFN LISPXLINE])

(TXFN
  [LAMBDA (LIN)
    (COND
      ((NULL LIN)

          (* 'FN' followed by carriage return or NIL at + will 
          just print current value of CURRENTFN without 
          changing it.)


        CURRENTFN)
      (T [MAPC LIN (FUNCTION (LAMBDA (X)
                   (TXFN1 X T]
         (CAR (LAST LIN])

(TXFN1
  [LAMBDA (FN OLDMESS)

          (* TXFN1 is used in several ways.
          TXFN uses it to reset CURRENTFN, but never to NIL.
          Other function use it to reset CURRENTFN to NIL, to 
          their last arg, or for side effect of 'noticing' a 
          FN name.)


    [AND CURRENTFN (NULL (GETP CURRENTFN (QUOTE XFORM)))
         (/RPLACA (QUOTE TRANSFORMATIONS)
                  (/DREMOVE CURRENTFN (CAR (QUOTE TRANSFORMATIONS]

          (* It is desirable to avoid accumulating atoms on 
          TRANSFORMATIONS which never got any entries.
          User probably mistyped the arg to a FN command, and 
          should be able to just do FN again without having to 
          ERASE the bad entry.)


    (AND OLDMESS FN (GETP FN (QUOTE XFORM))
         (PRINT (QUOTE (OLD XFORMS))
                T))                             (* If the new CURRENTFN 
                                                already has some 
                                                TRANSFORMATIONS, alert 
                                                user.)
    [AND FN [NULL (FMEMB FN (CAR (QUOTE TRANSFORMATIONS]
         (/RPLACA (QUOTE TRANSFORMATIONS)
                  (CONS FN (CAR (QUOTE TRANSFORMATIONS]

          (* Put FN on TRANSFORMATIONS if necessary, and 
          finally reset CURRENTFN. Value of TXFN1 is not 
          used.)


    (SAVESETQ CURRENTFN FN)
    NIL])

(TXDUMP
  [LAMBDA (LIN)
    (PROG ((FILE (CAR LIN))
           F)
          (TXFN1)
          (SORT TRANSFORMATIONS)
          (SORT USERNOTES T)
          [COND
            (FILE (SETQ F FILE))
            ((NEQ (QUOTE NOBIND)
                  (CAR (QUOTE DUMPFILE)))
              (SETQ F DUMPFILE))
            (T (PRIN1 (QUOTE "
FILE: ")
                      T)
               (SETQ F (RATOM T]
          (COND
            ((NULL (SETQ FILE (OUTFILEP F)))
              (ERROR (QUOTE "CANNOT OPEN FILE:")
                     F T)))
          (/RPLACA (QUOTE DUMPFILE)
                   F)
          (SETQ F (NAMEFIELD F))
          [COND
            ([NOT (ASSOC (QUOTE TRANSAVE)
                         (CAR (QUOTE XFORMSVARS]

          (* Initialize VARS if necessary;
          if some existing stuff just add TSET's command to 
          it, otherwise initialize to 
          ((transave)))


              (/RPLACA (QUOTE XFORMSVARS)
                       (CONS (LIST (QUOTE TRANSAVE))
                             (LISTP (CAR (QUOTE XFORMSVARS]
          (COND
            ((EQ (CAR (QUOTE XFORMSFNS))
                 (QUOTE NOBIND))

          (* If we leave it nobind, PRETTYDEF won't write out 
          an RPAQQ and therefore when FILE is loaded it won't 
          clobber any possible previous settings of 
          xformsfns.)


              (/RPLACA (QUOTE XFORMSFNS)
                       NIL)))
          (PRETTYDEF (QUOTE XFORMSFNS)
                     FILE
                     (QUOTE XFORMSVARS))
          (RETURN FILE])

(TXERASE
  [LAMBDA (LIN)

          (* Forgets the TRANSFORMATIONS for functions.
          Undoable. Has to remove the property entry with 
          REMPROP, and take them off the list TRANSFORMATIONS.
          Always resets CURRENTFN to NIL.
          ERASE followed by carriage return erases CURRENTFN.)


    (COND
      ((NLISTP LIN)
        (TXERASE1 CURRENTFN))
      (T (TXFN1 (CAR (LAST LIN)))
         (MAPCAR LIN (FUNCTION TXERASE1])

(TXERASE1
  [LAMBDA (FN)
    [AND (FMEMB FN (CAR (QUOTE TRANSFORMATIONS)))
         (/RPLACA (QUOTE TRANSFORMATIONS)
                  (/DREMOVE FN (CAR (QUOTE TRANSFORMATIONS]
    (COND
      ((GETP FN (QUOTE XFORM))
        (/REMPROP FN (QUOTE XFORM))
        FN)
      (T (CONS FN (QUOTE (-- NOTHING FOUND.])

(TXTEST
  [LAMBDA (LIN)
    (PROG ((TESTRAN T)
           (OLDO (OUTPUT T)))

          (* TESTRAN is a flag used by the listing machinery 
          to suppress listing for the tests made my the TEST 
          command.)


          (COND
            ((LISTP (CAR LIN))
              (/RPLACA (QUOTE TESTFORM)
                       (CAR LIN)))
            ((NULL (CAR (QUOTE TESTFORM)))
              (ERROR (QUOTE "CORRECT FORMAT IS:")
                     (QUOTE "TEST  (SAMPLE S-EXPRESSION TO TRANSOR)")
                     T)))
          (COND
            ((NULL (GETD (QUOTE TRANSORFORM)))
              (ERROR (QUOTE 
          "YOU MUST LOAD <LISP>TRANSOR.COM TO USE THE TEST COMMAND")
                     (QUOTE π)
                     T)))
          (RETURN (PROG1 [TRANSORFORM (COPY (CAR (QUOTE TESTFORM]
                         (OUTPUT OLDO])

(TXSHOW
  [LAMBDA (LIN)
    (PROG [(OLDO (OUTPUT T))
           (FLG (OR (NULL LIN)
                    (CDR LIN]
          (OR LIN (SETQ LIN (LIST CURRENTFN)))
          [MAPC LIN (FUNCTION (LAMBDA (FN)
                    (TXFN1 FN)
                    (COND
                      (FLG 

          (* Print the name of each transformation being shown 
          if more than one being done, or if doing the 
          default)


                           (PRINT FN)))
                    [PRINTDEF (OR (GETP FN (QUOTE XFORM))
                                  (QUOTE (NO TRANSFORMATIONS]
                    (TERPRI]
          (OUTPUT OLDO)
          (RETURN (CAR (LAST LIN])

(TXEDIT
  [LAMBDA (LIN)
    (OR LIN (SETQ LIN (LIST CURRENTFN)))
    [MAPC LIN (FUNCTION (LAMBDA (FN)
              (TXFN1 FN)
              (RUMARK (PUT FN (QUOTE XFORM)
                           (EDITE (OR (GETP FN (QUOTE XFORM))
                                      (ERROR FN (QUOTE "NOT EDITABLE")
                                             T))
                                  NIL FN))
                      FN]
    (CAR (LAST LIN])

(TXEXIT
  [LAMBDA NIL
    (FRPLACA (QUOTE USERINPUTP))
    (RETFROM (QUOTE TRANSORSET])

(TXNOTE
  [LAMBDA (LIN)

          (* Remark has a mandatory arg, the name of the 
          remark. If old, edits it; if new, demands TEXT and 
          enters it on USEREMARKS.)


    (PROG ((NAME (CAR LIN))
           TEXT)
          (COND
            ((OR (NULL NAME)
                 (NULL (LITATOM NAME)))
              (ERROR (QUOTE "ARG NOT LITATOM:")
                     NAME T))
            ([SETQ TEXT (CADR (FASSOC NAME (CAR (QUOTE USERNOTES]
              [EDITE (COND
                       ((EQ (CADR TEXT)
                            (QUOTE %%))         (* Don't edit the star 
                                                and per-cent sign we put
                                                in for him.)
                         (CDDR TEXT))
                       (T (CDR TEXT]            (* Old remark;
                                                EDIT it.)
              (RETURN NAME))
            ((LISTP (SETQ TEXT (CDR LIN)))      (* He should be able to 
                                                type either 
                                                "REMARK NAME RANDOM TEXT"
)
              [COND
                ((AND (LISTP (CAR TEXT))
                      (NULL (CDR TEXT)))        (* or 
                                                "REMARK NAME(RANDOM TEXT]"
)
                  (SETQ TEXT (CAR TEXT]
              (GO CHECKTXT))
            ((NOT (LISPXREADP))
              (PRIN1 (QUOTE "TEXT: ")
                     T)))
          (SETQ TEXT (READ T))
          [COND
            ((NLISTP TEXT)
              (SETQ TEXT (CONS TEXT (READLINE]

          (* Make sure it works whether he types in a list or 
          a line.)


      CHECKTXT
          (OR (EQ (CAR TEXT)
                  (QUOTE *))
              (SETQ TEXT (CONS (QUOTE *)
                               TEXT)))          (* Make sure it has a 
                                                star.)
          [OR (EQ (CADR TEXT)
                  (QUOTE %%))
              (FRPLACD TEXT (CONS (QUOTE %%)
                                  (CDR TEXT]    (* Make sure it gets 
                                                lower-cased.)
          [/RPLACA (QUOTE USERNOTES)
                   (CONS (LIST NAME TEXT)
                         (CAR (QUOTE USERNOTES]
                                                (* Enter on list of 
                                                remarks he has defined.)
          (RETURN NAME])

(GENREMNAM
  [LAMBDA (FN)

          (* Generates a name for a remark which has been used 
          in the transformation for FN.)


    (PROG [(N 0)
           (NAM (PACK (LIST FN (QUOTE :]
      CHECKIT
          (COND
            ((NULL (FASSOC NAM USERNOTES))      (* Name hasn't been used
                                                already so is ok.)
              (RETURN NAM)))
          [SETQ NAM (PACK (LIST FN (SETQ N (ADD1 N))
                                (QUOTE :]       (* Otherwise try again, 
                                                adding, or incrementing,
                                                a suffix of the FORM n:)
          (GO CHECKIT])

(TXDELNOTE
  [LAMBDA (LIN)
    (MAPCAR LIN (FUNCTION (LAMBDA (R1 TMP)
                (SETQ TMP (FASSOC R1 USERNOTES))
                (COND
                  [(NULL TMP)
                    (CONS R1 (QUOTE (NOT FOUND]
                  (T (/RPLACA (QUOTE USERNOTES)
                              (/DREMOVE TMP USERNOTES))
                     R1])
)
  (LISPXPRINT (QUOTE TSETFNS)
              T)
  (RPAQQ TSETFNS
         (TRANSORSET TRANSORINPUTP LISPXUSERFN RUMARK RUMARK1 
                     TRANSUNDER TXFN TXFN1 TXDUMP TXERASE TXERASE1 
                     TXTEST TXSHOW TXEDIT TXEXIT TXNOTE GENREMNAM 
                     TXDELNOTE))
  (LISPXPRINT (QUOTE TSETVARS)
              T)
  (RPAQQ
    TSETVARS
    (TSETMACROS
      (VARS
        (LISPXMACROS (APPEND TSETMACROS LISPXMACROS))
        (TESTFORM)
        [LISPXCOMS (NCONC LISPXCOMS (MAPCAR TSETMACROS
                                            (FUNCTION CAR]
        (MERGE)
        (PRETTYMACROS
          (CONS
            [QUOTE
              (TRANSAVE
                NIL DUMPFILE USERNOTES NLISTPCOMS LAMBDACOMS
                (PROP XFORM * TRANSFORMATIONS)
                (P (COND [(EQ (EVALV (QUOTE MERGE))
                              T)
                          [RPAQ TRANSFORMATIONS
                                (UNION TRANSFORMATIONS
                                       (LISTP (GETP (QUOTE 
                                                    TRANSFORMATIONS)
                                                    (QUOTE VALUE]
                          (MAPC (GETP (QUOTE USERNOTES)
                                      (QUOTE VALUE))
                                (FUNCTION (LAMBDA
                                            (NOTE)
                                            (OR (ASSOC (CAR NOTE)
                                                       USERNOTES)
                                                (SETQ USERNOTES
                                                      (CONS NOTE 
                                                          USERNOTES]
                         (T (MAPC (GETP (QUOTE TRANSFORMATIONS)
                                        (QUOTE VALUE))
                                  (FUNCTION
                                    (LAMBDA (X)
                                            (AND (NOT (MEMB X 
                                                     TRANSFORMATONS))
                                                 (/REMPROP
                                                   X
                                                   (QUOTE XFORM]
            PRETTYMACROS))
        (LCASELST (APPEND (QUOTE (DO TRANSFORMATIONS))
                          LCASELST)))
      (PROP UCASE BBN LISP SRI MIT QA3 PLANNER)))
  [RPAQQ TSETMACROS ((SHOW (TRANSUNDER TXSHOW))
          (EXIT (TRANSUNDER TXEXIT))
          (NOTE (TRANSUNDER TXNOTE T))
          (TEST (TRANSUNDER TXTEST T))
          (ERASE (TRANSUNDER TXERASE))
          (EDIT (TRANSUNDER TXEDIT))
          (DUMP (TRANSUNDER TXDUMP))
          (FN (TRANSUNDER TXFN))
          (DELNOTE (TRANSUNDER TXDELNOTE]
  (RPAQ LISPXMACROS (APPEND TSETMACROS LISPXMACROS))
  (RPAQ TESTFORM)
  [RPAQ LISPXCOMS (NCONC LISPXCOMS (MAPCAR TSETMACROS
                                           (FUNCTION CAR]
  (RPAQ MERGE)
  (RPAQ
    PRETTYMACROS
    (CONS
      [QUOTE
        (TRANSAVE
          NIL DUMPFILE USERNOTES NLISTPCOMS LAMBDACOMS
          (PROP XFORM * TRANSFORMATIONS)
          (P (COND [(EQ (EVALV (QUOTE M