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.     ((equal ( car sentence ) 'my)
  30.      (cons 'your (change-pros (cdr sentence))))
  31.     ((equal ( car sentence ) 'your)
  32.      (cons 'my (change-pros (cdr sentence))))
  33.  
  34.     ((equal (car sentence) 'im)
  35. 	 (cons 'you (cons 'are (cdr sentence))))
  36.     ((equal ( car sentence ) 'you)
  37.      (cons 'im (change-pros (cdr sentence))))
  38.  
  39.     ((equal ( car sentence ) 'mine)
  40.      (cons 'yours (change-pros (cdr sentence))))
  41.     ((equal ( car sentence ) 'yours)
  42.      (cons 'mine (change-pros (cdr sentence))))
  43.  
  44.      ((equal ( car sentence ) 'he)
  45.      (cons 'they (change-pros (cdr sentence))))
  46.      ((equal ( car sentence ) 'she)
  47.      (cons 'they (change-pros (cdr sentence))))
  48.      ((equal ( car sentence ) 'her)
  49.      (cons 'them (change-pros (cdr sentence))))
  50.      ((equal ( car sentence ) 'his)
  51.      (cons 'them (change-pros (cdr sentence))))
  52.  
  53.      ((equal ( car sentence ) 'me)
  54.      (cons 'you (change-pros (cdr sentence))))
  55.      ((equal ( car sentence ) 'you)
  56.      (cons 'me (change-pros (cdr sentence))))
  57.  
  58.      ((equal ( car sentence ) 'am)
  59.      (cons 'are (change-pros (cdr sentence))))
  60.      ((equal ( car sentence ) 'are)
  61.      (cons 'am (change-pros (cdr sentence))))
  62.  
  63.  
  64.  
  65.  
  66.  
  67.     ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  68.  
  69. ;;----------------------------------------------------------------------------
  70. ;; respond: given a sentence, looks through the database in search of
  71. ;; a matching pattern and the response; given the database response,
  72. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  73. ;; response
  74.  
  75. ( defun respond ( sentence db )
  76.   ( cond
  77.     ;; end of DB, return nil - should never really happen
  78.     ( ( null db ) nil )
  79.  
  80.     ;; if the result of matching the sentence against the current
  81.     ;; pattern is a success, produce this response
  82.     ( ( success ( setq result ( match sentence ( first ( car db ) ) ) ) )
  83.       ( instantiate result ( second ( car db ) ) ) )
  84.  
  85.     ;; otherwise, keep looking through the DB
  86.     ( t ( respond sentence ( cdr db ) ) ) ) )
  87.  
  88. ;;----------------------------------------------------------------------------
  89. ;; match: if there is not a match between this pattern and this data,
  90. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  91. ;; format
  92.  
  93. ( defun match ( data pattern )
  94.   ( cond
  95.     ;; end of both data and pattern; a match
  96.     ( ( and ( null data ) ( null pattern ) ) nil )
  97.  
  98.     ;; end of pattern, but not end of data; no match
  99.     ( ( null pattern ) fail )
  100.  
  101.     ;; end of data, but not end of pattern; if the pattern starts with
  102.     ;; a variable, eat it and try and match the rest of the pattern to
  103.     ;; the null sentence (will only work if all variables); otherwise,
  104.     ;; fail
  105.     ( ( null data ) 
  106.       ( cond
  107. 	( ( variablep ( car pattern ) )
  108. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  109. 	      result
  110. 	    fail ) )
  111. 	( t fail ) ) )
  112.  
  113.  
  114.     ;; first item of data and pattern are identical; if the rest of it
  115.     ;; matched, return the first item cons'ed with the rest of the
  116.     ;; partitioned sentence; otherwise, fail
  117.     ( ( equal ( car data ) ( car pattern ) )
  118.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  119. 	  ( cons ( list ( car data ) ) result )
  120. 	fail ) )
  121.  
  122.     ;; first item of pattern is a variable; if the rest of the data
  123.     ;; (minus the first word, matched to the variable) is a match with
  124.     ;; all of the pattern, return the appropriate stuff; if all of the
  125.     ;; data (variable eats nothing) matches the rest of the pattern,
  126.     ;; return appropriate stuff; else, fail.
  127.     ( ( variablep ( car pattern ) ) 
  128.       ( cond
  129. 	;; variable eats nothing;  () is put in partitioned sentence
  130. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  131. 	  ( cons () result ) )
  132. 	;; variable eats one word; word is cons'ed into the first
  133. 	;; element of the partitioned sentence, assuming that the step
  134. 	;; before an actual match word would be a ()
  135. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  136. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  137. 	;; otherwise, fail
  138. 	( t fail ) ) )
  139.  
  140.     ( t fail ) ) )
  141.  
  142. ;;----------------------------------------------------------------------------
  143. ;; instantiate: takes a partitioned sentence and the response it has
  144. ;; been matched to and generates the appropriated completed response
  145.  
  146. ( defun instantiate ( partitioned response )
  147.   ( cond
  148.     ( ( null response ) nil )
  149.     ;; numbers indicate what part of the partitioned sentence to
  150.     ;; insert into the response
  151.     ( ( numberp ( car response ) )
  152.       ( setq index ( - ( car response ) 1 ) )
  153.       ( append ( nth index partitioned )
  154. 	     ( instantiate partitioned ( cdr response ) ) ) )
  155.     ( t ( cons ( car response )
  156. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  157.  
  158. ;;---------------------------------------------------------------------------
  159. ;;
  160. ;;  			     helping functions
  161. ;;
  162. ;;---------------------------------------------------------------------------
  163.  
  164. ( setq fail '-1 )
  165.  
  166. ( defun success ( result )
  167.   ( not ( equal result fail ) ) )
  168.  
  169. ( defun variablep ( word )
  170.   ( equal word '0 ) )
  171.  
  172. (defun random-response-from (responses)
  173.   (nth (random (length responses)) responses))
  174.  
  175.  
  176. ;;---------------------------------------------------------------------------
  177. ;;
  178. ;;  			         database
  179. ;;
  180. ;;---------------------------------------------------------------------------
  181.  
  182. ;; CHANGE THIS: add more to this database so that the interaction is
  183. ;; more interesting and communicative and so that Eliza sounds like you 
  184. ;; would sound in the same conversation!
  185. ;;---------------------------------------------------------------------------
  186.  
  187. ( setq database
  188.        '(
  189. 	 ;; example greetings/farewells -- change them to sound like you
  190. 	 ((Hello 0)
  191.       ("Whats up? Everything been good today?"))
  192.      ((Goodbye 0)
  193.       ("Ill see you later, take it easy!"))
  194.      ((Whats up 0)
  195.       ("Not much, just waiting for you to ask me a question..."))
  196.      ((Hi 0)
  197.       ("Hey, what can I help you with today?"))
  198.      ((See you later 0)
  199.       ("Absolutely! Till next time."))
  200.      ((Ill see ya 0)
  201.       ("Later!"))
  202.      ((Bye 0)
  203.       ("Alright, have a good one!"))
  204.  
  205. 	 ;; feelings
  206. 	((0 you think 0)
  207.      ("And why do you think" 4 "?"))
  208.     ((0 Im happy 0)
  209.      (How long have you been happy?))
  210.     ((0 Im sad 0)
  211.      (Why are you feeling sad?))
  212.     ((0 im stressed 0)
  213.      (What is causing you stress?))
  214.     ((0 I need advice 0)
  215.      (What do you need advice for?))
  216.     ((0 school 0)
  217.      (What about school is on your mind?))
  218.     ((0 work 0)
  219.      (What about work is on your mind?))
  220.  
  221. 	 ;; the catch-alls
  222. 	 ( (0) 
  223. 	  ("Could you expand on that?")
  224. 	  ("Can you reword that? I don't think I'm getting it.")
  225. 	  ("It sounds like you need to take a break, do you agree?")
  226. 	  ("What do you think your mom would say about this?"))))
  227.  
  228.  
  229.  
  230. (setq response (eliza '(Yeah I have two projects that i need advice on to do right now)))
  231. (print response)
Success #stdin #stdout #stderr 0.02s 9624KB
comments (?)
stdin
copy 
Hello
stdout
copy 
("Could you expand on that?")
stderr
copy 
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x1541ec400000 - 0x1541ec6e4fff
  0x1541ec800000 - 0x1541ec802fff
  0x1541ec803000 - 0x1541eca01fff
  0x1541eca02000 - 0x1541eca02fff
  0x1541eca03000 - 0x1541eca03fff
  0x1541eca15000 - 0x1541eca39fff
  0x1541eca3a000 - 0x1541ecbacfff
  0x1541ecbad000 - 0x1541ecbf5fff
  0x1541ecbf6000 - 0x1541ecbf8fff
  0x1541ecbf9000 - 0x1541ecbfbfff
  0x1541ecbfc000 - 0x1541ecbfffff
  0x1541ecc00000 - 0x1541ecc03fff
  0x1541ecc04000 - 0x1541ece03fff
  0x1541ece04000 - 0x1541ece04fff
  0x1541ece05000 - 0x1541ece05fff
  0x1541ece36000 - 0x1541ece37fff
  0x1541ece38000 - 0x1541ece47fff
  0x1541ece48000 - 0x1541ece7bfff
  0x1541ece7c000 - 0x1541ecfb2fff
  0x1541ecfb3000 - 0x1541ecfb3fff
  0x1541ecfb4000 - 0x1541ecfb6fff
  0x1541ecfb7000 - 0x1541ecfb7fff
  0x1541ecfb8000 - 0x1541ecfb9fff
  0x1541ecfba000 - 0x1541ecfbafff
  0x1541ecfbb000 - 0x1541ecfbcfff
  0x1541ecfbd000 - 0x1541ecfbdfff
  0x1541ecfbe000 - 0x1541ecfbefff
  0x1541ecfbf000 - 0x1541ecfbffff
  0x1541ecfc0000 - 0x1541ecfcdfff
  0x1541ecfce000 - 0x1541ecfdbfff
  0x1541ecfdc000 - 0x1541ecfe8fff
  0x1541ecfe9000 - 0x1541ecfecfff
  0x1541ecfed000 - 0x1541ecfedfff
  0x1541ecfee000 - 0x1541ecfeefff
  0x1541ecfef000 - 0x1541ecff4fff
  0x1541ecff5000 - 0x1541ecff6fff
  0x1541ecff7000 - 0x1541ecff7fff
  0x1541ecff8000 - 0x1541ecff8fff
  0x1541ecff9000 - 0x1541ecff9fff
  0x1541ecffa000 - 0x1541ed027fff
  0x1541ed028000 - 0x1541ed036fff
  0x1541ed037000 - 0x1541ed0dcfff
  0x1541ed0dd000 - 0x1541ed173fff
  0x1541ed174000 - 0x1541ed174fff
  0x1541ed175000 - 0x1541ed175fff
  0x1541ed176000 - 0x1541ed189fff
  0x1541ed18a000 - 0x1541ed1b1fff
  0x1541ed1b2000 - 0x1541ed1bbfff
  0x1541ed1bc000 - 0x1541ed1bdfff
  0x1541ed1be000 - 0x1541ed1c3fff
  0x1541ed1c4000 - 0x1541ed1c6fff
  0x1541ed1c9000 - 0x1541ed1c9fff
  0x1541ed1ca000 - 0x1541ed1cafff
  0x1541ed1cb000 - 0x1541ed1cbfff
  0x1541ed1cc000 - 0x1541ed1ccfff
  0x1541ed1cd000 - 0x1541ed1cdfff
  0x1541ed1ce000 - 0x1541ed1d4fff
  0x1541ed1d5000 - 0x1541ed1d7fff
  0x1541ed1d8000 - 0x1541ed1d8fff
  0x1541ed1d9000 - 0x1541ed1f9fff
  0x1541ed1fa000 - 0x1541ed201fff
  0x1541ed202000 - 0x1541ed202fff
  0x1541ed203000 - 0x1541ed203fff
  0x1541ed204000 - 0x1541ed204fff
  0x561123ba3000 - 0x561123c93fff
  0x561123c94000 - 0x561123d9dfff
  0x561123d9e000 - 0x561123dfdfff
  0x561123dff000 - 0x561123e2dfff
  0x561123e2e000 - 0x561123e5efff
  0x561123e5f000 - 0x561123e62fff
  0x5611247ad000 - 0x5611247cdfff
  0x7ffe0c553000 - 0x7ffe0c573fff
  0x7ffe0c5c4000 - 0x7ffe0c5c7fff
  0x7ffe0c5c8000 - 0x7ffe0c5c9fff
https://ideone.com/JsZlAp
language:
Common Lisp (clisp 2.49.92)
created:
1 day 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!