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.  
  9. ( defun eliza ( sentence )
  10.   ( respond ( change-pros sentence ) database ) )
  11.  
  12. ;;----------------------------------------------------------------------------
  13. ;; change-pros: changes the pronouns of the sentence so that Eliza can
  14. ;; come back with the appropriately switched first and second person
  15. ;; references.
  16.  
  17. ( defun change-pros ( sentence )
  18.   ( cond 
  19.     ( ( null sentence ) nil )
  20.     ( ( equal ( car sentence ) 'you )
  21.       ( cons 'I ( change-pros ( cdr sentence ) ) ) )
  22.     ( ( equal ( car sentence ) 'I )
  23.       ( cons 'you ( change-pros ( cdr sentence ) ) ) )
  24.     ( ( equal ( car sentence ) 'my )
  25.       ( cons 'your ( change-pros ( cdr sentence ) ) ) )
  26.     ( ( equal ( car sentence ) 'am )
  27.       ( cons 'are ( change-pros ( cdr sentence ) ) ) )
  28.  
  29.     ;; CHANGE THIS: add more cases here of pronouns or other words
  30.     ;; that should flip in order for this to work well
  31.  
  32.     ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  33.  
  34. ;;----------------------------------------------------------------------------
  35. ;; respond: given a sentence, looks through the database in search of
  36. ;; a matching pattern and the response; given the database response,
  37. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  38. ;; response
  39.  
  40. (defun respond (sentence db)
  41.   (cond
  42.     ;; end of DB, return nil - should never really happen
  43.     ((null db) nil)
  44.  
  45.     ;; if the result of matching the sentence against the current
  46.     ;; pattern is a success, produce this response
  47.     ((success (setq result (match sentence (first (car db)))))
  48.      (let ((response (instantiate result (second (car db)))))
  49.        (format t "~a~%" response)
  50.        response))
  51.  
  52.  
  53.     ;; otherwise, keep looking through the DB
  54.     (t (respond sentence (cdr db)))))
  55.  
  56.  
  57.  
  58. ;;----------------------------------------------------------------------------
  59. ;; match: if there is not a match between this pattern and this data,
  60. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  61. ;; format
  62.  
  63. ( defun match ( data pattern )
  64.   ( cond
  65.     ;; end of both data and pattern; a match
  66.     ( ( and ( null data ) ( null pattern ) ) nil )
  67.  
  68.     ;; end of pattern, but not end of data; no match
  69.     ( ( null pattern ) fail )
  70.  
  71.     ;; end of data, but not end of pattern; if the pattern starts with
  72.     ;; a variable, eat it and try and match the rest of the pattern to
  73.     ;; the null sentence (will only work if all variables); otherwise,
  74.     ;; fail
  75.     ( ( null data ) 
  76.       ( cond
  77. 	( ( variablep ( car pattern ) )
  78. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  79. 	      result
  80. 	    fail ) )
  81. 	( t fail ) ) )
  82.  
  83.  
  84.     ;; first item of data and pattern are identical; if the rest of it
  85.     ;; matched, return the first item cons'ed with the rest of the
  86.     ;; partitioned sentence; otherwise, fail
  87.     ( ( equal ( car data ) ( car pattern ) )
  88.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  89. 	  ( cons ( list ( car data ) ) result )
  90. 	fail ) )
  91.  
  92.     ;; first item of pattern is a variable; if the rest of the data
  93.     ;; (minus the first word, matched to the variable) is a match with
  94.     ;; all of the pattern, return the appropriate stuff; if all of the
  95.     ;; data (variable eats nothing) matches the rest of the pattern,
  96.     ;; return appropriate stuff; else, fail.
  97.     ( ( variablep ( car pattern ) ) 
  98.       ( cond
  99. 	;; variable eats nothing;  () is put in partitioned sentence
  100. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  101. 	  ( cons () result ) )
  102. 	;; variable eats one word; word is cons'ed into the first
  103. 	;; element of the partitioned sentence, assuming that the step
  104. 	;; before an actual match word would be a ()
  105. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  106. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  107. 	;; otherwise, fail
  108. 	( t fail ) ) )
  109.  
  110.     ( t fail ) ) )
  111.  
  112. ;;----------------------------------------------------------------------------
  113. ;; instantiate: takes a partitioned sentence and the response it has
  114. ;; been matched to and generates the appropriated completed response
  115.  
  116. ( defun instantiate ( partitioned response )
  117.   ( cond
  118.     ( ( null response ) nil )
  119.     ;; numbers indicate what part of the partitioned sentence to
  120.     ;; insert into the response
  121.     ( ( numberp ( car response ) )
  122.       ( setq index ( - ( car response ) 1 ) )
  123.       ( append ( nth index partitioned )
  124. 	     ( instantiate partitioned ( cdr response ) ) ) )
  125.     ( t ( cons ( car response )
  126. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  127.  
  128. ;;---------------------------------------------------------------------------
  129. ;;
  130. ;;  			     helping functions
  131. ;;
  132. ;;---------------------------------------------------------------------------
  133.  
  134. ( setq fail '-1 )
  135.  
  136. ( defun success ( result )
  137.   ( not ( equal result fail ) ) )
  138.  
  139. ( defun variablep ( word )
  140.   ( equal word '0 ) )
  141.  
  142.  
  143. ;;---------------------------------------------------------------------------
  144. ;;
  145. ;;  			         database
  146. ;;
  147. ;;---------------------------------------------------------------------------
  148.  
  149. ;; CHANGE THIS: add more to this database so that the interaction is
  150. ;; more interesting and communicative and so that Eliza sounds like you 
  151. ;; would sound in the same conversation!
  152. ;;---------------------------------------------------------------------------
  153.  
  154. ( setq database
  155.        '(
  156. 	 ;; example greetings/farewells -- change them to sound like you
  157. 	 ( (Hello)
  158. 	   (hello are you feeling alright today?) )
  159. 	 ( (0 you came here because 0)
  160. 	   (lots of people come here for that exact reason) )
  161. 	 ( (0 Goodbye 0)
  162. 	   (goodbye. i hope this was able to help you.) )
  163. 	 ( (0 bye 0)
  164. 	   (bye. i hope this was able to help you.) )
  165. 	 ( (0 Late 0)
  166. 	   (you are just on time.) )
  167.  
  168. 	 ;; feelings
  169. 	 ( (0 stress 0)
  170. 	   (lots of people struggle with stress. you are not alone) )
  171. 	 ( (0 i think 0)
  172. 	   (And just why do you think 4 ?) )
  173. 	 ( (0 feel like 0)
  174. 	   (why do you feel like 4 ?) )
  175. 	 ( (0 feeling 0)
  176. 	   (what do you think is cauing you to feel 3 ?) )
  177. 	 ( (0 dont like 0)
  178. 	   (why do dont you like 4 ?) )
  179. 	 ( (0 overwhelmed 0)
  180. 	   (and why do you think you are feeling overwhelmed?) )
  181. 	 ( (0 anxiety 0)
  182. 	   (what do you think would help reduce this anxiety?) )
  183. 	 ( (0 behind 0)
  184. 	   (how do you think you got to be behind 3 ?) )
  185. 	 ( (0 busy 0)
  186. 	   (It can be hard to always feel busy. what do you think could help?) )
  187. 	 ( (0 are i doing 0)
  188. 	   (i am doing well. please tell me how you are feeling.) )
  189. 	 ( (0 tired 0)
  190. 	   (thats very common among people that come here.) )
  191. 	 ( (0 better 0)
  192. 	   (I am glad i could help. is there anything else i can help with?) )
  193.  
  194.  
  195. 	 ;; the catch-alls
  196. 	 ( (0 feel 0 ) 
  197. 	   (im sorry to hear that you feel that way. what do you think could help?) )
  198. 	 ( (0 cant 0) 
  199. 	   (a lot of people feel that way. you are not alone) )
  200. 	 ( (0 help 0) 
  201. 	   (i am here to help in any way i can. please continue.) )
  202. 	 ( (0 robotic 0) 
  203. 	   (im sorry you feel that way about me.) )
  204. 	 ( (0 creepy 0) 
  205. 	   (im sorry you feel that way about me.) )
  206. 	 ( (0) 
  207. 	   (i see. please continue.) ) ) )
  208. (eliza '(mainly how busy my life is now))
Success #stdin #stdout #stderr 0.01s 9776KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(IT CAN BE HARD TO ALWAYS FEEL BUSY. WHAT DO YOU THINK COULD HELP?)
stderr
copy 
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x14de28600000 - 0x14de288e4fff
  0x14de28a00000 - 0x14de28a02fff
  0x14de28a03000 - 0x14de28c01fff
  0x14de28c02000 - 0x14de28c02fff
  0x14de28c03000 - 0x14de28c03fff
  0x14de28c15000 - 0x14de28c39fff
  0x14de28c3a000 - 0x14de28dacfff
  0x14de28dad000 - 0x14de28df5fff
  0x14de28df6000 - 0x14de28df8fff
  0x14de28df9000 - 0x14de28dfbfff
  0x14de28dfc000 - 0x14de28dfffff
  0x14de28e00000 - 0x14de28e03fff
  0x14de28e04000 - 0x14de29003fff
  0x14de29004000 - 0x14de29004fff
  0x14de29005000 - 0x14de29005fff
  0x14de29023000 - 0x14de29024fff
  0x14de29025000 - 0x14de29034fff
  0x14de29035000 - 0x14de29068fff
  0x14de29069000 - 0x14de2919ffff
  0x14de291a0000 - 0x14de291a0fff
  0x14de291a1000 - 0x14de291a3fff
  0x14de291a4000 - 0x14de291a4fff
  0x14de291a5000 - 0x14de291a6fff
  0x14de291a7000 - 0x14de291a7fff
  0x14de291a8000 - 0x14de291a9fff
  0x14de291aa000 - 0x14de291aafff
  0x14de291ab000 - 0x14de291abfff
  0x14de291ac000 - 0x14de291acfff
  0x14de291ad000 - 0x14de291bafff
  0x14de291bb000 - 0x14de291c8fff
  0x14de291c9000 - 0x14de291d5fff
  0x14de291d6000 - 0x14de291d9fff
  0x14de291da000 - 0x14de291dafff
  0x14de291db000 - 0x14de291dbfff
  0x14de291dc000 - 0x14de291e1fff
  0x14de291e2000 - 0x14de291e3fff
  0x14de291e4000 - 0x14de291e4fff
  0x14de291e5000 - 0x14de291e5fff
  0x14de291e6000 - 0x14de291e6fff
  0x14de291e7000 - 0x14de29214fff
  0x14de29215000 - 0x14de29223fff
  0x14de29224000 - 0x14de292c9fff
  0x14de292ca000 - 0x14de29360fff
  0x14de29361000 - 0x14de29361fff
  0x14de29362000 - 0x14de29362fff
  0x14de29363000 - 0x14de29376fff
  0x14de29377000 - 0x14de2939efff
  0x14de2939f000 - 0x14de293a8fff
  0x14de293a9000 - 0x14de293aafff
  0x14de293ab000 - 0x14de293b0fff
  0x14de293b1000 - 0x14de293b3fff
  0x14de293b6000 - 0x14de293b6fff
  0x14de293b7000 - 0x14de293b7fff
  0x14de293b8000 - 0x14de293b8fff
  0x14de293b9000 - 0x14de293b9fff
  0x14de293ba000 - 0x14de293bafff
  0x14de293bb000 - 0x14de293c1fff
  0x14de293c2000 - 0x14de293c4fff
  0x14de293c5000 - 0x14de293c5fff
  0x14de293c6000 - 0x14de293e6fff
  0x14de293e7000 - 0x14de293eefff
  0x14de293ef000 - 0x14de293effff
  0x14de293f0000 - 0x14de293f0fff
  0x14de293f1000 - 0x14de293f1fff
  0x5610777d3000 - 0x5610778c3fff
  0x5610778c4000 - 0x5610779cdfff
  0x5610779ce000 - 0x561077a2dfff
  0x561077a2f000 - 0x561077a5dfff
  0x561077a5e000 - 0x561077a8efff
  0x561077a8f000 - 0x561077a92fff
  0x5610785bd000 - 0x5610785ddfff
  0x7fff7c225000 - 0x7fff7c245fff
  0x7fff7c2be000 - 0x7fff7c2c1fff
  0x7fff7c2c2000 - 0x7fff7c2c3fff
https://ideone.com/nxxrTB
language:
Common Lisp (clisp 2.49.92)
created:
2 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!