Created
September 14, 2015 18:49
-
-
Save udoschneider/0f86afe0cc88c6367744 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
structure WME {copied from page 41} | |
fields: array [1..3] of symbol | |
alpha-mem-items: list of item-in-alpha-memory {the ones with wme=this WME} | |
tokens: list of token {the ones with wme=this WME} | |
negative-join-results: list of negative-join-result | |
end | |
structure token {copied from page 48} | |
parent: token {points to the higher token, for items 1...i-1} | |
wme: WME {gives item i} | |
node: rete-node {points to the node this token is in} | |
children: list of token {the ones with parent=this token} | |
join-results: list of negative-join-result {used only on tokens in negative nodes} | |
ncc-results: list of token {similar to join-results but for NCC nodes} | |
owner: token {on tokens in NCC partners: token in whose local memory this result resides} | |
end | |
structure alpha-memory {revised from version on page 32} | |
items: list of item-in-alpha-memory | |
successors: list of rete-node | |
reference-count: integer | |
end | |
structure item-in-alpha-memory {copied from page 32} | |
wme: WME {the WME that's in the memory} | |
amem: alpha-memory {points to the alpha memory node} | |
end | |
structure constant-test-node: | |
field-to-test: "identifier", "attribute", "value", or "no-test" | |
thing-the-field-must-equal: symbol | |
output-memory: alpha-memory or nil | |
children: list of constant-test-node | |
end | |
procedure alpha-memory-activation (node: alpha-memory, w: WME) {copied from page 32} | |
new-item := allocate-memory(); | |
new-item.wme := w; | |
new-item.amem := node; | |
insert new-item at the head of node.items | |
insert new-item at the head of w.alpha-mem-items | |
for each child in node.successors do | |
right-activation (child, w) | |
end | |
procedure add-wme (w: WME) {data flow version} | |
constant-test-node-activation (the-top-node-of-the-alpha-network, w) | |
end | |
procedure constant-test-node-activation (node: constant-test-node; w: WME) | |
if node.field-to-test != 'no-test' then | |
v := w.[node.field-to-test] | |
if v != node.thing-the-field-must-equal then | |
return {failed the test, so don't propagate any further} | |
if node.output-memory != nil then | |
alpha-memory-activation (node.output-memory, w) {see Section 2.3.1} | |
for each c in node.children do | |
constant-test-node-activation (c, w) | |
end | |
procedure add-wme (w: WME) {exhaustive hash table version} {copied from page 17} | |
let v1, v2, and v3 be the symbols in the three fields of w | |
alpha-mem := lookup-in-hash-table (v1,v2,v3) | |
if alpha-mem != "not-found" then alpha-memory-activation (alpha-mem, w) | |
alpha-mem := lookup-in-hash-table (v1,v2,*) | |
if alpha-mem != "not-found" then alpha-memory-activation (alpha-mem, w) | |
alpha-mem := lookup-in-hash-table (v1,*,v3) | |
if alpha-mem != "not-found" then alpha-memory-activation (alpha-mem, w) | |
. | |
. | |
. | |
alpha-mem := lookup-in-hash-table (*,*,*) | |
if alpha-mem != "not-found" then alpha-memory-activation (alpha-mem, w) | |
end | |
structure rete-node: {copied from page 22} | |
type: "beta-memory", "join-node", "p-node", etc. {or various other node types} | |
children: list of rete-node | |
parent: rete-node | |
... (variant part | other data depending on node type) ... | |
end | |
structure beta-memory: {revised from version on page 22} | |
items: list of token | |
all-children: list of rete-node | |
end | |
procedure beta-memory-left-activation (node: beta-memory, t: token, w: WME) {copied from page 30} | |
new-token := make-token (node, t, w) | |
insert new-token at the head of node.items | |
for each child in node.children do | |
left-activation (child, new-token) | |
end | |
function make-token (node: rete-node, parent: token, w: wme) returning token {copied from page 42} | |
tok := allocate-memory() | |
tok.parent := parent | |
tok.wme := w | |
tok.node := node {for tree-based removal} | |
tok.children := nil {for tree-based removal} | |
insert tok at the head of parent.children {for tree-based removal} | |
if w != nil then {we need this check for negative conditions} | |
insert tok at the head of w.tokens {for tree-based removal} | |
return tok | |
end | |
structure join-node: {copied from page 90} | |
amem: alpha-memory {points to the alpha memory this node is attached to} | |
tests: list of test-at-join-node | |
nearest-ancestor-with-same-amem: rete-node | |
end | |
structure test-at-join-node: {copied from page 24} | |
field-of-arg1: "identifier", "attribute", or "value" | |
condition-number-of-arg2: integer | |
field-of-arg2: "identifier", "attribute", or "value" | |
end | |
function perform-join-tests (tests: list of test-at-join-node, t: token, w: WME) returning boolean {copied from page 25} | |
for each this-test in tests do | |
arg1 := w.[this-test.field-of-arg1] | |
{With list-form tokens, the following statement is really a loop} | |
wme2 := the [this-test.condition-number-of-arg2]'th element in t | |
arg2 := wme2.[this-test.field-of-arg2] | |
if arg1 != arg2 then | |
return false | |
return true | |
end | |
procedure join-node-left-activation (node: join-node, t: token) {copied from page 103} | |
if node.parent just became nonempty then | |
relink-to-alpha-memory (node) | |
if node.amem.items = nil then | |
remove node from the list node.parent.children | |
for each item in node.amem.items do | |
if perform-join-tests (node.tests, t, item.wme) then | |
for each child in node.children do | |
left-activation (child, t, item.wme) | |
end | |
procedure join-node-right-activation (node: join-node, w: WME) {copied from page 103} | |
if node.amem just became nonempty then | |
relink-to-beta-memory (node) | |
if node.parent.items = nil then | |
remove node from the list node.amem.successors | |
for each t in node.parent.items do {"parent" is the beta memory node} | |
if perform-join-tests (node.tests, t, w) then | |
for each child in node.children do | |
left-activation (child, t, w) | |
end | |
procedure relink-to-alpha-memory (node: rete-node) {version allowing conjunctive negations} {copied from page 91} | |
{follow links up from node, find first ancestor that's linked} | |
ancestor := node.nearest-ancestor-with-same-amem | |
while ancestor != nil and ancestor is right-unlinked do | |
ancestor := ancestor.nearest-ancestor-with-same-amem | |
{now splice in the node in the right place} | |
if ancestor != nil then | |
insert node into the list node.amem.successors immediately before ancestor | |
else | |
insert node at the tail of the list node.amem.successors | |
end | |
procedure relink-to-beta-memory (node: join-node) {copied from page 103} | |
insert node at the head of the list node.parent.children | |
end | |
structure negative-join-result {copied from page 41} | |
owner: token {the token in whose local memory this result resides} | |
wme: WME {the WME that matches owner} | |
end | |
structure negative-node: {copied from page 91} | |
{just like for a beta memory} | |
items: list of token | |
{just like for a join node} | |
amem: alpha-memory {points to the alpha memory this node is attached to} | |
tests: list of test-at-join-node | |
nearest-ancestor-with-same-amem: rete-node | |
end | |
procedure negative-node-left-activation (node: negative-node, t: token, w: WME) {copied from page 88} | |
if node.items = nil then | |
relink-to-alpha-memory (node) | |
{build and store a new token, just like a beta memory would} | |
new-token := make-token (node, t, w) | |
insert new-token at the head of node.items | |
{compute the join results} | |
new-token.join-results := nil | |
for each item in node.amem.items do | |
if perform-join-tests (node.tests, new-token, item.wme) then | |
jr := allocate-memory() | |
jr.owner := new-token; | |
jr.wme w | |
insert jr at the head of the list new-token.join-results | |
insert jr at the head of the list w.negative-join-results | |
{If join results is empty, then inform children} | |
if new-token.join-results=nil then | |
for each child in node.children do | |
left-activation (child, new-token, nil ) | |
end | |
procedure negative-node-right-activation (node: negative-node, w: WME) {copied from page 43} | |
for each t in node.items do | |
if perform-join-tests (node.tests, t, w) then | |
if t.join-results=nil then | |
delete-descendents-of-token (t) | |
jr := allocate-memory() | |
jr.owner t | |
jr.wme := w | |
insert jr at the head of the list t.join-results | |
insert jr at the head of the list w.negative-join-results | |
end | |
structure ncc-node {copied from page 47} | |
items: list of token | |
partner: rete-node {points to the corresponding NCC partner node} | |
end | |
structure ncc-partner-node {copied from page 48} | |
ncc-node: rete-node {points to the corresponding NCC node} | |
number-of-conjuncts: integer {number of conjuncts in the NCC} | |
new-result-buffer: list of token {results for the match the NCC node hasn't heard about} | |
end | |
procedure ncc-node-left-activation (node: ncc-node, t: token, w: WME) {copied from page 49} | |
new-token := make-token (node, t, w) {build and store a new token} | |
insert new-token at the head of node.items | |
new-token.ncc-results := nil {get initial ncc results} | |
for each result in node.partner.new-result-buffer do | |
remove result from node.partner.new-result-buffer | |
insert result at the head of new-token.ncc-results | |
result.owner := new-token | |
if new-token.ncc-results=nil then {No ncc results, so inform children} | |
for each child in node.children do | |
left-activation (child, new-token, nil ) | |
end | |
procedure ncc-partner-node-left-activation (partner: rete-node, t:token, w:WME) {copied from page 50 - see additional comments there} | |
ncc-node := partner.ncc-node | |
new-result := make-token (partner, t, w) {build a result token <t, w>} | |
{Find the appropriate owner token (into whose local memory we should put this result)} | |
owners-t := t; | |
owners-w := w | |
for i=1 to partner.number-of-conjuncts do | |
owners-w := owners-t.wme; | |
owners-t := owners-t.parent | |
{Look for this owner in the NCC node's memory. If we find it, add new-result to its local memory, and propagate (deletions) to the NCC node's children.} | |
if there is already a token owner in ncc-node.items with parent=owners-t and wme=owners-w then | |
add new-result to owner.ncc-results; | |
new-result.owner := owner | |
delete-descendents-of-token (owner) | |
else | |
{We didn't find an appropriate owner token already in the NCC node's memory, so we just stuff the result in our temporary buffer.} | |
insert new-result at the head of partner.new-result-buffer | |
end | |
procedure remove-wme (w: WME) {copied from page 102} | |
for each item in w.alpha-mem-items do | |
remove item from the list item.amem.items | |
if item.amem.items = nil then {alpha memory just became empty} | |
for each node in item.amem.successors do | |
if node is a join node then {don't left-unlink negative nodes} | |
remove node from the list node.parent.children | |
deallocate memory for item | |
while w.tokens != nil do | |
delete-token-and-descendents (the first item on w.tokens) | |
for each jr in w.negative-join-results do | |
remove jr from the list jr.owner.join-results | |
if jr.owner.join-results=nil then | |
for each child in jr.owner.node.children do | |
left-activation (child, jr.owner, nil ) | |
deallocate memory for jr | |
end | |
procedure delete-token-and-descendents (tok: token) {copied from page 87} | |
while tok.children != nil do | |
delete-token-and-descendents (the first item on tok.children) | |
if tok.node is not an NCC partner node then | |
remove tok from the list tok.node.items | |
if tok.wme != nil then | |
remove tok from the list tok.wme.tokens | |
remove tok from the list tok.parent.children | |
if tok.node is a memory node then | |
if tok.node.items = nil then | |
for each child in tok.node.children do | |
remove child from the list child.amem.successors | |
if tok.node is a negative node then | |
if tok.node.items = nil then | |
remove tok.node from the list tok.node.amem.successors | |
for each jr in tok.join-results do | |
remove jr from the list jr.w.negative-join-results | |
deallocate memory for jr | |
if tok.node is an NCC node then | |
for each result-tok in tok.ncc-results do | |
remove result-tok from the list result-tok.wme.tokens | |
remove result-tok from the list result-tok.parent.children | |
deallocate memory for result-tok | |
if tok.node is an NCC partner node then | |
remove tok from the list tok.owner.ncc-results | |
if tok.owner.ncc-results = nil then | |
for each child in tok.node.ncc-node.children do | |
left-activation (child, tok.owner, nil ) | |
deallocate memory for tok | |
end | |
procedure delete-descendents-of-token (t: token) {copied from page 43} | |
while t.children != nil do | |
delete-token-and-descendents (the first item on t.children) | |
end | |
function build-or-share-alpha-memory (c: condition) {dataflow network version} returning alpha-memory | |
current-node := top-node-of-alpha-network | |
for each constant test in each field of c do | |
let sym be the symbol tested for, and f be the field | |
current-node := build-or-share-constant-test-node (current-node, f, sym) | |
if current-node.output-memory != nil then | |
return current-node.output-memory | |
am := allocate-memory() | |
current-node.output-memory := am | |
am.successors := nil ; | |
am.items := nil | |
am.reference-count := 0 | |
{initialize am with any current WMEs} | |
for each WME w in working memory do | |
if w passes all the constant tests in c then | |
alpha-memory-activation (am ,w) | |
return am | |
end | |
function build-or-share-constant-test-node (parent: constant-test-node, f: field, sym: symbol ) returning constant-test-node | |
{look for an existing node we can share} | |
for each child in parent.children do | |
if child.field-to-test = f and child.thing-the-field-must-equal = sym then | |
return child | |
{couldn't find a node to share, so build a new one} | |
new := allocate-memory() | |
add new to the list parent.children | |
new.field-to-test := f; | |
new.thing-the-field-must-equal := sym | |
new.output-memory := nil ; | |
new.children := nil | |
return new | |
end | |
function build-or-share-alpha-memory (c: condition) {exhaustive table lookup version} returning alpha-memory {revised from version on page 36} | |
{figure out what the memory should look like} | |
id-test := nil ; | |
attr-test := nil ; | |
value-test := nil | |
if a constant test t occurs in the "id" field of c then id-test := t | |
if a constant test t occurs in the "attribute" field of c then attr-test := t | |
if a constant test t occurs in the "value" field of c then value-test := t | |
{is there an existing memory like this?} | |
am := lookup-in-hash-table (id-test, attr-test, value-test) | |
if am != nil then | |
return am | |
{no existing memory, so make a new one} | |
am := allocate-memory() | |
add am to the hash table for alpha memories | |
am.successors := nil ; | |
am.items := nil | |
am.reference-count := 0 | |
{initialize am with any current WMEs} | |
for each WME w in working memory do | |
if w passes all the constant tests in c then | |
alpha-memory-activation (am ,w) | |
return am | |
end | |
function build-or-share-beta-memory-node (parent: rete-node) returning rete-node {revised from version on page 34} | |
for each child in parent.children do {look for an existing node to share} | |
if child is a beta memory node then | |
return child | |
new := allocate-memory() | |
new.type := "beta-memory" | |
new.parent := parent; | |
insert new at the head of the list parent.children | |
new.children := nil | |
new.all-children := nil | |
new.items := nil | |
update-new-node-with-matches-from-above (new) | |
return new | |
end | |
function get-join-tests-from-condition (c: condition, earlier-conds: list of condition) returning list of test-at-join-node {revised from version on page 35} | |
result := nil | |
for each occurrence of a variable v in a field f of c do | |
if v occurs anywhere in a positive condition in earlier-conds then | |
let i be the largest i and f2 be a field such that v occurs in the f2 field of the i'th condition (a positive one) in earlier-conds | |
this-test := allocate-memory() | |
this-test.field-of-arg1 := f | |
this-test.condition-number-of-arg2 := i | |
this-test.field-of-arg2 := f2 | |
append this-test to result | |
return result | |
end | |
function find-nearest-ancestor-with-same-amem (node: rete-node, am: alpha-memory) returning rete-node | |
if node is the dummy top node then | |
return nil | |
if node.type = \join" or node.type = \negative" then | |
if node.amem = am then | |
return node | |
if node.type = "NCC" then | |
return find-nearest-ancestor-with-same-amem (node.partner.parent, am) | |
else | |
return find-nearest-ancestor-with-same-amem (node.parent, am) | |
end | |
function build-or-share-join-node (parent: rete-node, am: alpha-memory, tests: list of test-at-join-node) returning rete-node {revised from version on page 34} | |
for each child in parent.all-children do {look for an existing node to share} | |
if child is a join node and child.amem=am and child.tests=tests then | |
return child | |
new := allocate-memory() | |
new.type := "join" | |
new.parent := parent; | |
insert new at the head of the list parent.children | |
insert new at the head of the list parent.all-children | |
new.children := nil | |
new.tests := tests; | |
new.amem := am | |
insert new at the head of the list am.successors | |
increment am.reference-count | |
new.nearest-ancestor-with-same-amem := find-nearest-ancestor-with-same-amem (parent, am) | |
{Unlink right away if either memory is empty} | |
if parent.items = nil then | |
remove new from the list am.successors | |
else if | |
amem.items = nil then | |
remove new from the list parent.children | |
return new | |
end | |
function build-or-share-negative-node (parent: rete-node, am: alpha-memory, tests: list of test-at-join-node) returning rete-node | |
for each child in parent.children do {look for an existing node to share} | |
if child is a negative node and child.amem=am and child.tests=tests then | |
return child | |
new := allocate-memory() | |
new.type := "negative" | |
new.parent := parent; | |
insert new at the head of the list parent.children | |
new.children := nil | |
new.items := nil | |
new.tests := tests; | |
new.amem := am | |
insert new at the head of the list am.successors | |
increment am.reference-count | |
new.nearest-ancestor-with-same-amem := find-nearest-ancestor-with-same-amem (parent, am) | |
update-new-node-with-matches-from-above (new) | |
{Right-unlink the node if it has no tokens} | |
if new.items = nil then | |
remove new from the list am.successors | |
return new | |
end | |
function build-or-share-ncc-nodes (parent: rete-node, c: condition {the NCC condition}, earlier-conds: list of condition) returning rete-node {returns the NCC node} | |
bottom-of-subnetwork := build-or-share-network-for-conditions (parent, subconditions of c, earlier-conds) | |
for each child in parent.children do {look for an existing node to share} | |
if child is an NCC node and child.partner.parent=bottom-of-subnetwork then | |
return child | |
new := allocate-memory(); | |
new-partner := allocate-memory() | |
new.type := "NCC"; | |
new-partner.type := "NCC-partner" | |
new.parent := parent | |
insert new at the tail of the list parent.children {so the subnetwork comes first} | |
new-partner.parent := bottom-of-subnetwork | |
insert new-partner at the head of the list bottom-of-subnetwork.children | |
new.children := nil ; | |
new-partner.children := nil | |
new.partner := new-partner; | |
new-partner.ncc-node := new | |
new.items := nil ; | |
partner.new-result-buffer := nil | |
partner.number-of-conjuncts := number of subconditions of c | |
{Note: we have to inform NCC node of existing matches before informing the partner, otherwise lots of matches would all get mixed together in the new-result-buffer} | |
update-new-node-with-matches-from-above (new) | |
update-new-node-with-matches-from-above (partner) | |
return new | |
end | |
function build-or-share-network-for-conditions (parent: rete-node, conds: list of condition, earlier-conds: list of condition) returning rete-node | |
let the conds be denoted by c_1; ... ; c_k | |
current-node := parent | |
conds-higher-up := earlier-conds | |
for i = 1 to k do | |
if c_i is positive then | |
current-node := build-or-share-beta-memory-node (current-node) | |
tests = get-join-tests-from-condition (c_i, conds-higher-up) | |
am := build-or-share-alpha-memory (c_i) | |
current-node := build-or-share-join-no de (current-node, am, tests) | |
else if c_i is negative (but not NCC) then | |
tests = get-join-tests-from-condition (ci, conds-higher-up) | |
am := build-or-share-alpha-memory (ci) | |
current-node := build-or-share-negative-node (current-node, am, tests) | |
else {NCC's} | |
current-node := build-or-share-ncc-nodes (current-node, c_i, conds-higher-up) | |
append c_i to conds-higher-up | |
return current-node | |
end | |
procedure add-production (lhs: list of conditions) {revised from version on page 37} | |
current-node := build-or-share-network-for-conditions (dummy-top-node, lhs, nil ) | |
build a new production node, make it a child of current-node | |
update-new-node-with-matches-from-above (the new production node) | |
end | |
procedure update-new-node-with-matches-from-above (new-node: rete-node) {revised from version on page 38} | |
parent := new-node.parent | |
case parent.type of | |
"beta-memory": | |
for each tok in parent.items do | |
left-activation (new-node, tok) | |
"join": | |
saved-list-of-children := parent.children | |
parent.children [new-node] {list consisting of just new-node} | |
for each item in parent.amem.items do | |
right-activation (parent, item.wme) | |
parent.children := saved-list-of-children | |
"negative": | |
for each tok in parent.items do | |
if tok.join-results = nil then | |
left-activation (new-node, tok, nil ) | |
"NCC": | |
for each tok in parent.items do | |
if tok.ncc-results = nil then | |
left-activation (new-node, tok, nil ) | |
end | |
procedure remove-production (prod: production) {copied from page 38} | |
delete-node-and-any-unused-ancestors (the p-node for prod) | |
end | |
procedure delete-node-and-any-unused-ancestors (node: rete-node) {revised from version on page 39} | |
{For NCC nodes, delete the partner node too} | |
if node is an NCC node then | |
delete-node-and-any-unused-ancestors (node.partner) | |
{Clean up any tokens the node contains} | |
if node is a beta memory, negative, or NCC node then | |
while node.items != nil do | |
delete-token-and-descendents (first item on node.items) | |
if node is an NCC partner node then | |
while node.new-result-buffer != nil do | |
delete-token-and-descendents (first item on node.new-result-buffer) | |
{Deal with the alpha memory} | |
if node is a join or negative node then | |
if node is not right-unlinked then | |
remove node from the list node.amem.successors | |
decrement node.amem.reference-count | |
if node.amem.reference-count=0 then | |
delete-alpha-memory (node.amem) | |
{Deal with the parent} | |
if node is not left-unlinked then | |
remove node from the list node.parent.children | |
if node is a join node then | |
remove node from the list node.parent.all-children | |
if node.parent.all-children=nil then | |
delete-node-and-any-unused-ancestors (node.parent) | |
else if node.parent.children=nil then | |
delete-node-and-any-unused-ancestors (node.parent) | |
deallocate memory for node | |
end |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment