perm filename GENPAT[PAT,LMM]1 blob sn#058037 filedate 1973-08-13 generic text, type T, neo UTF8
(FILECREATED "13-AUG-73 22:51:20" GENPAT)


(DEFINEQ

(COLLECT
  [LAMBDA (FILE)
    (/SET (QUOTE CURRENTFILE)
          FILE)
    (AND FILE
         (PROGN (AND (NOT (FMEMB FILE FILELST))
                     (/SET (QUOTE FILELST)
                           (CONS FILE FILELST)))
                [OR (EQ (CAAAR (SETQ FILE (FILEVARS FILE)))
                        (QUOTE FNS))
                    (/SET FILE (CONS (LIST (QUOTE FNS))
                                     (COND
                                       [(EQ (CAR FILE)
                                            (QUOTE NOBIND))
                                         (LIST (LIST (QUOTE VARS]
                                       (T (CAR FILE]
                CURRENTFILE])

(LISTFILE
  [LAMBDA (FIL LISTFILEHOST LISTFILELOGIN)
    (BKSYSBUF (CONCAT "FTP
" [SETQ LISTFILEHOST (OR LISTFILEHOST HOST (SETQ HOST
                           (PROGN (PRIN1 "HOST? ")
                                  (READ T]
                      "
LOG "
                      [OR LISTFILELOGIN (GETP LISTFILEHOST
                                              (QUOTE LOGIN))
                          (PUT LISTFILEHOST (QUOTE LOGIN)
                               (PROGN (PRIN1 LISTFILEHOST T)
                                      (PRIN1 " LOGIN? " T)
                                      (READ T]
                      "
TE
SE " FIL "

≠DIS
QUI
QUI
"))
    (KFORK (SUBSYS])

(SAVE
  [LAMBDA NIL
    (AND (NLISTP (SYSOUT (QUOTE LARRY.SYS)))
         (DELFILE (QUOTE LARRY.SYS])

(CGQ
  [NLAMBDA (FN)
    (COPY (GETD FN])

(LISTFILES
  [LAMBDA (FILLST)
    [COND
      ((NULL FILLST)
        (SETQ FILLST NOTLISTEDFILES))
      ((NLISTP FILLST)
        (SETQ FILLST (CONS FILLST]
    (PROG1 (for FIL in FILLST do (LISTFILE (OR (INFILEP FIL)
                                               (ERROR 
                                             "NO SUCH FILE TO LIST" FIL)
                                               ))
                                 (/DSUBST NIL FIL NOTLISTEDFILES))
           (SETQ NOTLISTEDFILES (/DREMOVE NIL NOTLISTEDFILES])

(PICK
  [LAMBDA (L)
    (CAR (NTH L (RAND1 (LENGTH L])

(RAND1
  [LAMBDA (N)
    (XLATE (RAND 0.0 .999999)
           N])

(ORR
  [NLAMBDA X
    (PROG (TEM)
          [COND
            ((NULL STACK)
              (RETURN (EVAL (PICK X]
          (SETQ X (NTH X (OR (CAR STACK)
                             0)))
          (COND
            ((EVERY (CDR STACK)
                    (QUOTE NULL))
              (GO BUMP)))
      LP  (COND
            ((NULL X)
              (RPLACA STACK NIL)
              (ERROR!)))
          [COND
            ((SETQ TEM (ERSET (CAR X)))
              (RETURN (CAR TEM]
      BUMP(SETQ X (CDR X))
          (RPLACA STACK (ADD1 (OR (CAR STACK)
                                  0)))
          (GO LP])

(PAT
  [LAMBDA NIL
    (LISTOF (PATELT)
            1])

(PATELT
  [LAMBDA NIL
    (ORR (ORR (QUOTE &)
              (NUMBER)
              (STRING)
              NIL
              (CONS (QUOTE =)
                    (EXPRESSION))
              (CONS (QUOTE ==)
                    (EXPRESSION))
              (CONS (QUOTE ')
                    (EXPRESSION)))
         (ORR (QUOTE $)
              (QUOTE --))
         (CONS (QUOTE @)
               (CONS (FNNAME)
                     (PATELT)))
         (CONS (ORR (QUOTE *EVERY*)
                    (QUOTE *ANY*))
               (PAT))
         (ORR (CONS (ORR (QUOTE <-)
                         (QUOTE ←))
                    (CONS (VAR)
                          (PATELT)))
              (CONS (ORR (QUOTE →)
                         (QUOTE ->))
                    (CONS (EXPRESSION)
                          (PATELT)))
              (CONS (QUOTE *)
                    (PATELT)))
         (CONS (QUOTE SUBPAT)
               (PAT))
         (CONS (QUOTE })
               (PATELT))
         (CONS (QUOTE !)
               (PATELT))
         (CONS (QUOTE $PACKED$)
               (ORR (NUMBER)
                    (NUMBEREXPRESSION])

(EXPRESSION
  [LAMBDA (FLG)
    (ORR (COND
           (FLG NIL)
           (T (VAR)))
         (VAR)
         (NUMBER)
         (CONS (SETQ FLG (FNNAME))
               (COND
                 ((SUBRP FLG)
                   (LIST (EXPRESSION)))
                 ((GETD FLG)
                   (FOR X FROM 1 UNTIL (NARGS FLG) COLLECT (EXPRESSION))
                   )
                 (T (LISTOF (EXPRESSION)
                            0 3])

(VAR
  [LAMBDA NIL
    (PACK (LIST (PREFIX)
                (VOWEL)
                (SUFFIX])

(GENPAT
  [LAMBDA (STARDONE)
    (PROG (VAL)
          (PRINTDEF (SETQ VAL (PAT)))
          (TERPRI)
          (RETURN VAL])

(XLATE
  [LAMBDA (N1 N2)
    (ADD1 (FTIMES N2 (EXPT (FDIFFERENCE N1 .999999)
                           2])

(LISTOF
  [NLAMBDA (EXPR MIN MAX)
    (PROG (VAL (MIN (OR (EVAL MIN)
                        0))
               (MAX (OR (EVAL MAX)
                        4)))
          (RPTQ (IPLUS MIN (RAND1 (IDIFFERENCE MAX MIN)))
                (SETQ VAL (CONS (EVAL EXPR)
                                VAL)))
          (RETURN VAL])

(NUMBER
  [LAMBDA NIL
    (RAND 2 10])

(FNNAME
  [LAMBDA NIL
    (PICK (QUOTE (NUMBERP GETD EXPRP ATOM LITATOM STRINGP NNIL ZEROP 
                          INFILEP LISTP NLISTP MINUSP SMALLP 
                          EASYTORECOMPUTE])

(UNPATPARSE
  [LAMBDA (PAT)                                 (* Unpatparse each 
                                                pattern element and 
                                                NCONC values together)
    (MAPCONC PAT (FUNCTION UNPATPARSELT])

(UNPATPARSELT
  [LAMBDA (PATELT)                              (* create valid input 
                                                sytax)
    (PROG (TEM)
          (COND
            ((LITATOM PATELT)
              (SELECTQ PATELT
                       ((& $ * -- NIL T)
                         (LIST PATELT))
                       (HELP (QUOTE "CAN'T UNPATPARSE")
                             PATELT)))
            ((LISTP PATELT)
              (SELECTQ (CAR PATELT)
                       ((= == ')
                         (PACKRAT (CAR PATELT)
                                  (CDR PATELT)))
                       [* (COND
                            ((EQ (CDR PATELT)
                                 (QUOTE &))
                              (LIST (QUOTE *)))
                            (T (CONS (QUOTE *←)
                                     (UNPATPARSELT (CDR PAT]
                       [$PACKED$ (COND
                                   ((NLISTP (CDR PATELT))
                                     (PACKRAT (QUOTE $)
                                              (CDR PATELT)))
                                   (T (HELP "UNPARSE: $PACKED$ LISTP" 
                                            PATELT]
                       [≠ (LIST (PACK (CDR PATELT]
                       [≠≠ (LIST (PACKC (APPEND (CDDDR PATELT)
                                                  (QUOTE (27 27]
                       [SUBPAT (LIST (UNPATPARSE (CDR PATELT]
                       [@ (PACKRAT2 (APPEND (UNPATPARSELT (CDDR PATELT))
                                            (COND
                                              ((NLISTP (CADR PATELT))
                                                (LIST (QUOTE @)
                                                      (CADR PATELT)))
                                              ((EQ (CAADR PATELT)
                                                   (QUOTE }))
                                                (LIST (QUOTE }@)
                                                      (CDADR PATELT)))
                                              (T (HELP "UNPARSE"]
                       [(*ANY* *EVERY*)
                         (LIST (CONS (CAR PATELT)
                                     (UNPATPARSE (CDR PATELT]
                       ((← <-)
                         (NCONC [PACKRAT (CADR PATELT)
                                         (QUOTE ←)
                                         (CAR (SETQ TEM
                                                (UNPATPARSELT
                                                  (CDDR PATELT]
                                (CDR TEM)))
                       [(-> →)
                         (PACKRAT2 (APPEND (UNPATPARSELT (CDDR PATELT))
                                           (LIST (QUOTE ←)
                                                 (CADR PATELT]
                       ((} !)
                         (NCONC [PACKRAT (QUOTE !)
                                         (CAR (SETQ TEM
                                                (UNPATPARSELT
                                                  (CDR PATELT]
                                (CDR TEM)))
                       (HELP "UNPARSE")))
            ((OR (STRINGP PATELT)
                 (NUMBERP PATELT))
              (LIST PATELT))
            (T (HELP "UNPARSE"])

(PACKRAT
  [LAMBDA N
    (PROG ((CNT N)
           VAL ATLST)
      LP  (COND
            ((ZEROP CNT)
              (RETURN (PACKRAT1 ATLST VAL)))
            ((LITATOM (ARG N CNT))
              (SETQ ATLST (CONS (ARG N CNT)
                                ATLST)))
            (T (SETQ VAL (CONS (ARG N CNT)
                               (PACKRAT1 ATLST VAL)))
               (SETQ ATLST NIL)))
          (SETQ CNT (SUB1 CNT))
          (GO LP])

(PACKRAT1
  [LAMBDA (ATLST LST)
    (COND
      (ATLST (CONS (PACK ATLST)
                   LST))
      (T LST])

(TSTMATCH
  [LAMBDA (EXPR FAULTFN)                        (* EXPR AND FAULTFN ARE 
                                                NEEDED BY CLISPLOOKUP)
    (USEREXEC
      (PACK (LIST VARTOMATCH (QUOTE ":")))
      (APPEND
        [QUOTE ([G (CAR (LISPXUNREAD (LIST (UNPATPARSE (PROG (STARDONE)
                                                             (PAT]
                (STOP (RETFROM (QUOTE USEREXEC)))
                (GP (CAR (LISPXUNREAD (LIST (PROG (STARDONE)
                                                  (PAT']
        LISPXMACROS)
      (QUOTE LMUSERFN])

(LMUSERFN
  [LAMBDA (PAT EXPR)
    (COND
      ((LISTP PAT)
        (OUTPUT T)
        (LISPXPRINTDEF (PROGN (SETQ EXPR (MAKEMATCH VARTOMATCH PAT))
                              (COND
                                (CLMATCHFLG (CLISPIFY EXPR))
                                (T EXPR)))
                       1 T)
        (LISPXTERPRI T)
        (COND
          ((OPENP EXAMPLEFILE (QUOTE OUTPUT))
            (OUTPUT EXAMPLEFILE)
            (PRINT PAT)
            (TERPRI)
            (PRINTDEF EXPR)
            (PRIN1 "



")))
        (OUTPUT T)
        (RPLACA LISPXHIST (QUOTE !))
        (RETFROM (QUOTE LISPX))
        T])

(PREFIX
  [LAMBDA NIL
    (PICK0 (QUOTE ("" B C D F G H J K L M N P Q R S T V W X Z])

(SUFFIX
  [LAMBDA NIL
    (PICK0 (QUOTE (B C D E F G H J K L M N P Q R S T V W X Z])

(VOWEL
  [LAMBDA NIL
    (PICK0 (QUOTE (A E I O U OU])

(PICK0
  [LAMBDA (L)
    (CAR (NTH L (RAND 1 (LENGTH L])

(PARSEUSERFN
  [LAMBDA (PAT EXPR)
    (COND
      ((LISTP PAT)
        (PRIN1 "Parses to:" T)
        (PRINT (SETQ EXPR (PATPARSE (COPY PAT)))
               T)
        (PRIN1 "Which unparses to:" T)
        (PRINT (SETQ EXPR2 (UNPATPARSE EXPR))
               T)
        (TERPRI T)
        (CPLISTS PAT EXPR2)
        (TERPRI T)
        (CPLISTS EXPR (PATPARSE EXPR2))
        (RPLACA LISPXHIST EXPR)
        (RETFROM (QUOTE LISPX))
        T])

(TSTPARSE
  [LAMBDA NIL
    (USEREXEC
      (QUOTE PAT?)
      (APPEND
        [QUOTE ([G (CAR (LISPXUNREAD (LIST (UNPATPARSE (PROG (STARDONE)
                                                             (PAT]
                (STOP (RETFROM (QUOTE USEREXEC)))
                (GP (CAR (LISPXUNREAD (LIST (PROG (STARDONE)
                                                  (PAT']
        LISPXMACROS)
      (QUOTE PARSEUSERFN])

(ORR1
  [NLAMBDA L
    (EVAL (PICK0 L])

(PACKRAT2
  [LAMBDA (L)
    (APPLY (QUOTE PACKRAT)
           L])

(STRING
  [LAMBDA NIL
    (MKSTRING (VAR])

(NUMBEREXPRESSION
  [LAMBDA NIL
    (ORR (VAR)
         (LIST (QUOTE IPLUS)
               (VAR)
               (VAR])

(ERSET
  [LAMBDA (X)
    (PROG ((STACK (CDR STACK)))
          (ERRORSET X])
)
  (LISPXPRINT (QUOTE GENPATFNS)
              T)
  (RPAQQ GENPATFNS
         (COLLECT LISTFILE SAVE CGQ LISTFILES PICK RAND1 ORR PAT PATELT 
                  EXPRESSION VAR GENPAT XLATE LISTOF NUMBER FNNAME 
                  UNPATPARSE UNPATPARSELT PACKRAT PACKRAT1 TSTMATCH 
                  LMUSERFN PREFIX SUFFIX VOWEL PICK0 PARSEUSERFN 
                  TSTPARSE ORR1 PACKRAT2 STRING NUMBEREXPRESSION ERSET))
  (LISPXPRINT (QUOTE GENPATVARS)
              T)
  (RPAQQ GENPATVARS ((FNS DE PAT' PATELT' ELTPATELT' STUPID SMART)
          FUNNYATOMLST VARTOMATCH (VARS (CURRENTFILE)
                                        (HOST)
                                        (EXAMPLEFILE (QUOTE EXAMPLES))
                                        CLMATCHFLG PATTERNS)
          (ADVISE DEFINE LOAD UNBREAK0)
          [P (RELINK (QUOTE (UNBREAK]
          (P (MOVD (QUOTE LISPXPRINT)
                   (QUOTE LISPXPRINTDEF)))
          (PROP MACRO ORR LISTOF)
          (ADVICE PATELT)))
(DEFINEQ

(DE
  [NLAMBDA L
    (DEFINE (LIST L])

(PAT'
  [LAMBDA NIL
    (FOR X FROM 1 TO (RAND 1 5) JOIN (PATELT'])

(PATELT'
  [LAMBDA NIL
    (ORR1 (ELTPATELT')
          (LIST (ORR1 (QUOTE $)
                      (QUOTE $$)
                      (QUOTE --)))
          (ORR1 [PACKRAT2 (CONS (VAR)
                                (CONS (QUOTE ←)
                                      (PATELT']
                [PACKRAT2 (APPEND (PATELT')
                                  (LIST (QUOTE ←)
                                        (EXPRESSION]
                [PACKRAT2 (CONS (QUOTE !)
                                (CONS (VAR)
                                      (CONS (QUOTE ←)
                                            (PATELT']
                [PACKRAT2 (APPEND (PATELT')
                                  (LIST (ORR (QUOTE @)
                                             (QUOTE }@))
                                        (FNNAME]
                (PACKRAT (QUOTE $)
                         (ORR (NUMBER)
                              (VAR)))
                (PACKRAT (QUOTE !←)
                         (EXPRESSION])

(ELTPATELT'
  [LAMBDA NIL
    (ORR1 [LIST (CONS (ORR (QUOTE *ANY*)
                           (QUOTE *EVERY*))
                      (JOIN (ELTPATELT') FROM 1 TO (RAND 2 5]
          (PACKRAT (ORR (QUOTE =)
                        (QUOTE ==))
                   (EXPRESSION))
          (PACKRAT (QUOTE ')
                   (EXPRESSION))
          (LIST (ORR1 (QUOTE &)
                      (QUOTE $1)))
          (LIST (QUOTE *))
          (PACKRAT (VAR)
                   (ORR (QUOTE ≠)
                        (QUOTE ≠≠)))
          (LIST (PAT'))
          (LIST (ORR1 (VAR)
                      (NUMBER)
                      T NIL "STRING"))
          [PACKRAT2 (APPEND (ELTPATELT')
                            (LIST (ORR (QUOTE @)
                                       (QUOTE }@))
                                  (FNNAME]
          (PACKRAT2 (CONS (QUOTE })
                          (ELTPATELT')))
          [PACKRAT2 (APPEND (ELTPATELT')
                            (LIST (QUOTE ←)
                                  (EXPRESSION]
          (PACKRAT2 (CONS (VAR)
                          (CONS (QUOTE ←)
                                (ELTPATELT'])

(STUPID
  [LAMBDA NIL
    (LIST [ADVISE (QUOTE 'NOT)
                  (QUOTE (RETURN (LIST (QUOTE NOT)
                                       X]
          [ADVISE (QUOTE 'NLEFT)
                  (QUOTE (RETURN (LIST (QUOTE NLEFT)
                                       EXPR N TAIL]
          (ADVISE (QUOTE 'NOTLESSPLENGTH)
                  (QUOTE (RETURN <'NOT <'LESSP <'LENGTH X> N>>)))
          [ADVISE (QUOTE 'NTH)
                  (QUOTE (RETURN (LIST (QUOTE NTH)
                                       VAR LEN]
          [ADVISE (QUOTE 'OR)
                  (QUOTE (RETURN (CONS (QUOTE OR)
                                       LISTOFEXPRESSIONS]
          [ADVISE (QUOTE 'PLUS)
                  (QUOTE (RETURN (LIST (QUOTE IPLUS)
                                       EXPR1 EXPR2]
          [ADVISE (QUOTE 'AND)
                  (QUOTE (RETURN (LIST (QUOTE AND)
                                       EXPR1 EXPR2]
          [ADVISE (QUOTE 'CAR)
                  (QUOTE (RETURN (LIST (QUOTE CAR)
                                       X]
          [ADVISE (QUOTE 'CDR)
                  (QUOTE (RETURN (LIST (QUOTE CDR)
                                       X]
          (ADVISE (QUOTE 'REPLACE)
                  (QUOTE (RETURN <'REPLACE VAR EXPR>)))
          [ADVISE (QUOTE 'EQLENGTH)
                  (QUOTE (RETURN (LIST (QUOTE EQ)
                                       (LIST (QUOTE LENGTH)
                                             VAR)
                                       LEN]
          [ADVISE (QUOTE 'EQUAL)
                  (QUOTE (RETURN (LIST (QUOTE EQUAL)
                                       VAR EXPRESSION]
          [ADVISE (QUOTE 'NULL)
                  (QUOTE (RETURN (LIST (QUOTE NULL)
                                       X]
          (ADVISE (QUOTE 'EQ)
                  (QUOTE (RETURN (LIST (QUOTE EQ)
                                       VAR EXPRESSION])

(SMART
  [LAMBDA NIL
    (EVAL (CONS (QUOTE UNADVISE)
                (QUOTE ('NOT 'NLEFT 'NOTLESSPLENGTH 'NTH 'OR 'PLUS 'AND 
                             'CAR 'CDR 'REPLACE 'EQLENGTH 'EQUAL 'NULL])
)
  (RPAQQ FUNNYATOMLST
         ('MATCHTOP 'MATCH 'MATCHBIND 'MATCHELT 'MATCHEXP 'MATCHFIXED 
                    'MATCHSUBPAT 'MATCHTAIL 'MATCHSOME 'MATCHWITHMEMB 
                    'MATCHNNIL 'MATCHEXP1 LOCALPATVAR 'MATCH&SET 
                    'CDRLEN POSTPONE 'HEADP 'NLEFT 'NOT 'NOTLESSPLENGTH 
                    'NTH 'NTH{NUMBER⎇ 'OR 'PLUS 'REPLACE 
                    'SETQ←SIDE←EFFECT 'REPLACE←SIDE←EFFECT 'SETQ 
                    'SETVAR 'SOME 'AND '!AND 'CAR 'CDR 'EQ 'EQLENGTH 
                    'EQUAL 'LENGTH 'LISTP 'NULL 'LAST 'TAILP 'LDIFF 
                    'RETURN PATPARSE← MAKE!DEFAULT 
                    POSTPONE←SIDE←EFFECTS PAT' PATELT' LAST-TYPE))
  (RPAQQ VARTOMATCH var)
  (RPAQ CURRENTFILE)
  (RPAQ HOST)
  (RPAQQ EXAMPLEFILE EXAMPLES)
  (RPAQQ CLMATCHFLG NIL)
  (RPAQQ PATTERNS (*ANY* '& &@NUMBERP &@STRINGP '$ '-- NIL T
                         ('$PACKED$ ! (*ANY* &@NUMBERP 
                                             &@NUMBEREXPRESSION))
                         ('@ &@GETD ! &@PATTERNELT)
                         ((*ANY* '*EVERY* '*ANY*)
                          ! &@LISTOFPATTERNELTS)
                         ((*ANY* '<- '←)
                          &@VAR ! &@PATTERNELT)
                         ((*ANY* '→ '->)
                          &@EXPRESSION ! &@PATTERNELT)
                         ('= ! &@EXPRESSION)
                         ('== ! &@EXPRESSION)
                         ('' ! &@SEXPRESSION)
                         ('* ! &@ PATTERNELT)
                         ('SUBPAT ! &@LISTOFPATTERNELTS)
                         ('} ! &@PATTERNELT)))
(DEFLIST(QUOTE(
  [DEFINE
    (NIL (AFTER NIL
                (AND CURRENTFILE
                     (MAPC !VALUE
                           (FUNCTION
                             (LAMBDA (X)
                                     (/NCONC1
                                       (/DREMOVE X (CAAR (FILEVARS
                                                           CURRENTFILE))
                                                 )
                                       X]
  [LOAD (NIL (BIND NIL ((CURRENTFILE]
  [UNBREAK0 (NIL (AFTER NIL (SETQ LASTWORD FN]
))(QUOTE READVICE))

  (READVISE DEFINE LOAD UNBREAK0)
  (RELINK (QUOTE (UNBREAK)))
  (MOVD (QUOTE LISPXPRINT)
        (QUOTE LISPXPRINTDEF))
(DEFLIST(QUOTE(
  [ORR
    (L (PROG ((TEM 0))
             (CONS (QUOTE SELECTQ)
                   (CONS (LIST (QUOTE RAND1)
                               (LENGTH L))
                         (NCONC [MAPCAR L (FUNCTION
                                          (LAMBDA
                                            (X)
                                            (LIST (SETQ TEM
                                                        (ADD1 TEM))
                                                  X]
                                (QUOTE ((HELP]
  [LISTOF
    (L ([LAMBDA
          (EXPR MIN MAX)
          (LIST (QUOTE PROG)
                (QUOTE (VAL))
                (LIST (QUOTE RPTQ)
                      [COND [MIN (LIST (QUOTE IPLUS)
                                       MIN
                                       (LIST (QUOTE RAND1)
                                             (LIST (QUOTE IDIFFERENCE)
                                                   (OR MAX 10)
                                                   MIN]
                            (T (LIST (QUOTE RAND1)
                                     (OR MAX 10]
                      (LIST (QUOTE SETQ)
                            (QUOTE VAL)
                            (CONS (QUOTE CONS)
                                  (CONS EXPR (QUOTE (VAL]
        (CAR L)
        (CADR L)
        (CADDR L]
))(QUOTE MACRO))

(DEFLIST(QUOTE(
  [PATELT (NIL (BEFORE NIL (RETURN (TMPPATELT]
))(QUOTE READVICE))

STOP