Expert systems in forth

[ahmed]

Hi,
For my course, I've written a "Expert System Inference Engine":
expert_systems.fs.
It works (and tested) under gforth, iForth anf vfxForth.

Here is a session using it with a simple "animal data base": animal.fs.

1. What is necessary for the animal to be a zebra?
--------------------------------------------------
zebra :-?
rule: 15
verify: herbivore
verify: ungulate
verify: black-stripes
ok

2. What is necessary for the animal to be a penguin?
-----------------------------------------------------
penguin :-?
rule: 9
verify: swim
verify: black&white
verify: bird
ok

3. Assert the conditions for the animal to be a penguin:
------------------------------------------------------
swim yes ok
black&white yes ok
bird yes ok
ok

4. Forward chaining (using these asserted facts):
-------------------------------------------------
->? ok
result
It is a penguin. ok

5. Type the facts that are true:
-------------------------------
facts

-> true_fact:
action: ''
text:

-> not_fact:
action: ''
text:

-> swim:
action: ''
text:

-> bird:
action: ''
text:

-> black&white:
action: ''
text:

-> penguin:
action: '_penguin_ cr type'
text:
ok

6. Clear facts (true facts will be false):
-------------------------------------
clear_facts
ok

7. Verify that (the true_fact is always true):
----------------------------------------------
facts

-> true_fact:
action: ''
text:
ok

8. Backward chaining:
---------------------
<-?

verify: feathers <--- yes
apparently,

apparently,

verify: hair <---
verify: give-milk <---
verify: eat-vegetals <---
verify: eat-meat <---
verify: pointed-teeth <---
verify: claws <---
verify: forward-eyes <---
verify: mammal <---
verify: hoofs <---
verify: chew-cud <---
verify: swim <--- yes
verify: black&white <--- yes
apparently,
It is a penguin.

verify: long-neck <---
verify: not-fly <--- yes
verify: black-stripes <---
verify: carnivore <---
verify: tawny-color <---
verify: herbivore <---
verify: ungulate <---
verify: long-legs <---
verify: dark-spots <---
verify: fly-well <---
verify: wings <---
verify: fly <---
apparently,
It is a penguin.

final result:
-------------
finally,
It is a penguin. ok

9. Another one:
---------------
<-?

verify: feathers <---
verify: wings <--- yes
verify: lay-eggs <---
verify: hair <---
verify: give-milk <--- yes
apparently,

verify: eat-vegetals <---
verify: eat-meat <---
verify: pointed-teeth <---
verify: claws <---
verify: forward-eyes <---
verify: hoofs <---
verify: chew-cud <---
verify: swim <---
verify: black&white <---
verify: bird <---
verify: long-neck <---
verify: not-fly <---
verify: black-stripes <---
verify: carnivore <---
verify: tawny-color <---
verify: herbivore <---
verify: ungulate <---
verify: long-legs <---
verify: dark-spots <---
verify: fly-well <---
verify: fly <--- yes
apparently,
It is a bat.

apparently,
It is a bat.

final result:
-------------
finally,
It is a bat. ok

10. Another one:
----------------
<-?

verify: feathers <--- yes
apparently,

apparently,

verify: hair <---
verify: give-milk <---
verify: eat-vegetals <---
verify: eat-meat <---
verify: pointed-teeth <---
verify: claws <---
verify: forward-eyes <---
verify: mammal <---
verify: hoofs <---
verify: chew-cud <---
verify: swim <---
verify: black&white <--- yes
verify: long-neck <--- yes
verify: not-fly <--- yes
apparently,
It is an ostrich.

verify: black-stripes <---
verify: carnivore <---
verify: tawny-color <---
verify: herbivore <---
verify: ungulate <---
verify: long-legs <---
verify: dark-spots <---
verify: fly-well <---
verify: fly <---
apparently,
It is an ostrich.

final result:
-------------
finally,
It is an ostrich. ok

11. Another one:
----------------
<-?

