graphs: simplify by removing temporary namespace variables.

db4
John Benediktsson 2012-07-17 11:00:38 -07:00
parent 0c46a1834b
commit 75a1303a36
2 changed files with 13 additions and 31 deletions

View File

@ -16,9 +16,6 @@ $nl
ABOUT: "graphs"
HELP: graph
{ $var-description "Temporary variable used by various graph words." } ;
HELP: add-vertex
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." }

View File

@ -3,50 +3,35 @@
USING: assocs kernel namespaces sequences sets ;
IN: graphs
SYMBOL: graph
: if-graph ( vertex edges graph quot -- )
over
[ graph swap with-variable ]
[ 2drop 2drop ] if ; inline
dupd [ 3drop ] if ; inline
: nest ( key -- hash )
graph get [ drop H{ } clone ] cache ;
: nest ( key graph -- hash )
[ drop H{ } clone ] cache ; inline
: add-vertex ( vertex edges graph -- )
[ [ dupd nest set-at ] with each ] if-graph ; inline
: (add-vertex) ( key value vertex -- )
rot nest set-at ;
[ [ nest dupd set-at ] curry with each ] if-graph ; inline
: add-vertex* ( vertex edges graph -- )
[
swap [ (add-vertex) ] curry assoc-each
swapd [ [ rot ] dip nest set-at ] 2curry assoc-each
] if-graph ; inline
: remove-vertex ( vertex edges graph -- )
[ [ graph get at delete-at ] with each ] if-graph ; inline
: (remove-vertex) ( key value vertex -- )
rot graph get at delete-at drop ;
[ [ at delete-at ] curry with each ] if-graph ; inline
: remove-vertex* ( vertex edges graph -- )
[
swap [ (remove-vertex) ] curry assoc-each
swapd [ [ rot ] dip at delete-at drop ] 2curry assoc-each
] if-graph ; inline
SYMBOL: previous
: (closure) ( obj quot: ( elt -- assoc ) -- )
over previous get key? [
2drop
: (closure) ( obj assoc quot: ( elt -- assoc ) -- )
2over key? [
3drop
] [
over previous get conjoin
[ call ] keep
[ nip (closure) ] curry assoc-each
2over conjoin [ dip ] keep
[ [ drop ] 3dip (closure) ] 2curry assoc-each
] if ; inline recursive
: closure ( obj quot -- assoc )
H{ } clone [
previous [ (closure) ] with-variable
] keep ; inline
H{ } clone [ swap (closure) ] keep ; inline