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] ]