verify: feathers <---
verify: wings <---
verify: lay-eggs <---
verify: hair <--- yes
apparently,

apparently,

verify: eat-vegetals <---
verify: eat-meat <--- yes
apparently,

apparently,

verify: hoofs <---
verify: chew-cud <---
verify: swim <---
verify: black&white <---
verify: bird <---
verify: long-neck <---
verify: not-fly <--- yes
verify: black-stripes <--- yes
verify: tawny-color <--- yes
apparently,
It is a tiger.

verify: herbivore <---
verify: ungulate <---
verify: long-legs <---
verify: dark-spots <---
verify: fly-well <---
verify: fly <---
apparently,
It is a tiger.

final result:
-------------
finally,
It is a tiger. ok

12. Another one:
----------------
<-?

verify: feathers <---
verify: wings <---
verify: lay-eggs <---
verify: hair <---
verify: give-milk <--- yes
apparently,

verify: eat-vegetals <---
verify: eat-meat <--- yes
apparently,

apparently,

verify: hoofs <---
verify: chew-cud <---
verify: swim <---
verify: black&white <--- yes
verify: bird <---
verify: long-neck <---
verify: not-fly <--- yes
verify: black-stripes <--- yes
verify: tawny-color <--- yes
apparently,
It is a tiger.

verify: herbivore <---
verify: ungulate <---
verify: long-legs <---
verify: dark-spots <--- yes
apparently,
It is a cheetah.
It is a tiger.

verify: fly-well <---
verify: fly <---
apparently,
It is a cheetah.
It is a tiger.

final result:
-------------
finally,
It is a cheetah.
It is a tiger. ok
ok

13. Type the rules:
-------------------
rules
Rule n°:0 : bird :- feathers .;
Rule n°:1 : bird :- wings , lay-eggs .;
Rule n°:2 : mammal :- hair .;
Rule n°:3 : mammal :- give-milk .;
Rule n°:4 : herbivore :- eat-vegetals .;
Rule n°:5 : carnivore :- eat-meat .;
Rule n°:6 : carnivore :- pointed-teeth , claws , forward-eyes .;
Rule n°:7 : ungulate :- mammal , hoofs .;
Rule n°:8 : ungulate :- mammal , chew-cud .;
Rule n°:9 : penguin :- swim , black&white , bird , fly notfact .;
Rule n°:10 : ostrich :- black&white , bird , long-neck , not-fly
;
Rule n°:11 : tiger :- black-stripes , carnivore , tawny-color ,
mammal .;
Rule n°:12 : giraffe :- herbivore , long-neck , ungulate ,
long-legs , dark-spots .;
Rule n°:13 : cheetah :- dark-spots , tawny-color , carnivore ,
mammal .;
Rule n°:14 : albatros :- fly-well , bird .;
Rule n°:15 : zebra :- herbivore , ungulate , black-stripes .;
Rule n°:16 : bat :- wings , fly , mammal .; ok
ok

14. Verify mode of chaining:
----------------------------
mode forward ok

15. Change chaining mode:
-------------------------
backward_mode ok

16. Verify it:
--------------
mode backward ok

17. Change chaining mode:
-------------------------
forward_mode ok

18. Verify it:
--------------
mode forward ok

19. Type true facts:
--------------------
facts

-> true_fact:
action: ''
text:

-> not_fact:
action: ''
text:

-> give-milk:
action: 'give-milk yes'
text:

-> not-fly:
action: 'not-fly yes'
text:

-> tawny-color:
action: 'tawny-color yes'
text:

-> dark-spots:
action: 'dark-spots yes'
text:

-> black&white:
action: 'black&white yes'
text:

-> mammal:
action: ''
text:

-> black-stripes:
action: 'black-stripes yes'
text:

-> carnivore:
action: ''
text:

-> eat-meat:
action: 'eat-meat yes'
text:

-> cheetah:
action: '_cheetah_ cr type'
text:

-> tiger:
action: '_tiger_ cr type'
text:
ok

