CMU-CS-95-113.code

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