Re: Expert systems in forth

Here, I used ternary logic.
I defined these words:
\ 3-valued logic
254 value T \ true
127 value U \ unknown
0   value F \ false
\ lv : logic value : T, U or F
: not 0= ;
: not3 ( lv -- lv) T swap - ;
: and3 ( lv lv -- lv )  min ;
: or3 ( lv lv -- lv ) max ;
: imply3 ( lv lv -- lv)
    2dup
    T = swap T = or if 2drop T exit then
    F = swap F = or if       F exit then
    U
;
and used them.
The new version of expert_systems.fs is hereafter:
--------------- The code begins here-------------------
 \ expert system inference engin
\ forward and backward chainings
\ for iForth, vfxForth
\ false [if]
  : place  over >r rot over 1+ r> move c! ;
  : +place 2dup c@ dup >r + over c! r> 1+ + swap move ;
  : 0>= dup 0> swap 0= or ;
\ [then]
\ 3-valued logic
254 value T \ true
127 value U \ unknown
0   value F \ false
\ lv : logic value : T, U or F
: not 0= ;
: not3 ( lv -- lv) T swap - ;
: and3 ( lv lv -- lv )  min ;
: or3 ( lv lv -- lv ) max ;
: imply3 ( lv lv -- lv)
    2dup
    T = swap T = or if 2drop T exit then
    F = swap F = or if       F exit then
    U
;
\
100 constant max_num_facts
100 constant max_num_rules
255 constant rules_text_max_length
5  constant num_passes
create facts_list max_num_facts cells allot
create rules_base max_num_rules cells allot
create rules_text max_num_rules rules_text_max_length * allot
variable num_rules 0 num_rules !
variable num_facts 0 num_facts !
: >facts_list ' 16 + facts_list num_facts @ cells + ! 1 num_facts +! ;
: current_rule_position
    rules_text num_rules @
    rules_text_max_length * +
    rules_base num_rules @ cells +
;
: current_rule_text_position   current_rule_position drop ;
: current_rule_base_position   current_rule_position nip ;
: >rule_base                   current_rule_position ! ;
: >rule_text     ( a n -- )    current_rule_text_position place ;
: >rules                       >rule_text >rule_base 1 num_rules +! ;
: .rule
    dup 0>= over num_rules @ < and if
      dup cr ." Rule n°:" . ." :    "
      cells rules_base + @ count type
    else
      cr ." Not defined yet!"
    then
;
: .rules
    num_rules @ 0 ?do
      i .rule
    loop
;
: th_rule
    dup 0>=
    over num_rules @ <
    and if
      cells rules_base + @
      count
    else
      cr ." Not defined yet!"
    then
;
: th_rule_use  th_rule evaluate ;
: th_rule_position
    dup 0>=
    over num_rules @ <
    and if
      dup
      rules_text_max_length * rules_text +
      swap cells rules_base +
    else
      cr abort" This rules is not defined yet!!!"
    then
;
: th_rule_text_position   th_rule_position drop ;
: th_rule_base_position   th_rule_position nip ;
: >th_rule_base           th_rule_position ! ;
: >th_rule_text ( a n i -- )    th_rule_text_position place ;
: >th_rule                dup >r >th_rule_text r> >th_rule_base ;
: all_rules_use_one_pass  num_rules @ 0 do i th_rule_use loop ;
: (->?)                   num_passes 0 do all_rules_use_one_pass loop ;
create _name_ 256 allot
create _create_fact_ 256 allot
: get_name bl word count _name_ place ;
: fact
    s" create " _create_fact_ place
    get_name
    _name_ count _create_fact_ +place
    _create_fact_ count evaluate
    here
    dup facts_list num_facts @ cells + ! 1 num_facts +!
    dup false swap c! \ for used
    dup U swap 1+ c! \ for truth value: U, F or T, initialized to U
    256 allot \ for name
    _name_ count rot 2 + place \ place name
    256 allot \ action
    256 allot \ text
;
: facts 0 do fact loop ;
: used>fact   ( used fact --)    c! ;
: uft>fact    ( uft fact -- )    1+ c! ;
: name>fact   ( "name" fact -- ) 2 + parse-name rot place ;
: action>fact ( a n fact -- )    2 + 256 + place ;
: text>fact   ( a n fact -- )    2 + 256 + 256 + place ;
: fact_used ( fact -- used) c@ ;
: fact_uft  ( fact -- uft )  1+ c@ ;
: fact_name ( fact -- a n ) 2 + count ;
: fact_action ( fact -- a n ) 2 + 256 + count ;
: fact_text ( fact -- a n ) 2 + 256 + 256 + count ;
: .uft ( uft -- )
    dup
    U = if s" unknown" type drop exit then
    F = if s" false"  type      exit then
    s" true" type
