Path: ...!weretis.net!feeder9.news.weretis.net!news.nk.ca!rocksolid2!i2pn2.org!.POSTED!not-for-mail
From: melahi_ahmed@yahoo.fr (ahmed)
Newsgroups: comp.lang.forth
Subject: Re: Expert systems in forth
Date: Sat, 4 Jan 2025 11:42:38 +0000
Organization: novaBBS
Message-ID: <b535bfcb55635df60139b1842074ebc4@www.novabbs.com>
References: <069d1724f6056b4c36d9e1ffaa3d606d@www.novabbs.com> <a489c8f27620718e4eb53a7fd349040e@www.novabbs.com>
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8; format=flowed
Content-Transfer-Encoding: 8bit
Injection-Info: i2pn2.org;
	logging-data="1963614"; mail-complaints-to="usenet@i2pn2.org";
	posting-account="t+/9LUKLIiUqIe6reyFE7me/EcA/Gr17dRXgwnADesE";
User-Agent: Rocksolid Light
X-Spam-Checker-Version: SpamAssassin 4.0.0
X-Rslight-Site: $2y$10$xqzFsDKNaAN1u1DurpOCFeHVmFKRIEa7TCPpSRAFrGhSqzPdyvCwq
X-Rslight-Posting-User: 5f6b2e70af503e44dad56966aa15d35bdef29623
Bytes: 10903
Lines: 426

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
;
========== REMAINDER OF ARTICLE TRUNCATED ==========