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 2016-03-21 10:17:29 -07:00
parent f1fd761a72
commit 9cc73c9492
10 changed files with 70 additions and 123 deletions

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009, 2010 Slava Pestov. ! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; sequences sets stack-checker.dependencies words ;
IN: compiler.crossref IN: compiler.crossref
@ -58,9 +58,17 @@ generic-call-site-crossref [ H{ } clone ] initialize
"effect-dependencies" "conditional-dependencies" "definition-dependencies" "effect-dependencies" "conditional-dependencies" "definition-dependencies"
[ (store-dependencies) ] tri-curry@ tri-curry* tri ; [ (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-xref) ( word dependencies generic-dependencies -- )
compiled-crossref generic-call-site-crossref 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 -- ) : compiled-xref ( word dependencies generic-dependencies -- )
[ only-xref ] bi@ [ only-xref ] bi@
@ -86,7 +94,7 @@ generic-call-site-crossref [ H{ } clone ] initialize
join-dependencies ; join-dependencies ;
: (compiled-unxref) ( word dependencies variable -- ) : (compiled-unxref) ( word dependencies variable -- )
get remove-vertex* ; get remove-xref ;
: generic-call-sites ( word -- alist ) : generic-call-sites ( word -- alist )
"generic-call-sites" word-prop 2 group ; "generic-call-sites" word-prop 2 group ;

View File

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

View File

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

View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2010 Slava Pestov. ! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; make namespaces quotations sequences sets words words.symbol ;
IN: classes IN: classes
@ -135,18 +135,6 @@ GENERIC: implementors ( class/classes -- seq )
: class-usage ( class -- seq ) : class-usage ( class -- seq )
update-map get at members ; 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-usages ( class -- seq )
[ class-usage ] closure members ; [ class-usage ] closure members ;
@ -157,12 +145,10 @@ M: sequence implementors [ implementors ] gather ;
<PRIVATE <PRIVATE
: update-map+ ( class -- ) : update-map+ ( class -- )
dup class-uses update-map get dup class-uses update-map get add-vertex ;
[ adjoin-at ] curry with each ;
: update-map- ( class -- ) : update-map- ( class -- )
dup class-uses update-map get dup class-uses update-map get remove-vertex ;
[ at delete ] curry with each ;
: implementors-map+ ( class -- ) : implementors-map+ ( class -- )
[ HS{ } clone ] dip implementors-map get set-at ; [ HS{ } clone ] dip implementors-map get set-at ;

View File

@ -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 IN: graphs
ARTICLE: "graphs" "Directed graph utilities" 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 $nl
"To create a new graph, just create an assoc, for example by calling " { $link <hashtable> } ". To add vertices and edges to a graph:" "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 } { $subsections add-vertex }
@ -10,23 +11,23 @@ $nl
{ $subsections remove-vertex } { $subsections remove-vertex }
"Since graphs are represented as assocs, they can be cleared out by calling " { $link clear-assoc } "." "Since graphs are represented as assocs, they can be cleared out by calling " { $link clear-assoc } "."
$nl $nl
"You can perform queries on the graph:" "You can perform queries on a graph:"
{ $subsections closure } { $subsections closure }
"Directed graphs are used to maintain cross-referencing information for " { $link "definitions" } "." ; "Directed graphs are used to maintain cross-referencing information for " { $link "definitions" } "." ;
ABOUT: "graphs" ABOUT: "graphs"
HELP: add-vertex 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." } { $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." }
{ $side-effects "graph" } ; { $side-effects "graph" } ;
HELP: remove-vertex 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." } { $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" } ; { $side-effects "graph" } ;
HELP: closure HELP: closure
{ $values { "vertex" object } { "quot" { $quotation ( vertex -- assoc ) } } { "assoc" "a new assoc" } } { $values { "vertex" object } { "quot" { $quotation ( vertex -- edges ) } } { "set" hash-set } }
{ $description "Outputs a set of all vertices reachable from " { $snippet "vertex" } " via edges given by the quotation. The set always includes " { $snippet "vertex" } "." } ; { $description "Outputs all vertices reachable from " { $snippet "vertex" } " via edges given by the quotation. The set always includes " { $snippet "vertex" } "." } ;

View File

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

29
core/graphs/graphs.factor Normal file
View File

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