Provides a set of functions that create or modify trees (data structure composed of nodes, where each node has a parent node and zero or more child nodes).
A tree is a very common data structure that can be used in many ways by many different algorithms. This module defines a set of functions to create and modify trees. A tree is composed of nodes; each node has a type, some properties, a parent node (unless it's the root of the three), and zero or more child nodes.
〈Overview〉 ≡
make-node: func [
type [word!]
] [
reduce [type none copy [ ]]
]
node-type: 1 node-parent: 2 node-properties: 3 node-first-child: 4
node?: func [
node [any-type!]
] [
all [block? get/any 'node parse node [word! [block! | none!] block! any block!]]
]
invalid-arg: func [val] [throw make error! compose/only [script invalid-arg (:val)]]
set-assoc: func [block word value /local pos] [
either pos: find/only block word [
pos/2: :value
] [
insert/only insert/only tail block word :value
]
]
remove-node: func [node] [
if node/:node-parent [
fix-parents remove node/:node-parent
node/:node-parent: none
]
]
insert-node: func [pos node] [
unless node? :node [invalid-arg :node]
remove-node node
insert/only node/:node-parent: pos node
fix-parents next pos
]
fix-parents: func [
childs [block!]
] [
forall childs [
childs/1/:node-parent: childs
]
childs
]
resolve-path: func [path] [
path: copy path
parse path [
some [
path:
paren! (path: change/part path do path/1 1) :path
|
get-word! (path: change/part path get path/1 1) :path
|
skip
]
]
head path
]
node-path: make-rule [node /local pos] [
'parent (push-result if node/:node-parent [head node/:node-parent])
|
'next (push-result if node/:node-parent [node/:node-parent/2])
|
['prev | 'previous] (
push-result all [node/:node-parent node-first-child < index? node/:node-parent node/:node-parent/-1]
)
|
'childs [
set pos [integer! | word!]
|
set pos skip (invalid-arg :pos)
] (
node: at node node-first-child
either integer? pos [
if negative? pos [pos: pos + 1 + length? node]
push-result pick node max 0 pos
] [
push-result foreach child node [
if child/:node-type = pos [
break/return child
]
]
]
)
]
set-node: func [
[catch]
'what [path! set-path!]
value
/local node pos word
] [
parse what: resolve-path what [
set word word! (
node: throw-on-error [get word]
unless node? node [invalid-arg node]
) some [
'type end (
unless word? :value [invalid-arg :value]
node/:node-type: value
)
|
['prop | 'properties] [
set word word!
|
set word skip (invalid-arg :word)
] end (set-assoc node/:node-properties word :value)
|
['prop | 'properties] end (
unless block? :value [invalid-arg :value]
parse value [
any [[word! | path!] skip] end (node/:node-properties: value)
|
any [
set word set-word! do-next (set-assoc node/:node-properties to word! word pop-result)
|
set word set-path! do-next (set-assoc node/:node-properties to path! word pop-result)
] end
|
pos: (invalid-arg pos)
]
)
|
'parent end (
unless any [none? :value node? :value] [invalid-arg :value]
remove-node node
if value [
insert/only node/:node-parent: tail value node
]
)
|
'next end (
unless node/:node-parent [invalid-arg what]
insert-node next node/:node-parent :value
)
|
['prev | 'previous] end (
unless node/:node-parent [invalid-arg what]
insert-node node/:node-parent :value
)
|
(push-arguments [node]) node-path (
unless node? node: pop-result [invalid-arg what]
)
]
|
(invalid-arg mold what)
]
:value
]
get-node: func [
[catch]
'what [path!]
/local word node
] [
parse what: resolve-path what [
set word word! (
node: throw-on-error [get word]
unless node? node [invalid-arg node]
) some [
'type end (return node/:node-type)
|
['prop | 'properties] [
set word word!
|
set word skip (invalid-arg :word)
|
end (return node/:node-properties)
] end (return select node/:node-properties word)
|
'childs end (return at node node-first-child)
|
(push-arguments [node]) node-path (node: pop-result) [
end (return node)
|
(unless node? node [invalid-arg mold what])
]
]
|
(invalid-arg mold what)
]
]
append-node-rule: make-rule [
parent
child
] [
(set-node child/parent: parent push-result parent)
]
node-rule: make-rule [
/local type this-node name value
] [
set type word! (this-node: make-node type)
into [
any [
set name set-word!
do-next
(set-node this-node/prop/(to word! name) pop-result)
|
set name word!
set value skip
(set-node this-node/prop/:name: :value)
]
]
(push-result this-node)
any [
into [
node-rule append-node-rule
]
]
]
make-tree: func [
spec [block!]
] [
parse spec node-rule
pop-result
]
mold-tree*: func [
tree [block!]
/local result
] [
result: reduce [tree/:node-type tree/:node-properties]
foreach child get-node tree/childs [
append/only result mold-tree* child
]
result
]
mold-tree: func [
tree [block!]
] [
mold/all mold-tree* tree
]
clone-tree: func [
tree [block!]
/local result
] [
result: reduce [tree/:node-type none copy tree/:node-properties]
foreach child at tree node-first-child [
child: clone-tree child
set-node child/parent: result
]
result
]
save-tree: func [
where [file! url!]
tree [block!]
] [
save/all where mold-tree* tree
]
load-tree: func [
tree [file! url! string! any-block!]
] [
make-tree load tree
]
make-node-path: func [node /local result] [
result: make path! 4
until [
insert result node/:node-type
any [
none? node/:node-parent
not node: head node/:node-parent
]
]
result
]
match-path?: func [
current [word!]
pattern [word! paren!]
path [path!]
pattern-path [path!]
] [
forever [
if all [paren? pattern not find pattern current] [return false]
if all [word? pattern not find [* **] pattern pattern <> current] [return false]
if head? pattern-path [return true]
if head? path [return false]
either pattern = '** [
return any [
match-path? current pattern-path/-1 path back pattern-path
match-path? current '* path pattern-path
match-path? path/-1 '** back path pattern-path
]
] [
pattern-path: back pattern-path
path: back path
current: path/1
pattern: pattern-path/1
]
]
]
match-type?: func [
node [block!]
type [path!]
/local node-path
] [
node-path: back tail make-node-path node
type: back tail type
match-path? node-path/1 type/1 node-path type
]
all-step: func [[throw] value] [
unless :value [return false]
]
any-step: func [[throw] value] [
if :value [return true]
]
node-words: ['type | 'prop | 'properties | 'parent | 'next | 'prev | 'previous | 'childs]
match-node?: func [
[catch]
node [block!]
'mode [word!]
predicates [block!]
/local property value node2 result op
] [
mode: either mode = 'any [
result: false
:any-step
] [
result: true
:all-step
]
parse predicates [
some [
'any set predicates block! (mode match-node? node any predicates)
|
'all set predicates block! (mode match-node? node all predicates)
|
set property ['type | into [thru 'type]] '~ set value path! (
node2: either path? property [get-node node/(copy/part property back tail property)] [node]
mode match-type? node2 value
)
|
set property ['prop | 'properties | into [thru 'prop] | into [thru 'properties]]
'=
set value ['prop | 'properties | into [thru 'prop] | into [thru 'properties]] (
property: sort/skip get-node node/:property 2
value: sort/skip get-node node/:value 2
mode property = value
)
|
set property [node-words | into [node-words to end]] set op word! [
set value paren! (value: do value)
|
set value [node-words | into [node-words to end]] (value: get-node node/:value)
|
do-next (value: pop-result)
] (
property: get-node node/:property
either op = 'in [
mode find :value :property
] [
do head change next next [mode :property = :value] op
]
)
|
do-next (mode pop-result)
]
]
result
]
unwrap-node: func [
node [block!]
/local parent
] [
either empty? at node node-first-child [
set-node node/parent: none
] [
if parent: node/:node-parent [
change/part parent at node node-first-child 1
fix-parents parent
parent/1
]
]
]
rewrite-tree*: func [
tree rules
/local result
] [
result: false
foreach child at tree node-first-child [
result: result or rewrite-tree* child rules
]
foreach [match action] rules [
if match-node? tree all match [
result: true
do get action tree
]
]
result
]
rewrite-tree: func [
tree [block!]
rules [block!]
] [
until [
not rewrite-tree* tree rules
]
]