fork download
copy 
  1. ;gnu clisp  2.49.60
  2.  
  3. ;;
  4. ;; STARTER FILE FOR CSC 4240/5240 PROGRAM #1: Eliza
  5. ;;==========================================================================
  6.  
  7. ;;----------------------------------------------------------------------------
  8. ;; eliza: top-level function which, when given a sentence (no
  9. ;; punctuation, please!), comes back with a response like you would.
  10.  
  11. ( defun eliza ( sentence )
  12.   ;(format t "Input type: ~a, value: ~a~%" (type-of sentence) sentence)
  13.   ( respond ( change-pros sentence ) database ) )
  14.  
  15. ;;----------------------------------------------------------------------------
  16. ;; change-pros: changes the pronouns of the sentence so that Eliza can
  17. ;; come back with the appropriately switched first and second person
  18. ;; references.
  19.  
  20. ( defun change-pros ( sentence )
  21.   ( cond 
  22.     ( ( null sentence ) nil )
  23.  
  24.     ( ( equal ( car sentence ) 'you )
  25.       ( cons 'I ( change-pros ( cdr sentence ) ) ) )
  26.     ( ( equal ( car sentence ) 'I )
  27.       ( cons 'you ( change-pros ( cdr sentence ) ) ) )
  28.  
  29.     ( ( equal ( car sentence ) 'am )
  30.       ( cons 'are ( change-pros ( cdr sentence ) ) ) )
  31.  
  32.     ( ( equal ( car sentence ) 'my )
  33.       ( cons 'your ( change-pros ( cdr sentence ) ) ) )
  34.     ( ( equal ( car sentence ) 'your )
  35.       ( cons 'my ( change-pros ( cdr sentence ) ) ) )
  36.  
  37.     ( ( equal ( car sentence ) 'mine )
  38.       ( cons 'yours ( change-pros ( cdr sentence ) ) ) )
  39.     ( ( equal ( car sentence ) 'yours )
  40.       ( cons 'mine ( change-pros ( cdr sentence ) ) ) )
  41.  
  42.     ( ( equal ( car sentence ) 'he )
  43.       ( cons 'him ( change-pros ( cdr sentence ) ) ) )
  44.     ( ( equal ( car sentence ) 'him )
  45.       ( cons 'he ( change-pros ( cdr sentence ) ) ) )
  46.  
  47.     ( ( equal ( car sentence ) 'she )
  48.       ( cons 'she ( change-pros ( cdr sentence ) ) ) )
  49.     ( ( equal ( car sentence ) 'her )
  50.       ( cons 'hers ( change-pros ( cdr sentence ) ) ) )
  51.     ( ( equal ( car sentence ) 'hers )
  52.       ( cons 'her ( change-pros ( cdr sentence ) ) ) )
  53.  
  54.     ( ( equal ( car sentence ) 'it )
  55.       ( cons 'it ( change-pros ( cdr sentence ) ) ) )
  56.  
  57.     ;; CHANGE THIS: add more cases here of pronouns or other words
  58.     ;; that should flip in order for this to work well
  59.  
  60.     ( t ( cons ( car sentence ) ( change-pros ( cdr sentence ) ) ) ) ) )
  61.  
  62. ;;----------------------------------------------------------------------------
  63. ( defun get-random-index ( len )
  64.  
  65.     ;; random-idx is the variable that will store the random index we will return to the caller function. Initially is = 0
  66.     (setq random-idx 0)
  67.  
  68.     ;; We keep iterating until we have a value for our index which does not equal to 0 (it will be > 0 and < len)
  69.     ;; We apply mod operation to get an index from 0 to (len - 1) to choose a response to return
  70.     (loop while (= random-idx 0) do
  71.  
  72.         ;; I thought of an easy way how to get a random value to act as our seed and the timestamp would work perfect for this case
  73.         ;; get current timestamp as if its our seed, and we are sure it is a dynamic value and it will always lead to random results
  74.         (setq modu (get-universal-time))
  75.  
  76.         ;; We apply the mod (remainder) operation to get an index that lies within the possible range: [1, len - 1] (inclusive)
  77. 	    (setq random-idx (mod modu len))
  78.     )
  79.  
  80.     ;; This is a safe-check. If for any reason the random index had value of 0, we return the first response we had
  81.     ;; since index 0 does not contain a response, it's just a placeholder for pattern-matching
  82.     (if (= random-idx 0)
  83.         (setq random-idx 1)
  84.         (princ ""))
  85.  
  86. 	;; We return the random index value we got to the caller function to use the response we have at our database at that index
  87. random-idx)
  88.  
  89.  
  90. ;; respond: given a sentence, looks through the database in search of
  91. ;; a matching pattern and the response; given the database response,
  92. ;; uses 'instantiate' to fill in the blanks, and returns the completed
  93. ;; response
  94.  
  95. ( defun respond ( sentence db )
  96.   ( cond
  97.     ;; end of DB, return nil - should never really happen
  98.     ( ( null db ) nil )
  99.  
  100.     ;; if the result of matching the sentence against the current
  101.     ;; pattern is a success, produce this response
  102.     ( 
  103.         ( success ( setq result ( match sentence ( first ( car db ) ) ) ) )
  104.  
  105.         (setq random-index (get-random-index (length (car db))))
  106.  
  107.         ( instantiate result ( nth random-index ( car db ) ) )
  108.     )
  109.  
  110.     ;; otherwise, keep looking through the DB
  111.     ( t ( respond sentence ( cdr db ) ) ) ) )
  112.  
  113. ;;----------------------------------------------------------------------------
  114. ;; match: if there is not a match between this pattern and this data,
  115. ;; returns 'fail;' otherwise, returns the sentence in partitioned
  116. ;; format
  117.  
  118. ( defun match ( data pattern )
  119.   ( cond
  120.     ;; end of both data and pattern; a match
  121.     ( ( and ( null data ) ( null pattern ) ) nil )
  122.  
  123.     ;; end of pattern, but not end of data; no match
  124.     ( ( null pattern ) fail )
  125.  
  126.     ;; end of data, but not end of pattern; if the pattern starts with
  127.     ;; a variable, eat it and try and match the rest of the pattern to
  128.     ;; the null sentence (will only work if all variables); otherwise,
  129.     ;; fail
  130.     ( ( null data ) 
  131.       ( cond
  132. 	( ( variablep ( car pattern ) )
  133. 	  ( if ( success ( setq result ( match data ( cdr pattern ) ) ) )
  134. 	      result
  135. 	    fail ) )
  136. 	( t fail ) ) )
  137.  
  138.  
  139.     ;; first item of data and pattern are identical; if the rest of it
  140.     ;; matched, return the first item cons'ed with the rest of the
  141.     ;; partitioned sentence; otherwise, fail
  142.     ( ( equal ( car data ) ( car pattern ) )
  143.       ( if ( success ( setq result ( match ( cdr data ) ( cdr pattern ) ) ) )
  144. 	  ( cons ( list ( car data ) ) result )
  145. 	fail ) )
  146.  
  147.     ;; first item of pattern is a variable; if the rest of the data
  148.     ;; (minus the first word, matched to the variable) is a match with
  149.     ;; all of the pattern, return the appropriate stuff; if all of the
  150.     ;; data (variable eats nothing) matches the rest of the pattern,
  151.     ;; return appropriate stuff; else, fail.
  152.     ( ( variablep ( car pattern ) ) 
  153.       ( cond
  154. 	;; variable eats nothing;  () is put in partitioned sentence
  155. 	( ( success ( setq result ( match data ( cdr pattern ) ) ) )
  156. 	  ( cons () result ) )
  157. 	;; variable eats one word; word is cons'ed into the first
  158. 	;; element of the partitioned sentence, assuming that the step
  159. 	;; before an actual match word would be a ()
  160. 	( ( success ( setq result ( match ( cdr data ) pattern ) ) )
  161. 	  ( cons ( cons ( car data ) ( car result ) ) ( cdr result ) ) )
  162. 	;; otherwise, fail
  163. 	( t fail ) ) )
  164.  
  165.     ( t fail ) ) )
  166.  
  167. ;;----------------------------------------------------------------------------
  168. ;; instantiate: takes a partitioned sentence and the response it has
  169. ;; been matched to and generates the appropriated completed response
  170.  
  171. ( defun instantiate ( partitioned response )
  172.   ( cond
  173.     ( ( null response ) nil )
  174.     ;; numbers indicate what part of the partitioned sentence to
  175.     ;; insert into the response
  176.     ( ( numberp ( car response ) )
  177.       ( setq index ( - ( car response ) 1 ) )
  178.       ( append ( nth index partitioned )
  179. 	     ( instantiate partitioned ( cdr response ) ) ) )
  180.     ( t ( cons ( car response )
  181. 	     ( instantiate partitioned ( cdr response ) ) ) ) ) )
  182.  
  183. ;;---------------------------------------------------------------------------
  184. ;;
  185. ;;  			     helping functions
  186. ;;
  187. ;;---------------------------------------------------------------------------
  188.  
  189. ( setq fail '-1 )
  190.  
  191. ( defun success ( result )
  192.   ( not ( equal result fail ) ) )
  193.  
  194. ( defun variablep ( word )
  195.   ( equal word '0 ) )
  196.  
  197.  
  198. ;;---------------------------------------------------------------------------
  199. ;;
  200. ;;  			         database
  201. ;;
  202. ;;---------------------------------------------------------------------------
  203.  
  204. ;; CHANGE THIS: add more to this database so that the interaction is
  205. ;; more interesting and communicative and so that Eliza sounds like you 
  206. ;; would sound in the same conversation!
  207. ;;---------------------------------------------------------------------------
  208.  
  209. ;; Here I show the extra rules I added to the previous rules we already had at the starter file.
  210. ;; I tried adding different rules covering different cases, scenarios, and different emotions.
  211. ;; For the generic response, I added multiple ones in order to have multiple random ones that can be used needed
  212.  
  213. ( setq database
  214.     '(
  215.         ;; example greetings/farewells -- change them to sound like you
  216.         (
  217.         (Hello 0)
  218.         ("Hello - have a seat and tell me how you feel today.") 
  219.         )
  220.  
  221.         ( (0 Goodbye 0)
  222.         ("Goodbye - I hope you enjoyed this session.") )
  223.  
  224.         ( (0 You came here because 0)
  225.         (A lot of people come here for that reason so you are not alone.) )
  226.  
  227.         ;; normal open questions
  228.         ((0 your day 0)
  229.         ("Great! I would love to hear that, tell me how was your day?")
  230.         )
  231.  
  232.         ;; personal information about favourite things
  233.         (
  234.           (0 my favourite team won 0)
  235.           ("I'm glad to hear that! Tell me how's your health?" )
  236.         )
  237.  
  238.         ;; feelings
  239.         ( (0 you think 0)
  240.         (And just why do you think 4 ? ) )
  241.  
  242.         ( (0 you are happy 0) 
  243.         (That's wonderful! What’s making you happy today? ) )
  244.  
  245.         (
  246.           (0 you feel joyful 0)
  247.           ("I'm glad to hear that! Tell me more what makes you feel joyful?" )
  248.         )
  249.  
  250.         ((0 feel excited 0)
  251.         ("I'm glad to hear that! Tell me more what makes you feel excited?")
  252.         )
  253.  
  254.  
  255.         ((0 too much work 0)
  256.           ("Try getting some rest please, maybe get tomorrow as vacation")
  257.         )
  258.  
  259.         ((0 go to the gym 0)
  260.         ("Oh that is great! This is really very important to maintain a good health.")
  261.         )
  262.  
  263.         ((0 feel tired 0)
  264.           ("Sad to hear that. What happened?")
  265.         )
  266.  
  267.         ((0 you feel sad 0) 
  268.         ("I'm sorry to hear that. Why do you think you are sad?" 
  269.           "Tell me more about what’s troubling you."))
  270.  
  271.         ((0 you are angry 0)
  272.         ("Why do you think you’re feeling so angry?" )
  273.         )
  274.  
  275.         ;; recognize certain keywords and respond
  276.         ((0 try rescheduling 0)
  277.           ("That would be great! I hope you find another appointement soon")
  278.         )
  279.  
  280.         ((0 you are late 0)
  281.           ("It is never too late. Try to catch up.")
  282.         )
  283.  
  284.         ((0 laptop not working 0)
  285.           ("It is frustrating to hear that.. do you have a backup of your data?")
  286.         )
  287.  
  288.         ;; actions/acts
  289.         ((0 password 0)
  290.           ("You can reset your password if you forgot it")
  291.         )
  292.  
  293.         ((0 got lost 0)
  294.           ("Try calling 911 or go to nearest police station! Take care!")
  295.         )
  296.  
  297.         ((0 have breakfast 0)
  298.         ("Bon appétit! What will you eat?")
  299.         )
  300.  
  301.         ((0 will eat 0)
  302.         ("I do not know this food. What is it about?")
  303.         )
  304.  
  305.         ((0 have lunch 0)
  306.         ("Bon appétit! What will you eat?")
  307.         )
  308.  
  309.         ((0 have dinner 0)
  310.         ("Bon appétit! What will you eat?")
  311.         )
  312.  
  313.         ((0 delicious food 0)
  314.         ("Aha! That sounds tasty, enjoy your meal!")
  315.         )
  316.  
  317.         ((0 missed your appointment 0)
  318.         ("Uhh.. Can you try rescheduling it?")
  319.         )
  320.  
  321.         ((0 information 0)
  322.         ("Thanks for the new information. Glad that you feel happy. So how is everything else?")
  323.         )
  324.  
  325.         ;; the catch-alls
  326.         (
  327.           (0) 
  328.           ("Could you expand on that?")
  329.           ("Hmmm.. Is it possible to elaborate more on that please?")
  330.           ("Hmmm.. I feel I didn't get what you mean. Can you explain again in other terms?")
  331.           ("Uhh.. I fear I don't understand what are you talking about..")
  332.           ("Ops, didn't get it, please expand on that.")
  333.           ("Sorry, I could not understand that. Can you elaborate more?")
  334.         )
  335.     )
  336. )
  337.  
  338. (princ (eliza '(Thank you! That is true. So I will go now. Bye)))
  339.  
Success #stdin #stdout #stderr 0.69s 9700KB
comments (?)
stdin
copy 
Standard input is empty
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
  0x14e42b600000 - 0x14e42b8e4fff
  0x14e42ba00000 - 0x14e42ba02fff
  0x14e42ba03000 - 0x14e42bc01fff
  0x14e42bc02000 - 0x14e42bc02fff
  0x14e42bc03000 - 0x14e42bc03fff
  0x14e42bc15000 - 0x14e42bc39fff
  0x14e42bc3a000 - 0x14e42bdacfff
  0x14e42bdad000 - 0x14e42bdf5fff
  0x14e42bdf6000 - 0x14e42bdf8fff
  0x14e42bdf9000 - 0x14e42bdfbfff
  0x14e42bdfc000 - 0x14e42bdfffff
  0x14e42be00000 - 0x14e42be03fff
  0x14e42be04000 - 0x14e42c003fff
  0x14e42c004000 - 0x14e42c004fff
  0x14e42c005000 - 0x14e42c005fff
  0x14e42c063000 - 0x14e42c064fff
  0x14e42c065000 - 0x14e42c074fff
  0x14e42c075000 - 0x14e42c0a8fff
  0x14e42c0a9000 - 0x14e42c1dffff
  0x14e42c1e0000 - 0x14e42c1e0fff
  0x14e42c1e1000 - 0x14e42c1e3fff
  0x14e42c1e4000 - 0x14e42c1e4fff
  0x14e42c1e5000 - 0x14e42c1e6fff
  0x14e42c1e7000 - 0x14e42c1e7fff
  0x14e42c1e8000 - 0x14e42c1e9fff
  0x14e42c1ea000 - 0x14e42c1eafff
  0x14e42c1eb000 - 0x14e42c1ebfff
  0x14e42c1ec000 - 0x14e42c1ecfff
  0x14e42c1ed000 - 0x14e42c1fafff
  0x14e42c1fb000 - 0x14e42c208fff
  0x14e42c209000 - 0x14e42c215fff
  0x14e42c216000 - 0x14e42c219fff
  0x14e42c21a000 - 0x14e42c21afff
  0x14e42c21b000 - 0x14e42c21bfff
  0x14e42c21c000 - 0x14e42c221fff
  0x14e42c222000 - 0x14e42c223fff
  0x14e42c224000 - 0x14e42c224fff
  0x14e42c225000 - 0x14e42c225fff
  0x14e42c226000 - 0x14e42c226fff
  0x14e42c227000 - 0x14e42c254fff
  0x14e42c255000 - 0x14e42c263fff
  0x14e42c264000 - 0x14e42c309fff
  0x14e42c30a000 - 0x14e42c3a0fff
  0x14e42c3a1000 - 0x14e42c3a1fff
  0x14e42c3a2000 - 0x14e42c3a2fff
  0x14e42c3a3000 - 0x14e42c3b6fff
  0x14e42c3b7000 - 0x14e42c3defff
  0x14e42c3df000 - 0x14e42c3e8fff
  0x14e42c3e9000 - 0x14e42c3eafff
  0x14e42c3eb000 - 0x14e42c3f0fff
  0x14e42c3f1000 - 0x14e42c3f3fff
  0x14e42c3f6000 - 0x14e42c3f6fff
  0x14e42c3f7000 - 0x14e42c3f7fff
  0x14e42c3f8000 - 0x14e42c3f8fff
  0x14e42c3f9000 - 0x14e42c3f9fff
  0x14e42c3fa000 - 0x14e42c3fafff
  0x14e42c3fb000 - 0x14e42c401fff
  0x14e42c402000 - 0x14e42c404fff
  0x14e42c405000 - 0x14e42c405fff
  0x14e42c406000 - 0x14e42c426fff
  0x14e42c427000 - 0x14e42c42efff
  0x14e42c42f000 - 0x14e42c42ffff
  0x14e42c430000 - 0x14e42c430fff
  0x14e42c431000 - 0x14e42c431fff
  0x560ace3a4000 - 0x560ace494fff
  0x560ace495000 - 0x560ace59efff
  0x560ace59f000 - 0x560ace5fefff
  0x560ace600000 - 0x560ace62efff
  0x560ace62f000 - 0x560ace65ffff
  0x560ace660000 - 0x560ace663fff
  0x560ad015d000 - 0x560ad017dfff
  0x7ffe1958f000 - 0x7ffe195affff
  0x7ffe195de000 - 0x7ffe195e1fff
  0x7ffe195e2000 - 0x7ffe195e3fff
https://ideone.com/LZEh5h
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!