if 0 {[Richard Suchenwirth] 2004-03-08 - In the "software museum",  today I
play with the Semantic Information Retriever SIR (Raphael, 1964), a software that
takes natural-language sentences (a very restricted subset of English) to build
a relational knowledge base, or answer questions about it. The following Tcl
implementation is even weaker than the original from 40 years ago, but then
again it is only a little weekend fun project... and re-plays the sample dialog 
with SIR as seen in the literature:
   * populate the knowledge base with some facts
   * ask questions
   * SIR will ask back if facts are missing in its chain of reasoning}

 proc Sir, args {
    set sentence [join $args]
    if [regexp {^what is( an?)? (\w+)} $sentence -> . item] {
       return [isa $item ?]
    }
    if [regexp {^is( an?)? (\w+) a (\w+)} $sentence -> . item cat] {
       return [isa? $item $cat]
    }
    if [regexp {^(\w+) is a (\w+)} $sentence -> item cat] {
       return [isa $item $cat]
    }
    if [regexp {^every (\w+) is a (\w+)} $sentence -> item cat] {
       return [isa $item $cat]
    }
    if [regexp {^(any|every) (\w+) has (\d+) (\w+)s} $sentence -> . cat n item] {
       return [has $item $n $cat]
    }
    if [regexp {^an? (\w+) is part of an? (\w+)} $sentence -> part cat] {
       return [has $part * $cat]
    }
    if [regexp {^how many (\w+)s are on (\w+)} $sentence -> part cat] {
       return [has $part ? $cat]
    }
    error "don't understand '$sentence'"
 }
#-- Routines for adding to, or querying, the knowledge base (::K)
 proc isa {item cat} {
    if {$cat eq "?"} {
       whats $item
    } else {
       ladd ::K($item,isa) $cat
       ladd ::K($cat,eg) $item
    }
 }
 proc isa? {item cat} {
    if [info exists ::K($item,isa)] {
        foreach subcat $::K($item,isa) {
            if {$subcat eq $cat} {return yes}
            if {[isa? $subcat $cat] eq "yes"} {return yes}
        }
    }
    return no
 }
 proc has {item n cat} {
    if {$n eq "?"} {
       howmany $item $cat
    } else {
       set ::K($cat,has,$item) $n
       ladd ::K($item,ispartof) $cat
    }
 }
 proc howmany {item cat} {
    if [info exists ::K($cat,has,$item)] {
       set n $::K($cat,has,$item)
       if {$n eq "*"} {
          ask-n $item $cat
          return [howmany $item $cat]
       } else {return $n}
    } else {
       if [info  exists ::K($cat,isa)] {
          foreach subcat $::K($cat,isa) {
             set n [howmany $item $subcat]
             if [numeric $n] {return $n}
          }
       }
       foreach fact [array names ::K $cat,has,*] {
          regexp $cat,has,(.+) $fact -> part
          set n $::K($fact)
          set n2 [howmany $item $part]
          if [numeric $n2] {return [expr $n*$n2]}
       }
    }
    return "can't tell"
 }
 proc ask-n {item cat} {
    puts "How many ${item}s per $cat?"
    eval Sir, [gets stdin]
 }
 proc whats what {
    if [info exists ::K($what,isa)] {
       set cats $::K($what,isa)
       foreach i $cats {
          if [info exists ::K($i,isa)] {append cats " " $::K($i,isa)}
       }
       return "$what is a [join $cats {, a }]"
    } elseif [info exists ::K($what,eg)] {
       return "A $what is a [join $::K($what,eg) {, or a }]"
    } else {return "don't know"}
 }
#---- General utilities:
 proc ladd {listvar element} {
    upvar 1 $listvar list
    if ![info exists list] {set list {}}
    if {[lsearch $list $element]<0} {lappend list $element}
 }
 proc numeric x {string is integer -strict $x}
#---- Testing
 Sir, John is a boy
 Sir, every boy is a person
 Sir, any person has 2 hands
 Sir, a finger is part of a hand
 puts [Sir, what is John?]
 puts [Sir, what is a boy?]

if 0 {If we source this file in a [tclsh] (so that [gets] works), we see
 % source sir.tcl
 John is a boy, a person
 boy is a person
 % Sir, how many fingers are on John
 How many fingers per hand?
 every hand has 5 fingers
 10
which comes close to the 40-years old original as reported in 
http://staff.science.uva.nl/~mdr/Teaching/LTP/literature/monz_chap2.ps - the chain of reasoning
went John - boy - person, then through person's "parts", filling the unspecified number of fingers per hand, and finally computing 2 (hands) * 5 (fingers) for John. More tests:
 % Sir, Mary is a girl
 % Sir, every girl is a person
 % Sir, what is Mary?
 Mary is a girl, a person
 % Sir, what is a person?
 A person is a boy, or a girl
 % Sir, is John a person?
 yes
 % Sir, is John a girl?
 no
 % Sir, is a boy a person?
 yes

Playing with this "Sir", it's often helpful to inspect the knowledge base with 
 parray K
}
----
[Arts and crafts of Tcl-Tk programming]