mirror of
https://github.com/kennethreitz/elizagen.org.git
synced 2026-06-21 23:20:57 +00:00
jeffshrager
221 lines
6.0 KiB
Plaintext
221 lines
6.0 KiB
Plaintext
|
|
(DEFPROP WORKER (LAMBDA NIL (PROG (SENTENCE SOBLIST KEYSTACK)
|
|
A (INITIALIZE)
|
|
(READIN)
|
|
(ANALYZE)
|
|
(TERPRI)
|
|
(TERPRI)
|
|
(CLEANUP)
|
|
(GO A)
|
|
)) EXPR)
|
|
|
|
(DEFPROP INITIALIZE (LAMBDA NIL
|
|
(SETQ SOBLIST (APPEND OBLIST (SETQ SENTENCE (SETQ KEYSTACK NIL))))
|
|
) EXPR)
|
|
|
|
(DEFPROP READIN (LAMBDA NIL (PROG (WORD LETTER FLAG TERMINAL)
|
|
A (COND ((NULL (READWORD))(GO B)))
|
|
(MAKESENTENCE)
|
|
(SETKEYSTACK)
|
|
B (BREAKANALYZE)
|
|
(COND ((NOT FLAG)(GO A)))
|
|
(SETQ SENTENCE (REVERSE SENTENCE))
|
|
)) EXPR)
|
|
|
|
(DEFPROP ANALYZE (LAMBDA NIL (PROG (RULES PARSELIST DECOMP)
|
|
(SETQ KEYSTACK (APPEND KEYSTACK (LIST (GET (QUOTE NONE)
|
|
(COND ((ZEROP (SETQ FLIPFLOP (PLUS 2 (MINUS FLIPFLOP))))
|
|
(QUOTE MEM))((QUOTE LASTRESORT)))))))
|
|
A (SETQ RULES (GET (CAR KEYSTACK)(QUOTE RULES)))
|
|
B (SETQ DECOMP (CAAR (COND
|
|
((ATOM (CAR RULES))(SETQ RULES (GET (CAR RULES)(QUOTE RULES))))
|
|
(RULES) )))
|
|
(SETQ PARSELIST NIL)
|
|
(COND ((NOT (TEST DECOMP SENTENCE))(SETQ RULES (CDR RULES)))
|
|
((AND (NOT (ATOM (CAR (SETQ RULES (CAR (ADVANCE))))))
|
|
(NOT (EQ (CAAR RULES)(QUOTE PRE))))
|
|
(RETURN (SENTPRINT (RECONSTRUCT (CAR RULES)))))
|
|
((NOT (ATOM (CAR RULES)))
|
|
(SETQ SENTENCE (RECONSTRUCT (CADAR RULES)))
|
|
(SETQ RULES (CDDAR RULES)) )
|
|
((EQ (CAR RULES)(QUOTE NEWKEY))
|
|
(SETQ KEYSTACK (CDR KEYSTACK))
|
|
(GO A)))
|
|
(GO B)
|
|
)) EXPR)
|
|
|
|
(DEFPROP CLEANUP (LAMBDA NIL (PROG (NOBLIST)
|
|
(SETQ NOBLIST OBLIST)
|
|
A (RPLACA NOBLIST (CAR SOBLIST))
|
|
(COND ((SETQ NOBLIST (CDR NOBLIST))
|
|
(SETQ SOBLIST (CDR SOBLIST))
|
|
(GO A)))
|
|
)) EXPR)
|
|
|
|
(DEFPROP READWORD (LAMBDA NIL (PROG NIL
|
|
(SETQ WORD NIL)
|
|
A (COND ((SETQ FLAG (GET (SETQ LETTER (READCH))(QUOTE BREAK)))
|
|
(RETURN (COND (WORD (SETQ WORD (READLIST
|
|
(REVERSE WORD))))))))
|
|
(SETQ WORD (CONS LETTER WORD))
|
|
(GO A)
|
|
)) EXPR)
|
|
|
|
(DEFPROP MAKESENTENCE (LAMBDA NIL
|
|
(SETQ SENTENCE (CONS (COND
|
|
((SETQ FLAG (GET WORD (QUOTE TRANSLATION))) FLAG)
|
|
(WORD))
|
|
SENTENCE))
|
|
) EXPR)
|
|
|
|
(DEFPROP SETKEYSTACK (LAMBDA NIL (COND
|
|
((AND (SETQ FLAG (GET WORD (QUOTE PRIORITY)))
|
|
KEYSTACK
|
|
(GREATERP FLAG (GET (CAR KEYSTACK)(QUOTE PRIORITY))))
|
|
(SETQ KEYSTACK (CONS WORD KEYSTACK)))
|
|
(FLAG (SETQ KEYSTACK (APPEND KEYSTACK (LIST WORD))))
|
|
)) EXPR)
|
|
|
|
(DEFPROP BREAKANALYZE (LAMBDA NIL (COND
|
|
((EQ LETTER (INTERN (ASCII 15)))
|
|
(SETQ FLAG TERMINAL)(SETQ TERMINAL T))
|
|
((AND (SETQ FLAG (GET LETTER (QUOTE PUNCTUATION)))
|
|
KEYSTACK)
|
|
(GOBBLE))
|
|
(FLAG (SETQ SENTENCE (SETQ FLAG NIL)))
|
|
((NOT (EQ LETTER (INTERN (ASCII 12))))(SETQ TERMINAL NIL))
|
|
)) EXPR)
|
|
|
|
(DEFPROP TEST (LAMBDA (D S) (PROG NIL
|
|
G (DISINI (QUOTE FOO))
|
|
(DISPRINT KEYSTACK)
|
|
(DISPRINT SENTENCE)
|
|
(DISPRINT RULES)
|
|
(DISPRINT DECOMP)
|
|
(READCH)
|
|
(COND ((NULL D)(RETURN (COND ((NOT S) (SETQ
|
|
PARSELIST (REVERSE PARSELIST))))))
|
|
((NOT (COND ((NUMBERP (CAR D)) (COND
|
|
((ZEROP (CAR D))(TEST5))
|
|
((TEST3 (CAR D) NIL))))
|
|
((TEST4 (CAR D))(TEST2))
|
|
)) (RETURN NIL)))
|
|
|
|
(SETQ D (CDR D))
|
|
(GO G)
|
|
)) EXPR)
|
|
|
|
(DEFPROP ADVANCE (LAMBDA NIL (RPLACA
|
|
(CDAR RULES)
|
|
(COND ((NULL (CDADAR RULES))(CDDAR RULES))
|
|
((CDADAR RULES)) )
|
|
)) EXPR)
|
|
|
|
(DEFPROP SENTPRINT (LAMBDA (ANS) (PROG NIL
|
|
A (PRIN1 (CAR ANS))
|
|
|
|
(COND ((SETQ ANS (CDR ANS))
|
|
(COND ((GREATERP (FLATSIZE (CAR ANS))(ADD1 (CHRCT)))
|
|
(TERPRI))
|
|
((PRINC (QUOTE / ))) )
|
|
(GO A)) )
|
|
(MEMORY)
|
|
)) EXPR)
|
|
|
|
(DEFPROP RECONSTRUCT (LAMBDA (R) (COND
|
|
((NULL R) NIL)
|
|
((NUMBERP (CAR R))(APPEND (RECO1 (CAR R) PARSELIST)
|
|
(RECONSTRUCT (CDR R))))
|
|
((CONS (CAR R)(RECONSTRUCT (CDR R))))
|
|
)) EXPR)
|
|
|
|
(DEFPROP GOBBLE (LAMBDA NIL (PROG NIL
|
|
A (SETQ LETTER (READCH))
|
|
(BREAKANALYZE)
|
|
(COND ((NOT FLAG)(GO A)))
|
|
)) EXPR)
|
|
|
|
(DEFPROP TEST1 (LAMBDA (PROPL X) (COND
|
|
((NULL PROPL) NIL)
|
|
((GET X (CAR PROPL)) T)
|
|
((TEST1 (CDR PROPL) X))
|
|
)) EXPR)
|
|
|
|
(DEFPROP TEST2 (LAMBDA NIL (PROG NIL
|
|
(SETQ PARSELIST (CONS (LIST (CAR S)) PARSELIST))
|
|
(SETQ S (CDR S))
|
|
(RETURN T)
|
|
)) EXPR)
|
|
|
|
(DEFPROP TEST3 (LAMBDA (X L) (COND
|
|
((ZEROP X)(SETQ PARSELIST (CONS (REVERSE L) PARSELIST)))
|
|
(S (TEST3 (SUB1 X)(CONS (CAR S)(PROG2 (SETQ S (CDR S)) L))))
|
|
)) EXPR)
|
|
|
|
(DEFPROP TEST4 (LAMBDA (D) (COND ((NULL S) NIL)
|
|
((ATOM D) (EQ D (CAR S)))
|
|
((CAR D) (MEMBER (CAR S) D))
|
|
((TEST1 (CDR D) (CAR S)))
|
|
)) EXPR)
|
|
|
|
(DEFPROP TEST5 (LAMBDA NIL (PROG (L)
|
|
(COND ((NULL (CDR D)) (SETQ PARSELIST
|
|
(CONS S PARSELIST))
|
|
(RETURN (NOT (SETQ S NIL)))))
|
|
|
|
A (COND ((TEST4 (CADR D))(RETURN (SETQ PARSELIST (CONS
|
|
(REVERSE L) PARSELIST))))
|
|
((AND (SETQ L (CONS (CAR S) L)) (SETQ S (CDR S)))
|
|
(GO A)) )
|
|
)) EXPR)
|
|
|
|
(DEFPROP RECO1 (LAMBDA (X P) (COND
|
|
((GREATERP X 1)(RECO1 (SUB1 X)(CDR P)))
|
|
((CAR P))
|
|
)) EXPR)
|
|
|
|
(DEFPROP MEMORY (LAMBDA NIL (PROG (PARSELIST X)
|
|
(COND ((AND (SETQ RULES (GET (CAR KEYSTACK)(QUOTE MEMR)))
|
|
(TEST (CAAR RULES) SENTENCE))
|
|
(RPLACA (SETQ X (CDAR (GET (GET (QUOTE NONE)(QUOTE MEM))
|
|
(QUOTE RULES))))
|
|
(APPEND (CAR X) (LIST (RECONSTRUCT (CAAR (ADVANCE)))))
|
|
))) )) EXPR)
|
|
|
|
(SETQ FLIPFLOP 0)
|
|
(DEFPROP ASCII (LAMBDA (X)(LIST (CAR NIL)(QUOTE PNAME)(LIST (CDDR
|
|
(LSH X 29.)))))EXPR)
|
|
|
|
((LAMBDA (X) (PROG NIL
|
|
A (COND ((NULL X) (RETURN NIL)))
|
|
(PUTPROP (CAR X) T (QUOTE BREAK))
|
|
(SETQ X (CDR X))
|
|
(GO A)
|
|
))(LIST (QUOTE / )(INTERN (ASCII 12))(INTERN (ASCII 13))
|
|
(INTERN (ASCII 14))(INTERN (ASCII 15))(INTERN (ASCII 11))))
|
|
|
|
((LAMBDA (X) (PROG NIL
|
|
A (COND ((NULL X) (RETURN NIL)))
|
|
(PUTPROP (CAR X) T (QUOTE BREAK))
|
|
(PUTPROP (CAR X) T (QUOTE PUNCTUATION))
|
|
(SETQ X (CDR X))
|
|
(GO A)
|
|
)) (QUOTE (/. /, /( /) ! ? : ;)))
|
|
|
|
(PUTPROP (QUOTE NONE)(LIST (CAR NIL)(QUOTE RULES)(QUOTE
|
|
(((0)(NIL)(I AM NOT SURE I UNDERSTAND YOU FULLY)
|
|
(PLEASE GO ON)(WHAT DOES THAT SUGGEST TO YOU)(DO YOU
|
|
FEEL STRONGLY ABOUT DISCUSSING SUCH THINGS))) ))(QUOTE
|
|
LASTRESORT))
|
|
|
|
(PUTPROP (QUOTE NONE)(LIST (CAR NIL) (QUOTE RULES)
|
|
(LIST (LIST (LIST 0)(LIST NIL)(GET (QUOTE NONE)(QUOTE LASTRESORT))))
|
|
)(QUOTE MEM))
|
|
|
|
|
|
(ARRAY FOO NIL 1700)
|
|
(SETQ DISLIST (LIST (GET (QUOTE FOO)(QUOTE SUBR))))
|
|
(DEFPROP DISPRINT (LAMBDA (X) (PROG2 (DISAD (QUOTE FOO) ()
|
|
(QUOTE /
|
|
))(DISAD (QUOTE FOO) T X)))EXPR)
|
|
aü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü ü |