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.         ( princ rndm)
  79.         (princ #\Newline) 
  80.         (setq rndm 0)
  81.  
  82.         (if (= rndm 0)
  83.           (setq rndm 1)
  84.           (princ ""))
  85.  
  86.         (princ rndm)
  87.         (princ #\Newline) 
  88.         ( instantiate result ( nth rndm ( car db ) ) )
  89.     )
  90.  
  91.     ;; otherwise, keep looking through the DB
  92.     ( t ( respond sentence ( cdr db ) ) ) ) )
  93.  
  94. ;;----------------------------------------------------------------------------
  95. ;; match: if there is not a match between this pattern and this data,
  96. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  97. ;; format
  98.  
  99. ( defun match ( data pattern )
  100.   ( cond
  101.     ;; end of both data and pattern; a match
  102.     ( ( and ( null data ) ( null pattern ) ) nil )
  103.  
  104.     ;; end of pattern, but not end of data; no match
  105.     ( ( null pattern ) fail )
  106.  
  107.     ;; end of data, but not end of pattern; if the pattern starts with
  108.     ;; a variable, eat it and try and match the rest of the pattern to
  109.     ;; the null sentence (will only work if all variables); otherwise,
  110.     ;; fail
  111.     ( ( null data ) 
  112.       ( cond
  113. 	( ( variablep ( car pattern ) )
  114. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  115. 	      result
  116. 	    fail ) )
  117. 	( t fail ) ) )
  118.  
  119.  
  120.     ;; first item of data and pattern are identical; if the rest of it
  121.     ;; matched, return the first item cons'ed with the rest of the
  122.     ;; partitioned sentence; otherwise, fail
  123.     ( ( equal ( car data ) ( car pattern ) )
  124.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  125. 	  ( cons ( list ( car data ) ) result )
  126. 	fail ) )
  127.  
  128.     ;; first item of pattern is a variable; if the rest of the data
  129.     ;; (minus the first word, matched to the variable) is a match with
  130.     ;; all of the pattern, return the appropriate stuff; if all of the
  131.     ;; data (variable eats nothing) matches the rest of the pattern,
  132.     ;; return appropriate stuff; else, fail.
  133.     ( ( variablep ( car pattern ) ) 
  134.       ( cond
  135. 	;; variable eats nothing;  () is put in partitioned sentence
  136. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  137. 	  ( cons () result ) )
  138. 	;; variable eats one word; word is cons'ed into the first
  139. 	;; element of the partitioned sentence, assuming that the step
  140. 	;; before an actual match word would be a ()
  141. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  142. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  143. 	;; otherwise, fail
  144. 	( t fail ) ) )
  145.  
  146.     ( t fail ) ) )
  147.  
  148. ;;----------------------------------------------------------------------------
  149. ;; instantiate: takes a partitioned sentence and the response it has
  150. ;; been matched to and generates the appropriated completed response
  151.  
  152. ( defun instantiate ( partitioned response )
  153.   ( cond
  154.     ( ( null response ) nil )
  155.     ;; numbers indicate what part of the partitioned sentence to
  156.     ;; insert into the response
  157.     ( ( numberp ( car response ) )
  158.       ( setq index ( - ( car response ) 1 ) )
  159.       ( append ( nth index partitioned )
  160. 	     ( instantiate partitioned ( cdr response ) ) ) )
  161.     ( t ( cons ( car response )
  162. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  163.  
  164. ;;---------------------------------------------------------------------------
  165. ;;
  166. ;;  			     helping functions
  167. ;;
  168. ;;---------------------------------------------------------------------------
  169.  
  170. ( setq fail '-1 )
  171.  
  172. ( defun success ( result )
  173.   ( not ( equal result fail ) ) )
  174.  
  175. ( defun variablep ( word )
  176.   ( equal word '0 ) )
  177.  
  178.  
  179. ;;---------------------------------------------------------------------------
  180. ;;
  181. ;;  			         database
  182. ;;
  183. ;;---------------------------------------------------------------------------
  184.  
  185. ;; CHANGE THIS: add more to this database so that the interaction is
  186. ;; more interesting and communicative and so that Eliza sounds like you 
  187. ;; would sound in the same conversation!
  188. ;;---------------------------------------------------------------------------
  189.  
  190. ( setq database
  191.     '(
  192.         ;; example greetings/farewells -- change them to sound like you
  193.  
  194.         (
  195.         (Hello 0)
  196.         (Hello - have a seat and tell me how you feel today.) 
  197.         (Hello1 - have a seat and tell me how you feel today.)
  198.         (Hello2 - have a seat and tell me how you feel today.)
  199.         (Hello3 - have a seat and tell me how you feel today.)
  200.         (Hello4 - have a seat and tell me how you feel today.)
  201.         (Hello5 - have a seat and tell me how you feel today.)
  202.         (Hello6 - have a seat and tell me how you feel today.)
  203.         (Hello7 - have a seat and tell me how you feel today.)
  204.         (Hello8 - have a seat and tell me how you feel today.)
  205.         (Hello9 - have a seat and tell me how you feel today.)
  206.         (Hello10 - have a seat and tell me how you feel today.)
  207.         )
  208.  
  209.         ( (0 You came here because 0)
  210.         (A lot of people come here for that reason so you are not alone.) )
  211.  
  212.         ( (0 Goodbye 0)
  213.         (Goodbye - I hope you enjoyed this session.) )
  214.  
  215.         ;; feelings
  216.         ( (0 you think 0)
  217.         (And just why do you think 4 ?) )
  218.  
  219.         ( (0 you are happy 0) 
  220.         (That's wonderful! What’s making you happy today? ) )
  221.  
  222.         ((0 you feel joyful 0)
  223.         (
  224.           "I'm glad to hear that! Tell me more what makes you feel joyful?" 
  225.         ))
  226.  
  227.         ((0 you are excited 0)
  228.         (
  229.           "I'm glad to hear that! Tell me more what makes you feel excited?" 
  230.         ))
  231.  
  232.         ((0 you feel sad 0) 
  233.         ("I'm sorry to hear that. Why do you think you are sad?" 
  234.           "What’s making you feel sad?" 
  235.           "Tell me more about what’s troubling you."))
  236.  
  237.         ((0 you are angry 0)
  238.         ("I see. What made you feel this way?" 
  239.           "Why do you think you’re feeling so angry?" 
  240.           "Can you tell me more about what’s making you angry?"))
  241.  
  242.         ;; the catch-alls
  243.         (
  244.           (0) 
  245.           (Could you expand on that?)
  246.           ("Hmmm.. Is it possible to elaborate more on that please?")
  247.           ("Hmmm.. I feel I didn't get what you mean. Can you explain again in other terms?")
  248.           ("Uhh.. I fear I don't understand what are you talking about..")
  249.           ("Ops, didn't get it, please expand on that.")
  250.  
  251.         )
  252.     )
  253. )
  254.  
  255. (princ (eliza '(hello)))
  256.  
Success #stdin #stdout #stderr 0.01s 9668KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
7
1
(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
  0x146d82000000 - 0x146d822e4fff
  0x146d82415000 - 0x146d82439fff
  0x146d8243a000 - 0x146d825acfff
  0x146d825ad000 - 0x146d825f5fff
  0x146d825f6000 - 0x146d825f8fff
  0x146d825f9000 - 0x146d825fbfff
  0x146d825fc000 - 0x146d825fffff
  0x146d82600000 - 0x146d82602fff
  0x146d82603000 - 0x146d82801fff
  0x146d82802000 - 0x146d82802fff
  0x146d82803000 - 0x146d82803fff
  0x146d82880000 - 0x146d8288ffff
  0x146d82890000 - 0x146d828c3fff
  0x146d828c4000 - 0x146d829fafff
  0x146d829fb000 - 0x146d829fbfff
  0x146d829fc000 - 0x146d829fefff
  0x146d829ff000 - 0x146d829fffff
  0x146d82a00000 - 0x146d82a03fff
  0x146d82a04000 - 0x146d82c03fff
  0x146d82c04000 - 0x146d82c04fff
  0x146d82c05000 - 0x146d82c05fff
  0x146d82c79000 - 0x146d82c7cfff
  0x146d82c7d000 - 0x146d82c7dfff
  0x146d82c7e000 - 0x146d82c7ffff
  0x146d82c80000 - 0x146d82c80fff
  0x146d82c81000 - 0x146d82c81fff
  0x146d82c82000 - 0x146d82c82fff
  0x146d82c83000 - 0x146d82c90fff
  0x146d82c91000 - 0x146d82c9efff
  0x146d82c9f000 - 0x146d82cabfff
  0x146d82cac000 - 0x146d82caffff
  0x146d82cb0000 - 0x146d82cb0fff
  0x146d82cb1000 - 0x146d82cb1fff
  0x146d82cb2000 - 0x146d82cb7fff
  0x146d82cb8000 - 0x146d82cb9fff
  0x146d82cba000 - 0x146d82cbafff
  0x146d82cbb000 - 0x146d82cbbfff
  0x146d82cbc000 - 0x146d82cbcfff
  0x146d82cbd000 - 0x146d82ceafff
  0x146d82ceb000 - 0x146d82cf9fff
  0x146d82cfa000 - 0x146d82d9ffff
  0x146d82da0000 - 0x146d82e36fff
  0x146d82e37000 - 0x146d82e37fff
  0x146d82e38000 - 0x146d82e38fff
  0x146d82e39000 - 0x146d82e4cfff
  0x146d82e4d000 - 0x146d82e74fff
  0x146d82e75000 - 0x146d82e7efff
  0x146d82e7f000 - 0x146d82e80fff
  0x146d82e81000 - 0x146d82e86fff
  0x146d82e87000 - 0x146d82e89fff
  0x146d82e8c000 - 0x146d82e8cfff
  0x146d82e8d000 - 0x146d82e8dfff
  0x146d82e8e000 - 0x146d82e8efff
  0x146d82e8f000 - 0x146d82e8ffff
  0x146d82e90000 - 0x146d82e90fff
  0x146d82e91000 - 0x146d82e97fff
  0x146d82e98000 - 0x146d82e9afff
  0x146d82e9b000 - 0x146d82e9bfff
  0x146d82e9c000 - 0x146d82ebcfff
  0x146d82ebd000 - 0x146d82ec4fff
  0x146d82ec5000 - 0x146d82ec5fff
  0x146d82ec6000 - 0x146d82ec6fff
  0x146d82ec7000 - 0x146d82ec7fff
  0x55b5bea4b000 - 0x55b5beb3bfff
  0x55b5beb3c000 - 0x55b5bec45fff
  0x55b5bec46000 - 0x55b5beca5fff
  0x55b5beca7000 - 0x55b5becd5fff
  0x55b5becd6000 - 0x55b5bed06fff
  0x55b5bed07000 - 0x55b5bed0afff
  0x55b5c011a000 - 0x55b5c013afff
  0x7ffd124b2000 - 0x7ffd124d2fff
  0x7ffd1253f000 - 0x7ffd12542fff
  0x7ffd12543000 - 0x7ffd12544fff
https://ideone.com/tPeJDx
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!