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.     ( ( equal ( car sentence ) 'you )
  22.       ( cons 'I ( change-pros ( cdr sentence ) ) ) )
  23.     ( ( equal ( car sentence ) 'I )
  24.       ( cons 'you ( change-pros ( cdr sentence ) ) ) )
  25.  
  26.     ;; CHANGE THIS: add more cases here of pronouns or other words
  27.     ;; that should flip in order for this to work well
  28.  
  29.     ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  30.  
  31. ;;----------------------------------------------------------------------------
  32. ;; respond: given a sentence, looks through the database in search of
  33. ;; a matching pattern and the response; given the database response,
  34. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  35. ;; response
  36.  
  37. ( defun respond ( sentence db )
  38.   ( cond
  39.     ;; end of DB, return nil - should never really happen
  40.     ( ( null db ) nil )
  41.  
  42.     ;; if the result of matching the sentence against the current
  43.     ;; pattern is a success, produce this response
  44.     ( ( success ( setq result ( match sentence ( first ( car db ) ) ) ) )
  45.       ( instantiate result ( second ( car db ) ) ) )
  46.  
  47.     ;; otherwise, keep looking through the DB
  48.     ( t ( respond sentence ( cdr db ) ) ) ) )
  49.  
  50. ;;----------------------------------------------------------------------------
  51. ;; match: if there is not a match between this pattern and this data,
  52. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  53. ;; format
  54.  
  55. ( defun match ( data pattern )
  56.   ( cond
  57.     ;; end of both data and pattern; a match
  58.     ( ( and ( null data ) ( null pattern ) ) nil )
  59.  
  60.     ;; end of pattern, but not end of data; no match
  61.     ( ( null pattern ) fail )
  62.  
  63.     ;; end of data, but not end of pattern; if the pattern starts with
  64.     ;; a variable, eat it and try and match the rest of the pattern to
  65.     ;; the null sentence (will only work if all variables); otherwise,
  66.     ;; fail
  67.     ( ( null data ) 
  68.       ( cond
  69. 	( ( variablep ( car pattern ) )
  70. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  71. 	      result
  72. 	    fail ) )
  73. 	( t fail ) ) )
  74.  
  75.  
  76.     ;; first item of data and pattern are identical; if the rest of it
  77.     ;; matched, return the first item cons'ed with the rest of the
  78.     ;; partitioned sentence; otherwise, fail
  79.     ( ( equal ( car data ) ( car pattern ) )
  80.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  81. 	  ( cons ( list ( car data ) ) result )
  82. 	fail ) )
  83.  
  84.     ;; first item of pattern is a variable; if the rest of the data
  85.     ;; (minus the first word, matched to the variable) is a match with
  86.     ;; all of the pattern, return the appropriate stuff; if all of the
  87.     ;; data (variable eats nothing) matches the rest of the pattern,
  88.     ;; return appropriate stuff; else, fail.
  89.     ( ( variablep ( car pattern ) ) 
  90.       ( cond
  91. 	;; variable eats nothing;  () is put in partitioned sentence
  92. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  93. 	  ( cons () result ) )
  94. 	;; variable eats one word; word is cons'ed into the first
  95. 	;; element of the partitioned sentence, assuming that the step
  96. 	;; before an actual match word would be a ()
  97. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  98. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  99. 	;; otherwise, fail
  100. 	( t fail ) ) )
  101.  
  102.     ( t fail ) ) )
  103.  
  104. ;;----------------------------------------------------------------------------
  105. ;; instantiate: takes a partitioned sentence and the response it has
  106. ;; been matched to and generates the appropriated completed response
  107.  
  108. ( defun instantiate ( partitioned response )
  109.   ( cond
  110.     ( ( null response ) nil )
  111.     ;; numbers indicate what part of the partitioned sentence to
  112.     ;; insert into the response
  113.     ( ( numberp ( car response ) )
  114.       ( setq index ( - ( car response ) 1 ) )
  115.       ( append ( nth index partitioned )
  116. 	     ( instantiate partitioned ( cdr response ) ) ) )
  117.     ( t ( cons ( car response )
  118. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  119.  
  120. ;;---------------------------------------------------------------------------
  121. ;;
  122. ;;  			     helping functions
  123. ;;
  124. ;;---------------------------------------------------------------------------
  125.  
  126. ( setq fail '-1 )
  127.  
  128. ( defun success ( result )
  129.   ( not ( equal result fail ) ) )
  130.  
  131. ( defun variablep ( word )
  132.   ( equal word '0 ) )
  133.  
  134.  
  135. ;;---------------------------------------------------------------------------
  136. ;;
  137. ;;  			         database
  138. ;;
  139. ;;---------------------------------------------------------------------------
  140.  
  141. ;; CHANGE THIS: add more to this database so that the interaction is
  142. ;; more interesting and communicative and so that Eliza sounds like you 
  143. ;; would sound in the same conversation!
  144. ;;---------------------------------------------------------------------------
  145.  
  146. ( setq database
  147.        '(
  148. 	 ;; example greetings/farewells -- change them to sound like you
  149. 	 ( (Hello 0)
  150. 	   (Hello - have a seat and tell me how you feel today.) )
  151. 	 ( (0 you came here because 0)
  152. 	   (A lot of people come here for that reason so you are not alone.) )
  153. 	 ( (0 Goodbye 0)
  154. 	   (Goodbye - I hope you enjoyed this session.) )
  155.  
  156. 	 ;; feelings
  157. 	 ( (0 you think 0)
  158. 	   (And just why do you think 4 ?) )
  159.  
  160. 	 ;; the catch-alls
  161. 	 ( (0) 
  162. 	   (Could you expand on that?) ) ) )
  163.  
  164. 	(eliza '(hello))
  165.  
  166.  
Success #stdin #stdout #stderr 0.01s 9696KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
stderr
copy 
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x15292ce00000 - 0x15292d0e4fff
  0x15292d215000 - 0x15292d239fff
  0x15292d23a000 - 0x15292d3acfff
  0x15292d3ad000 - 0x15292d3f5fff
  0x15292d3f6000 - 0x15292d3f8fff
  0x15292d3f9000 - 0x15292d3fbfff
  0x15292d3fc000 - 0x15292d3fffff
  0x15292d400000 - 0x15292d402fff
  0x15292d403000 - 0x15292d601fff
  0x15292d602000 - 0x15292d602fff
  0x15292d603000 - 0x15292d603fff
  0x15292d680000 - 0x15292d68ffff
  0x15292d690000 - 0x15292d6c3fff
  0x15292d6c4000 - 0x15292d7fafff
  0x15292d7fb000 - 0x15292d7fbfff
  0x15292d7fc000 - 0x15292d7fefff
  0x15292d7ff000 - 0x15292d7fffff
  0x15292d800000 - 0x15292d803fff
  0x15292d804000 - 0x15292da03fff
  0x15292da04000 - 0x15292da04fff
  0x15292da05000 - 0x15292da05fff
  0x15292da27000 - 0x15292da2afff
  0x15292da2b000 - 0x15292da2bfff
  0x15292da2c000 - 0x15292da2dfff
  0x15292da2e000 - 0x15292da2efff
  0x15292da2f000 - 0x15292da2ffff
  0x15292da30000 - 0x15292da30fff
  0x15292da31000 - 0x15292da3efff
  0x15292da3f000 - 0x15292da4cfff
  0x15292da4d000 - 0x15292da59fff
  0x15292da5a000 - 0x15292da5dfff
  0x15292da5e000 - 0x15292da5efff
  0x15292da5f000 - 0x15292da5ffff
  0x15292da60000 - 0x15292da65fff
  0x15292da66000 - 0x15292da67fff
  0x15292da68000 - 0x15292da68fff
  0x15292da69000 - 0x15292da69fff
  0x15292da6a000 - 0x15292da6afff
  0x15292da6b000 - 0x15292da98fff
  0x15292da99000 - 0x15292daa7fff
  0x15292daa8000 - 0x15292db4dfff
  0x15292db4e000 - 0x15292dbe4fff
  0x15292dbe5000 - 0x15292dbe5fff
  0x15292dbe6000 - 0x15292dbe6fff
  0x15292dbe7000 - 0x15292dbfafff
  0x15292dbfb000 - 0x15292dc22fff
  0x15292dc23000 - 0x15292dc2cfff
  0x15292dc2d000 - 0x15292dc2efff
  0x15292dc2f000 - 0x15292dc34fff
  0x15292dc35000 - 0x15292dc37fff
  0x15292dc3a000 - 0x15292dc3afff
  0x15292dc3b000 - 0x15292dc3bfff
  0x15292dc3c000 - 0x15292dc3cfff
  0x15292dc3d000 - 0x15292dc3dfff
  0x15292dc3e000 - 0x15292dc3efff
  0x15292dc3f000 - 0x15292dc45fff
  0x15292dc46000 - 0x15292dc48fff
  0x15292dc49000 - 0x15292dc49fff
  0x15292dc4a000 - 0x15292dc6afff
  0x15292dc6b000 - 0x15292dc72fff
  0x15292dc73000 - 0x15292dc73fff
  0x15292dc74000 - 0x15292dc74fff
  0x15292dc75000 - 0x15292dc75fff
  0x55b15e7cc000 - 0x55b15e8bcfff
  0x55b15e8bd000 - 0x55b15e9c6fff
  0x55b15e9c7000 - 0x55b15ea26fff
  0x55b15ea28000 - 0x55b15ea56fff
  0x55b15ea57000 - 0x55b15ea87fff
  0x55b15ea88000 - 0x55b15ea8bfff
  0x55b15f9a1000 - 0x55b15f9c1fff
  0x7fff16017000 - 0x7fff16037fff
  0x7fff1608c000 - 0x7fff1608ffff
  0x7fff16090000 - 0x7fff16091fff
https://ideone.com/O0X5jK
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!