fork download
  1. ;;==========================================================================
  2. ;;
  3. ;; STARTER FILE FOR CSC 4240/5240 PROGRAM #1: Eliza
  4. ;;==========================================================================
  5.  
  6. ;;----------------------------------------------------------------------------
  7. ;; eliza: top-level function which, when given a sentence (no
  8. ;; punctuation, please!), comes back with a response like you would.
  9.  
  10. ( defun eliza ( sentence )
  11. ( respond ( change-pros sentence ) database ) )
  12.  
  13. ;;----------------------------------------------------------------------------
  14. ;; change-pros: changes the pronouns of the sentence so that Eliza can
  15. ;; come back with the appropriately switched first and second person
  16. ;; references.
  17.  
  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. ( ( equal ( car sentence ) 'am )
  26. ( cons 'are ( change-pros ( cdr sentence ) ) ) )
  27.  
  28. ;; CHANGE THIS: add more cases here of pronouns or other words
  29. ;; that should flip in order for this to work well
  30.  
  31. ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  32.  
  33. ;;----------------------------------------------------------------------------
  34. ;; respond: given a sentence, looks through the database in search of
  35. ;; a matching pattern and the response; given the database response,
  36. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  37. ;; response
  38.  
  39. (defun respond (sentence db)
  40. (cond
  41. ;; end of DB, return nil - should never really happen
  42. ((null db) nil)
  43.  
  44. ;; if the result of matching the sentence against the current
  45. ;; pattern is a success, produce this response
  46. ((success (setq result (match sentence (first (car db)))))
  47. (let ((response (instantiate result (second (car db)))))
  48. (format t "~a~%" response)
  49. response))
  50.  
  51.  
  52. ;; otherwise, keep looking through the DB
  53. (t (respond sentence (cdr db)))))
  54.  
  55.  
  56. ;;----------------------------------------------------------------------------
  57. ;; match: if there is not a match between this pattern and this data,
  58. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  59. ;; format
  60.  
  61. ( defun match ( data pattern )
  62. ( cond
  63. ;; end of both data and pattern; a match
  64. ( ( and ( null data ) ( null pattern ) ) nil )
  65.  
  66. ;; end of pattern, but not end of data; no match
  67. ( ( null pattern ) fail )
  68.  
  69. ;; end of data, but not end of pattern; if the pattern starts with
  70. ;; a variable, eat it and try and match the rest of the pattern to
  71. ;; the null sentence (will only work if all variables); otherwise,
  72. ;; fail
  73. ( ( null data )
  74. ( cond
  75. ( ( variablep ( car pattern ) )
  76. ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  77. result
  78. fail ) )
  79. ( t fail ) ) )
  80.  
  81.  
  82. ;; first item of data and pattern are identical; if the rest of it
  83. ;; matched, return the first item cons'ed with the rest of the
  84. ;; partitioned sentence; otherwise, fail
  85. ( ( equal ( car data ) ( car pattern ) )
  86. ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  87. ( cons ( list ( car data ) ) result )
  88. fail ) )
  89.  
  90. ;; first item of pattern is a variable; if the rest of the data
  91. ;; (minus the first word, matched to the variable) is a match with
  92. ;; all of the pattern, return the appropriate stuff; if all of the
  93. ;; data (variable eats nothing) matches the rest of the pattern,
  94. ;; return appropriate stuff; else, fail.
  95. ( ( variablep ( car pattern ) )
  96. ( cond
  97. ;; variable eats nothing; () is put in partitioned sentence
  98. ( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  99. ( cons () result ) )
  100. ;; variable eats one word; word is cons'ed into the first
  101. ;; element of the partitioned sentence, assuming that the step
  102. ;; before an actual match word would be a ()
  103. ( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  104. ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  105. ;; otherwise, fail
  106. ( t fail ) ) )
  107.  
  108. ( t fail ) ) )
  109.  
  110. ;;----------------------------------------------------------------------------
  111. ;; instantiate: takes a partitioned sentence and the response it has
  112. ;; been matched to and generates the appropriated completed response
  113.  
  114. ( defun instantiate ( partitioned response )
  115. ( cond
  116. ( ( null response ) nil )
  117. ;; numbers indicate what part of the partitioned sentence to
  118. ;; insert into the response
  119. ( ( numberp ( car response ) )
  120. ( setq index ( - ( car response ) 1 ) )
  121. ( append ( nth index partitioned )
  122. ( instantiate partitioned ( cdr response ) ) ) )
  123. ( t ( cons ( car response )
  124. ( instantiate partitioned ( cdr response ) ) ) ) ) )
  125.  
  126. ;;---------------------------------------------------------------------------
  127. ;;
  128. ;; helping functions
  129. ;;
  130. ;;---------------------------------------------------------------------------
  131.  
  132. ( setq fail '-1 )
  133.  
  134. ( defun success ( result )
  135. ( not ( equal result fail ) ) )
  136.  
  137. ( defun variablep ( word )
  138. ( equal word '0 ) )
  139.  
  140.  
  141. ;;---------------------------------------------------------------------------
  142. ;;
  143. ;; database
  144. ;;
  145. ;;---------------------------------------------------------------------------
  146.  
  147. ;; CHANGE THIS: add more to this database so that the interaction is
  148. ;; more interesting and communicative and so that Eliza sounds like you
  149. ;; would sound in the same conversation!
  150. ;;---------------------------------------------------------------------------
  151.  
  152. ( setq database
  153. '(
  154. ;; example greetings/farewells -- change them to sound like you
  155. ( (Hello 0)
  156. (Hello - have a seat and tell me how you feel today.) )
  157. ( (0 you came here because 0)
  158. (A lot of people come here for that reason so you are not alone.) )
  159. ( (0 Goodbye 0)
  160. (Goodbye - I hope you enjoyed this session.) )
  161. ( (0 Late 0)
  162. (It's never too late!) )
  163.  
  164. ;; feelings
  165. ( (0 you think 0)
  166. (And just why do you think 4 ?) )
  167. ( (0 you think 0)
  168. (what do you think about 4?) )
  169. ( (0 overwhelmed 0)
  170. (and why do you think you are feeling overwhelmed?) )
  171. ( (0 anxiety 0)
  172. (what do you think would help reduce this anxiety?) )
  173. ( (0 how are you 0)
  174. (i am doing well. please tell me how you are feeling.) )
  175.  
  176. ;; the catch-alls
  177. ( (0)
  178. (Could you expand on that?) ) ) )
  179. (eliza '(anxiety))
Success #stdin #stdout #stderr 0.01s 9688KB
stdin
Standard input is empty
stdout
(WHAT DO YOU THINK WOULD HELP REDUCE THIS ANXIETY?)
stderr
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x1488f4c00000 - 0x1488f4ee4fff
  0x1488f5015000 - 0x1488f5039fff
  0x1488f503a000 - 0x1488f51acfff
  0x1488f51ad000 - 0x1488f51f5fff
  0x1488f51f6000 - 0x1488f51f8fff
  0x1488f51f9000 - 0x1488f51fbfff
  0x1488f51fc000 - 0x1488f51fffff
  0x1488f5200000 - 0x1488f5202fff
  0x1488f5203000 - 0x1488f5401fff
  0x1488f5402000 - 0x1488f5402fff
  0x1488f5403000 - 0x1488f5403fff
  0x1488f5480000 - 0x1488f548ffff
  0x1488f5490000 - 0x1488f54c3fff
  0x1488f54c4000 - 0x1488f55fafff
  0x1488f55fb000 - 0x1488f55fbfff
  0x1488f55fc000 - 0x1488f55fefff
  0x1488f55ff000 - 0x1488f55fffff
  0x1488f5600000 - 0x1488f5603fff
  0x1488f5604000 - 0x1488f5803fff
  0x1488f5804000 - 0x1488f5804fff
  0x1488f5805000 - 0x1488f5805fff
  0x1488f58ff000 - 0x1488f5902fff
  0x1488f5903000 - 0x1488f5903fff
  0x1488f5904000 - 0x1488f5905fff
  0x1488f5906000 - 0x1488f5906fff
  0x1488f5907000 - 0x1488f5907fff
  0x1488f5908000 - 0x1488f5908fff
  0x1488f5909000 - 0x1488f5916fff
  0x1488f5917000 - 0x1488f5924fff
  0x1488f5925000 - 0x1488f5931fff
  0x1488f5932000 - 0x1488f5935fff
  0x1488f5936000 - 0x1488f5936fff
  0x1488f5937000 - 0x1488f5937fff
  0x1488f5938000 - 0x1488f593dfff
  0x1488f593e000 - 0x1488f593ffff
  0x1488f5940000 - 0x1488f5940fff
  0x1488f5941000 - 0x1488f5941fff
  0x1488f5942000 - 0x1488f5942fff
  0x1488f5943000 - 0x1488f5970fff
  0x1488f5971000 - 0x1488f597ffff
  0x1488f5980000 - 0x1488f5a25fff
  0x1488f5a26000 - 0x1488f5abcfff
  0x1488f5abd000 - 0x1488f5abdfff
  0x1488f5abe000 - 0x1488f5abefff
  0x1488f5abf000 - 0x1488f5ad2fff
  0x1488f5ad3000 - 0x1488f5afafff
  0x1488f5afb000 - 0x1488f5b04fff
  0x1488f5b05000 - 0x1488f5b06fff
  0x1488f5b07000 - 0x1488f5b0cfff
  0x1488f5b0d000 - 0x1488f5b0ffff
  0x1488f5b12000 - 0x1488f5b12fff
  0x1488f5b13000 - 0x1488f5b13fff
  0x1488f5b14000 - 0x1488f5b14fff
  0x1488f5b15000 - 0x1488f5b15fff
  0x1488f5b16000 - 0x1488f5b16fff
  0x1488f5b17000 - 0x1488f5b1dfff
  0x1488f5b1e000 - 0x1488f5b20fff
  0x1488f5b21000 - 0x1488f5b21fff
  0x1488f5b22000 - 0x1488f5b42fff
  0x1488f5b43000 - 0x1488f5b4afff
  0x1488f5b4b000 - 0x1488f5b4bfff
  0x1488f5b4c000 - 0x1488f5b4cfff
  0x1488f5b4d000 - 0x1488f5b4dfff
  0x55a24d1dd000 - 0x55a24d2cdfff
  0x55a24d2ce000 - 0x55a24d3d7fff
  0x55a24d3d8000 - 0x55a24d437fff
  0x55a24d439000 - 0x55a24d467fff
  0x55a24d468000 - 0x55a24d498fff
  0x55a24d499000 - 0x55a24d49cfff
  0x55a24e22c000 - 0x55a24e24cfff
  0x7ffc03dab000 - 0x7ffc03dcbfff
  0x7ffc03de1000 - 0x7ffc03de4fff
  0x7ffc03de5000 - 0x7ffc03de6fff