OLD [2002] rule/logic tinkerings

r2-rule-stuff.r

(is-a horse comet)		;; Comet is a horse
(is-a-parent-of comet prancer)	;; Comet is a parent of Prancer

Comet is a horse
Comet is a parent of Prancer


rule [
    name
    antecedents
    consequent
]


REBOL []

extract-variable: func [expr] [
    second expr
]

make-binding: func [var datum] [
    reduce [var datum]
]

add-binding: func [expr datum bindings] [
    ;print ["***add-binding" mold expr mold datum mold bindings]
    either equal? '_ extract-variable expr [
        bindings
    ][
        ;if none? bindings [bindings: copy []]
        ;head insert/only bindings make-binding extract-variable expr datum
        head insert bindings make-binding extract-variable expr datum
    ]
]

print mold add-binding [? x] 'apple [[y red]]
print mold add-binding [? _] 'apple [[y red]]


; This doesn't match the books data format exactly due to how
; Lisp ASSOC structures work.
find-binding: func [expr bindings /local word] [
    ;print ["***find-binding" mold expr mold bindings]
    if not-equal? '_ word: extract-variable expr [
        ;print ["..." mold bindings type? bindings]
        ;reduce [word select bindings word]
        ;if error? try [
        ;if none? bindings [print "%%%" return none]
        either all [bindings find bindings word] [
            ;print [tab "binding found for" word]
            reduce [word select bindings word]
        ][
            none
        ]
        ;][print ["..." mold bindings]]
    ]
]
print ""
print mold find-binding [? x] [x apple y red]
print mold find-binding [? y] [x apple y red]
print mold find-binding [? _] [x apple y red]

extract-key: func [binding] [first binding]
extract-value: func [binding] [second binding]

match-atoms: func [expr datum bindings] [
    ;print ["***match-atoms" expr datum]
    either equal? expr datum [bindings][false]
]

match-variable: func [expr datum bindings /local binding] [
    ;print ["***match-variable" mold expr mold datum mold bindings]
    either binding: find-binding expr bindings [
        match extract-value binding datum bindings
    ][
        add-binding expr datum bindings
    ]
]

match-pieces: func [expr datum bindings /local result] [
    ;print ["***match-pieces" mold expr mold datum]
    either all [tail? expr tail? datum] [
        bindings
    ][
        either false = result: match expr/1 datum/1 bindings [
            false
        ][
            match next expr next datum result
        ]
    ]
]

; return FALSE if no match; otherwise return list of associations
; between vars and values (e.g. [x apple y red]), which may be NONE.
match: func [expr datum bindings] [
    if none? bindings [bindings: copy []]
    either all [not any-block? expr not any-block? datum] [
        match-atoms expr datum bindings
    ][
        either all [not tail? expr any-block? expr '? = first expr] [
            match-variable expr datum bindings
        ][
            either all [any-block? expr any-block? datum] [
                match-pieces expr datum copy bindings
            ][
                false
            ]
        ]
    ]
]

; print ""
; print mold match [color apple red] [color apple red] copy []
; print mold match [color [? x] red] [color apple red] none
; print mold match [color apple [? y]] [color apple red] copy []
; print mold match [color [? x] [? y]] [color apple red] copy []

elements?: func [expr datum] [
    all [
        not any-block? expr
        not any-block? datum
    ]
]

variable?: func [expr] [
    all [
        any-block? expr
        not tail? expr
        '? = first expr
    ]
]

recursive?: func [expr datum] [
    all [
        any-block? expr
        any-block? datum
    ]
]

match: func [expr datum bindings] [
    if none? bindings [bindings: copy []]
    either elements? expr datum [
        match-atoms expr datum bindings
    ][
        either variable? expr [
            match-variable expr datum bindings
        ][
            either recursive? expr datum [
                ; It looks like we need to copy our bindings here in order
                ; for things to work, which makes sense.
                match-pieces expr datum either any-block? bindings [copy bindings][bindings]
            ][
                false
            ]
        ]
    ]
]

print ""
print mold match [color apple red] [color apple red] none
print mold match [color [? x] red] [color apple red] none
print mold match [color apple [? y]] [color apple red] none
print mold match [color [? x] [? y]] [color apple red] none
print mold match [color [? _] red] [color apple red] none
print mold match [color [? _] [? _]] [color apple red] none
print mold match [color apple orange] [color apple red] none
print mold match [color [? x] [? x]] [color apple red] none


