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.  
  76. ( defun respond ( sentence db )
  77.   ( cond
  78.     ;; end of DB, return nil - should never really happen
  79.     ( ( null db ) nil )
  80.  
  81.     ;; if the result of matching the sentence against the current
  82.     ;; pattern is a success, produce this response
  83.     ( ( success ( setq result ( match sentence ( first ( car db ) ) ) ) )
  84.       ( instantiate result ( second ( car db ) ) ) )
  85.  
  86.     ;; otherwise, keep looking through the DB
  87.     ( t ( respond sentence ( cdr db ) ) ) ) )
  88.  
  89. ;;----------------------------------------------------------------------------
  90. ;; match: if there is not a match between this pattern and this data,
  91. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  92. ;; format
  93.  
  94. ( defun match ( data pattern )
  95.   ( cond
  96.     ;; end of both data and pattern; a match
  97.     ( ( and ( null data ) ( null pattern ) ) nil )
  98.  
  99.     ;; end of pattern, but not end of data; no match
  100.     ( ( null pattern ) fail )
  101.  
  102.     ;; end of data, but not end of pattern; if the pattern starts with
  103.     ;; a variable, eat it and try and match the rest of the pattern to
  104.     ;; the null sentence (will only work if all variables); otherwise,
  105.     ;; fail
  106.     ( ( null data ) 
  107.       ( cond
  108. 	( ( variablep ( car pattern ) )
  109. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  110. 	      result
  111. 	    fail ) )
  112. 	( t fail ) ) )
  113.  
  114.  
  115.     ;; first item of data and pattern are identical; if the rest of it
  116.     ;; matched, return the first item cons'ed with the rest of the
  117.     ;; partitioned sentence; otherwise, fail
  118.     ( ( equal ( car data ) ( car pattern ) )
  119.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  120. 	  ( cons ( list ( car data ) ) result )
  121. 	fail ) )
  122.  
  123.     ;; first item of pattern is a variable; if the rest of the data
  124.     ;; (minus the first word, matched to the variable) is a match with
  125.     ;; all of the pattern, return the appropriate stuff; if all of the
  126.     ;; data (variable eats nothing) matches the rest of the pattern,
  127.     ;; return appropriate stuff; else, fail.
  128.     ( ( variablep ( car pattern ) ) 
  129.       ( cond
  130. 	;; variable eats nothing;  () is put in partitioned sentence
  131. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  132. 	  ( cons () result ) )
  133. 	;; variable eats one word; word is cons'ed into the first
  134. 	;; element of the partitioned sentence, assuming that the step
  135. 	;; before an actual match word would be a ()
  136. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  137. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  138. 	;; otherwise, fail
  139. 	( t fail ) ) )
  140.  
  141.     ( t fail ) ) )
  142.  
  143. ;;----------------------------------------------------------------------------
  144. ;; instantiate: takes a partitioned sentence and the response it has
  145. ;; been matched to and generates the appropriated completed response
  146.  
  147. ( defun instantiate ( partitioned response )
  148.   ( cond
  149.     ( ( null response ) nil )
  150.     ;; numbers indicate what part of the partitioned sentence to
  151.     ;; insert into the response
  152.     ( ( numberp ( car response ) )
  153.       ( setq index ( - ( car response ) 1 ) )
  154.       ( append ( nth index partitioned )
  155. 	     ( instantiate partitioned ( cdr response ) ) ) )
  156.     ( t ( cons ( car response )
  157. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  158.  
  159. ;;---------------------------------------------------------------------------
  160. ;;
  161. ;;  			     helping functions
  162. ;;
  163. ;;---------------------------------------------------------------------------
  164.  
  165. ( setq fail '-1 )
  166.  
  167. ( defun success ( result )
  168.   ( not ( equal result fail ) ) )
  169.  
  170. ( defun variablep ( word )
  171.   ( equal word '0 ) )
  172.  
  173.  
  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.      ((0 Goodbye 0)
  193.       (Ill see you later take it easy))
  194.      ((0 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.      ((0 See you later 0)
  199.       (Absolutely Till next time))
  200.      ((0 Ill see ya 0)
  201.       (Later))
  202.      ((0 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 happy 0)
  209.      ("How long have you been happy?"))
  210.     ((0 sad 0)
  211.      ("Why are you feeling sad?"))
  212.     ((0 stressed 0)
  213.      ("What is causing you stress?"))
  214.     ((0 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 dont think Im getting it)
  225.       (It sounds like you need to take a break do you agree)
  226.       (Thats an interesting point can you elaborate)
  227.       (How does that make you feel))
  228.     ))
  229.  
  230.  
  231.  
  232. (setq response (eliza '(input)))
  233. (print response)
Success #stdin #stdout #stderr 0.01s 9584KB
comments (?)
stdin
copy 


			

					
			
			

				
	
		
		
	
		
		 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
  0x14e7d9e00000 - 0x14e7da0e4fff
  0x14e7da215000 - 0x14e7da239fff
  0x14e7da23a000 - 0x14e7da3acfff
  0x14e7da3ad000 - 0x14e7da3f5fff
  0x14e7da3f6000 - 0x14e7da3f8fff
  0x14e7da3f9000 - 0x14e7da3fbfff
  0x14e7da3fc000 - 0x14e7da3fffff
  0x14e7da400000 - 0x14e7da402fff
  0x14e7da403000 - 0x14e7da601fff
  0x14e7da602000 - 0x14e7da602fff
  0x14e7da603000 - 0x14e7da603fff
  0x14e7da680000 - 0x14e7da68ffff
  0x14e7da690000 - 0x14e7da6c3fff
  0x14e7da6c4000 - 0x14e7da7fafff
  0x14e7da7fb000 - 0x14e7da7fbfff
  0x14e7da7fc000 - 0x14e7da7fefff
  0x14e7da7ff000 - 0x14e7da7fffff
  0x14e7da800000 - 0x14e7da803fff
  0x14e7da804000 - 0x14e7daa03fff
  0x14e7daa04000 - 0x14e7daa04fff
  0x14e7daa05000 - 0x14e7daa05fff
  0x14e7daa8a000 - 0x14e7daa8dfff
  0x14e7daa8e000 - 0x14e7daa8efff
  0x14e7daa8f000 - 0x14e7daa90fff
  0x14e7daa91000 - 0x14e7daa91fff
  0x14e7daa92000 - 0x14e7daa92fff
  0x14e7daa93000 - 0x14e7daa93fff
  0x14e7daa94000 - 0x14e7daaa1fff
  0x14e7daaa2000 - 0x14e7daaaffff
  0x14e7daab0000 - 0x14e7daabcfff
  0x14e7daabd000 - 0x14e7daac0fff
  0x14e7daac1000 - 0x14e7daac1fff
  0x14e7daac2000 - 0x14e7daac2fff
  0x14e7daac3000 - 0x14e7daac8fff
  0x14e7daac9000 - 0x14e7daacafff
  0x14e7daacb000 - 0x14e7daacbfff
  0x14e7daacc000 - 0x14e7daaccfff
  0x14e7daacd000 - 0x14e7daacdfff
  0x14e7daace000 - 0x14e7daafbfff
  0x14e7daafc000 - 0x14e7dab0afff
  0x14e7dab0b000 - 0x14e7dabb0fff
  0x14e7dabb1000 - 0x14e7dac47fff
  0x14e7dac48000 - 0x14e7dac48fff
  0x14e7dac49000 - 0x14e7dac49fff
  0x14e7dac4a000 - 0x14e7dac5dfff
  0x14e7dac5e000 - 0x14e7dac85fff
  0x14e7dac86000 - 0x14e7dac8ffff
  0x14e7dac90000 - 0x14e7dac91fff
  0x14e7dac92000 - 0x14e7dac97fff
  0x14e7dac98000 - 0x14e7dac9afff
  0x14e7dac9d000 - 0x14e7dac9dfff
  0x14e7dac9e000 - 0x14e7dac9efff
  0x14e7dac9f000 - 0x14e7dac9ffff
  0x14e7daca0000 - 0x14e7daca0fff
  0x14e7daca1000 - 0x14e7daca1fff
  0x14e7daca2000 - 0x14e7daca8fff
  0x14e7daca9000 - 0x14e7dacabfff
  0x14e7dacac000 - 0x14e7dacacfff
  0x14e7dacad000 - 0x14e7daccdfff
  0x14e7dacce000 - 0x14e7dacd5fff
  0x14e7dacd6000 - 0x14e7dacd6fff
  0x14e7dacd7000 - 0x14e7dacd7fff
  0x14e7dacd8000 - 0x14e7dacd8fff
  0x55ad39ab1000 - 0x55ad39ba1fff
  0x55ad39ba2000 - 0x55ad39cabfff
  0x55ad39cac000 - 0x55ad39d0bfff
  0x55ad39d0d000 - 0x55ad39d3bfff
  0x55ad39d3c000 - 0x55ad39d6cfff
  0x55ad39d6d000 - 0x55ad39d70fff
  0x55ad3aca3000 - 0x55ad3acc3fff
  0x7ffc37337000 - 0x7ffc37357fff
  0x7ffc3735c000 - 0x7ffc3735ffff
  0x7ffc37360000 - 0x7ffc37361fff


    

	
			

					
			
			
			
			
			
			
			
			

			
			
			
		

	
		
		

			

			                        







			
			

				

	
					
					 https://ideone.com/18ulPp
					
					
					
					
					

												

												
						
						

					

					
					
					

						
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!