; Semantic Network Program
;   by Jerry D. Hedden

; Allow this file to be reloaded
if buriedp "semnet-stuff  [ unbury :semnet-stuff ]  [ ]

; get some needed procedures.
load "Utilities/Words-Lists

make "semnet [
  procedure [ [ ] [ :net ] [ :inpt :result ] ]
  say [ Welcome to Jairy's Semantic Network Program. ]
  if not emptyp :net
     [ ( print-say se [ Loading network:\  ] :net
                   [ Loading network file.  Please wait. ] )
       make "result false
       catch "error [ load :net
                      print-say [ Network loaded successfully. ]
                      make "result true ]
       if :result  [ ]  [ print-say [ Error loading network! ] ] ]
     [ ]
  make "result filter [ = "^ first ] namelist
  if emptyp :result
     [ print-say [ Presently, I know nothing. ]
       print-say [ Please provide me with data. ] ]
     [ ( print-say [ Provide data or ask questions. ]
                   [ What can I do for you? ] ) ]
  while [ true ] [
    setpen @0 3
    type "=>
    setpen @0 1
    dowhile [
      while [ not linep ] [ sleep ]
      make "inpt rl
    ] [ emptyp :inpt ]
    make "inpt se lcase first :inpt bf :inpt
    if or  = ". last last :inpt  = "? last last :inpt
       [ make "inpt se bl :inpt bl last :inpt ]
       [ ]
    make "result interpret :inpt
    cond [
      [ = :result "ok ]
        [ print-say [ I understand. ] ]
      [ = :result "nothing ]
        [ print-say [ I know of nothing to tell you. ] ]
      [ = :result "unknown ]
        [ print-say [ Nothing that I know of. ] ]
      [ = :result "unsure ]
        [ print-say [ Not that I know of. ] ]
      [ = :result "isnt ]
        [ ( print-say [ It isn't that I know of. ]
                      [ It is ent that I know of. ] ) ]
      [ = :result "unsure-does ]
        [ ( print-say [ I don't know that it does or doesn't. ]
                      [ I don't know that it does or does ent. ] ) ]
      [ = :result "unsure-can ]
        [ print-say [ I don't know that it can or can't. ] ]
      [ = :result "unsure-is ]
        [ ( print-say [ I don't know that it is or isn't. ]
                      [ I don't know that it is or is ent. ] ) ]
      [ = :result "not-okay ]
        [ print-say [ I don't understand?!? ] ]
      [ = :result "terminate ]
        [ ( print-say [ Terminating SemNet! ] [ Good-bye ] )
          stop ] ] ] ]

; dialog interpreter
make "interpret [
  procedure [ [ :in-text ] [ ] [ :x :y :artx :arty :inpt :result ] ]
  cond [
    ; DATA: a(n) ___ is a(n) ___
    [ match [ [ a-an artx ] [ ? x ] is [ a-an arty ] [ ? y ] ] :in-text ]
      [ add-lists :x :y "is-a "includes
        pprop fput "^ :x "article :artx
        pprop fput "^ :y "article :arty
        output "ok ]
    ; DATA: a(n) ___ has ___
    [ match [ [ a-an artx ] [ ? x ] has [ ? y ] ] :in-text ]
      [ add-lists :x :y "has "with
        pprop fput "^ :x "article :artx
        output "ok ]
    ; DATA: a(n) ___ does not have ___
    [ match [ [ a-an artx ] [ ? x ] does not have [ ? y ] ] :in-text ]
      [ add-lists :x :y "has-not "without
        pprop fput "^ :x "article :artx
        output "ok ]
    ; DATA: a(n) ___ can ___
    [ match [ [ a-an artx ] [ ? x ] can [ ? y ] ] :in-text ]
      [ add-lists :x :y "can "able
        pprop fput "^ :x "article :artx
        output "ok ]
    ; DATA: a(n) ___ cannot ___
    [ match [ [ a-an artx ] [ ? x ] cannot [ ? y ] ] :in-text ]
      [ add-lists :x :y "cannot "unable
        pprop fput "^ :x "article :artx
        output "ok ]
    ; DATA: a(n) ___ is ___
    [ match [ [ a-an artx ] [ ? x ] is [ ? y ] ] :in-text ]
      [ add-lists :x :y "is "are
        pprop fput "^ :x "article :artx
        output "ok ]
    ; DATA: a(n) ___ is not ___
    [ match [ [ a-an artx ] [ ? x ] is not [ ? y ] ] :in-text ]
      [ add-lists :x :y "is-not "are-not
        pprop fput "^ :x "article :artx
        output "ok ]

    ; DATA: ask me about a(n) ___
    [ match [ ask me about [ a-an artx ] [ ? x ] ] :in-text ]
      [ print-say ( se "What "is :artx word :x "? )
        setpen @0 3
        type "==>>
        setpen @0 1
        while [ not linep ] [ sleep ]
        make "inpt rl
        if emptyp :inpt  [ ]
           [ ignore interpret ( se :artx :x "is :inpt ) ]
        print-say ( se "What "does :artx :x "have? )
        setpen @0 3
        type "==>>
        setpen @0 1
        while [ not linep ] [ sleep ]
        make "inpt rl
        if emptyp :inpt  [ ]
           [ interpret1 ( se :artx :x "has ) :inpt ]
        print-say ( se "What "does :artx :x "not "have? )
        setpen @0 3
        type "==>>
        setpen @0 1
        while [ not linep ] [ sleep ]
        make "inpt rl
        if emptyp :inpt  [ ]
           [ interpret1 ( se :artx :x [ does not have ] ) :inpt ]
        print-say ( se "What "can :artx :x "do? )
        setpen @0 3
        type "==>>
        setpen @0 1
        while [ not linep ] [ sleep ]
        make "inpt rl
        if emptyp :inpt  [ ]
           [ interpret1 ( se :artx :x "can ) :inpt ]
        print-say ( se "What "can :artx :x "not "do? )
        setpen @0 3
        type "==>>
        setpen @0 1
        while [ not linep ] [ sleep ]
        make "inpt rl
        if emptyp :inpt  [ ]
           [ interpret1 ( se :artx :x "cannot ) :inpt ]
        print-say ( se "What "can :artx :x "be? )
        setpen @0 3
        type "==>>
        setpen @0 1
        while [ not linep ] [ sleep ]
        make "inpt rl
        if emptyp :inpt  [ ]
           [ interpret1 ( se :artx :x "is ) :inpt ]
        print-say ( se "What "can :artx :x "not "be? )
        setpen @0 3
        type "==>>
        setpen @0 1
        while [ not linep ] [ sleep ]
        make "inpt rl
        if emptyp :inpt  [ ]
           [ interpret1 ( se :artx :x "is "not ) :inpt ]
        output " ]

    ; QUERY: what is a(n) ___
    [ match [ what is [ a-an artx ] [ ? x ] ] :in-text ]
      [ cond [
        [ not emptyp gprop fput "^ :x "is-a ]
          [ print-say ( se cap :artx :x "is
                           punc make-conj gprop fput "^ :x "is-a )
            output " ]
        [ not emptyp gprop fput "^ :x "includes ]
          [ print-say ( se cap :artx :x [ is something more general than ]
                           punc make-conj gprop fput "^ :x "includes )
            output " ]
        [ true ]
          [ output "unknown ] ] ]

    ; QUERY: what are examples of a(n) ___
    [ match [ what are examples of [ a-an artx ] [ ? x ] ] :in-text ]
      [ if emptyp gprop fput "^ :x "includes
           [ output "unknown ]
           [ print-say ( se "Examples "of :artx :x "include
                             punc make-conj gprop fput "^ :x "includes )
             output " ] ]

    ; QUERY: what has ___
    [ match [ what has [ ? y ] ] :in-text ]
      [ make "x gprop fput "^ :y "with
        if emptyp :x
          [ output "unknown ]
          [ print-say ( se cap make-conj :x has-have :x punc :y )
            output " ] ]
    ; QUERY: what does not have ___
    [ match [ what does not have [ ? y ] ] :in-text ]
      [ make "x gprop fput "^ :y "without
        if emptyp :x
          [ output "unknown ]
          [ print-say ( se cap make-conj :x
                           does-do :x "not "have punc :y )
            output " ] ]
    ; QUERY: what can ___
    [ match [ what can [ ? y ] ] :in-text ]
      [ make "x gprop fput "^ :y "able
        if emptyp :x
          [ output "unknown ]
          [ print-say ( se cap make-conj :x "can punc :y )
            output " ] ]
    ; QUERY: what cannot ___
    [ match [ what cannot [ ? y ] ] :in-text ]
      [ make "x gprop fput "^ :y "unable
        if emptyp :x
          [ output "unknown ]
          [ print-say ( se cap make-conj :x "cannot punc :y )
            output " ] ]
    ; QUERY: what is ___
    [ match [ what is [ ? y ] ] :in-text ]
      [ make "x gprop fput "^ :y "are
        if emptyp :x
          [ output "unknown ]
          [ print-say ( se cap make-conj :x is-are :x punc :y )
            output " ] ]
    ; QUERY: what is not ___
    [ match [ what is not [ ? y ] ] :in-text ]
      [ make "x gprop fput "^ :y "are-not
        if emptyp :x
          [ output "unknown ]
          [ print-say ( se cap make-conj :x is-are :x "not punc :y )
            output " ] ]

    ; QUERY: what does a(n) ___ have
    [ match [ what does [ a-an artx ] [ ? x ] have ] :in-text ]
      [ make "y gprop fput "^ :x "has
        if emptyp :y
          [ output "unknown ]
          [ print-say ( se cap :artx :x "has punc make-conj2 :y )
            output " ] ]
    ; QUERY: what does a(n) ___ not have
    [ match [ what does [ a-an artx ] [ ? x ] not have ] :in-text ]
      [ make "y gprop fput "^ :x "has-not
        if emptyp :y
          [ output "unknown ]
          [ print-say ( se cap :artx :x [ does not have ]
                           punc make-conj3 :y )
            output " ] ]
    ; QUERY: what can a(n) ___ do
    [ match [ what can [ a-an artx ] [ ? x ] do ] :in-text ]
      [ make "y gprop fput "^ :x "can
        if emptyp :y
          [ output "unknown ]
          [ print-say ( se cap :artx :x "can punc make-conj2 :y )
            output " ] ]
    ; QUERY: what can a(n) ___ not do
    [ match [ what can [ a-an artx ] [ ? x ] not do ] :in-text ]
      [ make "y gprop fput "^ :x "cannot
        if emptyp :y
          [ output "unknown ]
          [ print-say ( se cap :artx :x "cannot punc make-conj3 :y )
            output " ] ]
    ; QUERY: what can a(n) ___ be
    [ match [ what can [ a-an artx ] [ ? x ] be ] :in-text ]
      [ make "y gprop fput "^ :x "is
        if emptyp :y
          [ output "unknown ]
          [ print-say ( se cap :artx :x "is punc make-conj2 :y )
            output " ] ]
    ; QUERY: what can a(n) ___ not be
    [ match [ what can [ a-an artx ] [ ? x ] not be ] :in-text ]
      [ make "y gprop fput "^ :x "is-not
        if emptyp :y
          [ output "unknown ]
          [ print-say ( se cap :artx :x "is "not punc make-conj3 :y )
            output " ] ]

    ; QUERY: tell me about a(n) ___
    [ match [ tell me about [ a-an artx ] [ ? x ] ] :in-text ]
      [ make "result emptyp if not emptyp gprop fput "^ :x "is-a
                            [ interpret ( se "examples "of :artx :x ) ]
                            [ "none-higher ]
        make "result or :result
                emptyp interpret ( se "what "is :artx :x )
        make "result or :result
                emptyp interpret ( se "what "does :artx :x "have )
        make "result or :result
                emptyp interpret ( se "what "does :artx :x "not "have )
        make "result or :result
                emptyp interpret ( se "what "can :artx :x "do )
        make "result or :result
                emptyp interpret ( se "what "can :artx :x "not "do )
        make "result or :result
                emptyp interpret ( se "what "can :artx :x "be )
        make "result or :result
                emptyp interpret ( se "what "can :artx :x "not "be )
        if :result  [ output " ]  [ output "nothing ]  ]

    ; QUERY: tell me all about a(n) ___
    [ match [ tell me all about [ a-an artx ] [ ? x ] ] :in-text ]
      [ if emptyp interpret ( se "tell "me "about :artx :x )
           [ virtue :x gprop fput "^ :x "is-a fput :x [ ]
             output " ]
           [ output "nothing ] ]

    ; QUERY: what do you know
    [ = [ what do you know ] :in-text ]
      [ list-net
        output " ]

    ; QUERY: is a(n) ___ a(n) ___
    [ match [ is [ a-an artx ] [ ? x ] [ a-an arty ] [ ? y ] ] :in-text ]
      [ if emptyp attr-test :x :y "is-a "is-a
           [ output "unsure ]
           [ print-say ( se [ Yes, indeed, ] :artx :x "is :arty punc :y )
             output " ] ]
    ; QUERY: does a(n) ___ have ___
    [ match [ does [ a-an artx ] [ ? x ] have [ ? y ] ] :in-text ]
      [ make "result attr-test :x :y "has "has-not
        cond [
          [ = :result "affirmative ]
            [ print-say ( se [ Yes, indeed, ] :artx :x "has punc :y )
              output " ]
          [ = :result "negative ]
            [ print-say ( se [ No, indeed, ] :artx :x [ does not have ]
                             punc :y )
              output " ]
          [ true ]
            [ output "unsure-does ] ] ]
    ; QUERY: can a(n) ___ ___
    [ match [ can [ a-an artx ] [ ? x ] [ ? y ] ] :in-text ]
      [ make "result attr-test :x :y "can "cannot
        cond [
          [ = :result "affirmative ]
            [ print-say ( se [ Yes, indeed, ] :artx :x "can punc :y )
              output " ]
          [ = :result "negative ]
            [ print-say ( se [ No, indeed, ] :artx :x "cannot punc :y )
              output " ]
          [ true ]
            [ output "unsure-can ] ] ]
    ; QUERY: is a(n) ___ ___
    [ match [ is [ a-an artx ] [ ? x ] [ ? y ] ] :in-text ]
      [ make "result attr-test :x :y "is "is-not
        cond [
          [ = :result "affirmative ]
            [ print-say ( se [ Yes, indeed, ] :artx :x "is punc :y )
              output " ]
          [ = :result "negative ]
            [ print-say ( se [ No, indeed, ] :artx :x "is "not punc :y )
              output " ]
          [ true ]
            [ output "unsure-is ] ] ]

    ; QUERY: why is a(n) ___ a(n) ___
    [ match [ why is [ a-an artx ] [ ? x ] [ a-an arty ] [ ? y ] ]
            :in-text ]
      [ if emptyp attr-test :x :y "is-a "is-a
           [ output "isnt ]
           [ print-say ( se "Because punc isa-links :x :y )
             output " ] ]
    ; QUERY: why does a(n) ___ have ___
    [ match [ why does [ a-an artx ] [ ? x ] have [ ? y ] ] :in-text ]
      [ make "result attr-test :x :y "has "has-not
        cond [
          [ = :result "affirmative ]
            [ print-say ( se "Because
                              punc attr-links :x :y "has "has-not "has )
              output " ]
          [ = :result "negative ]
            [ print-say ( se [ Excuse me, but ] :artx :x
                             [ does not have ] punc :y )
              output " ]
          [ true ]
            [ output "unsure-does ] ] ]
    ; QUERY: why does a(n) ___ not have ___
    [ match [ why does [ a-an artx ] [ ? x ] not have [ ? y ] ] :in-text ]
      [ make "result attr-test :x :y "has "has-not
        cond [
          [ = :result "affirmative ]
            [ print-say ( se [ Excuse me, but ] :artx :x
                               "does "have punc :y )
              output " ]
          [ = :result "negative ]
            [ print-say ( se "Because punc
                               attr-not-links :x :y "has "has-not
                                              [ does not have ] )
              output " ]
          [ true ]
            [ output "unsure-does ] ] ]
    ; QUERY: why can a(n) ___ ___
    [ match [ why can [ a-an artx ] [ ? x ] [ ? y ] ] :in-text ]
      [ make "result attr-test :x :y "can "cannot
        cond [
          [ = :result "affirmative ]
            [ print-say ( se "Because
                              punc attr-links :x :y "can "cannot "can )
              output " ]
          [ = :result "negative ]
            [ print-say ( se [ Excuse me, but ] :artx :x "cannot punc :y )
              output " ]
          [ true ]
            [ output "unsure-can ] ] ]
    ; QUERY: why can a(n) ___ not ___
    [ match [ why can [ a-an artx ] [ ? x ] not [ ? y ] ] :in-text ]
      [ make "result attr-test :x :y "can "cannot
        cond [
          [ = :result "affirmative ]
            [ print-say ( se [ Excuse me, but ] :artx :x "can punc :y )
              output " ]
          [ = :result "negative ]
            [ print-say ( se "Because punc
                     attr-not-links :x :y "can "cannot "cannot )
              output " ]
          [ true ]
            [ output "unsure-can ] ] ]
    ; QUERY: why is a(n) ___ ___
    [ match [ why is [ a-an artx ] [ ? x ] [ ? y ] ] :in-text ]
      [ make "result attr-test :x :y "is "is-not
        cond [
          [ = :result "affirmative ]
            [ print-say ( se "Because
                              punc attr-links :x :y "is "is-not "is )
              output " ]
          [ = :result "negative ]
            [ print-say ( se [ Excuse me, but ] :artx :x
                             "is "not punc :y )
              output " ]
          [ true ]
            [ output "unsure-is ] ] ]
    ; QUERY: why is a(n) ___ not ___
    [ match [ why is [ a-an artx ] [ ? x ] not [ ? y ] ] :in-text ]
      [ make "result attr-test :x :y "is "is-not
        cond [
          [ = :result "affirmative ]
            [ print-say ( se [ Excuse me, but ] :artx :x "is punc :y )
              output " ]
          [ = :result "negative ]
            [ print-say ( se "Because punc
                     attr-not-links :x :y "is "is-not [ is not ] )
              output " ]
          [ true ]
            [ output "unsure-is ] ] ]

    [ = [ load ] :in-text ]
      [ make "in-text ( filerequest "\ Load\ Semantic\ Network\ \ \ \ \  )
        if emptyp :in-text
           [ ]
           [ ( print-say ( se [ Loading network:\  ] :in-text )
                              [ Loading network file.  Please wait. ] )
             erase filter [ = "^ first ] namelist
             catch "error [ load :in-text
                            print-say [ Network loaded successfully. ]
                            output " ]
             ( print-say [ Error loading network!
                           Previous network erased!! ]
                         [ oh no. ] ) ]
        output " ]
    [ = [ save ] :in-text ]
      [ make "in-text ( filerequest "\ Save\ Network\ To\ Disk\ \ \ \ \  )
        if emptyp :in-text
           [ ]
           [ ( print-say ( se [ Saving network to:\  ] :in-text )
                              [ Saving network to disk.  Please wait. ] )
             catch "error [ save :in-text filter [ = "^ first ] namelist
                            ( saveicon :in-text " [ SemNet-DataFile ] )
                            print-say [ Network written successfully. ]
                            output " ]
             ( print-say [ Error saving network! ] [ oh no. ] ) ]
        output " ]
    [ = [ quit ] :in-text ]
      [ output "terminate ]

    ; bad input
    [ true ]
      [ output "not-okay ] ] ]

make "interpret1 [
  procedure [ [ :x :y ] ]
  if emptyp :y
     [ ]
     [ ignore interpret se :x first :y
       interpret1 :x bf :y ] ]


; list adding functions
make "add-lists [
  procedure [ [ :x :y :a :b ] ]
  pprop fput "^ :x :a add-to-list :y gprop fput "^ :x :a
  pprop fput "^ :y :b add-to-list :x gprop fput "^ :y :b ]

make "add-to-list [
  procedure [ [ :a :b ] ]
  output if memberp :a :b  [ :b ]  [ fput :a :b ] ]


; retrieves hierarchical properties
make "virtue [
  procedure [ [ :x :y :z ] ]
  if emptyp :y
    [ ]
    [ attributes :x first :y :z
      virtue :x gprop fput "^ first :y "is-a fput first :y :z
      virtue :x bf :y :z
      stop ] ]

make "attributes [
  procedure [ [ :x :y :z ] [ ] [ :attr ] ]
  make "attr notlist gprop fput "^ :y "has :z "has-not
  if emptyp :attr
     [ ]
     [ print-say ( se [ Because it is ] gprop fput "^ :y "article :y
                      gprop fput "^ :x "article :x "has
                      punc make-conj2 :attr ) ]
  make "attr notlist gprop fput "^ :y "has-not :z "has
  if emptyp :attr
     [ ]
     [ print-say ( se [ Because it is ] gprop fput "^ :y "article :y
                      gprop fput "^ :x "article :x [ does not have ]
                      punc make-conj3 :attr ) ]
  make "attr notlist gprop fput "^ :y "can :z "cannot
  if emptyp :attr
     [ ]
     [ print-say ( se [ Because it is ] gprop fput "^ :y "article :y
                      gprop fput "^ :x "article :x "can
                      punc make-conj2 :attr ) ]
  make "attr notlist gprop fput "^ :y "cannot :z "can
  if emptyp :attr
     [ ]
     [ print-say ( se [ Because it is ] gprop fput "^ :y "article :y
                      gprop fput "^ :x "article :x "cannot
                      punc make-conj3 :attr ) ]
  make "attr notlist gprop fput "^ :y "is :z "is-not
  if emptyp :attr
     [ ]
     [ print-say ( se [ Because it is ] gprop fput "^ :y "article :y
                      gprop fput "^ :x "article :x "is
                      punc make-conj2 :attr ) ]
  make "attr notlist gprop fput "^ :y "is-not :z "is
  if emptyp :attr
     [ ]
     [ print-say ( se [ Because it is ] gprop fput "^ :y "article :y
                      gprop fput "^ :x "article :x [ is not ]
                      punc make-conj3 :attr ) ] ]

make "notlist [
  procedure [ [ :x :z :q ] ]
  cond [
    [ emptyp :x ]     [ output [ ] ]
    [ emptyp :z ]     [ output :x ]
    [ emptyp bf :z ]  [ output remlist :x gprop fput "^ first :z :q ]
    [ true ]          [ output notlist remlist :x gprop fput "^ first :z :q
                                       bf :z :q ] ] ]

make "remlist [
  procedure [ [ :x :y ] ]
  cond [
    [ emptyp :y ]     [ output :x ]
    [ emptyp bf :y ]  [ output remove fput first :y [ ] :x ]
    [ true ]          [ output
                         remlist remove fput first :y [ ] :x bf :y ] ] ]


; attribute test
make "attr-test [
  procedure [ [ :x :y :a :b ] ]
  cond [
    [ memberp :y gprop fput "^ :x :a ]
      [ output "affirmative ]
    [ memberp :y gprop fput "^ :x :b ]
      [ output "negative ]
    [ true ]
      [ output attr-test1 gprop fput "^ :x "is-a :y :a :b ] ] ]

make "attr-test1 [
  procedure [ [ :x :y :a :b ] [ ] [ :result ] ]
  cond [
    [ emptyp :x ]     [ output [ ] ]
    [ emptyp bf :x ]  [ output attr-test first :x :y :a :b ]
    [ true ]          [ make "result attr-test first :x :y :a :b
                        if emptyp :result
                           [ output attr-test1 bf :x :y :a :b ]
                           [ output :result ] ] ] ]


; explains relational chains
make "isa-links [
  procedure [ [ :x :y ] ]
  cond [
    [ = :x :y ]
      [ output [ they are identical ] ]
    [ memberp :y gprop fput "^ :x "is-a ]
      [ output [ I was given that fact ] ]
    [ true ]
      [ output isa-chain :x gprop fput "^ :x "is-a :y ] ] ]

make "isa-chain [
  procedure [ [ :x :l :y ] ]
  cond [
    [ memberp :y :l ]
      [ output tell-is :x :y ]
    [ not emptyp attr-test first :l :y "is-a "is-a ]
      [ output ( se tell-is :x first :l "and
                    isa-chain first :l gprop fput "^ first :l "is-a :y ) ]
    [ true ]
      [ output isa-chain :x bf :l :y ] ] ]

make "tell-is [
  procedure [ [ :x :y ] ]
  output ( se gprop fput "^ :x "article :x "is
              gprop fput "^ :y "article :y ) ]


; explains attribute chains
make "attr-links [
  procedure [ [ :x :y :a :b :q ] ]
  if memberp :y gprop fput "^ :x :a
    [ output [ I was given that fact ] ]
    [ output attr-chain :x gprop fput "^ :x "is-a :y :a :b :q ] ]

make "attr-chain [
  procedure [ [ :x :l :y :a :b :q ] ]
  cond [
    [ memberp :y gprop fput "^ :x :a ]
      [ output tell-attr :x :y :q ]
    [ = attr-test first :l :y :a :b "affirmative ]
      [ output ( se tell-is :x first :l "and
                    attr-chain first :l gprop fput "^ first :l "is-a
                               :y :a :b :q ) ]
    [ true ]
      [ output attr-chain :x bf :l :y :a :b :q ] ] ]


make "attr-not-links [
  procedure [ [ :x :y :a :b :q ] ]
  if memberp :y gprop fput "^ :x :b
    [ output [ I was given that fact ] ]
    [ output attr-not-chain :x gprop fput "^ :x "is-a :y :a :b :q ] ]

make "attr-not-chain [
  procedure [ [ :x :l :y :a :b :q ] ]
  cond [
    [ memberp :y gprop fput "^ :x :b ]
      [ output tell-attr :x :y :q ]
    [ = attr-test first :l :y :a :b "negative ]
      [ output ( se tell-is :x first :l "and
                    attr-not-chain first :l gprop fput "^ first :l "is-a
                                   :y :a :b :q ) ]
    [ true ]
      [ output attr-not-chain :x bf :l :y :a :b :q ] ] ]

make "tell-attr [
  procedure [ [ :x :y :q ] ]
  output ( se gprop fput "^ :x "article :x :q :y ) ]


; list of network contents
make "list-net [
  procedure [ [ ] [ ] [ :semdata :nlist ] ]
  say [ Just a moment. ]
  make "semdata sort "alphap filter [ = "^ first ] namelist
  if emptyp :semdata
     [ ( print-say [ The Semantic Network is empty. ]
                   [ I guess I don't know anything?!? ] )
       stop ]
     [ ]
  make "nlist map "put-art filter [ attrp "is-a "include ] :semdata
  ( print-say [ I know some things about the following: ]
              [ Here is what I know. ] )
  ( col-print :nlist 3 )
  make "nlist map "bf filter [ attrp "with "without ] :semdata
  if not emptyp :nlist
     [ pr [ I know that some things have or do not have the following: ]
       ( col-print :nlist 3 ) ]
     [ ]
  make "nlist map "bf filter [ attrp "able "unable  ] :semdata
  if not emptyp :nlist
     [ pr [ I know that some things can or cannot do the following: ]
       ( col-print :nlist 3 ) ]
     [ ]
  make "nlist map "bf filter [ attrp "are "are-not ] :semdata
  if not emptyp :nlist
     [ pr [ I know that some things are or are not the following: ]
       ( col-print :nlist 3 ) ]
     [ ]
]

make "attrp [
  procedure [ [ :a :b :x ] ]
  output not and  emptyp gprop :x :a  emptyp gprop :x :b ]

make "put-art [
  procedure [ [ :x ] ]
  output ( word gprop :x "article char 160 bf :x ) ]


; limited pattern matching function
make "match [
  procedure [ [ :p :s ] ]
  cond [
    [ emptyp :p ]
      [ output emptyp :s ]
    [ emptyp :s ]
      [ output false ]
    [ wordp first :p ]
      [ if = first :p first :s
           [ output match bf :p bf :s ]
           [ output false ] ]
    ; "?" wildcard
    [ = "? first first :p ]
      [ if match bf :p bf :s
           [ make last first :p first :s
             output true ]
           [ output false ] ]
    ; predicate form of match
    [ run se first first :p [ first :s ] ]
      [ if match bf :p bf :s
           [ make last first :p first :s
             output true ]
           [ output false ] ]
    [ true ]
      [ output false ] ] ]

; only two articles so far
make "a-an [
  procedure [ [ :x ] ]
  output memberp :x [ a an ] ]


; turns a list into [ a(n) ___ and a(n) ___ ... ]
make "make-conj [
  procedure [ [ :lst ] ]
  output if <= count :lst 1
    [ fput gprop fput "^ first :lst "article :lst ]
    [ ( se gprop fput "^ first :lst "article first :lst
           "and make-conj bf :lst ) ] ]

; adds ANDs to a list
make "make-conj2 [
  procedure [ [ :lst ] ]
  output if <= count :lst 1
    [ :lst ]
    [ ( se first :lst "and make-conj2 bf :lst ) ]  ]

; adds ORs to a list
make "make-conj3 [
  procedure [ [ :lst ] ]
  output if <= count :lst 1
    [ :lst ]
    [ ( se first :lst "or make-conj3 bf :lst ) ]  ]


; do we use has-have
make "has-have [
  procedure [ [ :lst ] ]
  output if <= count :lst 1  [ "has ]  [ "have ]  ]

; do we use does-do
make "does-do [
  procedure [ [ :lst ] ]
  output if <= count :lst 1  [ "does ]  [ "do ]  ]

; do we use is-are
make "is-are [
  procedure [ [ :lst ] ]
  output if <= count :lst 1  [ "is ]  [ "are ]  ]


; capitalize a word
make "cap [
  procedure [ [ :x ] ]
  output if listp :x
    [ fput fput char - ascii first first :x 32 bf first :x bf :x ]
    [ fput char - ascii first :x 32 bf :x ] ]

; add punctuation
make "punc [
  procedure [ [ :x ] ]
  output if listp :x
    [ se bl :x word last :x ". ]
    [ word :x ". ] ]


make "print-say [
  procedure [ [ :to-print ] [ :to-say ] [ :bigw :idx :ww ] ]
  say if emptyp :to-say  [ :to-print ]  [ :to-say ]
  make "ww - first window-size 1
  make "bigw bf reduce [ word char 160 word ] " :to-print
  while [ >= count :bigw :ww ] [
    make "idx - :ww 1
    while [ not = char 160 item :idx :bigw ] [ make "idx - :idx 1 ]
    pr items 1 :idx :bigw
    make "bigw restof :idx :bigw ]
  pr :bigw ]


; Bury the list of names defined in this file.

make "semnet-stuff [ semnet interpret interpret1 add-lists add-to-list
  virtue attributes notlist remlist attr-test attr-test1 isa-links
  isa-chain tell-is attr-links attr-chain attr-not-links attr-not-chain
  tell-attr list-net attrp put-art match a-an make-conj make-conj2
  make-conj3 has-have does-do is-are cap punc print-say semnet-stuff ]

bury :semnet-stuff