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 9604KB
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
  0x14a44de00000 - 0x14a44e0e4fff
  0x14a44e215000 - 0x14a44e239fff
  0x14a44e23a000 - 0x14a44e3acfff
  0x14a44e3ad000 - 0x14a44e3f5fff
  0x14a44e3f6000 - 0x14a44e3f8fff
  0x14a44e3f9000 - 0x14a44e3fbfff
  0x14a44e3fc000 - 0x14a44e3fffff
  0x14a44e400000 - 0x14a44e402fff
  0x14a44e403000 - 0x14a44e601fff
  0x14a44e602000 - 0x14a44e602fff
  0x14a44e603000 - 0x14a44e603fff
  0x14a44e680000 - 0x14a44e68ffff
  0x14a44e690000 - 0x14a44e6c3fff
  0x14a44e6c4000 - 0x14a44e7fafff
  0x14a44e7fb000 - 0x14a44e7fbfff
  0x14a44e7fc000 - 0x14a44e7fefff
  0x14a44e7ff000 - 0x14a44e7fffff
  0x14a44e800000 - 0x14a44e803fff
  0x14a44e804000 - 0x14a44ea03fff
  0x14a44ea04000 - 0x14a44ea04fff
  0x14a44ea05000 - 0x14a44ea05fff
  0x14a44eb76000 - 0x14a44eb79fff
  0x14a44eb7a000 - 0x14a44eb7afff
  0x14a44eb7b000 - 0x14a44eb7cfff
  0x14a44eb7d000 - 0x14a44eb7dfff
  0x14a44eb7e000 - 0x14a44eb7efff
  0x14a44eb7f000 - 0x14a44eb7ffff
  0x14a44eb80000 - 0x14a44eb8dfff
  0x14a44eb8e000 - 0x14a44eb9bfff
  0x14a44eb9c000 - 0x14a44eba8fff
  0x14a44eba9000 - 0x14a44ebacfff
  0x14a44ebad000 - 0x14a44ebadfff
  0x14a44ebae000 - 0x14a44ebaefff
  0x14a44ebaf000 - 0x14a44ebb4fff
  0x14a44ebb5000 - 0x14a44ebb6fff
  0x14a44ebb7000 - 0x14a44ebb7fff
  0x14a44ebb8000 - 0x14a44ebb8fff
  0x14a44ebb9000 - 0x14a44ebb9fff
  0x14a44ebba000 - 0x14a44ebe7fff
  0x14a44ebe8000 - 0x14a44ebf6fff
  0x14a44ebf7000 - 0x14a44ec9cfff
  0x14a44ec9d000 - 0x14a44ed33fff
  0x14a44ed34000 - 0x14a44ed34fff
  0x14a44ed35000 - 0x14a44ed35fff
  0x14a44ed36000 - 0x14a44ed49fff
  0x14a44ed4a000 - 0x14a44ed71fff
  0x14a44ed72000 - 0x14a44ed7bfff
  0x14a44ed7c000 - 0x14a44ed7dfff
  0x14a44ed7e000 - 0x14a44ed83fff
  0x14a44ed84000 - 0x14a44ed86fff
  0x14a44ed89000 - 0x14a44ed89fff
  0x14a44ed8a000 - 0x14a44ed8afff
  0x14a44ed8b000 - 0x14a44ed8bfff
  0x14a44ed8c000 - 0x14a44ed8cfff
  0x14a44ed8d000 - 0x14a44ed8dfff
  0x14a44ed8e000 - 0x14a44ed94fff
  0x14a44ed95000 - 0x14a44ed97fff
  0x14a44ed98000 - 0x14a44ed98fff
  0x14a44ed99000 - 0x14a44edb9fff
  0x14a44edba000 - 0x14a44edc1fff
  0x14a44edc2000 - 0x14a44edc2fff
  0x14a44edc3000 - 0x14a44edc3fff
  0x14a44edc4000 - 0x14a44edc4fff
  0x560daa58a000 - 0x560daa67afff
  0x560daa67b000 - 0x560daa784fff
  0x560daa785000 - 0x560daa7e4fff
  0x560daa7e6000 - 0x560daa814fff
  0x560daa815000 - 0x560daa845fff
  0x560daa846000 - 0x560daa849fff
  0x560daaec4000 - 0x560daaee4fff
  0x7ffd0bfec000 - 0x7ffd0c00cfff
  0x7ffd0c0bd000 - 0x7ffd0c0c0fff
  0x7ffd0c0c1000 - 0x7ffd0c0c2fff
https://ideone.com/2bUbIc
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!