summaryrefslogtreecommitdiff
path: root/progs/demo/eliza.hs
blob: d7bf975e636d0a6516d550c126832d491af0543e (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
-- Eliza: an implementation of the classic pseudo-psychoanalyst ---------------
--
-- Gofer version by Mark P. Jones, January 12 1992
--
-- Adapted from a pascal implementation provided as part of an experimental
-- package from James Risner (risner@ms.uky.edu), Univ. of KY. with original
-- pascal code apparently provided by Robert Migliaccio (mig@ms.uky.edu).
-------------------------------------------------------------------------------

import Prelude hiding (conjugate)

main  :: Dialogue
main   = interact (("\n\
		    \Hi! I'm Eliza. I am your personal therapy computer.\n\
		    \Please tell me your problem.\n\
		    \\n" ++)
                   . session initial []
                   . filter (not.null)
                   . map (words . trim)
                   . lines)

trim  :: String -> String                     -- strip punctuation characters
trim   = foldr cons "" . dropWhile (`elem` punct)
         where x `cons` xs | x `elem` punct && null xs = []
                           | otherwise                 = x : xs
               punct = [' ', '.', '!', '?', ',']

-- Read a line at a time, and produce some kind of response -------------------

session               :: State -> Words -> [Words] -> String
session rs prev []     = []
session rs prev (l:ls) = response ++ "\n\n" ++ session rs' l ls
                         where (response, rs') | prev == l = repeated rs
                                               | otherwise = answer rs l

answer                :: State -> Words -> (String, State)
answer st l            = (response, newKeyTab kt st)
 where (response, kt)         = ans (keyTabOf st)
       e `cons` (r, es)       = (r, e:es)
       ans (e:es) | null rs   = e `cons` ans es
                  | otherwise = (makeResponse a (head rs), (key,as):es)
                         where rs           = replies key l
                               (key,(a:as)) = e

-- Find all possible replies (without leading string for given key ------------

replies                 :: Words -> Words -> [String]
replies key l            = ( map (conjugate l . drop (length key))
                           . filter (prefix key . map ucase)
                           . tails) l

prefix                  :: Eq a => [a] -> [a] -> Bool
[]     `prefix` xs       = True
(x:xs) `prefix` []       = False
(x:xs) `prefix` (y:ys)   = x==y && (xs `prefix` ys)

tails                   :: [a] -> [[a]]          -- non-empty tails of list
tails []                 = []
tails xs                 = xs : tails (tail xs)

ucase                   :: String -> String      -- map string to upper case
ucase                    = map toUpper

-- Replace keywords in a list of words with appropriate conjugations ----------

conjugate  :: Words -> Words -> String
conjugate d = unwords . trailingI . map conj . maybe d  -- d is default input
              where maybe d xs = if null xs then d else xs
                    conj  w    = head ([m | (w',m)<-conjugates, uw==w'] ++ [w])
                                 where uw = ucase w
                    trailingI  = foldr cons []
                                 where x `cons` xs | x=="I" && null xs = ["me"]
                                                   | otherwise         = x:xs

conjugates :: [(Word, Word)]
conjugates  = prepare (oneways ++ concat [[(x,y), (y,x)] | (x,y) <- bothways])
              where oneways  = [ ("me",   "you") ]
                    bothways = [ ("are",  "am"),     ("we're", "was"),
				("you",  "I"),      ("your",  "my"),
				("I've", "you've"), ("I'm",   "you're") ]
                    prepare  = map (\(w,r) -> (ucase w, r))

-- Response data --------------------------------------------------------------

type Word     = String
type Words    = [Word]
type KeyTable = [(Key, Replies)]
type Replies  = [String]
type State    = (KeyTable, Replies)
type Key      = Words

repeated		  :: State -> (String, State)
repeated (kt, (r:rp))      = (r, (kt, rp))

newKeyTab                 :: KeyTable -> State -> State
newKeyTab kt' (kt, rp)     = (kt', rp)

keyTabOf                  :: State -> KeyTable
keyTabOf (kt, rp)          = kt

makeResponse             :: String -> String -> String
makeResponse ('?':cs) us  = cs ++ " " ++ us ++ "?"
makeResponse ('.':cs) us  = cs ++ " " ++ us ++ "."
makeResponse cs       us  = cs

initial     :: State
initial      = ([(words k, cycle rs) | (k,rs) <-respMsgs], cycle repeatMsgs)

respMsgs     = [ ("CAN YOU",		canYou),
		 ("CAN I",		canI),
		 ("YOU ARE",		youAre),
		 ("YOU'RE",		youAre),
		 ("I DON'T",		iDont),
		 ("I FEEL",		iFeel),
		 ("WHY DON'T YOU",	whyDont),
		 ("WHY CAN'T I",	whyCant),
		 ("ARE YOU",		areYou), 
		 ("I CAN'T",		iCant),
		 ("I AM",		iAm),
		 ("I'M",		iAm),
		 ("YOU", 		you),
		 ("YES",		yes),
		 ("NO",			no),
		 ("COMPUTER",		computer),
		 ("COMPUTERS",		computer),
		 ("I WANT",		iWant),
		 ("WHAT",		question),
		 ("HOW",		question),
		 ("WHO",		question),
		 ("WHERE",		question),
		 ("WHEN",		question),
		 ("WHY",		question),
		 ("NAME",		name),
		 ("BECAUSE",		because),
		 ("CAUSE",		because),
		 ("SORRY",		sorry),
		 ("DREAM",		dream),
		 ("DREAMS",		dream),
		 ("HI",			hello),
		 ("HELLO",		hello),
		 ("MAYBE",		maybe),
		 ("YOUR",		your),
		 ("ALWAYS",		always),
		 ("THINK",		think),
		 ("ALIKE",		alike),
		 ("FRIEND",		friend),
		 ("FRIENDS",		friend),
		 ("",			nokeyMsgs) ]

canYou	     = [ "?Don't you believe that I can",
		 "?Perhaps you would like to be able to",
		 "?You want me to be able to" ]
canI	     = [ "?Perhaps you don't want to",
		 "?Do you want to be able to" ]
youAre	     = [ "?What makes you think I am",
		 "?Does it please you to believe I am",
		 "?Perhaps you would like to be",
		 "?Do you sometimes wish you were" ]
iDont	     = [ "?Don't you really",
		 "?Why don't you",
		 "?Do you wish to be able to",
		 "Does that trouble you?" ]
iFeel	     = [ "Tell me more about such feelings.",
		 "?Do you often feel",
		 "?Do you enjoy feeling" ]
whyDont	     = [ "?Do you really believe I don't",
		 ".Perhaps in good time I will",
		 "?Do you want me to" ]
whyCant	     = [ "?Do you think you should be able to",
		 "?Why can't you" ]
areYou	     = [ "?Why are you interested in whether or not I am",
		 "?Would you prefer if I were not",
		 "?Perhaps in your fantasies I am" ]
iCant	     = [ "?How do you know you can't",
		 "Have you tried?",
		 "?Perhaps you can now" ]
iAm	     = [ "?Did you come to me because you are",
		 "?How long have you been",
		 "?Do you believe it is normal to be",
		 "?Do you enjoy being" ]
you	     = [ "We were discussing you --not me.",
		 "?Oh,",
		 "You're not really talking about me, are you?" ]
yes	     = [ "You seem quite positive.",
		 "Are you Sure?",
		 "I see.",
		 "I understand." ]
no	     = [ "Are you saying no just to be negative?",
		 "You are being a bit negative.",
		 "Why not?",
		 "Are you sure?",
		 "Why no?" ]
computer     = [ "Do computers worry you?",
		 "Are you talking about me in particular?",
		 "Are you frightened by machines?",
		 "Why do you mention computers?",
		 "What do you think machines have to do with your problems?",
		 "Don't you think computers can help people?",
		 "What is it about machines that worries you?" ]
iWant	     = [ "?Why do you want",
		 "?What would it mean to you if you got",
		 "?Suppose you got",
		 "?What if you never got",
		 ".I sometimes also want" ]
question     = [ "Why do you ask?",
		 "Does that question interest you?",
		 "What answer would please you the most?",
		 "What do you think?",
		 "Are such questions on your mind often?",
		 "What is it that you really want to know?",
		 "Have you asked anyone else?",
		 "Have you asked such questions before?",
		 "What else comes to mind when you ask that?" ]
name	     = [ "Names don't interest me.",
		 "I don't care about names --please go on." ]
because	     = [ "Is that the real reason?",
		 "Don't any other reasons come to mind?",
		 "Does that reason explain anything else?",
		 "What other reasons might there be?" ]
sorry	     = [ "Please don't apologise!",
		 "Apologies are not necessary.",
		 "What feelings do you have when you apologise?",
		 "Don't be so defensive!" ]
dream	     = [ "What does that dream suggest to you?",
		 "Do you dream often?",
		 "What persons appear in your dreams?",
		 "Are you disturbed by your dreams?" ]
hello	     = [ "How do you...please state your problem." ]
maybe	     = [ "You don't seem quite certain.",
		 "Why the uncertain tone?",
		 "Can't you be more positive?",
		 "You aren't sure?",
		 "Don't you know?" ]
your	     = [ "?Why are you concerned about my",
		 "?What about your own" ]
always	     = [ "Can you think of a specific example?",
		 "When?",
		 "What are you thinking of?",
		 "Really, always?" ]
think	     = [ "Do you really think so?",
		 "?But you are not sure you",
		 "?Do you doubt you" ]
alike	     = [ "In what way?",
		 "What resemblence do you see?",
		 "What does the similarity suggest to you?",
		 "What other connections do you see?",
		 "Cound there really be some connection?",
		 "How?" ]
friend	     = [ "Why do you bring up the topic of friends?",
		 "Do your friends worry you?",
		 "Do your friends pick on you?",
		 "Are you sure you have any friends?",
		 "Do you impose on your friends?",
		 "Perhaps your love for friends worries you." ]

repeatMsgs   = [ "Why did you repeat yourself?",
		 "Do you expect a different answer by repeating yourself?",
		 "Come, come, elucidate your thoughts.",
		 "Please don't repeat yourself!" ]

nokeyMsgs    = [ "I'm not sure I understand you fully.",
		 "What does that suggest to you?",
		 "I see.",
		 "Can you elaborate on that?",
		 "Say, do you have any psychological problems?" ]

-------------------------------------------------------------------------------