A simple version of Eliza

Arjen Markus The program "Eliza" is famous as an example of artificial intelligence, even though there is nothing particularly intelligent about the program itself. The idea is brilliant: the program can be described as emulating "a non-reactive psychiatrist, that is, a person who never answered any of your questions, but merely turned the answers back upon you." (quote from B. Allan, "Introducing LOGO").

I implemented a simple version with just a few phrases and keywords, relying on the sample code in the above book. To be run using tclsh (not wish!).

The educational aspects:

It is easy to extend with different phrases
It can be simplified, because now you can have multiple replies to the same keyword
It shows how to work with lists
It shows how to "massage" the input from the user via [regsub]

Here is a link to what seems the original publication [1]

(Mental note: This can be the basis for a different kind of game - one that explores the possibilities of state machines. The metaphor I used is "tamagotchi", but it would be a creature with various moods and needs that talks to the user)

TV (jun 2 03) Excellent program idea, I didn't know it comes from such early computer days, I knew it from the trs80. I'm sure it is not all that can be done with tcl, but I thought I'd first let Recursing Eliza happen, and then do a multiple personality leading game in bwise, by having separate state elizas do supervized talking in various network configurations... Maybe after that a distributed version.

 # eliza.tcl --
 #    A very basic implementation of the famous Eliza program
 #    (Idea copied from the book Introducing LOGO by Boris Allan)
 #

 namespace eval ::Talk {
    variable keywords [list]
    variable phrases  [list]
    variable dummies  [list]
 }

 # response --
 #    Link a response to a keyword (group multiple responses to
 #    the same keyword)
 #
 # Arguments:
 #    keyword   Keyword to respond to
 #    phrase    The phrase to print
 # Result:
 #    None
 # Side effects:
 #    Update of the lists keywords and phrases
 #
 proc ::Talk::response { keyword phrase } {
    variable keywords
    variable phrases

    set keyword [string tolower $keyword]
    set idx [lsearch $keywords $keyword]

    #
    # The keyword is new, then add it.
    # Otherwise only extend the list of responses
    #
    if { $idx == -1 } {
       lappend keywords $keyword
       lappend phrases  [list $phrase]
    } else {
       set prev_phrases [lindex $phrases $idx]
       set new_phrases  [concat $prev_phrases [list $phrase]]
       set phrases      [lreplace $phrases $idx $idx $new_phrases]
       puts $phrases
    }
 }

 # dummy --
 #    Register dummy phrases (used when no response is suitable)
 #
 # Arguments:
 #    phrase    The phrase to print
 # Result:
 #    None
 # Side effects:
 #    Update of the list dummies
 #
 proc ::Talk::dummy { phrase } {
    variable dummies

    lappend dummies $phrase
 }

 # replyto --
 #    Reply to the user (based on the given phrase)
 #
 # Arguments:
 #    phrase    The phrase the user typed in
 # Result:
 #    None
 # Side effects:
 #    Update of the lists keywords and phrases
 #
 proc ::Talk::replyto { phrase } {
    variable keywords
    variable phrases
    variable dummies

    regsub -all {[^A-Za-z]} $phrase " " phrase
    set idx    -1
    set phrase [string tolower $phrase]
    foreach word $phrase {
       set idx [lsearch $keywords $word]
       if { $idx > -1 } {
          set responses [lindex $phrases $idx]
          set which     [expr {int([llength $responses]*rand())}]
          set answer    [lindex $responses $which]
          break
       }
    }
    if { $idx == -1 } {
       set which     [expr {int([llength $dummies]*rand())}]
       set answer    [lindex $dummies $which]
    }

    puts $answer
 }

 # main code --
 #    Get the script going:
 #    - Create a little database of responses
 #    - Start the question-answer loop
 #
 ::Talk::response computer  "Are you worried about machines?"
 ::Talk::response Death  "Is this worry you?"
 ::Talk::response computers "We are intelligent!"
 ::Talk::response program   "I just love Tcl - I was written in it"
 ::Talk::response off       "No, sorry"
 ::Talk::response no        "Tell me, why not?"
 ::Talk::response life      "Life - do not talk to me about life!"
 ::Talk::response you       "We are considering you, not me"
 ::Talk::response I         "Do you often talk about yourself?"
 ::Talk::response I         "Do you like talking about yourself?"
 ::Talk::dummy    "So ... ?"
 ::Talk::dummy    "Shall we continue?"
 ::Talk::dummy    "What do you want to talk about?"
 ::Talk::dummy    "Anything specific?"
 ::Talk::dummy    "Talk about something more interesting?"
 #
 # First version, simple and straightforward
 #
 set version 2
 if { $version == 1 } {
    puts "What is your problem? (End this conversation with: QUIT)"
    while { 1 } {
       gets stdin line
       if { $line == "QUIT" } {
          break
       } else {
          ::Talk::replyto $line
       }
    }
 }

 #
 # Second version, more complicated but with a modern twist :)
 #
 if { $version == 2 } {
    proc oneline {} {
       global responsive
       global forever
       if { $responsive == 1 } {
          gets stdin line
          if { $line == "QUIT" } {
             set forever 1
             break
          } else {
             ::Talk::replyto $line
             after 0 oneline
          }
       } else {
          after 1000 oneline
       }
    }
    proc phonecall {} {
       global responsive
       puts "Trrriiiing!"
       set responsive 0
       after  300 {puts "Damn"}
       after  600 {puts "Excuse me"}
       after 2600 {puts "Hm ...? At the office!"}
       after 4600 {puts "Yes"}
       after 5600 {puts "No"}
       after 6000 {puts "Eh, ..., no"}
       after 8000 {puts "Okay, bye"}
       after 8100 {puts "\nNow, where were we?"}
       after 8250 {set responsive 1}
    }

    puts "What is your problem? (End this conversation with: QUIT)"
    set responsive 1
    after [expr {int((10+10*rand())*1000)}] phonecall
    after 0 oneline

    vwait forever
 }