20. Clear facts and verify it:
------------------------------
clear_facts
ok
facts

-> true_fact:
action: ''
text:
ok

Ahmed

--

[ahmed]

The animal.fs file:

include expert_systems.fs

\ facts
4 facts pointed-teeth claws swim forward-eyes
4 facts hoofs bird give-milk fly
4 facts hair chew-cud feathers lay-eggs
4 facts not-fly tawny-color fly-well dark-spots
4 facts black&white long-legs mammal black-stripes
4 facts carnivore long-neck ungulate eat-meat
4 facts wings bat eat-vegetals herbivore

4 facts cheetah tiger giraffe zebra
4 facts bat ostrich penguin albatros


\ rules
s" bird :- feathers .;"

rules

s" bird :- wings , lay-eggs .;"

rules

s" mammal :- hair .;"

rules

s" mammal :- give-milk .;"

rules

s" herbivore :- eat-vegetals .;"

rules

s" carnivore :- eat-meat .;"

rules

s" carnivore :- pointed-teeth , claws , forward-eyes .;"

rules

s" ungulate :- mammal , hoofs .;"

rules

s" ungulate :- mammal , chew-cud .;"

rules

s" penguin :- swim , black&white , bird , fly notfact .;"

rules

s" ostrich :- black&white , bird , long-neck , not-fly .;"

rules

s" tiger :- black-stripes , carnivore , tawny-color , mammal .;"

rules

s" giraffe :- herbivore , long-neck , ungulate , long-legs ,
dark-spots .;" >rules
s" cheetah :- dark-spots , tawny-color , carnivore , mammal .;"

rules

s" albatros :- fly-well , bird .;"

rules

s" zebra :- herbivore , ungulate , black-stripes .;"

rules

s" bat :- wings , fly , mammal .;"

rules

\ results
: _penguin_ s" It is a penguin." ;
: _ostrich_ s" It is an ostrich." ;
: _tiger_ s" It is a tiger." ;
: _giraffe_ s" It is a giraffe." ;
: _cheetah_ s" It is a cheetah." ;
: _albatros_ s" It is an albatros." ;
: _zebra_ s" It is a zebra." ;
: _bat_ s" It is a bat." ;

\ results in facts actions
s" _zebra_ cr type" zebra action>fact
s" _albatros_ cr type" albatros action>fact
s" _cheetah_ cr type" cheetah action>fact
s" _giraffe_ cr type" giraffe action>fact
s" _tiger_ cr type" tiger action>fact
s" _ostrich_ cr type" ostrich action>fact
s" _penguin_ cr type" penguin action>fact
s" _bat_ cr type" bat action>fact


Ahmed

--

[ahmed]

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

--

[minforth]

Thank you for sharing your outstanding work here!

I don't think I understand the details of your program
but it seems to me way simpler than the famous Warren
Abstract Machine. IMHO your concept is very well suited
for teaching students how to approach problemss from
the ground up.

[ahmed]

Post by minforth
Thank you for sharing your outstanding work here!
I don't think I understand the details of your program
but it seems to me way simpler than the famous Warren
Abstract Machine. IMHO your concept is very well suited
for teaching students how to approach problemss from
the ground up.

Thanks,

It works also under minforth MF348 (64 bit).
I had not Warren abstract machine in mind when I wrote it. I just
denfined facts, rules, forward chaining, backward chaining and some
words to interface it to set inference modes, display rules and facts.

Facts are structures with fields : name, use, true/flase, action and
text
name: in order to recognize the fact appearing in rules,
use : true if already used in the process of inference (false if
not), in
order to not repeat the test if it is true or false (true/false
field).
action: the fact can execute words if it is true,
text: additional field for comments, other actions, ...

Rules have the form :
goal_fact :- condition_fact1 , condition_fact2 , ... ,
condition_factn .;
... stands for other condition_facts
:-
,
.; are forth words

These three words are like defered words implemented with variables and
@ execute (first, I used defered words but that didn't give the good
results for iForth and vfxForth).