;
: .fact_used    ( fact -- ) fact_used  .uft  ;
: .fact_uft    ( fact -- ) fact_uft   .uft  ;
: .fact_name    ( fact -- ) fact_name type ;
: .fact_action ( fact -- ) fact_action type ;
: .fact_text  ( fact -- ) fact_text type ;
: .fact_name_action    ( fact -- )
    dup ." -> " .fact_name ."  : '" .fact_action ." '" cr
;
: .fact_name_text    ( fact -- )
    dup ." -> " .fact_name ."  : '" .fact_text ." '" cr
;
: .fact_name_action_text_uft ( fact -- )
     cr ." -> "           dup .fact_name   ." : "
     cr ."     action: "  dup .fact_action
     cr ."     text: "    dup .fact_text
     cr ."     u/f/t: "       .fact_uft
     cr
;
: .fact_name_action_text ( fact -- )
     cr ." -> "           dup .fact_name   ." : "
     cr ."     action: "  dup .fact_action
     cr ."     text: "        .fact_text
     cr
;
: .fact        ( fact -- ) .fact_name_action_text_uft ;
: .true_fact   ( fact -- ) .fact_name_action_text ;
: th_fact ( n -- fact) cells facts_list + @ ;
: .th_fact ( n -- )     th_fact .fact ;
: .th_true_fact ( n -- )     th_fact .true_fact ;
: .all_facts cr num_facts @ 0 do i .th_fact loop ;
: .facts
    cr
    num_facts @ 0 do
      i th_fact fact_uft T = if
        i .th_true_fact
      then
    loop
;
: assert T  swap uft>fact ;
: retract F  swap uft>fact ;
: unknown       U  swap uft>fact ;
: clear_facts
    cr num_facts @ 1 do
   i th_fact unknown
   false i th_fact used>fact
loop
;
3 facts true_fact false_fact unknown_fact
true_fact    assert
false_fact   retract
unknown_fact unknown
4 facts not_fact and_fact or_fact xor_fact
: notfact ( fact -- fact)
    fact_uft not3
    not_fact uft>fact
    not_fact
;
: andfact ( fact1 fact2)  fact_uft swap fact_uft and3 and_fact uft>fact
and_fact ;
: orfact  ( fact1 fact2)  fact_uft swap fact_uft or3  or_fact  uft>fact
or_fact  ;
: variables 0 do variable loop ;
3 variables _:-   _,  _.;
: :- _:- @ execute ;
: ,  _,  @ execute ;
: .; _.; @ execute ;
3 variables f_:- f_, f_.;
4 variables b_:- b_, b__, b_.;
3 variables v_:-  v_,  v_.;
3 variables up_:- up_, up_.;
3 variables us_:- us_, us_.;
: forward_:- ( fact -- fact true) T ;
: backward_:- ( fact -- fact u/f/t)
    dup fact_uft ( not3)
    T = if U else T then
;
: forward_, ( fact u/f/t fact -- fact u/f/t ) fact_uft and3 ;
: backward_, ( fact u/f/t fact --fact u/f/t)
   >r >r
   dup fact_uft dup F = swap U = or3
   r> r>
   rot T <> if
     dup fact_used not if
       dup fact_uft T = if
         fact_uft and3
       else
         dup
         cr ."   verify:  " fact_name type
true over used>fact
         fact_uft and3
       then
     else
       fact_uft and3
     then
   else
     drop
   then
;
: forward_.;  ( fact u/f/t fact --) , over fact_uft imply3 swap uft>fact
;
: backward_.; ( fact u/f/t fact --) , over fact_uft imply3 swap uft>fact
;
: (:-?) ( fact --)
   num_rules @ 0 do
     dup fact_name
     i th_rule drop over
     compare 0= if
       cr ." rule: " i .
       i th_rule evaluate
       dup fact_uft
       T = if dup cr fact_name type ."  yes."    then
     then
   loop
   drop
   clear_facts