unify-atoms: func [expr-1 expr-2 bindings] [
    ;print ["***unify-atoms" expr-1 expr-2]
    either equal? expr-1 expr-2 [bindings][false]
]

inside-or-equal?: func [var expr bindings /local binding] [
    ;return false   ; stub. This one will be a bit of work.
    if equal? var expr [return true]
    if not any-block? expr [return none]
    if equal? '? first expr [
        return either binding: find-binding expr bindings [
            inside-or-equal? var extract-value binding bindings
        ][
            none
        ]
    ]
    ; otherwise
    any [
        inside-or-equal? var first expr bindings
        inside-or-equal? var next  expr bindings
    ]
]

inside?: func [var expr bindings] [
    either equal? var expr [
        none
    ][
        inside-or-equal? var expr bindings
    ]
]

unify-variable: func [expr-1 expr-2 bindings /local binding] [
    ;print ["***unify-variable" mold expr mold datum mold bindings]
    either binding: find-binding expr-1 bindings [
        unify extract-value binding expr-2 bindings
        either inside? expr-1 expr-2 bindings [
            false
        ][
            add-binding expr-1 expr-2 bindings
        ]

    ][
        add-binding expr-1 expr-2 bindings
    ]
]

unify-pieces: func [expr-1 expr-2 bindings /local result] [
    ;print ["***unify-pieces" mold expr mold datum]
    either all [tail? expr-1 tail? expr-2] [
        bindings
    ][
        either false = result: unify first expr-1 first expr-2 bindings [
            false
        ][
            unify next expr-1 next expr-2 result
        ]
    ]
]

unify: func [expr-1 expr-2 bindings] [
    if none? bindings [bindings: copy []]
    either elements? expr-1 expr-2 [
        unify-atoms expr-1 expr-2 bindings
    ][
        either variable? expr-1 [
            unify-variable expr-1 expr-2 bindings
        ][
            either variable? expr-2 [
                unify-variable expr-2 expr-1 bindings
            ][
                either recursive? expr-1 expr-2 [
                    unify-pieces expr-1 expr-2 copy bindings
                ][
                    false
                ]
            ]
        ]
    ]
]

print ""
print mold match [bozo is a mammal] [deedee has hair]  none
print mold match [bozo is a mammal] [bozo is a mammal] none
print mold match [deedee is a mammal] [deedee has hair]  none
print mold match [deedee is a mammal] [bozo is a mammal] none
print ""
print mold unify [deedee is a mammal] [[? animal] is a mammal] none
print mold match [[? animal] has hair] [deedee has hair] [animal deedee]
print ""
print mold match [[? x] is a mammal] [deedee has hair] none
print mold match [[? x] is a mammal] [bozo is a mammal] none
print mold unify [[? x] is a mammal] [[? animal] is a mammal] none
print mold match [[? animal] has hair] [deedee has hair] [x [? animal]]

