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