home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / logo / powerlogo / examples / doctor < prev    next >
Text File  |  1992-09-21  |  23KB  |  849 lines
  1.  
  2. ;  This is an Eliza like program called 'doctor'
  3. ;  adapted from Computer Science LOGO Style by Brien Harvey.
  4.  
  5. ;  ******   Create Doctor   ******
  6.  
  7. make "doctor [
  8.    procedure [ [ ] [ ]
  9.       [ :v.text :v.sentence :STUFF :A :B :C :rules :keywords ] ]
  10.    make "v.memory [ ]
  11.    setpen @0 3
  12.    pr [ ]
  13.    pr [ HELLO, I AM THE DOCTOR. ]
  14.    pr [ PLEASE TELL ME ALL OF YOUR LIFES PROBLEMS. ]
  15.    pr [ PLEASE END YOUR REMARKS WITH AN EMPTY LINE. ]
  16.    pr [ ]
  17.    setpen @0 1
  18.    loop ]
  19.  
  20. ;  Controlling the conversation
  21.  
  22. make "loop [
  23.    procedure [ ]
  24.    make "v.text tokenize getstuff [ ]
  25.    make "v.sentence getsentence :v.text
  26.    setpen @0 3
  27.    analyze :v.sentence :keywords
  28.    setpen @0 1
  29.    pr [ ]
  30.    loop
  31.    stop ]
  32.  
  33. ;  Reading and preparing the input
  34.  
  35. make "getstuff [
  36.    procedure [ [ :STUFF ] [ ] [ :line ] ]
  37.    while [ not linep ] [ sleep ]
  38.    make "line upper rl
  39.    if emptyp :line [ op :STUFF ] [ ]
  40.    op getstuff se :STUFF :line ]
  41.  
  42. make "tokenize [
  43.    procedure [ [ :v.text ] ]
  44.    if emptyp :v.text [ op [ ] ] [ ]
  45.    op se tokenword first :v.text " tokenize bf :v.text ]
  46.  
  47. make "tokenword [
  48.    procedure [ [ :v.word :out ] ]
  49.    if emptyp :v.word [ op :out ] [ ]
  50.    if memberp first :v.word [ , " ] [ op tokenword bf :v.word :out ] [ ]
  51.    if memberp first :v.word [ . ? ! \; ] [ op se :out ". ] [ ]
  52.    op tokenword bf :v.word word :out first :v.word ]
  53.  
  54. make "getsentence [
  55.    procedure [ [ :v.text ] ]
  56.    make "keywords [ ]
  57.    op getsentence1 :v.text [ ] ]
  58.  
  59. make "getsentence1 [
  60.    procedure [ [ :v.text :out ] ]
  61.    if emptyp :v.text [ op :out ] [ ]
  62.    if equalp first :v.text ".
  63.       [  if emptyp :keywords 
  64.             [  op getsentence1 bf :v.text [ ] ]
  65.             [  op :out ] ]
  66.       [ ]
  67.    checkpriority first :v.text
  68.    op getsentence1 bf :v.text se :out translate first :v.text ]
  69.  
  70. make "translate [
  71.    procedure [ [ :v.word ] [ ] [ :v.new ] ]
  72.    make "v.new gprop :v.word "TRANSLATION
  73.    op if emptyp :v.new [ :v.word ] [ :v.new ] ]
  74.  
  75. make "checkpriority [
  76.    procedure [ [ :v.word ] [ ] [ :priority ] ]
  77.    make "priority gprop :v.word "PRIORITY
  78.    if emptyp :priority [ stop ] [ ]
  79.    if emptyp :keywords [ make "keywords fput :v.word [ ] stop ] [ ]
  80.    if > :priority gprop first :keywords "PRIORITY
  81.       [  make "keywords fput :v.word :keywords ]
  82.       [  make "keywords lput :v.word :keywords ] ]
  83.  
  84. ;  Choosing the rule and replying
  85.  
  86. make "analyze [
  87.    procedure [ [ :v.sentence :keywords ] [ ] [ :rules :keyword ] ]
  88.    if emptyp :keywords [ norules stop ] [ ]
  89.    make "keyword first :keywords
  90.    make "rules gprop :keyword "RULES
  91.    if wordp first :rules
  92.       [  make "keyword first :rules
  93.          make "rules gprop :keyword "RULES ] [ ]
  94.    checkrules :keyword :rules ]
  95.  
  96. make "checkrules [
  97.    procedure [ [ :keyword :rules ] ]
  98.    if not match first :rules :v.sentence
  99.       [  checkrules :keyword bf bf :rules
  100.          stop ] [ ]
  101.    dorule first bf :rules ]
  102.  
  103. make "dorule [
  104.    procedure [ [ :rule ] [ ] [ :v.print ] ]
  105.    make "v.print first gprop :keyword :rule
  106.    pprop :keyword :rule lput :v.print bf gprop :keyword :rule
  107.    if equalp :v.print "NEWKEY
  108.       [  analyze :v.sentence bf :keywords
  109.          stop ] [ ]
  110.    if wordp :v.print
  111.       [  checkrules :v.print gprop :v.print "RULES
  112.          stop ] [ ]
  113.    if equalp first :v.print "PRE
  114.       [  analyze reconstruct first bf :v.print bf bf :v.print
  115.          stop ] [ ]
  116.    pr reconstruct :v.print
  117.    memory :keyword :v.sentence ]
  118.  
  119. make "reconstruct [
  120.    procedure [ [ :v.sentence ] ]
  121.    if emptyp :v.sentence [ op [ ] ] [ ]
  122.    if not equalp ": first first :v.sentence
  123.       [  op fput first :v.sentence reconstruct bf :v.sentence ] [ ]
  124.    op se reword first :v.sentence reconstruct bf :v.sentence ]
  125.  
  126. make "reword [
  127.    procedure [ [ :v.word ] ]
  128.    if memberp last :v.word [ . ? , ]
  129.       [  op addpunct reword bl :v.word last :v.word ] [ ]
  130.    op thing bf :v.word ]
  131.  
  132. make "addpunct [
  133.    procedure [ [ :STUFF :v.char ] ]
  134.    if wordp :STUFF [ op word :STUFF :v.char ] [ ]
  135.    if emptyp :STUFF [ op :v.char ] [ ]
  136.    op se bl :STUFF word last :STUFF :v.char ]
  137.  
  138. make "memory [
  139.    procedure [ [ :keyword :v.sentence ] [ ] [ :rules :rule :v.name ] ]
  140.    make "rules gprop :keyword "MEMR
  141.    if emptyp :rules [ stop ] [ ]
  142.    if not match first :rules :v.sentence [ stop ] [ ]
  143.    make "v.name last :rules
  144.    make "rules gprop :keyword :v.name
  145.    make "rule first :rules
  146.    pprop :keyword :v.name lput :rule bf :rules
  147.    make "v.memory fput reconstruct :v.sentence :v.memory ]
  148.  
  149. make "norules [
  150.    procedure [ ]
  151.    if :memflag [ usememory ] [ uselastresort ]
  152.    make "memflag not :memflag ]
  153.  
  154. make "uselastresort [
  155.    procedure [ ]
  156.    pr first :lastresort
  157.    make "lastresort lput first :lastresort bf :lastresort ]
  158.  
  159. make "usememory [
  160.    procedure [ ]
  161.    if emptyp :v.memory [ uselastresort stop ] [ ]
  162.    pr first :v.memory
  163.    make "v.memory bf :v.memory ]
  164.  
  165. ;  Predicates for patterns
  166.  
  167. make "BELIEFP [
  168.    procedure [ [ :v.word ] ]
  169.    op not emptyp gprop :v.word "BELIEF ]
  170.  
  171. make "FAMILYP [
  172.    procedure [ [ :v.word ] ]
  173.    op not emptyp gprop :v.word "FAMILY ]
  174.  
  175. ;  Convert all lower case letters to upper case.
  176.  
  177. make "upper [
  178.    procedure [ [ :w ] [ ] [ :l :c :o ] ]
  179.    if listp :w
  180.       [  while [ not emptyp :w ]
  181.             [  make "o fput upper first :w :o
  182.                make "w bf :w ]
  183.          output reverselist :o ]
  184.       [  make "o " 
  185.          make "c count :w
  186.          repeat :c
  187.             [  make "l item :c :w
  188.                if  and  >= ascii :l 97  <= ascii :l 122
  189.                   [  make "o fput char - ascii :l 32 :o ]
  190.                   [  make "o fput :l :o ]
  191.                make "c - :c 1 ]
  192.          output :o ] ]
  193.  
  194. ;  Reverse the order of the items in a list.
  195.  
  196. make "reverselist [ 
  197.    procedure [ [ :from ] [ ] [ :o ] ]
  198.    repeat count :from
  199.       [  make "o fput first :from :o
  200.          make "from bf :from ]
  201.    op :o ]
  202.  
  203.  
  204. ;  ******   Pattern Matcher       ******
  205.  
  206.  
  207. make "match [
  208.    procedure [
  209.       [ :pat :sen ] [ ]
  210.       [ :special.var :special.pred :special.buffer :in.list ] ]
  211.    if or wordp :pat wordp :sen [ op false ] [ ]
  212.    if emptyp :pat [ op emptyp :sen ] [ ]
  213.    if listp first :pat [ op special fput "!: :pat :sen ] [ ]
  214.    if memberp first first :pat [ ? # ! & @ ] [ op special :pat :sen ] [ ]
  215.    if emptyp :sen [ op false ] [ ]
  216.    if equalp first :pat first :sen [ op match bf :pat bf :sen ] [ ]
  217.    op false ]
  218.  
  219. ;  Parsing quantifiers
  220.  
  221. make "special [
  222.    procedure [ [ :pat :sen ] ]
  223.    set.special parse.special bf first :pat "  
  224.    op run fput first first :pat [ ] ]
  225.  
  226. make "parse.special [
  227.    procedure [ [ :v.word :var ] ]
  228.    if emptyp :v.word [ op list :var "p.always ] [ ]
  229.    if equalp first :v.word ": [ op list :var bf :v.word ] [ ]
  230.    op parse.special bf :v.word word :var first :v.word ]
  231.  
  232. make "set.special [
  233.    procedure [ [ :v.list ] ]
  234.    make "special.var first :v.list
  235.    make "special.pred last :v.list
  236.    if emptyp :special.var [ make "special.var "special.buffer ] [ ]
  237.    if memberp :special.pred [ IN anyof ] [ set.in ] [ ]
  238.    if not emptyp :special.pred [ stop ] [ ]
  239.    make "special.pred first bf :pat
  240.    make :pat fput first :pat bf bf :pat ]
  241.  
  242. make "set.in [
  243.    procedure [ ]
  244.    make "in.list first bf :pat
  245.    make "pat fput first :pat bf bf :pat ]
  246.  
  247. ;  Exactly one match
  248.  
  249. make "! [
  250.    procedure [ ]
  251.    if emptyp :sen [ op false ] [ ]
  252.    if not try.pred [ op false ] [ ]
  253.    make :special.var first :sen
  254.    op match bf :pat bf :sen ]
  255.  
  256. ;  Zero or one match
  257.  
  258. make "? [
  259.    procedure [ ]
  260.    make :special.var [ ]
  261.    if emptyp :sen [ op match bf :pat :sen ] [ ]
  262.    if not try.pred [ op match bf :pat :sen ] [ ]
  263.    make :special.var first :sen
  264.    if match bf :pat bf :sen [ op true ] [ ]
  265.    make :special.var [ ]
  266.    op match bf :pat :sen ]
  267.  
  268. ;  Zero or more matches
  269.  
  270. make "# [
  271.    procedure [ ]
  272.    make :special.var [ ]
  273.    op #test #gather :sen ]
  274.  
  275. make "#gather [
  276.    procedure [ [ :sen ] ]
  277.    if emptyp :sen [ op :sen ] [ ]
  278.    if not try.pred [ op :sen ] [ ]
  279.    make :special.var lput first :sen thing :special.var
  280.    op #gather bf :sen ]
  281.  
  282. make "#test [
  283.    procedure [ [ :sen ] ]
  284.    if match bf :pat :sen [ op true ] [ ]
  285.    if emptyp thing :special.var [ op false ] [ ]
  286.    op #test2 fput last thing :special.var :sen ]
  287.  
  288. make "#test2 [
  289.    procedure [ [ :sen ] ]
  290.    make :special.var bl thing :special.var
  291.    op #test :sen ]
  292.  
  293. ;  One or more matches
  294.  
  295. make "& [
  296.    procedure [ ]
  297.    op &test # ]
  298.  
  299. make "&test [
  300.    procedure [ [ :tf ] ]
  301.    if emptyp thing :special.var [ op false ] [ ]
  302.    op :tf ]
  303.  
  304. ;  Match words in a group
  305.  
  306. make "@ [
  307.    procedure [ ]
  308.    make :special.var :sen
  309.    op @test [ ] ]
  310.  
  311. make "@test [
  312.    procedure [ [ :sen ] ]
  313.    if @try.pred [ if match bf :pat :sen [ op true ] [ ] ] [ ]
  314.    if emptyp thing :special.var [ op false ] [ ]
  315.    op @test2 fput last thing :special.var :sen ]
  316.  
  317. make "@test2 [
  318.    procedure [ [ :sen ] ]
  319.    make :special.var bl thing :special.var
  320.    op @test :sen ]
  321.  
  322. ;  Applying the predicates
  323.  
  324. make "try.pred [
  325.    procedure [ ]
  326.    if listp :special.pred [ op match :special.pred first :sen ] [ ]
  327.    op run list :special.pred quoted first :sen ]
  328.  
  329. make "quoted [
  330.    procedure [ [ :v.thing ] ]
  331.    if listp :v.thing [ op thing ] [ ]
  332.    op word "" :v.thing ]
  333.  
  334. make "@try.pred [
  335.    procedure [ ]
  336.    if listp :special.pred [ op match :special.pred thing :special.var ] [ ]
  337.    op run list :special.pred thing :special.var ]
  338.  
  339. ;  Special predicates
  340.  
  341. make "p.always [
  342.    procedure [ [ :x ] ]
  343.    op true ]
  344.  
  345. make "IN [
  346.    procedure [ [ :v.word ] ]
  347.    op memberp :v.word :in.list ]
  348.  
  349. make "anyof [
  350.    procedure [ [ :sen ] ]
  351.    op anyof1 :sen :in.list ]
  352.  
  353. make "anyof1 [
  354.    procedure [ [ :sen :pats ] ]
  355.    if emptyp :pats [ op false ] [ ]
  356.    if match first :pats :sen [ op true ] [ ]
  357.    op anyof1 :sen bf :pats ]
  358.  
  359.  
  360. ;  ******   Rules and responses   ******
  361.  
  362.  
  363. ;  Set up for doctor
  364.  
  365. make "setup [
  366.    procedure [ ]
  367.    make "memflag false
  368.    make "lastresort [
  369.       [ I AM NOT SURE I UNDERSTAND YOU FULLY. ]
  370.       [ PLEASE GO ON. ]
  371.       [ WHAT DOES THAT SUGEST TO YOU? ]
  372.       [ DO YOU FEEL STRONGLY ABOUT DISCUSSING SUCH THINGS? ] ]
  373.  
  374. ; * SETUP 1 *
  375.  
  376.    PPROP "SORRY "PRIORITY 0
  377.    ADDRULE "SORRY [ # ]
  378.    [  [ PLEASE DON'T APOLIGIZE. ]
  379.       [ WHAT FEELINGS DO YOU HAVE WHEN YOU APOLOGIZE? ]
  380.       [ APOLIGIES ARE NOT NECESSARY. ] ]
  381.  
  382.    PPROP "DONT "TRANSLATION "DON'T
  383.    PPROP "CANT "TRANSLATION "CAN'T
  384.    PPROP "WONT "TRANSLATION "WON'T
  385.  
  386.    PPROP "REMEMBER "PRIORITY 5
  387.    ADDRULE "REMEMBER [ # YOU REMEMBER #STUFF ]
  388.    [  [ DO YOU OFTEN THINK OF :STUFF? ]
  389.       [ DOES THINKING OF :STUFF BRING ANYTHING ELSE TO MIND? ]
  390.       [ WHY DO YOU REMBER :STUFF NOW? ]
  391.       [ WHAT NOW REMINDS YOU OF :STUFF? ]
  392.       [ WHAT ELSE DO YOU REMEMBER? ] ]
  393.    ADDRULE "REMEMBER [ # DO I REMEMBER :STUFF ]
  394.    [  [ DID YOU THINK I WOULD FORGET :STUFF? ]
  395.       [ WHY DO YOU THINK I SHOULD RECALL :STUFF NOW? ]
  396.       [ WHAT ABOUT :STUFF? ]
  397.       WHAT
  398.       [ YOU MENTIONED :STUFF. ] ]
  399.    ADDRULE "REMEMBER [ # ] [ NEWKEY ]
  400.  
  401.    PPROP "IF "PRIORITY 3
  402.    ADDRULE "IF [ #A IF #B HAD #C ]
  403.    [ [ PRE [ :A IF :B MIGHT HAVE :C ] IF ] ]
  404.    ADDRULE "IF [ # IF #STUFF ]
  405.    [  [ DO YOU THINK THAT :STUFF? ]
  406.       [ WHAT DO YOU THINK ABOUT :STUFF? ]
  407.       [ DO YOU WISH THAT :STUFF? ] ]
  408.  
  409.    PPROP "DREAMED "PRIORITY 4
  410.    ADDRULE "DREAMED [ # YOU DREAMED #STUFF ]
  411.    [  [ REALLY :STUFF? ]
  412.       [ HAVE YOU EVER FANTASIED :STUFF WHILE YOU WERE AWAKE? ]
  413.       [ HAVE YOU DREAMED :STUFF BEFORE? ]
  414.       DREAM
  415.       NEWKEY ]
  416.    ADDRULE "DREAMED [ # ]
  417.    [  DREAM
  418.       NEWKEY ]
  419.  
  420.    PPROP "DREAMT "TRANSLATION "DREAMED
  421.    PPROP "DREAMT "PRIORITY 4
  422.    PPROP "DREAMT "RULES [ DREAMED ]
  423.  
  424.    PPROP "DREAM "PRIORITY 3
  425.    ADDRULE "DREAM [ # ]
  426.    [  [ WHAT DOES THAT DREAM SUGGEST TO YOU. ]
  427.       [ DO YOU DREAM OFTEN? ]
  428.       NEWKEY ]
  429.  
  430.    PPROP "DREAMS "TRANSLATION "DREAM
  431.    PPROP "DREAMS "PRIORITY 3
  432.    PPROP "DREAMS "RULES [ DREAM ]
  433.  
  434.    PPROP "WHAT "PRIORITY 0
  435.    ADDRULE "WHAT [ !:IN [ WHAT WHERE ] # ] [ HOW ]
  436.    ADDRULE "WHAT [ # !A:IN [ WHAT WHERE ] #B ]
  437.    [  [ TELL ME ABOUT :A :B. ]
  438.       [ :A :B? ]
  439.       [ REALLY. ]
  440.       NEWKEY ]
  441.  
  442.    PPROP "ALIKE "PRIORITY 10
  443.    PPROP "ALIKE "RULES [ DIT ]
  444.  
  445.    PPROP "SAME "PRIORITY 10
  446.    PPROP "SAME "RULES [ DIT ]
  447.  
  448.    PPROP "CERTAINLY "PRIORITY 0
  449.    PPROP "CERTAINLY "RULES [ YES ]
  450.  
  451.    PPROP "FEEL "BELIEF "TRUE
  452.    PPROP "THINK "BELIEF "TRUE
  453.    PPROP "BELIEVE "BELIEF "TRUE
  454.    PPROP "WISH "BELIEF "TRUE
  455.    PPROP "BET "BELIEF "TRUE
  456.  
  457.    ADDMEMR "MY [ # YOUR &STUFF ]
  458.    [  [ EARLIER YOU SAID YOUR :STUFF. ]
  459.       [ BUT YOUR :STUFF. ]
  460.       [ DOES THAT HAVE ANYTHING TO DO WITH YOUR STATEMENT ABOUT :STUFF? ] ]
  461.  
  462.    PPROP "PERHAPS "PRIORITY 0
  463.    ADDRULE "PERHAPS [ # ]
  464.    [  [ YOU DON'T SEEM QUITE CERTAIN. ]
  465.       [ WHY THE USCERTAIN TONE? ]
  466.       [ DON'T YOU KNOW? ] ]
  467.  
  468.    PPROP "MAYBE "PRIORITY 0
  469.    PPROP "MAYBE "RULES [ PERHAPS ]
  470.  
  471.    PPROP "NAME "PRIORITY 15
  472.    ADDRULE "NAME [ # ]
  473.    [  [ I AM NOT INTERESTED IN NAMES. ]
  474.       [ I'VE TOLD YOU BEFORE I DON'T CARE ABOUT NAMES; PLEASE CONTINUE ] ]
  475.  
  476.  
  477.    PPROP "HELLO "PRIORITY 0
  478.    ADDRULE "HELLO [ # ]
  479.    [  [ HOW DO YOU DO. PLEASE STATE YOUR PROBLEM. ] ]
  480.  
  481.    PPROP "COMPUTER "PRIORITY 50
  482.    ADDRULE "COMPUTER [ # ]
  483.    [  [ DO COMPUTERS WORRY YOU? ]
  484.       [ WHY DO YOU MENTION COMPUTERS? ]
  485.       [ WHAT DO YOU THINK ABOUT MACHINES? ] ]
  486.  
  487.    PPROP "MACHINE "PRIORITY 50
  488.    PPROP "MACHINE "RULES [ COMPUTER ]
  489.  
  490.    PPROP "MACHINES "PRIORITY 50
  491.    PPROP "MACHINES "RULES [ COMPUTER ]
  492.  
  493.    PPROP "COMPUTERS "PRIORITY 50
  494.    PPROP "COMPUTERS "RULES [ COMPUTER ]
  495.  
  496.    PPROP "AM "PRIORITY 0
  497.    PPROP "AM "TRANSLATION "ARE
  498.  
  499. ; * SETUP 2 *
  500.  
  501.    ADDRULE "AM [ # ARE YOU #STUFF ]
  502.    [  [ DO YOU BELIVE YOU ARE :STUFF? ]
  503.       [ WOULD YOU WANT TO BE :STUFF? ]
  504.       [ WHAT WOULD IT MEAN IF YOU WERE :STUFF? ]
  505.       HOW ]
  506.    ADDRULE "AM [ # ]
  507.    [  [ WHY DO YOU SAY "AM"? ]
  508.       [ I DON'T UNDERSTAND THAT ] ]
  509.  
  510.    PPROP "ARE "PRIORITY 0
  511.    ADDRULE "ARE [ #A THERE ARE #B YOU #C ]
  512.    [  [ PRE [ :A THERE ARE :B ] ARE ] ]
  513.    ADDRULE "ARE [ # THERE ARE &STUFF ]
  514.    [  [ WHAT MAKES YOU THINK THERE ARE :STUFF? ]
  515.       [ DO YOU WISH THERE WERE :STUFF? ] ]
  516.    ADDRULE "ARE [ # ARE I #STUFF ]
  517.    [  [ WHY ARE YOU INTERESTED IN WETHER I AM :STUFF OR NOT? ]
  518.       [ WOULD YOU PREFER IF I WEREN'T :STUFF? ]
  519.       HOW ]
  520.    ADDRULE "ARE [ ARE # ]
  521.    [  HOW ]
  522.    ADDRULE "ARE [ # ARE #STUFF ]
  523.    [  [ DID YOU TRHINK THEY MIGHT NOT BE :STUFF? ]
  524.       [ POSSIBLY THEY ARE :STUFF. ] ]
  525.  
  526.    PPROP "YOUR "PRIORITY 0
  527.    PPROP "YOUR "TRANSLATION "MY
  528.    ADDRULE "YOUR [ # MY #STUFF ]
  529.    [  [ WHY ARE YOU CONCERNED OVER MY :STUFF? ]
  530.       [ WHAT ABOUT YOUR OWN :STUFF? ]
  531.       [ ARE YOU WORRIED ABOUT SOMEONE ELSE'S :STUFF? ]
  532.       [ REALLY, MY :STUFF? ] ]
  533.  
  534.    PPROP "WAS "PRIORITY 2
  535.    ADDRULE "WAS [ # WAS YOU #STUFF ]
  536.    [  [ WHAT IF YOU WERE :STUFF? ]
  537.       [ WHAT DOES " :STUFF " SUGGEST TO YOU? ]
  538.       HOW ]
  539.    ADDRULE "WAS [ # YOU WAS #STUFF ]
  540.    [  [ WERE YOU REALLY? ]
  541.       [ PERHAPS I ALREADY KNEW YOU WERE :STUFF? ] ]
  542.    ADDRULE "WAS [ # WAS I #STUFF ]
  543.    [  [ WOULD YOU LIKE TO BELIEVE I WAS :STUFF? ]
  544.       [ WHAT IF I HAD BEEN :STUFF? ] ]
  545.    ADDRULE "WAS [ # ] [ NEWKEY ]
  546.  
  547.    PPROP "WERE "PRIORITY 0
  548.    PPROP "WERE "TRANSLATION "WAS
  549.    PPROP "WERE "RULES [ WAS ]
  550.  
  551.    PPROP "ME "TRANSLATION "YOU
  552.  
  553.    PPROP "YOU'RE "PRIORITY 0
  554.    PPROP "YOU'RE "TRANSLATION "I'M
  555.    ADDRULE "YOU'RE [ # I'M #STUFF ]
  556.    [  [ PRE [ I ARE :STUFF ] YOU ] ]
  557.  
  558.    PPROP "I'M "PRIORITY 0
  559.    PPROP "I'M "TRANSLATION "YOU'RE
  560.    ADDRULE "I'M [ # YOU'RE #STUFF ]
  561.    [  [ PRE [ YOU ARE :STUFF ] I ] ]
  562.  
  563.    PPROP "MYSELF "TRANSLATION "YOURSELF
  564.    PPROP "YOURSELF "TRANSLATION "MYSELF
  565.  
  566.    PPROP "MOTHER "FAMILY "TRUE
  567.    PPROP "MOM "TRANSLATION "MOTHER
  568.    PPROP "MOM "FAMILY "TRUE
  569.    PPROP "MOMMY "TRANSLATION "MOTHER
  570.    PPROP "MOMMY "FAMILY "TRUE
  571.  
  572.    PPROP "FATHER "FAMILY "TRUE
  573.    PPROP "DAD "TRANSLATION "FATHER
  574.    PPROP "DAD "FAMILY "TRUE
  575.    PPROP "DADDY "TRANSLATION "FATHER
  576.    PPROP "DADDY "FAMILY "TRUE
  577.  
  578.    PPROP "SISTER "FAMILY "TRUE
  579.    PPROP "BROTHER "FAMILY "TRUE
  580.    PPROP "HUSBAND "FAMILY "TRUE
  581.    PPROP "WIFE "FAMILY "TRUE
  582.    PPROP "CHILDREN "FAMILY "TRUE
  583.  
  584.    PPROP "I "PRIORITY 0
  585.    PPROP "I "TRANSLATION "YOU
  586.    ADDRULE "I [ # YOU !:IN [ WANT NEED ] #STUFF ]
  587.    [  [ WHAT WOULD IT MEAN TO YOU IF YOU GOT :STUFF? ]
  588.       [ WHY DO YOU WANT :STUFF? ]
  589.       [ I SUSPECT YOU REALLY DON'T WANT :STUFF. ] ]
  590.    ADDRULE "I [ # YOU ARE # !STUFF:IN [ SAD UNHAPPY DEPRESSED SICK ] # ]
  591.    [  [ I'M SORRY TO HEAR YOU ARE :STUFF. ]
  592.       [ DO YOU THINK I CAN HELP YOU NOT TO BE :STUFF? ]
  593.       [ PLEASE GO ON. ] ]
  594.    ADDRULE "I [ # YOU ARE # !STUFF:IN [ HAPPY ELATED GLAD BETTER ] # ]
  595.    [  [ HOW HAVE I HELPED YOU TO BE :STUFF? ]
  596.       [ WHAT MAKES YOU :STUFF JUST NOW? ]
  597.       [ WHAT DO YOU MEAN BY :STUFF? ] ]
  598.    ADDRULE "I [ # YOU WAS # ]
  599.    [  WAS ]
  600.    ADDRULE "I [ # YOU !:BELIEFP YOU #STUFF ]
  601.    [  [ DO YOU REALLY THINK SO? ]
  602.       [ DO YOU REALLY DOUBT YOU :STUFF? ] ]
  603.    ADDRULE "I [ # YOU # !:BELIEFP # I # ]
  604.    [  YOU ]
  605.    ADDRULE "I [ # YOU ARE #STUFF ]
  606.    [  [ IS IT BECAUSE YOU ARE :STUFF THAT YOU CAME TO ME? ]
  607.       [ DO YOU ENJOY BEING :STUFF? ] ]
  608.    ADDRULE "I [ # YOU !:IN [ CAN'T CANNOT ] #STUFF ]
  609.    [  [ HOW DO YOU KNOW YOU CAN'T :STUFF? ]
  610.       [ DO YOU REALLY WANT TO BE ABLE TO :STUFF? ] ]
  611.  
  612. ; * SETUP 3 *
  613.  
  614.    ADDRULE "I [ YOU DON'T #STUFF ]
  615.    [  [ DON'T YOU REALLY :STUFF? ]
  616.       [ WHY DON'T YOU :STUFF? ]
  617.       [ DOES THAT TROUBLE YOU? ] ]
  618.    ADDRULE "I [ # YOU FEEL #STUFF ]
  619.    [  [ TELL ME MORE ABOUT SUCH FEELINGS. ]
  620.       [ OF WHAT DOES FEELING :STUFF REMIND YOU? ] ]
  621.    ADDRULE "I [ # YOU #STUFF I # ]
  622.    [  [ PERHAPS IN YOUR FANTASY WE :STUFF EACH OTHER. ]
  623.       [ DO YOU WISH TO :STUFF ME? ]
  624.       [ DO YOU :STUFF ANYONE ELSE? ] ]
  625.    ADDRULE "I [ #STUFF ]
  626.    [  [ YOU SAY :STUFF. ]
  627.       [ DO YOU SAY :STUFF FOR SOME SPECIAL REASON? ] ]
  628.  
  629.    PPROP "YOU "PRIORITY 0
  630.    PPROP "YOU "TRANSLATION "I
  631.    ADDRULE "YOU [ # I REMIND YOU OF # ]
  632.    [  DIT ]
  633.    ADDRULE "YOU [ # I ARE # YOU # ]
  634.    [  NEWKEY ]
  635.    ADDRULE "YOU [ # I ARE #STUFF ]
  636.    [  [ WHAT MAKES YOU THINK I AM :STUFF? ]
  637.       [ DO YOU SOMETIMES WISH YOU WERE :STUFF? ] ]
  638.    ADDRULE "YOU [ # I #STUFF YOU ]
  639.    [  [ WHY DO YOU THINK I :STUFF YOU? ]
  640.       [ DOES SOMEONE ELSE BELIEVE I :STUFF YOU? ] ]
  641.    ADDRULE "YOU [ # I &STUFF ]
  642.    [  [ WE WERE DISCUSSING YOU, NOT ME. ]
  643.       [ OH, I :STUFF? ]
  644.       [ DO YOU :STUFF? ]
  645.       [ WHAT ARE YOUR FEELINGS NOW? ] ]
  646.    ADDRULE "YOU [ # ]
  647.    [  NEWKEY ]
  648.  
  649.    PPROP "WE "TRANSLATION "YOU
  650.    PPROP "WE "PRIORITY 0
  651.    PPROP "WE "RULES [ I ]
  652.  
  653.    PPROP "XXYYZZ "PRIORITY 0
  654.    ADDRULE "XXYYZZ [ # ]
  655.    [  [ YOU'RE BEING SOMEWHAT SHORT WITH ME. ]
  656.       [ PERHAPS YOU'D RATHER TALK ABOUT SOMETHING ELSE. ]
  657.       NEWKEY ]
  658.  
  659.    PPROP "YES "PRIORITY 0
  660.    ADDRULE "YES [ YES ]
  661.    [  XXYYZZ [ PREE [ X YES ] YES ] ]
  662.    ADDRULE "YES [ # ]
  663.    [  [ YOU SEEM QUITE POSITIVE. ]
  664.       [ I SEE. ]
  665.       NEWKEY ]
  666.  
  667.    PPROP "NO "PRIORITY 0
  668.    ADDRULE "NO [ NO ]
  669.    [  XXYYZZ [ PRE [ X NO ] NO ] ]
  670.    ADDRULE "NO [ # ]
  671.    [  [ ARE YOU SAYING "NO" JUST TO BE NEGATIVE? ]
  672.       [ WHY NOT? ]
  673.       NEWKEY ]
  674.  
  675.    PPROP "MY "PRIORITY 2
  676.    PPROP "MY "TRANSLATION "YOUR
  677.    ADDRULE "MY [ # YOUR # !A:FAMILYP #B ]
  678.    [  [ TEL ME MORE ABOUT YOUR FAMILY. ]
  679.       [ WHAT ELSE COMES TO MIND WHEN YOU THINK OF YOUR :A? ] ]
  680.    ADDRULE "MY [ # YOUR &STUFF ]
  681.    [  [ YOUR :STUFF? ]
  682.       [ IS IT IMPORTANT TO YOU THAT YOUR :STUFF? ] ]
  683.    ADDRULE "MY [ # ]
  684.    [  NEWKEY ]
  685.  
  686.    PPROP "CAN "PRIORITY 0
  687.    ADDRULE "CAN [ # CAN I #STUFF ]
  688.    [  [ YOU BELIEVE I CAN :STUFF, DON'T YOU? ]
  689.       HOW
  690.       [ PERHAPS YOU WOULD LIKE TO BE ABLE TO :STUFF YOURSELF. ] ]
  691.    ADDRULE "CAN [ # CAN YOU #STUFF ]
  692.    [  [ WETHER OR NOT YOU CAN :STUFF DEPENDS MORE ON YOU THAN ON ME. ]
  693.       [ PERHAPS YOU DON'T WANT TO BE ABLE TO :STUFF? ]
  694.       HOW ]
  695.    ADDRULE "CAN [ # ]
  696.    [  HOW
  697.       NEWKEY ]
  698.  
  699.    PPROP "IS "PRIORITY 0
  700.    ADDRULE "IS [ &A IS &B ]
  701.    [  [ SUPPOSE :A WERE NOT :B. ]
  702.       [ PERHAPS :A REALLY IS :B. ]
  703.       [ TELL ME MORE ABOUT :A. ] ]
  704.    ADDRULE "IS [ # ]
  705.    [  NEWKEY ]
  706.  
  707.    PPROP "WHERE "PRIORITY 0
  708.    PPROP "WHERE "RULES [ HOW ]
  709.  
  710.    PPROP "HOW "PRIORITY 0
  711.    ADDRULE "HOW [ # ]
  712.    [  [ WHY DO YOU ASK? ]
  713.       [ DOES THAT QUSTION INTEREST YOU? ]
  714.       [ WHAT DO YOU THINK? ]
  715.       [ HAVE YOU ASKED ANYONE ELSE? ] ]
  716.  
  717.    PPROP "BECAUSE "PRIORITY 0
  718.    ADDRULE "BECAUSE [ # ]
  719.    [  [ IS THAT THE REAL REASON? ]
  720.       [ YOUR NOT CONCEALING ANYTHING FROM ME, ARE YOU? ] ]
  721.  
  722.    PPROP "WHY "PRIORITY 0
  723.    ADDRULE "WHY [ # WHY DON'T I #STUFF ]
  724.    [  [ DO YOU BELIEVE I DON'T :STUFF? ]
  725.       [ YOU SHOULD :STUFF YOURSELF? ]
  726.       [ YOU WANT ME TO :STUFF? ]
  727.       HOW ]
  728.  
  729. ; * SETUP 4 *
  730.  
  731.    ADDRULE "WHY [ # WHY CAN'T YOU #STUFF ]
  732.    [  [ DO YOU THINK YOU SHOULD BE ABLE TO :STUFF? ]
  733.       [ HAVE YOU ANY IDEA WHY YOU CAN'T :STUFF? ]
  734.       HOW ]
  735.    ADDRULE "WHY [ # ]
  736.    [  [ WHY INDEED? ]
  737.       [ WHY "WHY"? ]
  738.       [ WHY NOT? ]
  739.       HOW
  740.       NEWKEY ]
  741.  
  742.    PPROP "EVERYONE "PRIORITY 2
  743.    ADDRULE "EVERYONE [ # !A:IN [ EVERYONE EVERYBODY NOBODY NOONE ] # ]
  744.    [  [ REALLY, :A? ]
  745.       [ SURELY NOT :A. ]
  746.       [ CAN YOU THINK OF ANYONE IN PARTICULAR? ]
  747.       [ I SUSPECT YOU'RE EXAGGERATING A LITTLE. ] ]
  748.  
  749.    PPROP "EVERYBODY "PRIORITY 2
  750.    PPROP "EVERYBODY "RULES [ EVERYONE ]
  751.  
  752.    PPROP "NOBODY "PRIORITY 2
  753.    PPROP "NOBODY "RULES [ EVERYONE ]
  754.  
  755.    PPROP "NOONE "PRIORITY 2
  756.    PPROP "NOONE "RULES [ EVERYONE ]
  757.  
  758.    PPROP "ALWAYS "PRIORITY 1
  759.    ADDRULE "ALWAYS [ # ]
  760.    [  [ CAN YOU THINK OF A SPECIFIC EXAMPLE? ]
  761.       [ WHEN? ]
  762.       [ WHAT IF THIS NEVER HAPPENED? ] ]
  763.  
  764.    PPROP "LIKE "PRIORITY 10
  765.    ADDRULE "LIKE [ # !:IN [ AM IS ARE WAS ] # LIKE # ]
  766.    [  DIT ]
  767.    ADDRULE "LIKE [ # ]
  768.    [  NEWKEY ]
  769.  
  770.    ADDRULE "DIT [ # ]
  771.    [  [ IN WHAT WAY? ]
  772.       [ WHAT RESENBLANCE DO YOU SEE? ]
  773.       [ COULD THERE REALLY BE SOME CONNECTION? ]
  774.       HOW ]
  775.  
  776.    PPROP "PROBLEM "PRIORITY 5
  777.    ADDRULE "PROBLEM
  778.    [ #A !B:IN [ IS ARE ] YOUR !C:IN [ PROBLEM PROBLEMS ] # ]
  779.    [  [ :A :B YOUR :C. ]
  780.       [ ARE YOU SURE :A :B YOUR :C. ]
  781.       [ DO YOU OFTEN THINK ABOUT :A? ] ]
  782.    ADDRULE "PROBLEM
  783.    [ # YOUR !A:IN [ PROBLEM PROBLEMS ] !B:IN [ IS ARE ] #C ]
  784.    [  [ YOUR :A :B :C? ]
  785.       [ ARE YOU SURE YOUR :A :B :C? ]
  786.       [ YOU THINK YOU HAVE PROBLEMS? ] ]
  787.    ADDRULE "PROBLEM [ # ]
  788.    [  [ PLEASE CONTINUE, THIS MAY BE INTERESTING. ]
  789.       [ YOU SEEM A BIT UNEASY. ]
  790.       NEWKEY ]
  791.  
  792.    PPROP "PROBLEMS "PRIORITY 5
  793.    PPROP "PROBLEMS "RULES [ PROBLEM ]
  794.  
  795.    ADDMEMR "PROBLEM [ #STUFF IS YOUR PROBLEM # ]
  796.    [  [ EARLIER YOU MENTIONED :STUFF. ]
  797.       [ TELL ME MORE ABOUT :STUFF. ]
  798.       [ YOU HAVEN'T MENTIONED :STUFF FOR A WHILE. ] ]
  799.  
  800.    PPROP "ASK "PRIORITY 0
  801.    ADDRULE "ASK [ # YOU ASK # ]
  802.    [  HOW ]
  803.    ADDRULE "ASK [ # YOU ! ASKING # ]
  804.    [  HOW ]
  805.    ADDRULE "ASK [ # I # ]
  806.    [  YOU ]
  807.    ADDRULE "ASK [ # ]
  808.    [  NEWKEY ]
  809.  
  810.    ] ; *** end of setup ***
  811.  
  812. ;  Adding rules
  813.  
  814. make "ADDRULE [
  815.    procedure [ [ :v.word :pattern :results ] [ ] [ :propname ] ]
  816.    make "propname gensym
  817.    pprop :v.word "RULES ( se gprop :v.word "RULES list :pattern :propname )
  818.    pprop :v.word :propname :results ]
  819.  
  820. make "ADDMEMR [
  821.    procedure [ [ :v.word :pattern :results ] [ ] [ :propname ] ]
  822.    make "propname gensym
  823.    pprop :v.word "MEMR ( se gprop :v.word "MEMR list :pattern :propname )
  824.    pprop :v.word :propname :results ]
  825.  
  826. make "gensym [
  827.    procedure [ ]
  828.    if not namep "gensym.number [ make "gensym.number 0 ] [ ]
  829.    make "gensym.number + 1 :gensym.number
  830.    op word "g :gensym.number ]
  831.  
  832. make "PPROP [
  833.    procedure [ [ :a :b :c ] ]
  834.    if equalp :c "TRUE [ make "c true ] [ ]
  835.    pprop :a :b :c ]
  836.  
  837. ;  Do setup
  838.  
  839. pr [ ]
  840. pr [ Running setup for doctor. ]
  841. pr [ ]
  842. setup
  843. erase [ setup ADDRULE ADDMEMR gensym PPROP ]
  844. pr [ Setup for doctor is complete. ]
  845. pr [ ]
  846. pr [ Give the command "doctor" to see it run. ]
  847. pr [ ]
  848.  
  849.