Re: Expert systems in forth

And the expert_systems.fs file:
\ 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]
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 false swap 1+ c! \ for tf
    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! ;
: tf>fact  ( tf 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_tf  ( fact -- tf )  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 ;
: .tf     ( tf -- )   if s" true " else s" false" then type ;
: .fact_used    ( fact -- ) fact_used .tf  ;
: .fact_tf    ( fact -- ) fact_tf   .tf  ;
: .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_tf ( fact -- )
     cr ." -> "           dup .fact_name   ." : "
     cr ."     action: "  dup .fact_action
     cr ."     text: "    dup .fact_text
     cr ."     t/f: "         .fact_tf
     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_tf ;
: .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_tf if
        i .th_true_fact
      then
    loop
;
: assert true  swap tf>fact ;
: retract false swap tf>fact ;
: clear_facts
    cr num_facts @ 1 do
   i th_fact retract
   false i th_fact used>fact
loop
;
2 facts true_fact false_fact
true_fact  assert
false_fact retract
4 facts not_fact and_fact or_fact xor_fact
: not 0= ;
: notfact ( fact -- fact) fact_tf              not not_fact tf>fact
not_fact ;
: andfact ( fact1 fact2)  fact_tf swap fact_tf and and_fact tf>fact
and_fact ;
: orfact  ( fact1 fact2)  fact_tf swap fact_tf or  or_fact  tf>fact
or_fact  ;
: xorfact ( fact1 fact2)  fact_tf swap fact_tf xor xor_fact tf>fact
xor_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) true ;
: backward_:- ( fact -- fact t/f)
    dup fact_tf if
      false
    else
      true
    then
;
: forward_, ( fact t/f fact -- fact t/f ) fact_tf and ;
: backward_, ( fact t/f fact --fact t/f)
   >r >r
   dup fact_tf 0=
   r> r>
   rot if
     dup fact_used 0= if
       dup fact_tf if
         fact_tf and
       else
         dup
         cr ."   verify:  " fact_name type
     true over used>fact
         fact_tf and
       then
else
   fact_tf and
then
   else
     drop
   then
;
: forward_.;  ( fact t/f fact --) , over fact_tf or swap tf>fact ;
: backward_.; ( fact t/f fact --) , over fact_tf or swap tf>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_tf 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
: :-? backward_mode (:-?) ;
: ->? forward_mode  (->?) ;
: yes assert ;
: no  retract ;
: do-it
   dup fact_tf
   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 t/f fact --fact t/f)
   >r >r
   dup fact_tf 0=
   r> r>
   rot if
     dup fact_used 0= if
       dup fact_tf if
         fact_tf and
       else
         dup
         cr ."   verify:  " fact_name type
         dup verify_fact
     true over used>fact
     fact_tf and
       then
else
   fact_tf and
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 t/f fact --fact t/f)
   >r >r
   dup fact_tf 0=
   r> r>
   rot if
     fact_tf and
   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_tf 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 <-?
Ahmed
--