fork download
copy 
  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.  
  22.     ( ( equal ( car sentence ) 'you )
  23.       ( cons 'I ( change-pros ( cdr sentence ) ) ) )
  24.     ( ( equal ( car sentence ) 'I )
  25.       ( cons 'you ( change-pros ( cdr sentence ) ) ) )
  26.  
  27.     ( ( equal ( car sentence ) 'my )
  28.       ( cons 'your ( change-pros ( cdr sentence ) ) ) )
  29.     ( ( equal ( car sentence ) 'your )
  30.       ( cons 'my ( change-pros ( cdr sentence ) ) ) )
  31.  
  32.     ( ( equal ( car sentence ) 'mine )
  33.       ( cons 'yours ( change-pros ( cdr sentence ) ) ) )
  34.     ( ( equal ( car sentence ) 'yours )
  35.       ( cons 'mine ( change-pros ( cdr sentence ) ) ) )
  36.  
  37.     ( ( equal ( car sentence ) 'he )
  38.       ( cons 'him ( change-pros ( cdr sentence ) ) ) )
  39.     ( ( equal ( car sentence ) 'him )
  40.       ( cons 'he ( change-pros ( cdr sentence ) ) ) )
  41.  
  42.     ( ( equal ( car sentence ) 'she )
  43.       ( cons 'she ( change-pros ( cdr sentence ) ) ) )
  44.     ( ( equal ( car sentence ) 'her )
  45.       ( cons 'hers ( change-pros ( cdr sentence ) ) ) )
  46.     ( ( equal ( car sentence ) 'hers )
  47.       ( cons 'her ( change-pros ( cdr sentence ) ) ) )
  48.  
  49.     ( ( equal ( car sentence ) 'it )
  50.       ( cons 'it ( change-pros ( cdr sentence ) ) ) )
  51.  
  52.     ;; CHANGE THIS: add more cases here of pronouns or other words
  53.     ;; that should flip in order for this to work well
  54.  
  55.     ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  56.  
  57. ;;----------------------------------------------------------------------------
  58. ;; respond: given a sentence, looks through the database in search of
  59. ;; a matching pattern and the response; given the database response,
  60. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  61. ;; response
  62.  
  63. ( defun respond ( sentence db )
  64.   ( cond
  65.     ;; end of DB, return nil - should never really happen
  66.     ( ( null db ) nil )
  67.  
  68.     ;; if the result of matching the sentence against the current
  69.     ;; pattern is a success, produce this response
  70.     ( 
  71.         ( success ( setq result ( match sentence ( first ( car db ) ) ) ) )
  72.  
  73.         (setf *random-state* (make-random-state t))
  74.  
  75.         (setq idx ( length (car db) ))
  76.         (setq rndm ( random idx ))
  77.  
  78.         (if (= rndm 0)
  79.           (setq rndm 1)
  80.           (princ ""))
  81.  
  82.         (princ rndm)
  83.         (princ #\Newline) 
  84.         ( instantiate result ( nth rndm ( car db ) ) )
  85.     )
  86.  
  87.     ;; otherwise, keep looking through the DB
  88.     ( t ( respond sentence ( cdr db ) ) ) ) )
  89.  
  90. ;;----------------------------------------------------------------------------
  91. ;; match: if there is not a match between this pattern and this data,
  92. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  93. ;; format
  94.  
  95. ( defun match ( data pattern )
  96.   ( cond
  97.     ;; end of both data and pattern; a match
  98.     ( ( and ( null data ) ( null pattern ) ) nil )
  99.  
  100.     ;; end of pattern, but not end of data; no match
  101.     ( ( null pattern ) fail )
  102.  
  103.     ;; end of data, but not end of pattern; if the pattern starts with
  104.     ;; a variable, eat it and try and match the rest of the pattern to
  105.     ;; the null sentence (will only work if all variables); otherwise,
  106.     ;; fail
  107.     ( ( null data ) 
  108.       ( cond
  109. 	( ( variablep ( car pattern ) )
  110. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  111. 	      result
  112. 	    fail ) )
  113. 	( t fail ) ) )
  114.  
  115.  
  116.     ;; first item of data and pattern are identical; if the rest of it
  117.     ;; matched, return the first item cons'ed with the rest of the
  118.     ;; partitioned sentence; otherwise, fail
  119.     ( ( equal ( car data ) ( car pattern ) )
  120.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  121. 	  ( cons ( list ( car data ) ) result )
  122. 	fail ) )
  123.  
  124.     ;; first item of pattern is a variable; if the rest of the data
  125.     ;; (minus the first word, matched to the variable) is a match with
  126.     ;; all of the pattern, return the appropriate stuff; if all of the
  127.     ;; data (variable eats nothing) matches the rest of the pattern,
  128.     ;; return appropriate stuff; else, fail.
  129.     ( ( variablep ( car pattern ) ) 
  130.       ( cond
  131. 	;; variable eats nothing;  () is put in partitioned sentence
  132. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  133. 	  ( cons () result ) )
  134. 	;; variable eats one word; word is cons'ed into the first
  135. 	;; element of the partitioned sentence, assuming that the step
  136. 	;; before an actual match word would be a ()
  137. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  138. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  139. 	;; otherwise, fail
  140. 	( t fail ) ) )
  141.  
  142.     ( t fail ) ) )
  143.  
  144. ;;----------------------------------------------------------------------------
  145. ;; instantiate: takes a partitioned sentence and the response it has
  146. ;; been matched to and generates the appropriated completed response
  147.  
  148. ( defun instantiate ( partitioned response )
  149.   ( cond
  150.     ( ( null response ) nil )
  151.     ;; numbers indicate what part of the partitioned sentence to
  152.     ;; insert into the response
  153.     ( ( numberp ( car response ) )
  154.       ( setq index ( - ( car response ) 1 ) )
  155.       ( append ( nth index partitioned )
  156. 	     ( instantiate partitioned ( cdr response ) ) ) )
  157.     ( t ( cons ( car response )
  158. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  159.  
  160. ;;---------------------------------------------------------------------------
  161. ;;
  162. ;;  			     helping functions
  163. ;;
  164. ;;---------------------------------------------------------------------------
  165.  
  166. ( setq fail '-1 )
  167.  
  168. ( defun success ( result )
  169.   ( not ( equal result fail ) ) )
  170.  
  171. ( defun variablep ( word )
  172.   ( equal word '0 ) )
  173.  
  174.  
  175. ;;---------------------------------------------------------------------------
  176. ;;
  177. ;;  			         database
  178. ;;
  179. ;;---------------------------------------------------------------------------
  180.  
  181. ;; CHANGE THIS: add more to this database so that the interaction is
  182. ;; more interesting and communicative and so that Eliza sounds like you 
  183. ;; would sound in the same conversation!
  184. ;;---------------------------------------------------------------------------
  185.  
  186. ( setq database
  187.     '(
  188.         ;; example greetings/farewells -- change them to sound like you
  189.  
  190.         (
  191.         (Hello 0)
  192.         (Hello - have a seat and tell me how you feel today.) 
  193.         (Hello1 - have a seat and tell me how you feel today.)
  194.         (Hello2 - have a seat and tell me how you feel today.)
  195.         (Hello3 - have a seat and tell me how you feel today.)
  196.         (Hello4 - have a seat and tell me how you feel today.)
  197.         (Hello5 - have a seat and tell me how you feel today.)
  198.         (Hello6 - have a seat and tell me how you feel today.)
  199.         (Hello7 - have a seat and tell me how you feel today.)
  200.         (Hello8 - have a seat and tell me how you feel today.)
  201.         (Hello9 - have a seat and tell me how you feel today.)
  202.         (Hello10 - have a seat and tell me how you feel today.)
  203.         )
  204.  
  205.         ( (0 You came here because 0)
  206.         (A lot of people come here for that reason so you are not alone.) )
  207.  
  208.         ( (0 Goodbye 0)
  209.         (Goodbye - I hope you enjoyed this session.) )
  210.  
  211.         ;; feelings
  212.         ( (0 you think 0)
  213.         (And just why do you think 4 ?) )
  214.  
  215.         ( (0 you are happy 0) 
  216.         (That's wonderful! What’s making you happy today? ) )
  217.  
  218.         ((0 you feel joyful 0)
  219.         (
  220.           "I'm glad to hear that! Tell me more what makes you feel joyful?" 
  221.         ))
  222.  
  223.         ((0 you are excited 0)
  224.         (
  225.           "I'm glad to hear that! Tell me more what makes you feel excited?" 
  226.         ))
  227.  
  228.         ((0 you feel sad 0) 
  229.         ("I'm sorry to hear that. Why do you think you are sad?" 
  230.           "What’s making you feel sad?" 
  231.           "Tell me more about what’s troubling you."))
  232.  
  233.         ((0 you are angry 0)
  234.         ("I see. What made you feel this way?" 
  235.           "Why do you think you’re feeling so angry?" 
  236.           "Can you tell me more about what’s making you angry?"))
  237.  
  238.         ;; the catch-alls
  239.         (
  240.           (0) 
  241.           (Could you expand on that?)
  242.           ("Hmmm.. Is it possible to elaborate more on that please?")
  243.           ("Hmmm.. I feel I didn't get what you mean. Can you explain again in other terms?")
  244.           ("Uhh.. I fear I don't understand what are you talking about..")
  245.           ("Ops, didn't get it, please expand on that.")
  246.  
  247.         )
  248.     )
  249. )
  250.  
  251. (princ (eliza '(helvvvlo)))
  252.  
Success #stdin #stdout #stderr 0.01s 9616KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
1
(COULD YOU EXPAND ON THAT?)
stderr
copy 
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x1548f6600000 - 0x1548f68e4fff
  0x1548f6a15000 - 0x1548f6a39fff
  0x1548f6a3a000 - 0x1548f6bacfff
  0x1548f6bad000 - 0x1548f6bf5fff
  0x1548f6bf6000 - 0x1548f6bf8fff
  0x1548f6bf9000 - 0x1548f6bfbfff
  0x1548f6bfc000 - 0x1548f6bfffff
  0x1548f6c00000 - 0x1548f6c02fff
  0x1548f6c03000 - 0x1548f6e01fff
  0x1548f6e02000 - 0x1548f6e02fff
  0x1548f6e03000 - 0x1548f6e03fff
  0x1548f6e80000 - 0x1548f6e8ffff
  0x1548f6e90000 - 0x1548f6ec3fff
  0x1548f6ec4000 - 0x1548f6ffafff
  0x1548f6ffb000 - 0x1548f6ffbfff
  0x1548f6ffc000 - 0x1548f6ffefff
  0x1548f6fff000 - 0x1548f6ffffff
  0x1548f7000000 - 0x1548f7003fff
  0x1548f7004000 - 0x1548f7203fff
  0x1548f7204000 - 0x1548f7204fff
  0x1548f7205000 - 0x1548f7205fff
  0x1548f7278000 - 0x1548f727bfff
  0x1548f727c000 - 0x1548f727cfff
  0x1548f727d000 - 0x1548f727efff
  0x1548f727f000 - 0x1548f727ffff
  0x1548f7280000 - 0x1548f7280fff
  0x1548f7281000 - 0x1548f7281fff
  0x1548f7282000 - 0x1548f728ffff
  0x1548f7290000 - 0x1548f729dfff
  0x1548f729e000 - 0x1548f72aafff
  0x1548f72ab000 - 0x1548f72aefff
  0x1548f72af000 - 0x1548f72affff
  0x1548f72b0000 - 0x1548f72b0fff
  0x1548f72b1000 - 0x1548f72b6fff
  0x1548f72b7000 - 0x1548f72b8fff
  0x1548f72b9000 - 0x1548f72b9fff
  0x1548f72ba000 - 0x1548f72bafff
  0x1548f72bb000 - 0x1548f72bbfff
  0x1548f72bc000 - 0x1548f72e9fff
  0x1548f72ea000 - 0x1548f72f8fff
  0x1548f72f9000 - 0x1548f739efff
  0x1548f739f000 - 0x1548f7435fff
  0x1548f7436000 - 0x1548f7436fff
  0x1548f7437000 - 0x1548f7437fff
  0x1548f7438000 - 0x1548f744bfff
  0x1548f744c000 - 0x1548f7473fff
  0x1548f7474000 - 0x1548f747dfff
  0x1548f747e000 - 0x1548f747ffff
  0x1548f7480000 - 0x1548f7485fff
  0x1548f7486000 - 0x1548f7488fff
  0x1548f748b000 - 0x1548f748bfff
  0x1548f748c000 - 0x1548f748cfff
  0x1548f748d000 - 0x1548f748dfff
  0x1548f748e000 - 0x1548f748efff
  0x1548f748f000 - 0x1548f748ffff
  0x1548f7490000 - 0x1548f7496fff
  0x1548f7497000 - 0x1548f7499fff
  0x1548f749a000 - 0x1548f749afff
  0x1548f749b000 - 0x1548f74bbfff
  0x1548f74bc000 - 0x1548f74c3fff
  0x1548f74c4000 - 0x1548f74c4fff
  0x1548f74c5000 - 0x1548f74c5fff
  0x1548f74c6000 - 0x1548f74c6fff
  0x55e407c9b000 - 0x55e407d8bfff
  0x55e407d8c000 - 0x55e407e95fff
  0x55e407e96000 - 0x55e407ef5fff
  0x55e407ef7000 - 0x55e407f25fff
  0x55e407f26000 - 0x55e407f56fff
  0x55e407f57000 - 0x55e407f5afff
  0x55e409a2b000 - 0x55e409a4bfff
  0x7ffde684b000 - 0x7ffde686bfff
  0x7ffde69e2000 - 0x7ffde69e5fff
  0x7ffde69e6000 - 0x7ffde69e7fff
https://ideone.com/3bYLFG
language:
Common Lisp (clisp 2.49.92)
created:
2 days ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!