These words change their behavior for 3 phases:
- forward mode
- backward mode:
- verify facts: the operator (user) respond by yes/no, (yes and no
are
defined as forth words) when prompted by:
verify factname <---
- update facts: perform the actions in the facts (action field)
if the fact
is true (true/false field)
- use facts: perform the infernce

In forward mode, the user asserts the facts that he knows they are true
then invoke the forth word ->? to launch the inference process and with
result forth word he can display the result of the inference.

He can also use .facts forth word to see the facts that are true.

In backward mode, the user can launch the process of inference using the
forth word <-? . The infernce launched this way ask the user to verify
certain facts (that appear in the condition part of the rules) and the
user respond with yes or no, and an empty response is considered as no,
and a response other than yes/no/empty will stop the process of
inference with an error ( undefined word).

During this inference process, the system can guess the result and
perhaps display 'Apparently: ....' followed bye a result and after some
steps it stops by 'Finally: ...' and display the result if found and if
not it displays 'No results".

The user can ask the system to give the condition facts that are
necessary to get a goal_fact true. the forth word :-? is used for that.

The user can see the rules using the forth word : .rules or for a
specific rule:
n .rule where n is the number of the rule.

For the moment, the infernce process pass through the rules one after
another in that order. Perhaps, if time permits, I'll change that using
the action field of some facts used to change the flow of the inference.

Notice here:
<-? backward chaining, the arrow <- in <-? is towards the left
->? forward cahining, the arrow -> in ->? is towards the right
:-? asking for condition facts to get a goal fact true, used
like this:
penguin :-?

The user can use :
.mode : to display the current mode used (forward or backward)
forward_mode : to set the forward mode
backward_mode : to set the backward mode

The words <-? and ->? set the mode automatically to backward or forward
respectively.

The work is under development, and possible ideas will be used.

Ahmed

--

[mhx]

Post by ahmed
(first, I used defered words but that didn't give the good
results for iForth and vfxForth)

What went wrong?

-marcel

[ahmed]

Hi,
First, I have the free version:

iForth version 4.0.627, generated 15:51:53, December 18, 2010.
x86_64 binary, native floating-point, extended precision.
Copyright 1996 - 2010 Marcel Hendrix.

I download it some years ago, and thanks for it.

1- For exapmple, I can't use ['] in a colon definition:
defer go