stream-first: func [stream] [
    either any [none? stream empty? stream] [none][first  stream]
]
stream-rest:  func [stream] [
    either any [none? stream empty? stream] [none][second stream]
]
stream-end?:  func [stream] [equal? stream 'empty-stream]

stream-cons:  func [obj stream] [reduce [obj stream]]
print ""
print mold s1: stream-cons 'a stream-cons 'b 'empty-stream
print mold s2: stream-cons 'x stream-cons 'y 'empty-stream

stream-append: func [stream-1 stream-2] [
    either stream-end? stream-1 [
        stream-2
    ][
        stream-cons stream-first stream-1
            stream-append stream-rest stream-1 stream-2
    ]
]
print mold stream-append s1 s2

stream-concatenate: func [streams] [
    either stream-end? streams [
        'empty-stream
    ][
        either stream-end? stream-first streams [
            stream-concatenate stream-rest streams
        ][
            stream-cons stream-first stream-first streams
                stream-concatenate
                    stream-cons stream-rest stream-first streams
                        stream-rest streams
        ]
    ]
]
print mold ss: stream-cons s1 stream-cons s2 'empty-stream
print mold stream-concatenate ss

stream-transform: func [procedure stream] [
    either stream-end? stream [
        'empty-stream
    ][
        stream-cons procedure stream-first stream
            stream-transform :procedure stream-rest stream
    ]
]
print "=== stream-transform"
print mold sn: stream-cons 2 stream-cons 3 'empty-stream
print mold stream-transform func [number] [
        either number? number [power 2 number][number]
    ] sn


stream-member: func [object stream] [
    either stream-end? stream [
        none
    ][
        either equal? object stream-first stream [
            true
        ][
            stream-member object stream-rest stream
        ]
    ]
]

stream-remember: func ['word 'stream] [
    either none? stream-member word get stream [
        set stream
            stream-append
                get stream
                stream-cons get word 'empty-stream
        ;set word none
        word
    ][
        ;get stream
        none
    ]
]

print "=== stream-remember"
last-object: none
print mold long-stream: [a [b [x [y empty-stream]]]]
print mold stream-remember 'last-object long-stream
print mold long-stream: [a [b [x [y [last-object empty-stream]]]]]
print mold stream-remember 'last-object long-stream

initial-input-stream: copy [empty-stream]

remember-assertion: func [assertion] [
    stream-remember assertion *assertions*
]

print "=== remember-assertion"
*assertions*: 'empty-stream
remember-assertion [bozo is a dog]
remember-assertion [deedee is a horse]
remember-assertion [deedee is a parent of sugar]
remember-assertion [deedee is a parent of brassy]
print mold *assertions*

but-last: func [series [series!] /part len [integer!]] [
    copy/part :series (subtract length? :series either part [len][1])
]

rule-name: func [rule] [first rule]
rule-ifs:  func [rule] [but-last next rule]
rule-then: func [rule] [last rule]

remember-rule: func [rule] [
    stream-remember rule *rules*
]

print "=== remember-rule"
*rules*: 'empty-stream
remember-rule [
    identify
        [[? animal] is a [? species]]
        [[? animal] is a parent of [? child]]
        [[? child] is a [? species]]

]
print mold *rules*


try-assertion: func [pattern assertion bindings /local result] [
    either false = result: match pattern assertion bindings [
        'empty-stream
    ][
        stream-cons result 'empty-stream
    ]
]

print ""
print "=== try-assertion"
print mold try-assertion
    [[? animal] is a [? species]]
    [bozo is a dog]
    none
print mold try-assertion
    [[? animal] is a parent of [? child]]
    [deedee is a parent of sugar]
    [species dog animal bozo]
print mold try-assertion
    [[? animal] is a [? species]]
    [deedee is a horse]
    none
print mold try-assertion
    [[? animal] is a parent of [? child]]
    [deedee is a parent of sugar]
    [species horse animal deedee]


match-pattern-to-assertions: func [pattern bindings] [
    stream-concatenate
        stream-transform
            func [assertion] [
                ;print ["---" mold assertion mold bindings]
                try-assertion pattern assertion bindings
            ]
        *assertions*
]

print ""
print "=== match-pattern-to-assertions"
;print mold match-pattern-to-assertions [bozo is a mammal] none
print mold match-pattern-to-assertions [[? animal] is a [? species]] none
print mold match-pattern-to-assertions
    [[? animal] is a parent of [? child]]
    [species dog animal bozo]
print mold match-pattern-to-assertions
    [[? animal] is a parent of [? child]]
    [species horse animal deedee]



filter-binding-stream: func [patterns stream] [
    stream-concatenate stream-transform
        func [bindings] [
            ;print [":::" mold bindings "::" mold patterns ":" mold stream]
            match-pattern-to-assertions patterns bindings
        ]
        stream
]

print "=== filter-binding-stream"
print mold filter-binding-stream
    [[? animal] is a [? species]]
    [#[none] empty-stream]
print mold filter-binding-stream
    [[? animal] is a parent of [? child]]
    [[species dog animal bozo] [[species horse animal deedee] empty-stream]]
print mold filter-binding-stream
    [[? animal] is a parent of [? child]]
    filter-binding-stream
        [[? animal] is a [? species]]
        [#[none] empty-stream]

;-- Good to here! 29-oct-2002

apply-filters: func [patterns stream] [
    either tail? patterns [
        stream
    ][
        apply-filters
            next patterns
            filter-binding-stream
                first patterns
                stream
    ]
]

print "=== apply-filters"
print mold apply-filters
    [
        [[? animal] is a [? species]]
        [[? animal] is a parent of [? child]]
    ]
    copy [#[none] empty-stream]


instantiate-variables: func [pattern a-list] [
    either not any-block? pattern [
        ;print ["A" mold pattern ":" mold a-list]
        pattern
    ][
        ;print ["B" mold pattern ":" mold a-list]
        either all [not empty? pattern  equal? '? first pattern] [
            ;print ["C" mold pattern ":" mold a-list]
            extract-value find-binding pattern a-list
            ;print ["CC" mold pattern ":" mold a-list]
        ][
            ;print ["D" mold pattern ":" mold a-list]
            either not empty? pattern [
                append
                    to block! instantiate-variables first pattern a-list  ;either empty? pattern [[]][first pattern]
                    instantiate-variables next pattern a-list
            ][
                ;print "E"
                copy []
                ;none
            ]
        ]
    ]
]

print "=== instantiate-variables"
print mold instantiate-variables
    [[? child] is a [? species]]
    [child sugar species horse animal deedee]

print mold instantiate-variables
    [[? child] is a [? species]]
    [child brassy species horse animal deedee]

;print mold instantiate-variables
;    [[? child] is a [? species]]
;    none

;-- Good to here! 31-oct-2002

; lisp-do: func [params test result body] [
;     while [not do test] [
;         do body
;     ]
;     do result
; ]
; ; spec vars body
; ;do [params][test and return][body]

use-rule: func [rule /local binding-stream success-switch result] [

    success-switch: false
    binding-stream: apply-filters
        rule-ifs rule
        stream-cons none 'empty-stream
    ;print mold binding-stream

    while [not stream-end? binding-stream] [
        result: instantiate-variables
            rule-then rule
            stream-first binding-stream
        ;print ["###" mold result]
        if remember-assertion result [
            print ["Rule" uppercase to string! rule-name rule "indicates" mold result]
            success-switch: true
        ]
        binding-stream: stream-rest binding-stream
    ]
    success-switch

]

print "=== use-rule"
print mold *assertions*
print mold use-rule [
    identify
    [[? animal] is a [? species]]
    [[? animal] is a parent of [? child]]
    [[? child] is a [? species]]
]
print mold *assertions*

;-- Good to here! 1-nov-2002

;!! OK, in order for this to work, we have to have rule-stream live
;   outside the context of the function, so it maintains its value.
;   Then we also need to set it to none before we call it again.
; rule-stream: none
; forward-chain: has [ repeat-switch result] [
;     if none? rule-stream [rule-stream: *rules*]
;     while [not stream-end? rule-stream] [
;         if use-rule stream-first rule-stream [
;             repeat-switch: true
;         ]
;         rule-stream: stream-rest rule-stream
;     ]
;     either repeat-switch [
;         print "I am trying the rules again."
;         forward-chain
;     ][
;         print "Nothing new noted."
;         'done
;     ]
; ]

;-- Here is an alternate method, where we pass the stream along when
;   we make a recursive call.
forward-chain: func [/with rule-stream* /local rule-stream repeat-switch result] [
    rule-stream: either with [rule-stream*][*rules*]
    while [not stream-end? rule-stream] [
        if use-rule stream-first rule-stream [
            repeat-switch: true
        ]
        rule-stream: stream-rest rule-stream
    ]
    either repeat-switch [
        print "I am trying the rules again."
        forward-chain/with rule-stream
    ][
        print "Nothing new noted."
        'done
    ]
]

print [newline "=== forward-chain"]
print mold forward-chain



*rules*: 'empty-stream
remember-rule [
    identify-1
    [[? animal] has hair]
    [[? animal] is a mammal]
]
remember-rule [
    identify-2
    [[? animal] gives milk]
    [[? animal] is a mammal]
]
remember-rule [
    identify-3
    [[? animal] has feathers]
    [[? animal] is a bird]
]
remember-rule [
    identify-4
    [[? animal] flies]
    [[? animal] lays eggs]
    [[? animal] is a bird]
]
remember-rule [
    identify-5
    [[? animal] eats meat]
    [[? animal] is a carnivore]
]
remember-rule [
    identify-6
    [[? animal] has pointed teeth]
    [[? animal] has claws]
    [[? animal] has forward eyes]
    [[? animal] is a carnivore]
]
remember-rule [
    identify-7
    [[? animal] is a mammal]
    [[? animal] has hoofs]
    [[? animal] is an ungulate]
]
remember-rule [
    identify-8
    [[? animal] is a mammal]
    [[? animal] chews cud]
    [[? animal] is an ungulate]
]
remember-rule [
    identify-9
    [[? animal] is a mammal]
    [[? animal] is a carnivore]
    [[? animal] has tawny color]
    [[? animal] has dark spots]
    [[? animal] is a cheetah]
]
remember-rule [
    identify-10
    [[? animal] is a mammal]
    [[? animal] is a carnivore]
    [[? animal] has tawny color]
    [[? animal] has black stripes]
    [[? animal] is a tiger]
]
remember-rule [
    identify-11
    [[? animal] is an ungulate]
    [[? animal] is a carnivore]
    [[? animal] has long neck]
    [[? animal] has long legs]
    [[? animal] is a giraffe]
]
remember-rule [
    identify-12
    [[? animal] is an ungulate]
    [[? animal] has black stripes]
    [[? animal] is a zebra]
]
remember-rule [
    identify-13
    [[? animal] is a bird]
    [[? animal] does not fly]
    [[? animal] has long neck]
    [[? animal] has long legs]
    [[? animal] is black and white]
    [[? animal] is an ostrich]
]
remember-rule [
    identify-14
    [[? animal] is a bird]
    [[? animal] does not fly]
    [[? animal] swims]
    [[? animal] is black and white]
    [[? animal] is an penguin]
]
remember-rule [
    identify-15
    [[? animal] is a bird]
    [[? animal] flies well]
    [[? animal] is an albatross]
]
remember-rule [
    identify-16
    [[? animal] is a [? species]]
    [[? animal] is a parent of [? child]]
    [[? child] is a [? species]]
]

*assertions*: 'empty-stream
remember-assertion [robbie has dark spots]
remember-assertion [robbie has tawny color]
remember-assertion [robbie eats meat]
remember-assertion [robbie has hair]
remember-assertion [suzie has feathers]
remember-assertion [suzie flies well]

print [newline "=== forward-chain #2"]
print mold forward-chain


;== Backward Chaining Version of functions starts here

print "^/=== Backward Chaining Version of functions starts here^/"

*assertions*: 'empty-stream
remember-assertion [deedee has hair]
remember-assertion [bozo is a mammal]

*rules*: 'empty-stream
remember-rule [
    identify
    [[? animal] has hair]
    [[? animal] is a mammal]
]

print "=== match & unify"
print mold match [bozo is a mammal] [deedee has hair] none
print mold match [bozo is a mammal] [bozo is a mammal] none
print mold match [deedee is a mammal] [deedee has hair] none
print mold match [deedee is a mammal] [bozo is a mammal] none
print mold unify [deedee is a mammal] [[? animal] is a mammal] none
print ""
print mold match [[? x] is a mammal] [deedee has hair] none
print mold match [[? x] is a mammal] [bozo is a mammal] none
print mold unify [[? x] is a mammal] [[? animal] is a mammal] none
print mold unify [[? animal] has hair] [deedee has hair] [x [? animal]]

;-- Good to here! 3-nov-2002

;!! Not the same as the function of the same name used for forward-chaining.
filter-binding-stream: func [patterns stream] [
    stream-concatenate stream-transform
        func [bindings] [
            stream-concatenate stream-cons
                ;print [":::" mold bindings "::" mold patterns ":" mold stream]
                match-pattern-to-assertions patterns bindings
                stream-cons
                    match-pattern-to-rules patterns bindings
                    'empty-stream
        ]
        stream
]

print ""
print "=== match-pattern-to-assertions"
print mold match-pattern-to-assertions [bozo is a mammal] none
print "=== try-assertion"
print mold try-assertion [bozo is a mammal] [bozo is a mammal] none
print mold try-assertion [bozo is a mammal] [deedee has hair] none

match-pattern-to-rules: func [pattern bindings] [
    stream-concatenate
        stream-transform
            func [rule] [
                try-rule pattern rule bindings
            ]
        *rules*
]

try-rule: func [pattern rule bindings /local result] [
    rule: make-variables-unique rule
    either false = result: unify pattern rule-then rule bindings [
        'empty-stream
    ][
        apply-filters
            rule-ifs rule
            stream-cons result 'empty-stream
    ]
]


lisp-gen-obj: make object! [
    count: 0
    set 'gentemp func ['word] [
        count: count + 1
        join word count
    ]
]


make-variables-unique: func [rule /local vars] [
    vars: list-variables rule
    foreach var vars [
        rule: instantiate-variables
            rule
            append/only append/only var append/only ['?] gentemp var
    ]
]

;!! Need to define make-variables-unique for most of these to work
print ""
print mold unify [bozo is a mammal] [[? animal] is a mammal]  none
;print mold apply-filters [[? animal] has hair] [[animal bozo] empty-stream]
;print mold match-pattern-to-rules [bozo is a mammal] none
;print mold filter-binding-stream [bozo is a mammal] [none empty-stream]
print mold match-pattern-to-assertions [deedee is a mammal] none
print mold unify [deedee is a mammal] [[? animal] is a mammal] none
;print mold apply-filters [[? animal] has hair] [[animal deedee] empty-stream]


halt