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.  
  26. ;; CHANGE THIS: add more cases here of pronouns or other words
  27. ;; that should flip in order for this to work well
  28.  
  29. ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  30.  
  31. ;;----------------------------------------------------------------------------
  32. ;; respond: given a sentence, looks through the database in search of
  33. ;; a matching pattern and the response; given the database response,
  34. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  35. ;; response
  36.  
  37. (defun respond (sentence db)
  38. (cond
  39. ;; end of DB, return nil - should never really happen
  40. ((null db) nil)
  41.  
  42. ;; if the result of matching the sentence against the current
  43. ;; pattern is a success, produce this response
  44. ((success (setq result (match sentence (first (car db)))))
  45. (let ((response (instantiate result (second (car db)))))
  46. (format t "~a~%" response)
  47. response))
  48.  
  49. ;; otherwise, keep looking through the DB
  50. (t (respond sentence (cdr db)))))
  51.  
  52.  
  53. ;;----------------------------------------------------------------------------
  54. ;; match: if there is not a match between this pattern and this data,
  55. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  56. ;; format
  57.  
  58. ( defun match ( data pattern )
  59. ( cond
  60. ;; end of both data and pattern; a match
  61. ( ( and ( null data ) ( null pattern ) ) nil )
  62.  
  63. ;; end of pattern, but not end of data; no match
  64. ( ( null pattern ) fail )
  65.  
  66. ;; end of data, but not end of pattern; if the pattern starts with
  67. ;; a variable, eat it and try and match the rest of the pattern to
  68. ;; the null sentence (will only work if all variables); otherwise,
  69. ;; fail
  70. ( ( null data )
  71. ( cond
  72. ( ( variablep ( car pattern ) )
  73. ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  74. result
  75. fail ) )
  76. ( t fail ) ) )
  77.  
  78.  
  79. ;; first item of data and pattern are identical; if the rest of it
  80. ;; matched, return the first item cons'ed with the rest of the
  81. ;; partitioned sentence; otherwise, fail
  82. ( ( equal ( car data ) ( car pattern ) )
  83. ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  84. ( cons ( list ( car data ) ) result )
  85. fail ) )
  86.  
  87. ;; first item of pattern is a variable; if the rest of the data
  88. ;; (minus the first word, matched to the variable) is a match with
  89. ;; all of the pattern, return the appropriate stuff; if all of the
  90. ;; data (variable eats nothing) matches the rest of the pattern,
  91. ;; return appropriate stuff; else, fail.
  92. ( ( variablep ( car pattern ) )
  93. ( cond
  94. ;; variable eats nothing; () is put in partitioned sentence
  95. ( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  96. ( cons () result ) )
  97. ;; variable eats one word; word is cons'ed into the first
  98. ;; element of the partitioned sentence, assuming that the step
  99. ;; before an actual match word would be a ()
  100. ( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  101. ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  102. ;; otherwise, fail
  103. ( t fail ) ) )
  104.  
  105. ( t fail ) ) )
  106.  
  107. ;;----------------------------------------------------------------------------
  108. ;; instantiate: takes a partitioned sentence and the response it has
  109. ;; been matched to and generates the appropriated completed response
  110.  
  111. ( defun instantiate ( partitioned response )
  112. ( cond
  113. ( ( null response ) nil )
  114. ;; numbers indicate what part of the partitioned sentence to
  115. ;; insert into the response
  116. ( ( numberp ( car response ) )
  117. ( setq index ( - ( car response ) 1 ) )
  118. ( append ( nth index partitioned )
  119. ( instantiate partitioned ( cdr response ) ) ) )
  120. ( t ( cons ( car response )
  121. ( instantiate partitioned ( cdr response ) ) ) ) ) )
  122.  
  123. ;;---------------------------------------------------------------------------
  124. ;;
  125. ;; helping functions
  126. ;;
  127. ;;---------------------------------------------------------------------------
  128.  
  129. ( setq fail '-1 )
  130.  
  131. ( defun success ( result )
  132. ( not ( equal result fail ) ) )
  133.  
  134. ( defun variablep ( word )
  135. ( equal word '0 ) )
  136.  
  137.  
  138. ;;---------------------------------------------------------------------------
  139. ;;
  140. ;; database
  141. ;;
  142. ;;---------------------------------------------------------------------------
  143.  
  144. ;; CHANGE THIS: add more to this database so that the interaction is
  145. ;; more interesting and communicative and so that Eliza sounds like you
  146. ;; would sound in the same conversation!
  147. ;;---------------------------------------------------------------------------
  148.  
  149. ( setq database
  150. '(
  151. ;; example greetings/farewells -- change them to sound like you
  152. ( (Hello 0)
  153. (Hello - have a seat and tell me how you feel today.) )
  154. ( (0 you came here because 0)
  155. (A lot of people come here for that reason so you are not alone.) )
  156. ( (0 Goodbye 0)
  157. (Goodbye - I hope you enjoyed this session.) )
  158.  
  159. ;; feelings
  160. ( (0 you think 0)
  161. (And just why do you think 4 ?) )
  162.  
  163. ;; the catch-alls
  164. ( (0)
  165. (Could you expand on that?) ) ) )
  166. (eliza '(i feel quite bad))
Success #stdin #stdout #stderr 0.01s 9708KB
stdin
hello
stdout
(COULD YOU EXPAND ON THAT?)
stderr
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x145a71e00000 - 0x145a720e4fff
  0x145a72200000 - 0x145a72202fff
  0x145a72203000 - 0x145a72401fff
  0x145a72402000 - 0x145a72402fff
  0x145a72403000 - 0x145a72403fff
  0x145a72415000 - 0x145a72439fff
  0x145a7243a000 - 0x145a725acfff
  0x145a725ad000 - 0x145a725f5fff
  0x145a725f6000 - 0x145a725f8fff
  0x145a725f9000 - 0x145a725fbfff
  0x145a725fc000 - 0x145a725fffff
  0x145a72600000 - 0x145a72603fff
  0x145a72604000 - 0x145a72803fff
  0x145a72804000 - 0x145a72804fff
  0x145a72805000 - 0x145a72805fff
  0x145a72829000 - 0x145a7282afff
  0x145a7282b000 - 0x145a7283afff
  0x145a7283b000 - 0x145a7286efff
  0x145a7286f000 - 0x145a729a5fff
  0x145a729a6000 - 0x145a729a6fff
  0x145a729a7000 - 0x145a729a9fff
  0x145a729aa000 - 0x145a729aafff
  0x145a729ab000 - 0x145a729acfff
  0x145a729ad000 - 0x145a729adfff
  0x145a729ae000 - 0x145a729affff
  0x145a729b0000 - 0x145a729b0fff
  0x145a729b1000 - 0x145a729b1fff
  0x145a729b2000 - 0x145a729b2fff
  0x145a729b3000 - 0x145a729c0fff
  0x145a729c1000 - 0x145a729cefff
  0x145a729cf000 - 0x145a729dbfff
  0x145a729dc000 - 0x145a729dffff
  0x145a729e0000 - 0x145a729e0fff
  0x145a729e1000 - 0x145a729e1fff
  0x145a729e2000 - 0x145a729e7fff
  0x145a729e8000 - 0x145a729e9fff
  0x145a729ea000 - 0x145a729eafff
  0x145a729eb000 - 0x145a729ebfff
  0x145a729ec000 - 0x145a729ecfff
  0x145a729ed000 - 0x145a72a1afff
  0x145a72a1b000 - 0x145a72a29fff
  0x145a72a2a000 - 0x145a72acffff
  0x145a72ad0000 - 0x145a72b66fff
  0x145a72b67000 - 0x145a72b67fff
  0x145a72b68000 - 0x145a72b68fff
  0x145a72b69000 - 0x145a72b7cfff
  0x145a72b7d000 - 0x145a72ba4fff
  0x145a72ba5000 - 0x145a72baefff
  0x145a72baf000 - 0x145a72bb0fff
  0x145a72bb1000 - 0x145a72bb6fff
  0x145a72bb7000 - 0x145a72bb9fff
  0x145a72bbc000 - 0x145a72bbcfff
  0x145a72bbd000 - 0x145a72bbdfff
  0x145a72bbe000 - 0x145a72bbefff
  0x145a72bbf000 - 0x145a72bbffff
  0x145a72bc0000 - 0x145a72bc0fff
  0x145a72bc1000 - 0x145a72bc7fff
  0x145a72bc8000 - 0x145a72bcafff
  0x145a72bcb000 - 0x145a72bcbfff
  0x145a72bcc000 - 0x145a72becfff
  0x145a72bed000 - 0x145a72bf4fff
  0x145a72bf5000 - 0x145a72bf5fff
  0x145a72bf6000 - 0x145a72bf6fff
  0x145a72bf7000 - 0x145a72bf7fff
  0x557b9a7f8000 - 0x557b9a8e8fff
  0x557b9a8e9000 - 0x557b9a9f2fff
  0x557b9a9f3000 - 0x557b9aa52fff
  0x557b9aa54000 - 0x557b9aa82fff
  0x557b9aa83000 - 0x557b9aab3fff
  0x557b9aab4000 - 0x557b9aab7fff
  0x557b9bd86000 - 0x557b9bda6fff
  0x7ffde6059000 - 0x7ffde6079fff
  0x7ffde612c000 - 0x7ffde612ffff
  0x7ffde6130000 - 0x7ffde6131fff