REBOL [
Title: "Graph Functions"
Purpose: "Define functions for working on graphs."
Author: "Brett Handley"
Date: 15-dec-2001
Version: 1.0.1
Rights: {Copyright © Brett Handley 2001
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, subrights,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.}
History: [
1.0.0 [1-May-2001 "Initial version" "Brett Handley"]
1.0.1 [15-Dec-2001 "Added comment and changed to function help to improve understanding." "Brett Handley"]
]
]
graph-topological-sort: function [ [catch]
"Topological sort - Returns block keys (precedents before their antecedents)."
dag [block!] "DAG structure a list of keys with their optional precedents listed in a block after the key."
/adjacency "dag in form of adjacency list (every key must have dependency block even if empty) - this is critical for accuracy."
/cycle "Search for cycles - return it if found otherwise return none."
][result working node key key-ref neighbours][
result: copy []
; Duplicate the input and ensure single references
working: either adjacency [copy/deep dag][graph-adjaceny-list? dag]
if not parse working [any [ series! to skip end | any-type! into [to end] ]] [
throw make error! "Adjacency list has an incorrect format"
]
for i 2 length? working 2 [
poke working i neighbours: unique pick working i
]
; Now sort
while [not tail? working] [
either node: find/only working [] [
node: back node
key: first node
][
either cycle [
RETURN working
][
throw make error! "Topological sort failed - cycles encountered."
]
]
for i 2 length? working 2 [ if key-ref: find/only working/:i key [remove key-ref] ]
remove/part node 2
append/only result key
]
RETURN either cycle [none][result]
]
graph-adjaceny-list?: function [
"Function to create adjacency-list from block structure - has the nice property that it can be applied to itself."
graph-structure [block!] "List of node keys each followed by an optional block of keys representing adjacent nodes (recusion allowed)."
/undirected "Automatically complete the adjaceny list."
][parse-result result block-structure key stack neighbours neighbours2][
block-structure: [
any [
series! to end skip |
[
set key any-type! (
if all [not empty? stack not find/only last stack key] [append/only last stack key]
if not neighbours: select/only result key [
append result reduce [key neighbours: copy []]
]
append/only stack neighbours
)
opt [into [block-structure]]
(remove back tail stack)
]
]
]
stack: copy []
result: copy []
parse-result: parse graph-structure block-structure
if not parse-result [RETURN none]
if not undirected [RETURN result]
forskip result 2 [
key: first result
neighbours: second result
foreach neighbour neighbours [
if not find/only neighbours2: select head result neighbour key [
append/only neighbours2 key
]
]
]
return head result
]
graph-trees?: function [
"Produces a recursive style adjacency list."
dag [block!] "DAG structure a list of keys with their optional precedents listed in a block after the key."
/complete "All combinations"
][result working output sorted-keys key neighbours visited-keys add-children][
result: copy []
visited-keys: copy []
add-key-node: function [parent-block key][children child-block][
append/only visited-keys key
insert/only parent-block key
children: select working key
if not empty? children [
insert/only next parent-block child-block: copy []
for i 1 length? children 1 [
add-key-node child-block children/:i
]
]
]
working: graph-adjaceny-list? dag
sorted-keys: head reverse graph-topological-sort working
while [ not tail? sorted-keys] [
key: first sorted-keys
if any [complete not find/only visited-keys key] [ add-key-node result key ]
sorted-keys: next sorted-keys
]
RETURN result
]
graph-dfs?: function [
"Depth first search - returns the visited keys (a minimum spanning tree)"
graph-structure [block!] "List of node keys each followed by an optional block of keys representing connected nodes."
/from start-key "Starts the search with this key."
/until search-key "Specifies a key to search for."
/undirected "Automatically complete the adjaceny list."
][stack visited-keys neighbours neighbour working][
stack: copy []
visited-keys: copy []
either undirected [
working: graph-adjaceny-list?/undirected graph-structure
][
working: graph-adjaceny-list?/undirected graph-structure
]
if not empty? working [
if not from [start-key: first working]
append/only visited-keys start-key
append/only stack start-key
]
while [not empty? stack] [
current-key: last stack
neighbours: select/only working current-key
neighbour: graph-unvisited-neighbour? neighbours visited-keys
either neighbour [
append/only visited-keys neighbour
append/only stack neighbour
if all [until equal? search-key neighbour][RETURN visited-keys]
][ remove back tail stack ]
]
either search-key [RETURN none ][RETURN visited-keys]
]
graph-bfs?: function [
"Breadth first search - returns the visited keys (a minimum spanning tree)"
graph-structure [block!] "List of node keys each followed by an optional block of keys representing adjacent nodes."
/from start-key "Starts the search with this key."
/until search-key "Specifies a key to search for."
/undirected "Automatically complete the adjaceny list."
][queue visited-keys neighbours neighbour current-key working][
queue: copy []
visited-keys: copy []
either undirected [
working: graph-adjaceny-list?/undirected graph-structure
][
working: graph-adjaceny-list? graph-structure
]
if not empty? working [
if not from [start-key: first working]
append/only queue start-key
append/only visited-keys start-key
]
while [not empty? queue] [
current-key: first queue
remove queue
neighbours: select/only working current-key
while [neighbour: graph-unvisited-neighbour? neighbours visited-keys] [
append/only visited-keys neighbour
append/only queue neighbour
if all [until equal? search-key neighbour][RETURN visited-keys]
]
]
either search-key [RETURN none ][RETURN visited-keys]
]
graph-unvisited-neighbour?: function [
neighbours [block!] "Block of keys."
visited-keys [block!]
][][
neighbour: neighbours
while [
all [ not tail? neighbour find/only visited-keys first neighbour ]
][ neighbour: next neighbour ]
either tail? neighbour [RETURN none][first neighbour]
]