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 ) 'youre )
  27.       ( cons 'im ( change-pros ( cdr sentence ) ) ) )
  28.     ( ( equal ( car sentence ) 'am )
  29.       ( cons 'are ( change-pros ( cdr sentence ) ) ) )
  30.     ( ( equal ( car sentence ) 'me )
  31.       ( cons 'you ( change-pros ( cdr sentence ) ) ) )
  32.  
  33.     ;; CHANGE THIS: add more cases here of pronouns or other words
  34.     ;; that should flip in order for this to work well
  35.  
  36.     ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  37.  
  38. ;;----------------------------------------------------------------------------
  39. ;; respond: given a sentence, looks through the database in search of
  40. ;; a matching pattern and the response; given the database response,
  41. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  42. ;; response
  43.  
  44. (defun respond (sentence db)
  45.   (cond
  46.     ;; end of DB, return nil - should never really happen
  47.     ((null db) nil)
  48.  
  49.     ;; if the result of matching the sentence against the current
  50.     ;; pattern is a success, produce this response
  51.     ((success (setq result (match sentence (first (car db)))))
  52.      (let ((response (instantiate result (second (car db)))))
  53.        (format t "~a~%" response)
  54.        response))
  55.  
  56.  
  57.     ;; otherwise, keep looking through the DB
  58.     (t (respond sentence (cdr db)))))
  59.  
  60.  
  61.  
  62. ;;----------------------------------------------------------------------------
  63. ;; match: if there is not a match between this pattern and this data,
  64. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  65. ;; format
  66.  
  67. ( defun match ( data pattern )
  68.   ( cond
  69.     ;; end of both data and pattern; a match
  70.     ( ( and ( null data ) ( null pattern ) ) nil )
  71.  
  72.     ;; end of pattern, but not end of data; no match
  73.     ( ( null pattern ) fail )
  74.  
  75.     ;; end of data, but not end of pattern; if the pattern starts with
  76.     ;; a variable, eat it and try and match the rest of the pattern to
  77.     ;; the null sentence (will only work if all variables); otherwise,
  78.     ;; fail
  79.     ( ( null data ) 
  80.       ( cond
  81. 	( ( variablep ( car pattern ) )
  82. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  83. 	      result
  84. 	    fail ) )
  85. 	( t fail ) ) )
  86.  
  87.  
  88.     ;; first item of data and pattern are identical; if the rest of it
  89.     ;; matched, return the first item cons'ed with the rest of the
  90.     ;; partitioned sentence; otherwise, fail
  91.     ( ( equal ( car data ) ( car pattern ) )
  92.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  93. 	  ( cons ( list ( car data ) ) result )
  94. 	fail ) )
  95.  
  96.     ;; first item of pattern is a variable; if the rest of the data
  97.     ;; (minus the first word, matched to the variable) is a match with
  98.     ;; all of the pattern, return the appropriate stuff; if all of the
  99.     ;; data (variable eats nothing) matches the rest of the pattern,
  100.     ;; return appropriate stuff; else, fail.
  101.     ( ( variablep ( car pattern ) ) 
  102.       ( cond
  103. 	;; variable eats nothing;  () is put in partitioned sentence
  104. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  105. 	  ( cons () result ) )
  106. 	;; variable eats one word; word is cons'ed into the first
  107. 	;; element of the partitioned sentence, assuming that the step
  108. 	;; before an actual match word would be a ()
  109. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  110. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  111. 	;; otherwise, fail
  112. 	( t fail ) ) )
  113.  
  114.     ( t fail ) ) )
  115.  
  116. ;;----------------------------------------------------------------------------
  117. ;; instantiate: takes a partitioned sentence and the response it has
  118. ;; been matched to and generates the appropriated completed response
  119.  
  120. ( defun instantiate ( partitioned response )
  121.   ( cond
  122.     ( ( null response ) nil )
  123.     ;; numbers indicate what part of the partitioned sentence to
  124.     ;; insert into the response
  125.     ( ( numberp ( car response ) )
  126.       ( setq index ( - ( car response ) 1 ) )
  127.       ( append ( nth index partitioned )
  128. 	     ( instantiate partitioned ( cdr response ) ) ) )
  129.     ( t ( cons ( car response )
  130. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  131.  
  132. ;;---------------------------------------------------------------------------
  133. ;;
  134. ;;  			     helping functions
  135. ;;
  136. ;;---------------------------------------------------------------------------
  137.  
  138. ( setq fail '-1 )
  139.  
  140. ( defun success ( result )
  141.   ( not ( equal result fail ) ) )
  142.  
  143. ( defun variablep ( word )
  144.   ( equal word '0 ) )
  145.  
  146.  
  147. ;;---------------------------------------------------------------------------
  148. ;;
  149. ;;  			         database
  150. ;;
  151. ;;---------------------------------------------------------------------------
  152.  
  153. ;; CHANGE THIS: add more to this database so that the interaction is
  154. ;; more interesting and communicative and so that Eliza sounds like you 
  155. ;; would sound in the same conversation!
  156. ;;---------------------------------------------------------------------------
  157.  
  158. ( setq database
  159.        '(
  160. 	 ;; example greetings/farewells -- change them to sound like you
  161. 	 ( (Hello)
  162. 	   (hello are you feeling alright today?) )
  163. 	 ( (0 you came here because 0)
  164. 	   (lots of people come here for that exact reason) )
  165. 	 ( (0 Goodbye 0)
  166. 	   (goodbye. i hope this was able to help you.) )
  167. 	 ( (0 bye 0)
  168. 	   (bye. i hope this was able to help you.) )
  169. 	 ( (0 Late 0)
  170. 	   (you are just on time.) )
  171.  
  172. 	 ;; feelings
  173. 	 ( (0 stress 0)
  174. 	   (lots of people struggle with stress. you are not alone) )
  175. 	 ( (0 i think 0)
  176. 	   (And just why do you think 4 ?) )
  177. 	 ( (0 good 0)
  178. 	   (I am glad you feel good) )
  179. 	 ( (0 feel like 0)
  180. 	   (why do you feel like 4 ?) )
  181. 	 ( (0 feeling 0)
  182. 	   (what do you think is cauing you to feel 3 ?) )
  183. 	 ( (0 dont like 0)
  184. 	   (why do dont you like 4 ?) )
  185. 	 ( (0 overwhelmed 0)
  186. 	   (and why do you think you are feeling overwhelmed?) )
  187. 	 ( (0 anxiety 0)
  188. 	   (what do you think would help reduce this anxiety?) )
  189. 	 ( (0 behind 0)
  190. 	   (how do you think you got to be behind 3 ?) )
  191. 	 ( (0 busy 0)
  192. 	   (It can be hard to always feel busy. what do you think could help?) )
  193. 	 ( (0 are i doing 0)
  194. 	   (i am doing well. please tell me how you are feeling.) )
  195. 	 ( (0 tired 0)
  196. 	   (thats very common among people that come here.) )
  197. 	 ( (0 better 0)
  198. 	   (I am glad i could help. is there anything else i can help with?) )
  199.  
  200.  
  201. 	 ;; the catch-alls
  202. 	 ( (0 feel 0 ) 
  203. 	   (im sorry to hear that you feel that way. what do you think could help?) )
  204. 	 ( (0 cant 0) 
  205. 	   (a lot of people feel that way. you are not alone) )
  206. 	 ( (0 help 0) 
  207. 	   (i am here to help in any way i can. please continue.) )
  208. 	 ( (0 robotic 0) 
  209. 	   (im sorry you feel that way about me.) )
  210. 	 ( (0 creepy 0) 
  211. 	   (im sorry you feel that way about me.) )
  212. 	 ( (0) 
  213. 	   (i see. please continue.) ) ) )
  214. (eliza '(there are several reasons))
Success #stdin #stdout #stderr 0.02s 9588KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(I SEE. PLEASE CONTINUE.)
stderr
copy 
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x14a107c00000 - 0x14a107ee4fff
  0x14a108015000 - 0x14a108039fff
  0x14a10803a000 - 0x14a1081acfff
  0x14a1081ad000 - 0x14a1081f5fff
  0x14a1081f6000 - 0x14a1081f8fff
  0x14a1081f9000 - 0x14a1081fbfff
  0x14a1081fc000 - 0x14a1081fffff
  0x14a108200000 - 0x14a108202fff
  0x14a108203000 - 0x14a108401fff
  0x14a108402000 - 0x14a108402fff
  0x14a108403000 - 0x14a108403fff
  0x14a108480000 - 0x14a10848ffff
  0x14a108490000 - 0x14a1084c3fff
  0x14a1084c4000 - 0x14a1085fafff
  0x14a1085fb000 - 0x14a1085fbfff
  0x14a1085fc000 - 0x14a1085fefff
  0x14a1085ff000 - 0x14a1085fffff
  0x14a108600000 - 0x14a108603fff
  0x14a108604000 - 0x14a108803fff
  0x14a108804000 - 0x14a108804fff
  0x14a108805000 - 0x14a108805fff
  0x14a108967000 - 0x14a10896afff
  0x14a10896b000 - 0x14a10896bfff
  0x14a10896c000 - 0x14a10896dfff
  0x14a10896e000 - 0x14a10896efff
  0x14a10896f000 - 0x14a10896ffff
  0x14a108970000 - 0x14a108970fff
  0x14a108971000 - 0x14a10897efff
  0x14a10897f000 - 0x14a10898cfff
  0x14a10898d000 - 0x14a108999fff
  0x14a10899a000 - 0x14a10899dfff
  0x14a10899e000 - 0x14a10899efff
  0x14a10899f000 - 0x14a10899ffff
  0x14a1089a0000 - 0x14a1089a5fff
  0x14a1089a6000 - 0x14a1089a7fff
  0x14a1089a8000 - 0x14a1089a8fff
  0x14a1089a9000 - 0x14a1089a9fff
  0x14a1089aa000 - 0x14a1089aafff
  0x14a1089ab000 - 0x14a1089d8fff
  0x14a1089d9000 - 0x14a1089e7fff
  0x14a1089e8000 - 0x14a108a8dfff
  0x14a108a8e000 - 0x14a108b24fff
  0x14a108b25000 - 0x14a108b25fff
  0x14a108b26000 - 0x14a108b26fff
  0x14a108b27000 - 0x14a108b3afff
  0x14a108b3b000 - 0x14a108b62fff
  0x14a108b63000 - 0x14a108b6cfff
  0x14a108b6d000 - 0x14a108b6efff
  0x14a108b6f000 - 0x14a108b74fff
  0x14a108b75000 - 0x14a108b77fff
  0x14a108b7a000 - 0x14a108b7afff
  0x14a108b7b000 - 0x14a108b7bfff
  0x14a108b7c000 - 0x14a108b7cfff
  0x14a108b7d000 - 0x14a108b7dfff
  0x14a108b7e000 - 0x14a108b7efff
  0x14a108b7f000 - 0x14a108b85fff
  0x14a108b86000 - 0x14a108b88fff
  0x14a108b89000 - 0x14a108b89fff
  0x14a108b8a000 - 0x14a108baafff
  0x14a108bab000 - 0x14a108bb2fff
  0x14a108bb3000 - 0x14a108bb3fff
  0x14a108bb4000 - 0x14a108bb4fff
  0x14a108bb5000 - 0x14a108bb5fff
  0x559513d51000 - 0x559513e41fff
  0x559513e42000 - 0x559513f4bfff
  0x559513f4c000 - 0x559513fabfff
  0x559513fad000 - 0x559513fdbfff
  0x559513fdc000 - 0x55951400cfff
  0x55951400d000 - 0x559514010fff
  0x55951441d000 - 0x55951443dfff
  0x7ffec6133000 - 0x7ffec6153fff
  0x7ffec61a9000 - 0x7ffec61acfff
  0x7ffec61ad000 - 0x7ffec61aefff
https://ideone.com/cdbDT6
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!