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.   ;(format t "Input type: ~a, value: ~a~%" (type-of sentence) sentence)
  12.   ( respond ( change-pros sentence ) database ) )
  13.  
  14. ;;----------------------------------------------------------------------------
  15. ;; change-pros: changes the pronouns of the sentence so that Eliza can
  16. ;; come back with the appropriately switched first and second person
  17. ;; references.
  18.  
  19. ( defun change-pros ( sentence )
  20.   ( cond 
  21.     ( ( null sentence ) nil )
  22.  
  23.     ( ( equal ( car sentence ) 'you )
  24.       ( cons 'I ( change-pros ( cdr sentence ) ) ) )
  25.     ( ( equal ( car sentence ) 'I )
  26.       ( cons 'you ( change-pros ( cdr sentence ) ) ) )
  27.  
  28.     ( ( equal ( car sentence ) 'my )
  29.       ( cons 'your ( change-pros ( cdr sentence ) ) ) )
  30.     ( ( equal ( car sentence ) 'your )
  31.       ( cons 'my ( change-pros ( cdr sentence ) ) ) )
  32.  
  33.     ( ( equal ( car sentence ) 'mine )
  34.       ( cons 'yours ( change-pros ( cdr sentence ) ) ) )
  35.     ( ( equal ( car sentence ) 'yours )
  36.       ( cons 'mine ( change-pros ( cdr sentence ) ) ) )
  37.  
  38.     ( ( equal ( car sentence ) 'he )
  39.       ( cons 'him ( change-pros ( cdr sentence ) ) ) )
  40.     ( ( equal ( car sentence ) 'him )
  41.       ( cons 'he ( change-pros ( cdr sentence ) ) ) )
  42.  
  43.     ( ( equal ( car sentence ) 'she )
  44.       ( cons 'she ( change-pros ( cdr sentence ) ) ) )
  45.     ( ( equal ( car sentence ) 'her )
  46.       ( cons 'hers ( change-pros ( cdr sentence ) ) ) )
  47.     ( ( equal ( car sentence ) 'hers )
  48.       ( cons 'her ( change-pros ( cdr sentence ) ) ) )
  49.  
  50.     ( ( equal ( car sentence ) 'it )
  51.       ( cons 'it ( change-pros ( cdr sentence ) ) ) )
  52.  
  53.     ;; CHANGE THIS: add more cases here of pronouns or other words
  54.     ;; that should flip in order for this to work well
  55.  
  56.     ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  57.  
  58. ;;----------------------------------------------------------------------------
  59. ;; respond: given a sentence, looks through the database in search of
  60. ;; a matching pattern and the response; given the database response,
  61. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  62. ;; response
  63.  
  64. ( defun respond ( sentence db )
  65.   ( cond
  66.     ;; end of DB, return nil - should never really happen
  67.     ( ( null db ) nil )
  68.  
  69.     ;; if the result of matching the sentence against the current
  70.     ;; pattern is a success, produce this response
  71.     ( 
  72.         ( success ( setq result ( match sentence ( first ( car db ) ) ) ) )
  73.  
  74.         (setf *random-state* (make-random-state t))
  75.  
  76.         (setq idx ( length (car db) ))
  77.         (setq rndm ( random idx ))
  78.  
  79.         (if (= rndm 0)
  80.           (setq rndm 1)
  81.           (princ ""))
  82.  
  83.         ; (princ rndm)
  84.         ; (princ #\Newline) 
  85.         ( instantiate result ( nth rndm ( car db ) ) )
  86.     )
  87.  
  88.     ;; otherwise, keep looking through the DB
  89.     ( t ( respond sentence ( cdr db ) ) ) ) )
  90.  
  91. ;;----------------------------------------------------------------------------
  92. ;; match: if there is not a match between this pattern and this data,
  93. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  94. ;; format
  95.  
  96. ( defun match ( data pattern )
  97.   ( cond
  98.     ;; end of both data and pattern; a match
  99.     ( ( and ( null data ) ( null pattern ) ) nil )
  100.  
  101.     ;; end of pattern, but not end of data; no match
  102.     ( ( null pattern ) fail )
  103.  
  104.     ;; end of data, but not end of pattern; if the pattern starts with
  105.     ;; a variable, eat it and try and match the rest of the pattern to
  106.     ;; the null sentence (will only work if all variables); otherwise,
  107.     ;; fail
  108.     ( ( null data ) 
  109.       ( cond
  110. 	( ( variablep ( car pattern ) )
  111. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  112. 	      result
  113. 	    fail ) )
  114. 	( t fail ) ) )
  115.  
  116.  
  117.     ;; first item of data and pattern are identical; if the rest of it
  118.     ;; matched, return the first item cons'ed with the rest of the
  119.     ;; partitioned sentence; otherwise, fail
  120.     ( ( equal ( car data ) ( car pattern ) )
  121.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  122. 	  ( cons ( list ( car data ) ) result )
  123. 	fail ) )
  124.  
  125.     ;; first item of pattern is a variable; if the rest of the data
  126.     ;; (minus the first word, matched to the variable) is a match with
  127.     ;; all of the pattern, return the appropriate stuff; if all of the
  128.     ;; data (variable eats nothing) matches the rest of the pattern,
  129.     ;; return appropriate stuff; else, fail.
  130.     ( ( variablep ( car pattern ) ) 
  131.       ( cond
  132. 	;; variable eats nothing;  () is put in partitioned sentence
  133. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  134. 	  ( cons () result ) )
  135. 	;; variable eats one word; word is cons'ed into the first
  136. 	;; element of the partitioned sentence, assuming that the step
  137. 	;; before an actual match word would be a ()
  138. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  139. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  140. 	;; otherwise, fail
  141. 	( t fail ) ) )
  142.  
  143.     ( t fail ) ) )
  144.  
  145. ;;----------------------------------------------------------------------------
  146. ;; instantiate: takes a partitioned sentence and the response it has
  147. ;; been matched to and generates the appropriated completed response
  148.  
  149. ( defun instantiate ( partitioned response )
  150.   ( cond
  151.     ( ( null response ) nil )
  152.     ;; numbers indicate what part of the partitioned sentence to
  153.     ;; insert into the response
  154.     ( ( numberp ( car response ) )
  155.       ( setq index ( - ( car response ) 1 ) )
  156.       ( append ( nth index partitioned )
  157. 	     ( instantiate partitioned ( cdr response ) ) ) )
  158.     ( t ( cons ( car response )
  159. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  160.  
  161. ;;---------------------------------------------------------------------------
  162. ;;
  163. ;;  			     helping functions
  164. ;;
  165. ;;---------------------------------------------------------------------------
  166.  
  167. ( setq fail '-1 )
  168.  
  169. ( defun success ( result )
  170.   ( not ( equal result fail ) ) )
  171.  
  172. ( defun variablep ( word )
  173.   ( equal word '0 ) )
  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.  
  191.         (
  192.         (Hello 0)
  193.         (Hello - have a seat and tell me how you feel today.) 
  194.         )
  195.  
  196.         ( (0 You came here because 0)
  197.         (A lot of people come here for that reason so you are not alone.) )
  198.  
  199.         ((0 your day 0)
  200.         ("Great! I would love to hear that, tell me how was your day?")
  201.         )
  202.  
  203.         ( (0 Goodbye 0)
  204.         (Goodbye - I hope you enjoyed this session.) )
  205.  
  206.         ;; feelings
  207.         ( (0 you think 0)
  208.         (And just why do you think 4 ? ) )
  209.  
  210.         ( (0 you are happy 0) 
  211.         (That's wonderful! What’s making you happy today? ) )
  212.  
  213.         (
  214.           (0 you feel joyful 0)
  215.           ("I'm glad to hear that! Tell me more what makes you feel joyful?" )
  216.         )
  217.  
  218.         ((0 you are excited 0)
  219.         (
  220.           "I'm glad to hear that! Tell me more what makes you feel excited?" 
  221.         ))
  222.  
  223.         ((0 password 0)
  224.           "You can reset your password if you forgot it"
  225.         )
  226.  
  227.         ((0 got lost 0)
  228.           "Try calling 911 or go to nearest police station! Take care!"
  229.         )
  230.  
  231.         ((0 missed your appointment 0)
  232.           "I know how it feels, but can you try rescheduling it?"
  233.         )
  234.  
  235.         ((0 laptop not working 0)
  236.           "It is frustrating to hear that.. do you have a backup of your data?"
  237.         )
  238.  
  239.         ((0 too much work 0)
  240.           "Try getting some rest please"
  241.         )
  242.  
  243.         ((0 feel tired 0)
  244.           "Why do you feel tired?"
  245.         )
  246.  
  247.         ((0 you feel sad 0) 
  248.         ("I'm sorry to hear that. Why do you think you are sad?" 
  249.           "What’s making you feel sad?" 
  250.           "Tell me more about what’s troubling you."))
  251.  
  252.         ((0 you are angry 0)
  253.         ("I see. What made you feel this way?" 
  254.           "Why do you think you’re feeling so angry?" 
  255.           "Can you tell me more about what’s making you angry?"))
  256.  
  257.         ;; the catch-alls
  258.         (
  259.           (0) 
  260.           (Could you expand on that?)
  261.           ("Hmmm.. Is it possible to elaborate more on that please?")
  262.           ("Hmmm.. I feel I didn't get what you mean. Can you explain again in other terms?")
  263.           ("Uhh.. I fear I don't understand what are you talking about..")
  264.           ("Ops, didn't get it, please expand on that.")
  265.  
  266.         )
  267.     )
  268. )
  269. (setq my-string (read-line))
  270. (defun custom-split-string (str)
  271.   "Splits a string into a list of words using spaces as separators."
  272.   (let ((start 0)
  273.         (words '()))
  274.     (loop for i from 0 to (length str)
  275.           do (when (or (= i (length str)) (char= (char str i) #\Space))
  276.                (push (subseq str start i) words)
  277.                (setf start (1+ i))))
  278.     (nreverse words)))  ;; Return the list of words in the correct order
  279.  
  280. (defun string-to-cons-list (str)
  281.   "Converts a string into a list of symbols (CONS)."
  282.   (mapcar #'(lambda (word) (intern (string-upcase word)))
  283.           (custom-split-string str)))
  284. (let ((converted-input (string-to-cons-list my-string)))
  285.   (princ (eliza converted-input)))
  286.  
  287.  
  288. ; (princ (eliza '(I feel joyful))
  289.  
  290. ; (dotimes (i 4)  ; Loop 10 times with `i` from 0 to 9
  291.  
  292. ; 	(setq inn (read-line))  ;; Define `inn` as a string
  293. ; 	; (let ((inn (read-line)))
  294. ; 	(princ inn)
  295. ; 	(princ #\Newline)
  296. ; 	(princ (type-of inn))
  297. ; 	(princ #\Newline)
  298. ; 	;; Convert `inn` to a list containing a single symbol
  299. ; 	(setq inn-list (list (intern (string-upcase inn))))  ;; Creates a list: (HELLO)
  300. ; 	(princ (eliza inn-list))  ;; Call `eliza` with `inn-list`
  301. ; 	(princ #\Newline) 
  302. ; )
  303.  
Success #stdin #stdout #stderr 0.02s 9624KB
comments (?)
stdin
copy 
I feel joyful
Hello
a
b
stdout
copy 
(I'm glad to hear that! Tell me more what makes you feel joyful?)
stderr
copy 
Warning: reserving address range 0x80000c0000...0x1fffffffffff that contains memory mappings. clisp might crash later!
Memory dump:
  0x8000000000 - 0x80000bffff
  0x149fd5800000 - 0x149fd5ae4fff
  0x149fd5c15000 - 0x149fd5c39fff
  0x149fd5c3a000 - 0x149fd5dacfff
  0x149fd5dad000 - 0x149fd5df5fff
  0x149fd5df6000 - 0x149fd5df8fff
  0x149fd5df9000 - 0x149fd5dfbfff
  0x149fd5dfc000 - 0x149fd5dfffff
  0x149fd5e00000 - 0x149fd5e02fff
  0x149fd5e03000 - 0x149fd6001fff
  0x149fd6002000 - 0x149fd6002fff
  0x149fd6003000 - 0x149fd6003fff
  0x149fd6080000 - 0x149fd608ffff
  0x149fd6090000 - 0x149fd60c3fff
  0x149fd60c4000 - 0x149fd61fafff
  0x149fd61fb000 - 0x149fd61fbfff
  0x149fd61fc000 - 0x149fd61fefff
  0x149fd61ff000 - 0x149fd61fffff
  0x149fd6200000 - 0x149fd6203fff
  0x149fd6204000 - 0x149fd6403fff
  0x149fd6404000 - 0x149fd6404fff
  0x149fd6405000 - 0x149fd6405fff
  0x149fd646c000 - 0x149fd646ffff
  0x149fd6470000 - 0x149fd6470fff
  0x149fd6471000 - 0x149fd6472fff
  0x149fd6473000 - 0x149fd6473fff
  0x149fd6474000 - 0x149fd6474fff
  0x149fd6475000 - 0x149fd6475fff
  0x149fd6476000 - 0x149fd6483fff
  0x149fd6484000 - 0x149fd6491fff
  0x149fd6492000 - 0x149fd649efff
  0x149fd649f000 - 0x149fd64a2fff
  0x149fd64a3000 - 0x149fd64a3fff
  0x149fd64a4000 - 0x149fd64a4fff
  0x149fd64a5000 - 0x149fd64aafff
  0x149fd64ab000 - 0x149fd64acfff
  0x149fd64ad000 - 0x149fd64adfff
  0x149fd64ae000 - 0x149fd64aefff
  0x149fd64af000 - 0x149fd64affff
  0x149fd64b0000 - 0x149fd64ddfff
  0x149fd64de000 - 0x149fd64ecfff
  0x149fd64ed000 - 0x149fd6592fff
  0x149fd6593000 - 0x149fd6629fff
  0x149fd662a000 - 0x149fd662afff
  0x149fd662b000 - 0x149fd662bfff
  0x149fd662c000 - 0x149fd663ffff
  0x149fd6640000 - 0x149fd6667fff
  0x149fd6668000 - 0x149fd6671fff
  0x149fd6672000 - 0x149fd6673fff
  0x149fd6674000 - 0x149fd6679fff
  0x149fd667a000 - 0x149fd667cfff
  0x149fd667f000 - 0x149fd667ffff
  0x149fd6680000 - 0x149fd6680fff
  0x149fd6681000 - 0x149fd6681fff
  0x149fd6682000 - 0x149fd6682fff
  0x149fd6683000 - 0x149fd6683fff
  0x149fd6684000 - 0x149fd668afff
  0x149fd668b000 - 0x149fd668dfff
  0x149fd668e000 - 0x149fd668efff
  0x149fd668f000 - 0x149fd66affff
  0x149fd66b0000 - 0x149fd66b7fff
  0x149fd66b8000 - 0x149fd66b8fff
  0x149fd66b9000 - 0x149fd66b9fff
  0x149fd66ba000 - 0x149fd66bafff
  0x563a7947f000 - 0x563a7956ffff
  0x563a79570000 - 0x563a79679fff
  0x563a7967a000 - 0x563a796d9fff
  0x563a796db000 - 0x563a79709fff
  0x563a7970a000 - 0x563a7973afff
  0x563a7973b000 - 0x563a7973efff
  0x563a7ae2c000 - 0x563a7ae4cfff
  0x7ffeea28a000 - 0x7ffeea2aafff
  0x7ffeea390000 - 0x7ffeea393fff
  0x7ffeea394000 - 0x7ffeea395fff
https://ideone.com/ZA0pAr
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!