: go1 ..... ;
: use_go ['] go1 is go ;
doesn't work for me.

2- The forth word latest (gforth) is not defined in iForth:
I used latest in the definition of the forth word fact.
I modified the defintion of fact to get rid of latest.

3- The forth words place and +place are not defined in iForth:
I borrowed the definitions from gforth.

4- this for vfxForth:
The forth words 0>= and +place are not defined.

I added their definitions in the top of the expert_systems.fs file.

I changed the use of ['] in colon definitions by using variables and @
execute,
and ( @, !) instead of defer and is.

So I managed to get it working under: gforth, iForth, vfxForth anf
minforth (MF348).

Ahmed

--

[mhx]

Post by ahmed
Hi,
iForth version 4.0.627, generated 15:51:53, December 18, 2010.
x86_64 binary, native floating-point, extended precision.
Copyright 1996 - 2010 Marcel Hendrix.

Sending an e-mail address to ***@iae.nl might cure a problem.

-marcel

[dxf]

Post by ahmed
Hi,
iForth version 4.0.627, generated 15:51:53, December 18, 2010.
x86_64 binary, native floating-point, extended precision.
Copyright 1996 - 2010 Marcel Hendrix.

A newer version of the 2005 manual posted below might help too.

https://iforth.nl/

[ahmed]

Post by dxf

Post by ahmed
Hi,
iForth version 4.0.627, generated 15:51:53, December 18, 2010.
x86_64 binary, native floating-point, extended precision.
Copyright 1996 - 2010 Marcel Hendrix.

A newer version of the 2005 manual posted below might help too.
https://iforth.nl/

Thanks for the link.

I've already seen it, read and learnt a lot from it. Thanks to Marcel.

Ahmed

--

[Anton Ertl]

Post by minforth
Thank you for sharing your outstanding work here!
I don't think I understand the details of your program
but it seems to me way simpler than the famous Warren
Abstract Machine.

That would not surprise me, because Ahmed Melahi is implementing an
expert system framework, not Prolog (the progamming language for which
the WAM was designed). Like for all other expert system examples I
have seen (several, but no production expert systems), the examples do
not include any logic variables, and I guess that his system does not
support them; the majority of the complexity of implementing Prolog
and of the WAM comes from dealing with logic variables, which can
contain structures that themselves contain logic variables.

OTOH, Ahmed Melahi's expert system framework supports forward
chaining, while Prolog does not.

Another difference is that Prolog uses the closed-world-assumption (if
there is no fact for <something>, <something> is false), while Ahmed
Melahi's framework (and expert systems in general) asks the user for
input when it does not have a fact about <something>.

Unlike expert systems examples I have seen earlier, where the rules
led to a decision tree, trying some example leads to asking
apparently-redundant questions (not answering "yes" is the same as
answering "no"), e.g.:

verify: feathers <---
verify: wings <---
verify: lay-eggs <---
verify: hair <--- yes
apparently,

apparently,

verify: eat-vegetals <---
verify: eat-meat <--- yes
apparently,

apparently,

verify: hoofs <--- yes
apparently,

apparently,

verify: swim <--- yes
verify: black&white <---
verify: bird <---
verify: long-neck <---
verify: not-fly <--- yes
verify: black-stripes <---
verify: tawny-color <---
verify: herbivore <---
verify: long-legs <---
verify: dark-spots <---
verify: fly-well <---
verify: fly <---
apparently,

final result:
-------------
finally, ok

It seems that these additional questions are from having alternative
rules for the same thing, e.g.:

s" bird :- feathers .;"

Post by minforth
rules

s" bird :- wings , lay-eggs .;"

Post by minforth
rules

However, given that I answered "" (i.e., "no") to wings, there is no
reason for the system to ask me "lay-eggs". So I think that the
redundant questions are not just due to alternative rules, but also a
shortcoming of the system. Finally, the system could have found out
earlier (and printed more clearly that it knows of no animal that has
the properties that I answered with "yes". As for the animal
database, the Platypus would be an interesting addition.

- anton

[ahmed]

Hi,
thanks for testing.

As already said in my previous post the work is under development.

The system works well taking in consideration:
- known that the scanning of the rules is linear, it doesn't repeat
the
same question but can ask for additional inforamtion, for example,
when
responding to eat-vegetals by no (or empty) it can ask if it is
herbivore, the `no' reponse doesn't change the truth of a goal fact
but
the goal fact becomes true if all condtion facts are true.

- when doing backward chaining, there are some results but they are
not
displayed, for your example: it says Finally: and nothing displayed
after,
but there are some results like: carnivore, ungulate and you can
see these
by executing .facts which displays only the true facts. After
"Finally" the
system executes the actions associated to the facts that are true
and in
this case the actions associated to carnivore and ungulate but
these
actions aren't set before (nothing in the action field of the fcats
carnivore and ungulate).

I'll see how to change the flow of the inference using the action field
of facts and executing them during the inference, like this we can
choose the next rule to use. I think this can be possible by modifying
the words `,' and `.;'

It is up to the knowledge engineer to define how rules are scanned
(linear, predetermined or with respect to the responses given by the
user when asked to verify a fact) and this is not in expert_systems.fs
file itself but in its data base file (where facts, rules and actions
are defined) (here animal.fs).

Adding the rules for platypus :

s" platypus :- swim , not-fly , eat-meat , hoofs , hair .;" >rules

and defining the action associated to platypus:

: _paltypus_ s" It is a platypus." ;
s" _platypus_ cr type" platypus action>fact

gives:

<-?

verify: feathers <---
verify: wings <---
verify: lay-eggs <---
verify: hair <--- yes
apparently,

apparently,

verify: eat-vegetals <---
verify: eat-meat <--- yes
apparently,

apparently,

verify: hoofs <--- yes
apparently,

apparently,

verify: swim <--- yes
verify: black&white <---
verify: bird <---
verify: long-neck <---
verify: not-fly <--- yes
verify: black-stripes <---
verify: tawny-color <---
verify: herbivore <---
verify: long-legs <---
verify: dark-spots <---
verify: fly-well <---
verify: fly <---
apparently,
It is a platypus.

apparently,
It is a platypus.

final result:
-------------
finally,
It is a platypus. ok

Thanks again.

Ahmed

--

[Anton Ertl]

Post by ahmed
I'll see how to change the flow of the inference using the action field
of facts and executing them during the inference, like this we can
choose the next rule to use.

Potential improvements:

Also have rules that work for both truth and falsness. E.g., for
non-extinct animals, all birds have feathers and only birds have
feathers. So if you ask the "feathers" question, and you get a "yes",
you know it is a bird, and if you get a "no", you know that it is no
bird.

And then you do not need to ask about wings and egg-laying unless the
answer is "don't know" (supporting that would be another improvement).

Post by ahmed
s" platypus :- swim , not-fly , eat-meat , hoofs , hair .;" >rules

It seems to me that the platypus has claws, not hoofs. The most
puzzling property of the platypus, though, is that it is a mammal and
lays eggs.

- anton

[ahmed]

Post by Anton Ertl

Post by ahmed
I'll see how to change the flow of the inference using the action field
of facts and executing them during the inference, like this we can
choose the next rule to use.

Also have rules that work for both truth and falsness. E.g., for
non-extinct animals, all birds have feathers and only birds have
feathers. So if you ask the "feathers" question, and you get a "yes",
you know it is a bird, and if you get a "no", you know that it is no
bird.
And then you do not need to ask about wings

The bat has wings and can fly and it is a mammal.

Post by Anton Ertl
and egg-laying unless the
answer is "don't know" (supporting that would be another improvement).

Your example `platypus', it lays eggs, and it is not a bird.

Post by Anton Ertl

Post by ahmed
s" platypus :- swim , not-fly , eat-meat , hoofs , hair .;" >rules

It seems to me that the platypus has claws, not hoofs. The most
puzzling property of the platypus, though, is that it is a mammal and
lays eggs.
- anton

Until now, I assume: no equivalent to unknown.
Three level logic: yes/no/unknown (true/false/unknown)can be
implemented.
Perhaps, Carnaugh tables can be helpful.
I'll try to do it if time permits.

Ahmed

--

[Anton Ertl]

Post by ahmed

Post by Anton Ertl

Post by ahmed
I'll see how to change the flow of the inference using the action field
of facts and executing them during the inference, like this we can
choose the next rule to use.

Also have rules that work for both truth and falsness.

Or, more generally, negative rules. Then there would be:

bird :- feathers .;
not bird :- not feathers .;

Post by ahmed

Post by Anton Ertl
And then you do not need to ask about wings

The bat has wings and can fly and it is a mammal.

Post by Anton Ertl
and egg-laying unless the
answer is "don't know" (supporting that would be another improvement).

Your example `platypus', it lays eggs, and it is not a bird.

I am referring to your rule

bird :- wings , lay-eggs .;

So if you have established that the animal has wings AND lays eggs
(and is not extinct), it's a bird. With the negative rules one could
also specify

not bird :- not wings .;
not bird :- not lay-eggs .;

Post by ahmed
Until now, I assume: no equivalent to unknown.
Three level logic: yes/no/unknown (true/false/unknown)can be
implemented.
Perhaps, Carnaugh tables can be helpful.

Strangely, even though there are a lot of people working on logic in
my school, I have never heard of any work in that direction. But I
would be very surprised if that was uncharted land.

- anton

[ahmed]

Post by Anton Ertl
bird :- feathers .;
not bird :- not feathers .;

I'll see how to do that if possible (I mean 'not' in the goal fact).

Post by Anton Ertl
I am referring to your rule
bird :- wings , lay-eggs .;
So if you have established that the animal has wings AND lays eggs
(and is not extinct), it's a bird. With the negative rules one could
also specify
not bird :- not wings .;
not bird :- not lay-eggs .;

Your are right (Logically true), but for the moment I haven't 'not' in
the goal facts.

Post by Anton Ertl

Post by ahmed
Until now, I assume: no equivalent to unknown.
Three level logic: yes/no/unknown (true/false/unknown)can be
implemented.
Perhaps, Carnaugh tables can be helpful.

Strangely, even though there are a lot of people working on logic in
my school, I have never heard of any work in that direction. But I
would be very surprised if that was uncharted land.

I meant multi-valued logic (three-valued logic).
and when I said Carnaugh tables, I was referring to the possibility to
consider unknown as yes or no given the situation (in the inference
process) but this is a two-valued logic. Perhaps, I was just confused.

Post by Anton Ertl
- anton

Ahmed

--

[a***@spenarnc.xs4all.nl]

Post by Anton Ertl

Post by ahmed
I'll see how to change the flow of the inference using the action field
of facts and executing them during the inference, like this we can
choose the next rule to use.

Also have rules that work for both truth and falsness. E.g., for
non-extinct animals, all birds have feathers and only birds have
feathers. So if you ask the "feathers" question, and you get a "yes",
you know it is a bird, and if you get a "no", you know that it is no
bird.
And then you do not need to ask about wings and egg-laying unless the
answer is "don't know" (supporting that would be another improvement).

Post by ahmed
s" platypus :- swim , not-fly , eat-meat , hoofs , hair .;" >rules

It seems to me that the platypus has claws, not hoofs. The most
puzzling property of the platypus, though, is that it is a mammal and
lays eggs.

I had an animals database code in c. I considered a property as true only
if the majority of the respondents considered it true. That weeds out
unanswerable questions whether a leopard has mainly sweat glands on its belly.
You were supposed to have an animal in mind and answer the questions.
At the end you are left with a correct answer or undistingishable animals.
In game theory fashion the questions are selected by chance to give
the most information, and the answers are accumulated, such that
a good question goes to the fore. (In game theory you are supposed
to try unfavourable strategies once in a while. If you have a
solid reputation as a poker player, you can shove all in with
2 8 not suited, once in a while.)

I imagine that it was a good medical database. If the questions are
"has the patient a rash of a type similar to figure 10a"
the answers are definitive, not based on stereotypical images.
(You can ask a three year old whether an elephant has a trunk,
before she have ever seen an elephant.)
Then there is the possibility to attach costs for each question. "Has
the patient globules in his liver, revealed by an MRI scan?". If there
are cost effective questions to be answered, that eliminates diagnoses,
these would be favoured first.

Now AI takes over. A simple metafysical database where you have
decide whether this is hoofs or claws, is old fashioned.
It reminds me of Plato where the idea of hoofs exist independent
of the human minds. Where hoofs are a shadow of the ideal hoofs
outside of the cave.

Post by Anton Ertl
- anton

Groetje Albert

[ahmed]

Post by a***@spenarnc.xs4all.nl
Now AI takes over. A simple metafysical database where you have
decide whether this is hoofs or claws, is old fashioned.

Agreed.

Post by a***@spenarnc.xs4all.nl
Groetje Albert

Ahmed

--

[ahmed]

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

--

[dxf]

Post by a***@spenarnc.xs4all.nl
...
Now AI takes over. A simple metafysical database where you have
decide whether this is hoofs or claws, is old fashioned.
It reminds me of Plato where the idea of hoofs exist independent
of the human minds. Where hoofs are a shadow of the ideal hoofs
outside of the cave.

Plato's 'featherless bipeds'

https://nextnature.org/en/magazine/story/2006/featherless-chicken