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 '(hello)))
  223.  
Success #stdin #stdout #stderr 0.02s 9668KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(HELLO - HAVE A SEAT AND TELL ME HOW YOU FEEL TODAY.)
stderr
copy 
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x14a5cc600000 - 0x14a5cc8e4fff
  0x14a5cca00000 - 0x14a5cca02fff
  0x14a5cca03000 - 0x14a5ccc01fff
  0x14a5ccc02000 - 0x14a5ccc02fff
  0x14a5ccc03000 - 0x14a5ccc03fff
  0x14a5ccc15000 - 0x14a5ccc39fff
  0x14a5ccc3a000 - 0x14a5ccdacfff
  0x14a5ccdad000 - 0x14a5ccdf5fff
  0x14a5ccdf6000 - 0x14a5ccdf8fff
  0x14a5ccdf9000 - 0x14a5ccdfbfff
  0x14a5ccdfc000 - 0x14a5ccdfffff
  0x14a5cce00000 - 0x14a5cce03fff
  0x14a5cce04000 - 0x14a5cd003fff
  0x14a5cd004000 - 0x14a5cd004fff
  0x14a5cd005000 - 0x14a5cd005fff
  0x14a5cd034000 - 0x14a5cd035fff
  0x14a5cd036000 - 0x14a5cd045fff
  0x14a5cd046000 - 0x14a5cd079fff
  0x14a5cd07a000 - 0x14a5cd1b0fff
  0x14a5cd1b1000 - 0x14a5cd1b1fff
  0x14a5cd1b2000 - 0x14a5cd1b4fff
  0x14a5cd1b5000 - 0x14a5cd1b5fff
  0x14a5cd1b6000 - 0x14a5cd1b7fff
  0x14a5cd1b8000 - 0x14a5cd1b8fff
  0x14a5cd1b9000 - 0x14a5cd1bafff
  0x14a5cd1bb000 - 0x14a5cd1bbfff
  0x14a5cd1bc000 - 0x14a5cd1bcfff
  0x14a5cd1bd000 - 0x14a5cd1bdfff
  0x14a5cd1be000 - 0x14a5cd1cbfff
  0x14a5cd1cc000 - 0x14a5cd1d9fff
  0x14a5cd1da000 - 0x14a5cd1e6fff
  0x14a5cd1e7000 - 0x14a5cd1eafff
  0x14a5cd1eb000 - 0x14a5cd1ebfff
  0x14a5cd1ec000 - 0x14a5cd1ecfff
  0x14a5cd1ed000 - 0x14a5cd1f2fff
  0x14a5cd1f3000 - 0x14a5cd1f4fff
  0x14a5cd1f5000 - 0x14a5cd1f5fff
  0x14a5cd1f6000 - 0x14a5cd1f6fff
  0x14a5cd1f7000 - 0x14a5cd1f7fff
  0x14a5cd1f8000 - 0x14a5cd225fff
  0x14a5cd226000 - 0x14a5cd234fff
  0x14a5cd235000 - 0x14a5cd2dafff
  0x14a5cd2db000 - 0x14a5cd371fff
  0x14a5cd372000 - 0x14a5cd372fff
  0x14a5cd373000 - 0x14a5cd373fff
  0x14a5cd374000 - 0x14a5cd387fff
  0x14a5cd388000 - 0x14a5cd3affff
  0x14a5cd3b0000 - 0x14a5cd3b9fff
  0x14a5cd3ba000 - 0x14a5cd3bbfff
  0x14a5cd3bc000 - 0x14a5cd3c1fff
  0x14a5cd3c2000 - 0x14a5cd3c4fff
  0x14a5cd3c7000 - 0x14a5cd3c7fff
  0x14a5cd3c8000 - 0x14a5cd3c8fff
  0x14a5cd3c9000 - 0x14a5cd3c9fff
  0x14a5cd3ca000 - 0x14a5cd3cafff
  0x14a5cd3cb000 - 0x14a5cd3cbfff
  0x14a5cd3cc000 - 0x14a5cd3d2fff
  0x14a5cd3d3000 - 0x14a5cd3d5fff
  0x14a5cd3d6000 - 0x14a5cd3d6fff
  0x14a5cd3d7000 - 0x14a5cd3f7fff
  0x14a5cd3f8000 - 0x14a5cd3fffff
  0x14a5cd400000 - 0x14a5cd400fff
  0x14a5cd401000 - 0x14a5cd401fff
  0x14a5cd402000 - 0x14a5cd402fff
  0x559ae99ae000 - 0x559ae9a9efff
  0x559ae9a9f000 - 0x559ae9ba8fff
  0x559ae9ba9000 - 0x559ae9c08fff
  0x559ae9c0a000 - 0x559ae9c38fff
  0x559ae9c39000 - 0x559ae9c69fff
  0x559ae9c6a000 - 0x559ae9c6dfff
  0x559aeadf3000 - 0x559aeae13fff
  0x7ffce9c45000 - 0x7ffce9c65fff
  0x7ffce9c68000 - 0x7ffce9c6bfff
  0x7ffce9c6c000 - 0x7ffce9c6dfff
https://ideone.com/JDBLI3
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!