fork download
  1. ;;==========================================================================
  2. ;;
  3. ;; STARTER FILE FOR CSC 4240/5240 PROGRAM #1: Eliza
  4. ;;
  5. ;;==========================================================================
  6. ;;----------------------------------------------------------------------------
  7. ;;
  8. ;; eliza: top-level function which, when given a sentence (no
  9. ;; punctuation, please!), comes back with a response like you would.
  10.  
  11. ( defun eliza ( sentence )
  12. ( respond ( change-pros sentence ) database ) )
  13.  
  14. ;;----------------------------------------------------------------------------
  15. ;; change-pros: changes the pronouns of the sentence so that Eliza can
  16. ;; come back with the appropriately switched first and second person
  17. ;; references.
  18. ( defun change-pros ( sentence )
  19. ( cond
  20. ( ( null sentence ) nil )
  21. ( ( equal ( car sentence ) 'you )
  22. ( cons 'I ( change-pros ( cdr sentence ) ) ) )
  23. ( ( equal ( car sentence ) 'I )
  24. ( cons 'you ( change-pros ( cdr sentence ) ) ) )
  25. ;; CHANGE THIS: add more cases here of pronouns or other words
  26. ;; that should flip in order for this to work well
  27. ( ( equal ( car sentence ) 'am )
  28. ( cons 'are ( change-pros ( cdr sentence ) ) ) )
  29. ( ( equal ( car sentence ) 'are )
  30. ( cons 'am ( change-pros ( cdr sentence ) ) ) )
  31. ( ( equal ( car sentence ) 'me )
  32. ( cons 'you ( change-pros ( cdr sentence ) ) ) )
  33. ( ( equal ( car sentence ) 'you )
  34. ( cons 'me ( change-pros ( cdr sentence ) ) ) )
  35. ( ( equal ( car sentence ) 'my )
  36. ( cons 'your ( change-pros ( cdr sentence ) ) ) )
  37. ( ( equal ( car sentence ) 'your )
  38. ( cons 'my ( change-pros ( cdr sentence ) ) ) )
  39. ( ( equal ( car sentence ) 'messed )
  40. ( cons 'mess ( change-pros ( cdr sentence ) ) ) )
  41. ( ( equal ( car sentence ) 'mess )
  42. ( cons 'messed ( change-pros ( cdr sentence ) ) ) )
  43. ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  44.  
  45. ;;----------------------------------------------------------------------------
  46. ;; respond: given a sentence, looks through the database in search of
  47. ;; a matching pattern and the response; given the database response,
  48. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  49. ;; response
  50.  
  51. ( defun respond ( sentence db )
  52. ( cond
  53. ;; end of DB, return nil - should never really happen
  54. ( ( null db ) nil )
  55.  
  56. ;; if the result of matching the sentence against the current
  57. ;; pattern is a success, produce this response
  58. ( ( success ( setq result ( match sentence ( first ( car db ) ) ) ) )
  59. ;;( instantiate result ( second ( car db ) ) ) )
  60.  
  61. ;; Random response function for catch-alls
  62. (instantiate result (random-pick (second (car db)))))
  63.  
  64. ;; otherwise, keep looking through the DB
  65. ( t ( respond sentence ( cdr db ) ) ) ) )
  66.  
  67. ( defun random-pick (variable-response-list)
  68. (nth (random (length variable-response-list)) variable-response-list))
  69.  
  70. ;;----------------------------------------------------------------------------
  71. ;; match: if there is not a match between this pattern and this data,
  72. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  73. ;; format
  74.  
  75. ( defun match ( data pattern )
  76. ( cond
  77. ;; end of both data and pattern; a match
  78. ( ( and ( null data ) ( null pattern ) ) nil )
  79. ;; end of pattern, but not end of data; no match
  80. ( ( null pattern ) fail )
  81. ;; end of data, but not end of pattern; if the pattern starts with
  82. ;; a variable, eat it and try and match the rest of the pattern to
  83. ;; the null sentence (will only work if all variables); otherwise,
  84. ;; fail
  85. ( ( null data )
  86. ( cond
  87. ( ( variablep ( car pattern ) )
  88. ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  89. result
  90. fail ) )
  91. ( t fail ) ) )
  92.  
  93. ;; first item of data and pattern are identical; if the rest of it
  94. ;; matched, return the first item cons'ed with the rest of the
  95. ;; partitioned sentence; otherwise, fail
  96. ( ( equal ( car data ) ( car pattern ) )
  97. ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  98. ( cons ( list ( car data ) ) result )
  99. fail ) )
  100. ;; first item of pattern is a variable; if the rest of the data
  101. ;; (minus the first word, matched to the variable) is a match with
  102. ;; all of the pattern, return the appropriate stuff; if all of the
  103. ;; data (variable eats nothing) matches the rest of the pattern,
  104. ;; return appropriate stuff; else, fail.
  105. ( ( variablep ( car pattern ) )
  106. ( cond
  107. ;; variable eats nothing; () is put in partitioned sentence
  108. ( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  109. ( cons () result ) )
  110. ;; variable eats one word; word is cons'ed into the first
  111. ;; element of the partitioned sentence, assuming that the step
  112. ;; before an actual match word would be a ()
  113. ( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  114. ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  115. ;; otherwise, fail
  116. ( t fail ) ) )
  117. ( t fail ) ) )
  118.  
  119. ;;----------------------------------------------------------------------------
  120. ;; instantiate: takes a partitioned sentence and the response it has
  121. ;; been matched to and generates the appropriated completed response
  122.  
  123. ( defun instantiate ( partitioned response )
  124. ( cond
  125. ( ( null response ) nil )
  126. ;; numbers indicate what part of the partitioned sentence to
  127. ;; insert into the response
  128. ( ( numberp ( car response ) )
  129. ( setq index ( - ( car response ) 1 ) )
  130. ( append ( nth index partitioned )
  131. ( instantiate partitioned ( cdr response ) ) ) )
  132. ( t ( cons ( car response )
  133. ( instantiate partitioned ( cdr response ) ) ) ) ) )
  134.  
  135. ;;---------------------------------------------------------------------------
  136. ;;
  137. ;; helping functions
  138. ;;
  139. ;;---------------------------------------------------------------------------
  140.  
  141. ( setq fail '-1 )
  142. ( defun success ( result )
  143. ( not ( equal result fail ) ) )
  144. ( defun variablep ( word )
  145. ( equal word '0 ) )
  146.  
  147. ;;---------------------------------------------------------------------------
  148. ;;
  149. ;; database
  150. ;;
  151. ;;---------------------------------------------------------------------------
  152. ;; CHANGE THIS: add more to this database so that the interaction is
  153. ;; more interesting and communicative and so that Eliza sounds like you
  154. ;; would sound in the same conversation!
  155. ;;---------------------------------------------------------------------------
  156.  
  157. ( setq database '(
  158. ;; example greetings/farewells -- change them to sound like you
  159. ( (Hello 0)
  160. ((Heyyy - how are you feeling today?) ))
  161. ( (0 you came here because 0)
  162. ((Many times we simply need to talk things out so I am here for you. Talk to me.) ))
  163. ( (0 Goodbye 0)
  164. ((Goodbye - I hope you are feeling better. I am here for you anytime.) ))
  165. ( (0 Sad 0)
  166. ((Why do you feel sad?) ))
  167. ( (0 Mad 0)
  168. ((What has caused you to be mad ?) ))
  169. ( (0 Yes 0)
  170. ((You have to keep trying and move forward!)) )
  171. ( (0 a little bit 0)
  172. ((You have to keep trying and move forward!) ))
  173. ( (0 No 0)
  174. ((Try harder!) ))
  175. ( (0 Not really 0)
  176. ((But why? Do better!) ))
  177. ( (0 can be 0)
  178. ((In what way ?) ))
  179. ( (0 and 0)
  180. ((So how do you think you can resolve that ?) ))
  181. ( (0 maybe 0)
  182. ((There is a possibility.) ))
  183. ( (0 Thanks 0)
  184. ((Anytime friend. Is there anything else you want to talk about ?) ))
  185. ( (0 im okay 0)
  186. ((Sounds good. Have a good rest of your day!) ))
  187.  
  188. ;; feelings
  189. ( (0 you think you 0)
  190. ((why do you think you 5 ?) ))
  191. ( (0 you want to 0)
  192. ((Take one step at a time but start somewhere and 5) ))
  193.  
  194. ;; trying to find a solution
  195. ( (0 because you 0)
  196. (( have you tried to not 4 ?) ))
  197. ( (0 because the 0)
  198. (( what makes you feel like the 4 ?) ))
  199. ( (0 but 0)
  200. (( but what if it isn't that bad 4 ?) ))
  201.  
  202. ;;the catch-alls
  203. ((0)
  204. ((Okay. Help me understand your feelings better. Tell me more.)
  205. (Can you elaborate on that ?)
  206. (Thats interesting! Expand on that.)
  207. (Im starting to understand. Please continue) ))
  208. ))
  209.  
  210.  
  211. ;; response input
  212. (format t "~a~%" (eliza '(hello)))
  213. (format t "~a~%" (eliza '(i am upset)))
  214. (format t "~a~%" (eliza '(because my football team lost a game)))
  215. (format t "~a~%" (eliza '(i fumbled the ball right at the end of the fourth quarter)))
  216. (format t "~a~%" (eliza '(but my quarterback didnt make a good throw)))
  217. (format t "~a~%" (eliza '(i blame it on him)))
  218. (format t "~a~%" (eliza '(i know i am a good catcher)))
  219. (format t "~a~%" (eliza '(he can be really mean during games)))
  220. (format t "~a~%" (eliza '(my sister also lost her volleyball game)))
  221. (format t "~a~%" (eliza '(we are both upset about our losses tonight)))
  222. (format t "~a~%" (eliza '(Do you think im a good football catcher?)))
  223. (format t "~a~%" (eliza '(well i think i am a good player)))
  224. (format t "~a~%" (eliza '(because all i do is win)))
Success #stdin #stdout #stderr 0.03s 9676KB
stdin
Standard input is empty
stdout
(HEYYY - HOW ARE YOU FEELING TODAY?)
(CAN YOU ELABORATE ON THAT ?)
(IM STARTING TO UNDERSTAND. PLEASE CONTINUE)
(IM STARTING TO UNDERSTAND. PLEASE CONTINUE)
(BUT WHAT IF IT ISN 'T THAT BAD ?)
(IM STARTING TO UNDERSTAND. PLEASE CONTINUE)
(IM STARTING TO UNDERSTAND. PLEASE CONTINUE)
(IN WHAT WAY ?)
(OKAY. HELP ME UNDERSTAND YOUR FEELINGS BETTER. TELL ME MORE.)
(CAN YOU ELABORATE ON THAT ?)
(CAN YOU ELABORATE ON THAT ?)
(WHY DO YOU THINK YOU ARE A GOOD PLAYER ?)
(IM STARTING TO UNDERSTAND. PLEASE CONTINUE)
stderr
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x14cf67000000 - 0x14cf672e4fff
  0x14cf67415000 - 0x14cf67439fff
  0x14cf6743a000 - 0x14cf675acfff
  0x14cf675ad000 - 0x14cf675f5fff
  0x14cf675f6000 - 0x14cf675f8fff
  0x14cf675f9000 - 0x14cf675fbfff
  0x14cf675fc000 - 0x14cf675fffff
  0x14cf67600000 - 0x14cf67602fff
  0x14cf67603000 - 0x14cf67801fff
  0x14cf67802000 - 0x14cf67802fff
  0x14cf67803000 - 0x14cf67803fff
  0x14cf67880000 - 0x14cf6788ffff
  0x14cf67890000 - 0x14cf678c3fff
  0x14cf678c4000 - 0x14cf679fafff
  0x14cf679fb000 - 0x14cf679fbfff
  0x14cf679fc000 - 0x14cf679fefff
  0x14cf679ff000 - 0x14cf679fffff
  0x14cf67a00000 - 0x14cf67a03fff
  0x14cf67a04000 - 0x14cf67c03fff
  0x14cf67c04000 - 0x14cf67c04fff
  0x14cf67c05000 - 0x14cf67c05fff
  0x14cf67cb3000 - 0x14cf67cb6fff
  0x14cf67cb7000 - 0x14cf67cb7fff
  0x14cf67cb8000 - 0x14cf67cb9fff
  0x14cf67cba000 - 0x14cf67cbafff
  0x14cf67cbb000 - 0x14cf67cbbfff
  0x14cf67cbc000 - 0x14cf67cbcfff
  0x14cf67cbd000 - 0x14cf67ccafff
  0x14cf67ccb000 - 0x14cf67cd8fff
  0x14cf67cd9000 - 0x14cf67ce5fff
  0x14cf67ce6000 - 0x14cf67ce9fff
  0x14cf67cea000 - 0x14cf67ceafff
  0x14cf67ceb000 - 0x14cf67cebfff
  0x14cf67cec000 - 0x14cf67cf1fff
  0x14cf67cf2000 - 0x14cf67cf3fff
  0x14cf67cf4000 - 0x14cf67cf4fff
  0x14cf67cf5000 - 0x14cf67cf5fff
  0x14cf67cf6000 - 0x14cf67cf6fff
  0x14cf67cf7000 - 0x14cf67d24fff
  0x14cf67d25000 - 0x14cf67d33fff
  0x14cf67d34000 - 0x14cf67dd9fff
  0x14cf67dda000 - 0x14cf67e70fff
  0x14cf67e71000 - 0x14cf67e71fff
  0x14cf67e72000 - 0x14cf67e72fff
  0x14cf67e73000 - 0x14cf67e86fff
  0x14cf67e87000 - 0x14cf67eaefff
  0x14cf67eaf000 - 0x14cf67eb8fff
  0x14cf67eb9000 - 0x14cf67ebafff
  0x14cf67ebb000 - 0x14cf67ec0fff
  0x14cf67ec1000 - 0x14cf67ec3fff
  0x14cf67ec6000 - 0x14cf67ec6fff
  0x14cf67ec7000 - 0x14cf67ec7fff
  0x14cf67ec8000 - 0x14cf67ec8fff
  0x14cf67ec9000 - 0x14cf67ec9fff
  0x14cf67eca000 - 0x14cf67ecafff
  0x14cf67ecb000 - 0x14cf67ed1fff
  0x14cf67ed2000 - 0x14cf67ed4fff
  0x14cf67ed5000 - 0x14cf67ed5fff
  0x14cf67ed6000 - 0x14cf67ef6fff
  0x14cf67ef7000 - 0x14cf67efefff
  0x14cf67eff000 - 0x14cf67efffff
  0x14cf67f00000 - 0x14cf67f00fff
  0x14cf67f01000 - 0x14cf67f01fff
  0x55d0b90e4000 - 0x55d0b91d4fff
  0x55d0b91d5000 - 0x55d0b92defff
  0x55d0b92df000 - 0x55d0b933efff
  0x55d0b9340000 - 0x55d0b936efff
  0x55d0b936f000 - 0x55d0b939ffff
  0x55d0b93a0000 - 0x55d0b93a3fff
  0x55d0b97f6000 - 0x55d0b9816fff
  0x7ffded58b000 - 0x7ffded5abfff
  0x7ffded5e0000 - 0x7ffded5e3fff
  0x7ffded5e4000 - 0x7ffded5e5fff