graphs: move to core and simplify.
1. remove add-vertex* and remove-vertex* that contradicted the documentation.
2. graphs use hash-sets of edges instead of hashtables of {edge,edge} pairs.
3. make graphs:closure work like classes:closure, use in classes.
locals-and-roots
John Benediktsson
parent
f1fd761a72
commit
9cc73c9492
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs combinators fry graphs grouping kernel namespaces
|
||||
USING: assocs combinators fry grouping kernel namespaces
|
||||
sequences sets stack-checker.dependencies words ;
|
||||
IN: compiler.crossref
|
||||
|
||||
|
|
@ -58,9 +58,17 @@ generic-call-site-crossref [ H{ } clone ] initialize
|
|||
"effect-dependencies" "conditional-dependencies" "definition-dependencies"
|
||||
[ (store-dependencies) ] tri-curry@ tri-curry* tri ;
|
||||
|
||||
: add-xref ( word dependencies crossref -- )
|
||||
rot '[
|
||||
swap _ [ drop H{ } clone ] cache _ swap set-at
|
||||
] assoc-each ;
|
||||
|
||||
: remove-xref ( word dependencies crossref -- )
|
||||
[ keys ] dip '[ _ at delete-at ] with each ;
|
||||
|
||||
: (compiled-xref) ( word dependencies generic-dependencies -- )
|
||||
compiled-crossref generic-call-site-crossref
|
||||
[ get add-vertex* ] bi-curry@ bi-curry* bi ;
|
||||
[ get add-xref ] bi-curry@ bi-curry* bi ;
|
||||
|
||||
: compiled-xref ( word dependencies generic-dependencies -- )
|
||||
[ only-xref ] bi@
|
||||
|
|
@ -86,7 +94,7 @@ generic-call-site-crossref [ H{ } clone ] initialize
|
|||
join-dependencies ;
|
||||
|
||||
: (compiled-unxref) ( word dependencies variable -- )
|
||||
get remove-vertex* ;
|
||||
get remove-xref ;
|
||||
|
||||
: generic-call-sites ( word -- alist )
|
||||
"generic-call-sites" word-prop 2 group ;
|
||||
|
|
|
|||
|
|
@ -1,50 +0,0 @@
|
|||
USING: graphs tools.test namespaces kernel sorting assocs ;
|
||||
|
||||
H{ } "g" set
|
||||
{ 1 2 3 } "v" set
|
||||
|
||||
{ } [ "v" dup get "g" get add-vertex ] unit-test
|
||||
|
||||
{ { "v" } } [ 1 "g" get at keys ] unit-test
|
||||
|
||||
H{
|
||||
{ 1 H{ { 1 1 } { 2 2 } } }
|
||||
{ 2 H{ { 3 3 } { 4 4 } } }
|
||||
{ 4 H{ { 4 4 } { 5 5 } } }
|
||||
} "g" set
|
||||
|
||||
{ { 2 3 4 5 } } [
|
||||
2 [ "g" get at ] closure keys natural-sort
|
||||
] unit-test
|
||||
|
||||
H{ } "g" set
|
||||
|
||||
{ } [
|
||||
"mary"
|
||||
H{ { "billy" "one" } { "joey" "two" } }
|
||||
"g" get add-vertex*
|
||||
] unit-test
|
||||
|
||||
{ H{ { "mary" "one" } } } [
|
||||
"billy" "g" get at
|
||||
] unit-test
|
||||
|
||||
{ } [
|
||||
"liz"
|
||||
H{ { "billy" "four" } { "fred" "three" } }
|
||||
"g" get add-vertex*
|
||||
] unit-test
|
||||
|
||||
{ H{ { "mary" "one" } { "liz" "four" } } } [
|
||||
"billy" "g" get at
|
||||
] unit-test
|
||||
|
||||
{ } [
|
||||
"mary"
|
||||
H{ { "billy" "one" } { "joey" "two" } }
|
||||
"g" get remove-vertex*
|
||||
] unit-test
|
||||
|
||||
{ H{ { "liz" "four" } } } [
|
||||
"billy" "g" get at
|
||||
] unit-test
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel sequences sets ;
|
||||
IN: graphs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: if-graph ( vertex edges graph quot -- )
|
||||
dupd [ 3drop ] if ; inline
|
||||
|
||||
: nest ( key graph -- hash )
|
||||
[ drop H{ } clone ] cache ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: add-vertex ( vertex edges graph -- )
|
||||
[ [ nest conjoin ] curry with each ] if-graph ; inline
|
||||
|
||||
: add-vertex* ( vertex edges graph -- )
|
||||
[
|
||||
swapd [ [ rot ] dip nest set-at ] 2curry assoc-each
|
||||
] if-graph ; inline
|
||||
|
||||
: remove-vertex ( vertex edges graph -- )
|
||||
[ [ at delete-at ] curry with each ] if-graph ; inline
|
||||
|
||||
: remove-vertex* ( vertex edges graph -- )
|
||||
[
|
||||
swapd [ [ rot ] dip at delete-at drop ] 2curry assoc-each
|
||||
] if-graph ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (closure) ( vertex assoc quot: ( vertex -- assoc ) -- )
|
||||
2over key? [
|
||||
3drop
|
||||
] [
|
||||
2over conjoin [ dip ] keep
|
||||
[ [ drop ] 3dip (closure) ] 2curry assoc-each
|
||||
] if ; inline recursive
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: closure ( vertex quot: ( vertex -- assoc ) -- assoc )
|
||||
H{ } clone [ swap (closure) ] keep ; inline
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators definitions kernel
|
||||
USING: accessors assocs combinators definitions graphs kernel
|
||||
make namespaces quotations sequences sets words words.symbol ;
|
||||
IN: classes
|
||||
|
||||
|
|
@ -135,18 +135,6 @@ GENERIC: implementors ( class/classes -- seq )
|
|||
: class-usage ( class -- seq )
|
||||
update-map get at members ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (closure) ( obj set quot: ( elt -- seq ) -- )
|
||||
2over ?adjoin [
|
||||
[ dip ] keep [ (closure) ] 2curry each
|
||||
] [ 3drop ] if ; inline recursive
|
||||
|
||||
: closure ( obj quot -- set )
|
||||
HS{ } clone [ swap (closure) ] keep ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: class-usages ( class -- seq )
|
||||
[ class-usage ] closure members ;
|
||||
|
||||
|
|
@ -157,12 +145,10 @@ M: sequence implementors [ implementors ] gather ;
|
|||
<PRIVATE
|
||||
|
||||
: update-map+ ( class -- )
|
||||
dup class-uses update-map get
|
||||
[ adjoin-at ] curry with each ;
|
||||
dup class-uses update-map get add-vertex ;
|
||||
|
||||
: update-map- ( class -- )
|
||||
dup class-uses update-map get
|
||||
[ at delete ] curry with each ;
|
||||
dup class-uses update-map get remove-vertex ;
|
||||
|
||||
: implementors-map+ ( class -- )
|
||||
[ HS{ } clone ] dip implementors-map get set-at ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
USING: assocs hashtables help.markup help.syntax kernel sequences ;
|
||||
USING: assocs hashtables hash-sets help.markup help.syntax
|
||||
kernel sequences sets ;
|
||||
IN: graphs
|
||||
|
||||
ARTICLE: "graphs" "Directed graph utilities"
|
||||
"Words for treating associative mappings as directed graphs can be found in the " { $vocab-link "graphs" } " vocabulary. A directed graph is represented as an assoc mapping each vertex to a set of edges entering that vertex, where the set is itself an assoc, with equal keys and values."
|
||||
"Words for treating associative mappings as directed graphs can be found in the " { $vocab-link "graphs" } " vocabulary. A directed graph is represented as an assoc mapping each vertex to a " { $link hash-set } " of edges entering that vertex."
|
||||
$nl
|
||||
"To create a new graph, just create an assoc, for example by calling " { $link <hashtable> } ". To add vertices and edges to a graph:"
|
||||
{ $subsections add-vertex }
|
||||
|
|
@ -10,23 +11,23 @@ $nl
|
|||
{ $subsections remove-vertex }
|
||||
"Since graphs are represented as assocs, they can be cleared out by calling " { $link clear-assoc } "."
|
||||
$nl
|
||||
"You can perform queries on the graph:"
|
||||
"You can perform queries on a graph:"
|
||||
{ $subsections closure }
|
||||
"Directed graphs are used to maintain cross-referencing information for " { $link "definitions" } "." ;
|
||||
|
||||
ABOUT: "graphs"
|
||||
|
||||
HELP: add-vertex
|
||||
{ $values { "vertex" object } { "edges" sequence } { "graph" "an assoc mapping vertices to sequences of edges" } }
|
||||
{ $values { "vertex" object } { "edges" sequence } { "graph" "an " { $link assoc } " mapping vertices to " { $link hash-set } " of edges" } }
|
||||
{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." }
|
||||
{ $side-effects "graph" } ;
|
||||
|
||||
HELP: remove-vertex
|
||||
{ $values { "vertex" object } { "edges" sequence } { "graph" "an assoc mapping vertices to sequences of edges" } }
|
||||
{ $values { "vertex" object } { "edges" sequence } { "graph" "an " { $link assoc } " mapping vertices to " { $link unordered-set } "s of edges" } }
|
||||
{ $description "Removes a vertex from a graph, using the given edges sequence." }
|
||||
{ $notes "The " { $snippet "edges" } " sequence must equal the value passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." }
|
||||
{ $notes "The " { $snippet "edges" } " sequence must have all the values passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." }
|
||||
{ $side-effects "graph" } ;
|
||||
|
||||
HELP: closure
|
||||
{ $values { "vertex" object } { "quot" { $quotation ( vertex -- assoc ) } } { "assoc" "a new assoc" } }
|
||||
{ $description "Outputs a set of all vertices reachable from " { $snippet "vertex" } " via edges given by the quotation. The set always includes " { $snippet "vertex" } "." } ;
|
||||
{ $values { "vertex" object } { "quot" { $quotation ( vertex -- edges ) } } { "set" hash-set } }
|
||||
{ $description "Outputs all vertices reachable from " { $snippet "vertex" } " via edges given by the quotation. The set always includes " { $snippet "vertex" } "." } ;
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
USING: assocs graphs kernel namespaces sets sorting tools.test ;
|
||||
|
||||
H{ } "g" set
|
||||
{ 1 2 3 } "v" set
|
||||
|
||||
{ } [ "v" dup get "g" get add-vertex ] unit-test
|
||||
|
||||
{ { "v" } } [ 1 "g" get at members ] unit-test
|
||||
|
||||
H{
|
||||
{ 1 HS{ 1 2 } }
|
||||
{ 2 HS{ 3 4 } }
|
||||
{ 4 HS{ 4 5 } }
|
||||
} "g" set
|
||||
|
||||
{ { 2 3 4 5 } } [
|
||||
2 [ "g" get at members ] closure members natural-sort
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel sequences sets ;
|
||||
IN: graphs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: nest ( vertex graph -- edges )
|
||||
[ drop HS{ } clone ] cache ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: add-vertex ( vertex edges graph -- )
|
||||
[ nest adjoin ] curry with each ; inline
|
||||
|
||||
: remove-vertex ( vertex edges graph -- )
|
||||
[ at delete ] curry with each ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (closure) ( vertex set quot: ( vertex -- edges ) -- )
|
||||
2over ?adjoin [
|
||||
[ dip ] keep [ (closure) ] 2curry each
|
||||
] [ 3drop ] if ; inline recursive
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: closure ( vertex quot: ( vertex -- edges ) -- set )
|
||||
HS{ } clone [ swap (closure) ] keep ; inline
|
||||
Loading…
Reference in New Issue