Chris Pollett>Old Classes>PIC 15, Fall 1999>Hw6
Read SICP 406-478. For this assignment you can work in either Prolog or Scheme. Your job is to add to either the Scheme or Prolog code below to make as sophisticated computer therapist as possible. The minimum you are required to do is to add at least six new patterns recognized by the Eliza program as well as double the number of important words it acts on. However, you are encouraged to make your program as clever as possible. The top three programs will receive bonus points. The person with the best program will have their final grade raised to the next higher grade. The two runner-ups will receive three bonus points on their grade after curving. You can improve Eliza by doing things other than strict pattern matching. You might also want to have different types of important words. Another thing you can do is dynamically add and delete from possible patterns. You should name your program in the \submit folder as either hw6.scm or hw6.P depending or whether you used Scheme or Prolog.
% eliza - a short psychoanalysis program (based on code from Stirling Shapiro)
%
% the goal: eliza. runs this program
%
% I forgot to mention you can also do comments this way in Prolog
%
eliza :- greeting, read_word_list(Input), eliza(Input), !.
eliza([bye]) :- write('Goodbye. Hope I have been helpful').
eliza(Input) :- pattern(Stimulus, Response),
match(Stimulus, Dictionary, Input),
match(Response, Dictionary, Output),
reply(Output),
read_word_list(Input1),
!, eliza(Input1).
greeting :-
write('Hi there, I am Eliza, a therapy program. How may I help you?'), nl.
match([N|Pattern],Dictionary,Target) :-
integer(N),lookup(N,Dictionary,LeftTarget),
append(LeftTarget,RightTarget,Target),
match(Pattern,Dictionary,RightTarget).
match([Word|Pattern],Dictionary,[Word|Target]) :-
atom(Word), match(Pattern, Dictionary,Target).
match([],_,[]).
lookup(Key,dict(Key,X,_,_), Value) :- !, X= Value.
lookup(Key,dict(Key1,_,Left,_), Value) :- Key < Key1,
lookup(Key,Left,Value).
lookup(Key,dict(Key1,_,_,Right), Value) :- Key > Key1,
lookup(Key,Right,Value).
reply([Head|Tail]) :- write(Head), write(' '),reply(Tail).
reply([]) :-nl.
pattern([i, am, 1], [how, long, have, you, been, 1,?]).
pattern([1,you,2,me],[what,makes,you,think,i,2,you,?]).
pattern([i, like, 1],[does,anyone,else,in, your, family, like,1,?]).
pattern([i, feel, 1],[do, you,often,feel, that, way,?]).
%
%add your code here...
%
pattern([1,X,2],[can, you,tell,me, more, about,X,?]) :- important(X).
pattern([1],[please,go,on]).
important(father).
important(mother).
important(sister).
important(brother).
important(son).
important(daughter).
%
%and add your code here...
%
read_word_list(Ws) :- get0(C),
read_word_list(C,Ws).
read_word_list(C,[W|Ws]) :- word_char(C),
read_word(C,W,C1),
read_word_list(C1,Ws).
read_word_list(C,Ws) :- fill_char(C),
get0(C1),
read_word_list(C1,Ws).
read_word_list(C,[]) :- end_of_words_char(C).
read_word(C,W,C1) :- word_chars(C,Cs,C1),
name(W,Cs).
word_chars(C,[C|Cs],C0) :- word_char(C),
!,
get0(C1),
word_chars(C1,Cs,C0).
word_chars(C,[],C) :- not(word_char(C)).
word_char(C) :- 97 =< C, C =< 122. %lower-case
word_char(C) :- 65 =< C, C =< 90. %upper-case
word_char(95). %underscore
fill_char(32). %space
end_of_words_char(46). %period
end_of_words_char(10). %carriage return
append([],L,L).
append([X|L1],L2,[X|L3]) :- append(L1,L2,L3).
;
; Now the Scheme version
;
;eliza
;=====
; runs the eliza therapy program
;
;Example Session
;================
; >(eliza)
;Hi there, I am Eliza, a therapy program. How may I help you?
;I am so orange
;how long have you been so orange ?
;dsaf agga you dfgsdf sghhsg me
;what makes you think i dfgsdf sghhsg you ?
;bye
;
(define (eliza)
(define (eliza-loop)
(let ((x (read-input)))
(cond ((null? x) '())
((not (eq? (car x) 'bye))
(begin
(reply (match x pattern))
(eliza-loop))))))
(begin
(display "Hi there, I am Eliza, a therapy program. How may I help you?")
(newline)
(eliza-loop)
)
)
; match
; =====
; takes as input a list x and matches it against a list of pattern-pairs called plist
; outputs the response generated by the first pair to match x.
;
; Example:
; ========
; x is (i am very hungry)
;
; plist is ( ((you are 1) (why am i 1)) ((i am 1 2)(are you 1 1 1 2)) )
;
; then the list (are you very very very hungry) will be returned
(define (match x plist)
(if (not (null? plist))
(or (first-match x (car plist))
(match x (cdr plist)))))
; first-match
; ===========
; takes as input a list sentence and a single pattern-pair. If sentence matches
; with the car of the pattern pair then the response called for by the cdr of
; the pattern pair is generated. Otherwise #f is returned
;
; Example:
; ========
; sentence is (i am an ape)
;
; pattern-pair is ((i am an 1 )(are you a big 1))
;
; then the list (are you a big ape) will be returned
(define (first-match sentence pattern-pair)
(let ((matched-list (pattern-match sentence (car pattern-pair))))
(if matched-list
(insert-pattern matched-list (cadr pattern-pair))
#f)))
; pattern-match
; =============
; takes a list sentence and a pattern. If the pattern matches with the
; sentence then a table of what the integers and the xxx's map to is returned.
; Otherwise #f is returned.
;
; Example:
; ========
; sentence is (i am very schemelike and functional)
;
; pattern is (i am 1 and 2)
;
; then the table ( (1 (very schemelike)) (2 (functional)) ) will be returned.
(define (pattern-match sentence pattern)
(define (do-rest)
(pattern-match (cdr sentence) (cdr pattern)))
(define (match-number word pat)
(or (pattern-match sentence (cdr pattern))
(let ((pmatch (do-rest)))
(if pmatch
(cons (cons pat (list word)) pmatch)
(let ((rematch (pattern-match (cdr sentence) pattern)))
(if rematch
(cons (cons pat (cons word (cdr (car rematch)))) (cdr rematch))
#f))))))
(define (match-important word pat)
(if (find? word important)
(let ((pmatch (do-rest)))
(if pmatch (cons (cons 'xxx (list word)) pmatch) #f)
)
#f))
(cond ( (and (null? sentence) (null? pattern)) '())
( (or (null? sentence) (null? pattern)) #f)
(else (let ((word (car sentence))
(pat (car pattern)))
(cond
((number? pat) (match-number word pat))
((important? pat) (match-important word pat))
((eq? word pat) (do-rest))
(else #f)
))))
)
; insert-pattern
; =============
;
; Takes a table and a pattern and replaces the integer and xxx elements of the pattern
; with their value out of the table
;
; Example
; =======
; If the table was:
; ((1 (your nose)) (2 (is really)))
;
; and the pattern was: (1 2 too big. get plastic surgery dude)
; then the output would be: (your nose is really too big. get plastic surgery dude)
;
(define (insert-pattern table pattern)
(define (insert pat)
(if (null? pat) '()
(let ((first (car pat))
(rest (cdr pat)))
(if (or (number? first) (important? first))
(append (lookup-table first table) (insert (cdr pat)))
(cons first (insert (cdr pat)))
))))
(insert pattern)
)
; lookup-table
; =============
;
; Takes a key and a table and returns info associated with key if key is in the table
;
; Example
; =======
; If the table was:
; ((1 (you)) (2 (snore)))
;
; and the key was: 1
; then the output would be: (you)
;
(define (lookup-table key table)
(cond ((null? table) #f)
((eq? key (caar table)) (cdr (car table)))
(else (lookup-table key (cdr table)))))
; important?
; =============
;
; Checks if item matches the important tag
;
(define (important? item)
(eq? item 'xxx))
; find?
; =============
;
; Checks if word is an element of the list set
;
(define (find? word set)
(cond ((null? set) #f)
((eq? word (car set)) #t)
(else (find? word (cdr set)))))
;
; add your code to pattern
;
(define pattern '(((I am 1)(How long have you been 1 ?))
((1 you 2 me) (What makes you think I 2 you ?))
((I like 1) (Does anyone else in your family like 1 ?))
((I feel 1) (Do you often feel that way ?))
((1 XXX 2) (Can you tell me more about XXX ?))
((1) (Please go on))
)
)
;also add your code to important
;
(define important '(father mother sister brother son daughter))
; reply
; =============
;
; Prints out the list passed to it
;
(define (reply list)
(if (null? list)
(newline)
(begin
(display (car list))
(display " ")
(reply (cdr list)))))
; read-input
; =============
;
; Gets an input from the user
;
(define (read-input)
(define (get-word s)
(if (char=? (peek-char) #\newline)
(list (string->symbol s))
(let ((c (string (char-downcase (read-char)))))
(if (string=? c " ")
(list (string->symbol s))
(get-word (string-append s c))
)
)
)
)
(if (char=? (peek-char) #\newline)
(begin (read-char) '()) ;get rid of the newline in the buffer and return
; empty list
(append (get-word "") (read-input))
)
)