2007-09-20 18:09:08 -04:00
|
|
|
! Copyright (C) 2006, 2007 Slava Pestov.
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-06-11 03:58:38 -04:00
|
|
|
USING: assocs kernel namespaces sequences sets ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: graphs
|
|
|
|
|
2012-08-30 14:31:52 -04:00
|
|
|
<PRIVATE
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: if-graph ( vertex edges graph quot -- )
|
2012-07-17 14:00:38 -04:00
|
|
|
dupd [ 3drop ] if ; inline
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2012-07-17 14:00:38 -04:00
|
|
|
: nest ( key graph -- hash )
|
|
|
|
[ drop H{ } clone ] cache ; inline
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2012-08-30 14:31:52 -04:00
|
|
|
PRIVATE>
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: add-vertex ( vertex edges graph -- )
|
2012-07-17 14:00:38 -04:00
|
|
|
[ [ nest dupd set-at ] curry with each ] if-graph ; inline
|
2008-01-12 04:25:16 -05:00
|
|
|
|
|
|
|
: add-vertex* ( vertex edges graph -- )
|
|
|
|
[
|
2012-07-17 14:00:38 -04:00
|
|
|
swapd [ [ rot ] dip nest set-at ] 2curry assoc-each
|
2008-01-12 04:25:16 -05:00
|
|
|
] if-graph ; inline
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: remove-vertex ( vertex edges graph -- )
|
2012-07-17 14:00:38 -04:00
|
|
|
[ [ at delete-at ] curry with each ] if-graph ; inline
|
2008-01-12 04:25:16 -05:00
|
|
|
|
|
|
|
: remove-vertex* ( vertex edges graph -- )
|
|
|
|
[
|
2012-07-17 14:00:38 -04:00
|
|
|
swapd [ [ rot ] dip at delete-at drop ] 2curry assoc-each
|
2008-01-12 04:25:16 -05:00
|
|
|
] if-graph ; inline
|
|
|
|
|
2012-08-30 14:31:52 -04:00
|
|
|
<PRIVATE
|
|
|
|
|
2012-07-17 14:00:38 -04:00
|
|
|
: (closure) ( obj assoc quot: ( elt -- assoc ) -- )
|
|
|
|
2over key? [
|
|
|
|
3drop
|
2007-09-20 18:09:08 -04:00
|
|
|
] [
|
2012-07-17 14:00:38 -04:00
|
|
|
2over conjoin [ dip ] keep
|
|
|
|
[ [ drop ] 3dip (closure) ] 2curry assoc-each
|
2008-07-18 20:22:59 -04:00
|
|
|
] if ; inline recursive
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2012-08-30 14:31:52 -04:00
|
|
|
PRIVATE>
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: closure ( obj quot -- assoc )
|
2012-07-17 14:00:38 -04:00
|
|
|
H{ } clone [ swap (closure) ] keep ; inline
|