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.         ( instantiate result ( second ( car db ) ) )
  73.     )
  74.  
  75.     ;; otherwise, keep looking through the DB
  76.     ( t ( respond sentence ( cdr db ) ) ) ) )
  77.  
  78. ;;----------------------------------------------------------------------------
  79. ;; match: if there is not a match between this pattern and this data,
  80. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  81. ;; format
  82.  
  83. ( defun match ( data pattern )
  84.   ( cond
  85.     ;; end of both data and pattern; a match
  86.     ( ( and ( null data ) ( null pattern ) ) nil )
  87.  
  88.     ;; end of pattern, but not end of data; no match
  89.     ( ( null pattern ) fail )
  90.  
  91.     ;; end of data, but not end of pattern; if the pattern starts with
  92.     ;; a variable, eat it and try and match the rest of the pattern to
  93.     ;; the null sentence (will only work if all variables); otherwise,
  94.     ;; fail
  95.     ( ( null data ) 
  96.       ( cond
  97. 	( ( variablep ( car pattern ) )
  98. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  99. 	      result
  100. 	    fail ) )
  101. 	( t fail ) ) )
  102.  
  103.  
  104.     ;; first item of data and pattern are identical; if the rest of it
  105.     ;; matched, return the first item cons'ed with the rest of the
  106.     ;; partitioned sentence; otherwise, fail
  107.     ( ( equal ( car data ) ( car pattern ) )
  108.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  109. 	  ( cons ( list ( car data ) ) result )
  110. 	fail ) )
  111.  
  112.     ;; first item of pattern is a variable; if the rest of the data
  113.     ;; (minus the first word, matched to the variable) is a match with
  114.     ;; all of the pattern, return the appropriate stuff; if all of the
  115.     ;; data (variable eats nothing) matches the rest of the pattern,
  116.     ;; return appropriate stuff; else, fail.
  117.     ( ( variablep ( car pattern ) ) 
  118.       ( cond
  119. 	;; variable eats nothing;  () is put in partitioned sentence
  120. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  121. 	  ( cons () result ) )
  122. 	;; variable eats one word; word is cons'ed into the first
  123. 	;; element of the partitioned sentence, assuming that the step
  124. 	;; before an actual match word would be a ()
  125. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  126. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  127. 	;; otherwise, fail
  128. 	( t fail ) ) )
  129.  
  130.     ( t fail ) ) )
  131.  
  132. ;;----------------------------------------------------------------------------
  133. ;; instantiate: takes a partitioned sentence and the response it has
  134. ;; been matched to and generates the appropriated completed response
  135.  
  136. ( defun instantiate ( partitioned response )
  137.   ( cond
  138.     ( ( null response ) nil )
  139.     ;; numbers indicate what part of the partitioned sentence to
  140.     ;; insert into the response
  141.     ( ( numberp ( car response ) )
  142.       ( setq index ( - ( car response ) 1 ) )
  143.       ( append ( nth index partitioned )
  144. 	     ( instantiate partitioned ( cdr response ) ) ) )
  145.     ( t ( cons ( car response )
  146. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  147.  
  148. ;;---------------------------------------------------------------------------
  149. ;;
  150. ;;  			     helping functions
  151. ;;
  152. ;;---------------------------------------------------------------------------
  153.  
  154. ( setq fail '-1 )
  155.  
  156. ( defun success ( result )
  157.   ( not ( equal result fail ) ) )
  158.  
  159. ( defun variablep ( word )
  160.   ( equal word '0 ) )
  161.  
  162.  
  163. ;;---------------------------------------------------------------------------
  164. ;;
  165. ;;  			         database
  166. ;;
  167. ;;---------------------------------------------------------------------------
  168.  
  169. ;; CHANGE THIS: add more to this database so that the interaction is
  170. ;; more interesting and communicative and so that Eliza sounds like you 
  171. ;; would sound in the same conversation!
  172. ;;---------------------------------------------------------------------------
  173.  
  174. ( setq database
  175.     '(
  176.         ;; example greetings/farewells -- change them to sound like you
  177.  
  178.         ( (Hello 0)
  179.         (Hello - have a seat and tell me how you feel today.) )
  180.  
  181.         ( (0 you came here because 0)
  182.         (A lot of people come here for that reason so you are not alone.) )
  183.  
  184.         ( (0 Goodbye 0)
  185.         (Goodbye - I hope you enjoyed this session.) )
  186.  
  187.         ;; feelings
  188.         ( (0 you think 0)
  189.         (And just why do you think 4 ?) )
  190.  
  191.         ((0 i am happy 0) 
  192.         ("That's wonderful! What’s making you happy today?" 
  193.           "I'm glad to hear that! Tell me more about your happiness." 
  194.           "It's great to see you're happy! What's the reason?"))
  195.  
  196.         ((0 i feel joyful 0)
  197.         (
  198.           "I'm glad to hear that! Tell me more what makes you feel joyful?" 
  199.         ))
  200.  
  201.         ((0 i am excited 0)
  202.         (
  203.           "I'm glad to hear that! Tell me more what makes you feel excited?" 
  204.         ))
  205.  
  206.         ((0 i am sad 0) 
  207.         ("I'm sorry to hear that. Why do you think you are sad?" 
  208.           "What’s making you feel sad?" 
  209.           "Tell me more about what’s troubling you."))
  210.  
  211.         ((0 i am angry 0)
  212.         ("I see. What made you feel this way?" 
  213.           "Why do you think you’re feeling so angry?" 
  214.           "Can you tell me more about what’s making you angry?"))
  215.  
  216.         ;; the catch-alls
  217.         ( (0) 
  218.         (Could you expand on that?) )
  219.     )
  220. )
  221.  
  222. (princ (eliza '(Ok Goodbye)))
  223.  
Success #stdin #stdout #stderr 0.02s 9696KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(GOODBYE - I HOPE YOU ENJOYED THIS SESSION.)
stderr
copy 
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x146e14a00000 - 0x146e14ce4fff
  0x146e14e00000 - 0x146e14e02fff
  0x146e14e03000 - 0x146e15001fff
  0x146e15002000 - 0x146e15002fff
  0x146e15003000 - 0x146e15003fff
  0x146e15015000 - 0x146e15039fff
  0x146e1503a000 - 0x146e151acfff
  0x146e151ad000 - 0x146e151f5fff
  0x146e151f6000 - 0x146e151f8fff
  0x146e151f9000 - 0x146e151fbfff
  0x146e151fc000 - 0x146e151fffff
  0x146e15200000 - 0x146e15203fff
  0x146e15204000 - 0x146e15403fff
  0x146e15404000 - 0x146e15404fff
  0x146e15405000 - 0x146e15405fff
  0x146e15430000 - 0x146e15431fff
  0x146e15432000 - 0x146e15441fff
  0x146e15442000 - 0x146e15475fff
  0x146e15476000 - 0x146e155acfff
  0x146e155ad000 - 0x146e155adfff
  0x146e155ae000 - 0x146e155b0fff
  0x146e155b1000 - 0x146e155b1fff
  0x146e155b2000 - 0x146e155b3fff
  0x146e155b4000 - 0x146e155b4fff
  0x146e155b5000 - 0x146e155b6fff
  0x146e155b7000 - 0x146e155b7fff
  0x146e155b8000 - 0x146e155b8fff
  0x146e155b9000 - 0x146e155b9fff
  0x146e155ba000 - 0x146e155c7fff
  0x146e155c8000 - 0x146e155d5fff
  0x146e155d6000 - 0x146e155e2fff
  0x146e155e3000 - 0x146e155e6fff
  0x146e155e7000 - 0x146e155e7fff
  0x146e155e8000 - 0x146e155e8fff
  0x146e155e9000 - 0x146e155eefff
  0x146e155ef000 - 0x146e155f0fff
  0x146e155f1000 - 0x146e155f1fff
  0x146e155f2000 - 0x146e155f2fff
  0x146e155f3000 - 0x146e155f3fff
  0x146e155f4000 - 0x146e15621fff
  0x146e15622000 - 0x146e15630fff
  0x146e15631000 - 0x146e156d6fff
  0x146e156d7000 - 0x146e1576dfff
  0x146e1576e000 - 0x146e1576efff
  0x146e1576f000 - 0x146e1576ffff
  0x146e15770000 - 0x146e15783fff
  0x146e15784000 - 0x146e157abfff
  0x146e157ac000 - 0x146e157b5fff
  0x146e157b6000 - 0x146e157b7fff
  0x146e157b8000 - 0x146e157bdfff
  0x146e157be000 - 0x146e157c0fff
  0x146e157c3000 - 0x146e157c3fff
  0x146e157c4000 - 0x146e157c4fff
  0x146e157c5000 - 0x146e157c5fff
  0x146e157c6000 - 0x146e157c6fff
  0x146e157c7000 - 0x146e157c7fff
  0x146e157c8000 - 0x146e157cefff
  0x146e157cf000 - 0x146e157d1fff
  0x146e157d2000 - 0x146e157d2fff
  0x146e157d3000 - 0x146e157f3fff
  0x146e157f4000 - 0x146e157fbfff
  0x146e157fc000 - 0x146e157fcfff
  0x146e157fd000 - 0x146e157fdfff
  0x146e157fe000 - 0x146e157fefff
  0x555fa013c000 - 0x555fa022cfff
  0x555fa022d000 - 0x555fa0336fff
  0x555fa0337000 - 0x555fa0396fff
  0x555fa0398000 - 0x555fa03c6fff
  0x555fa03c7000 - 0x555fa03f7fff
  0x555fa03f8000 - 0x555fa03fbfff
  0x555fa18a7000 - 0x555fa18c7fff
  0x7fff3d99b000 - 0x7fff3d9bbfff
  0x7fff3d9bf000 - 0x7fff3d9c2fff
  0x7fff3d9c3000 - 0x7fff3d9c4fff
https://ideone.com/WAe11R
language:
Common Lisp (clisp 2.49.92)
created:
3 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!