;
create inference_mode 16 allot
: f_mode s" forward" inference_mode place ;
: b_mode s" backward" inference_mode place ;
: .mode inference_mode count type ;
' forward_:-  f_:- ! ' forward_,   f_, ! ' forward_.;  f_.; !
' backward_:- b_:- ! ' backward_,  b_, ! ' backward_.; b_.; !
: forward_mode   f_:- @ _:- ! f_, @ _, ! f_.; @ _.; ! f_mode ;
: backward_mode  b_:- @ _:- ! b_, @ _, ! b_.; @ _.; ! b_mode ;
backward_mode
: :-? clear_facts backward_mode (:-?) ;
: ->? forward_mode  (->?) ;
: yes     assert ;
: no      retract ;
\ : uknown  unkown  ;
: do-it ( fact -- )
   dup fact_uft T =
   over fact_action nip
   0<> and   if
     fact_action evaluate
   else
     drop
   then
;
: apply_actions num_facts @ 0 do i th_fact do-it loop ;
: .result         ->? apply_actions ( clear_facts) ;
: .partial_result ->? apply_actions ;
create xxx 256 allot
create xxxbuff 256 allot
defer <-?
: <-?_by_facts
    num_facts @ 6 do
      cr
      i th_fact fact_name type
  i th_fact fact_name xxx place
  s"   " xxx +place
      ."  <--- " xxxbuff 1+ 255 accept xxxbuff c!
  xxxbuff count
  0= if
    0 xxx c!
  else
    xxxbuff count xxx +place
  then
  drop
      xxx count evaluate
    loop
    cr .result
;
' <-?_by_facts is <-?
: verify_fact ( fact --)
    dup >r
fact_name xxx place
s"   " xxx +place
    ."  <--- " xxxbuff 1+ 255 accept xxxbuff c!
xxxbuff count
0= if
  0 xxx c!
else
  xxxbuff count xxx +place
then
drop
xxx count r> fact_action drop 1- place
;
: backward__, ( fact u/f/t fact --fact u/f/t)
   >r >r
   dup fact_uft dup F = swap U = or3
   r> r>
   rot T <> if
     dup fact_used not if
       dup fact_uft U <> if
         fact_uft and3
       else
         dup
         cr ."   verify:  " fact_name type
         dup verify_fact
     true over used>fact
     fact_uft and3
       then
     else
       fact_uft and3
     then
   else
     drop
   then
;
' backward_:- b_:- ! ' backward__, b__, ! ' backward_.; b_.; !
: backward_mode  b_:- @ _:- ! b_, @ _,  ! b_.; @ _.; ! b_mode ;
backward_mode
: verify_:- backward_:- ;
: verify_,  backward__, ;
: verify_.; backward_.; ;
: update_:- drop ;
: update_,  fact_action evaluate ;
: update_.; update_, ;
: use_:- backward_:- ;
: use_,  ( fact u/f/t fact --fact u/f/t)
   >r >r
   dup fact_uft dup F = swap U = or3
   r> r>
   rot T <> if
     fact_uft and3
   else
     drop
   then
;
: use_.; backward_.; ;
' verify_:- v_:-  ! ' verify_, v_,  ! ' verify_.; v_.;  !
' update_:- up_:- ! ' update_, up_, ! ' update_.; up_.; !
' use_:-    us_:- ! ' use_,    us_, ! ' use_.;    us_.; !
: verify v_:-  @ _:- ! v_,  @ _, ! v_.;  @ _.; ! ;
: update up_:- @ _:- ! up_, @ _, ! up_.; @ _.; ! ;
: use    us_:- @ _:- ! us_, @ _, ! us_.; @ _.; ! ;
: verify_facts verify evaluate ;
: update_facts update evaluate ;
: use_facts    use    evaluate ;
0 value k
: <-?_by_rules
    clear_facts
    2 0 do i to k
      num_rules @ 0 do
        num_facts @ 6 do
          i th_fact fact_name
  j th_rule drop over
  compare 0= if
            j th_rule verify_facts
    j th_rule update_facts
    j th_rule use_facts
    i th_fact fact_uft T = if
      cr ." apparently, " .partial_result cr
      k 1 = if
        cr ." final result:"
                cr ." -------------"
                cr ." finally, " .result unloop unloop unloop exit
              then
            then
          then
        loop
      loop
    loop
    cr ." No results!"
;
' <-?_by_rules is <-?
----- The code terminates here
The user can respond by: yes, no or unknown.
An empty response is considered as unknown.
Ahmed
--