graphs: change closure to use a set and operate on sequences.
parent
30bdecd876
commit
67e3cfae22
|
@ -130,9 +130,11 @@ GENERIC: implementors ( class/classes -- seq )
|
|||
tri
|
||||
] { } make ;
|
||||
|
||||
: class-usage ( class -- seq ) update-map get at ;
|
||||
: class-usage ( class -- seq )
|
||||
update-map get at keys ;
|
||||
|
||||
: class-usages ( class -- seq ) [ class-usage ] closure keys ;
|
||||
: class-usages ( class -- seq )
|
||||
[ class-usage ] closure sets:members ;
|
||||
|
||||
M: class implementors implementors-map get at sets:members ;
|
||||
|
||||
|
@ -170,7 +172,7 @@ GENERIC: metaclass-changed ( use class -- )
|
|||
: check-metaclass ( class metaclass -- usages/f )
|
||||
over class? [
|
||||
over "metaclass" word-prop eq?
|
||||
[ drop f ] [ class-usage keys ] if
|
||||
[ drop f ] [ class-usage ] if
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
: ?define-symbol ( word -- )
|
||||
|
|
|
@ -298,7 +298,7 @@ PRIVATE>
|
|||
GENERIC: make-final ( class -- )
|
||||
|
||||
M: tuple-class make-final
|
||||
[ dup class-usage keys ?metaclass-changed ]
|
||||
[ dup class-usage ?metaclass-changed ]
|
||||
[ t "final" set-word-prop ]
|
||||
bi ;
|
||||
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
USING: assocs hashtables help.markup help.syntax kernel sequences ;
|
||||
USING: assocs hashtables help.markup help.syntax kernel
|
||||
sequences sets ;
|
||||
IN: graphs
|
||||
|
||||
ARTICLE: "graphs" "Directed graph utilities"
|
||||
|
@ -28,5 +29,5 @@ HELP: remove-vertex
|
|||
{ $side-effects "graph" } ;
|
||||
|
||||
HELP: closure
|
||||
{ $values { "obj" object } { "quot" { $quotation "( obj -- assoc )" } } { "assoc" "a new assoc" } }
|
||||
{ $values { "obj" object } { "quot" { $quotation "( obj -- assoc )" } } { "set" set } }
|
||||
{ $description "Outputs a set of all vertices reachable from " { $snippet "vertex" } " via edges given by the quotation. The set always includes " { $snippet "vertex" } "." } ;
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
USING: graphs tools.test namespaces kernel sorting assocs ;
|
||||
FROM: sets => members ;
|
||||
|
||||
H{ } "g" set
|
||||
{ 1 2 3 } "v" set
|
||||
|
@ -14,7 +15,7 @@ H{
|
|||
} "g" set
|
||||
|
||||
[ { 2 3 4 5 } ] [
|
||||
2 [ "g" get at ] closure keys natural-sort
|
||||
2 [ "g" get at keys ] closure members natural-sort
|
||||
] unit-test
|
||||
|
||||
H{ } "g" set
|
||||
|
|
|
@ -31,15 +31,12 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: (closure) ( obj assoc quot: ( elt -- assoc ) -- )
|
||||
2over key? [
|
||||
3drop
|
||||
] [
|
||||
2over conjoin [ dip ] keep
|
||||
[ [ drop ] 3dip (closure) ] 2curry assoc-each
|
||||
] if ; inline recursive
|
||||
: (closure) ( obj set quot: ( elt -- seq ) -- )
|
||||
2over ?adjoin [
|
||||
[ dip ] keep [ (closure) ] 2curry each
|
||||
] [ 3drop ] if ; inline recursive
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: closure ( obj quot -- assoc )
|
||||
H{ } clone [ swap (closure) ] keep ; inline
|
||||
: closure ( obj quot -- set )
|
||||
HS{ } clone [ swap (closure) ] keep ; inline
|
||||
|
|
Loading…
Reference in New Issue