2010-02-26 16:01:01 -05:00
|
|
|
! Copyright (C) 2010 Daniel Ehrenberg
|
2008-04-14 03:20:37 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2013-03-23 18:22:52 -04:00
|
|
|
USING: assocs hashtables kernel math sequences vectors ;
|
2008-04-14 03:20:37 -04:00
|
|
|
IN: sets
|
|
|
|
|
2016-03-29 20:14:42 -04:00
|
|
|
! Set protocol
|
2016-03-29 18:46:29 -04:00
|
|
|
MIXIN: set
|
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
GENERIC: adjoin ( elt set -- )
|
2013-03-23 19:56:35 -04:00
|
|
|
GENERIC: ?adjoin ( elt set -- ? )
|
2010-02-26 16:01:01 -05:00
|
|
|
GENERIC: in? ( elt set -- ? )
|
|
|
|
GENERIC: delete ( elt set -- )
|
2017-02-07 16:31:07 -05:00
|
|
|
GENERIC: ?delete ( elt set -- ? )
|
2010-02-26 16:01:01 -05:00
|
|
|
GENERIC: set-like ( set exemplar -- set' )
|
|
|
|
GENERIC: fast-set ( set -- set' )
|
2010-03-16 20:17:26 -04:00
|
|
|
GENERIC: members ( set -- seq )
|
2010-02-26 16:01:01 -05:00
|
|
|
GENERIC: union ( set1 set2 -- set )
|
|
|
|
GENERIC: intersect ( set1 set2 -- set )
|
|
|
|
GENERIC: intersects? ( set1 set2 -- ? )
|
|
|
|
GENERIC: diff ( set1 set2 -- set )
|
|
|
|
GENERIC: subset? ( set1 set2 -- ? )
|
|
|
|
GENERIC: set= ( set1 set2 -- ? )
|
2010-02-27 00:27:40 -05:00
|
|
|
GENERIC: duplicates ( set -- seq )
|
2010-02-26 16:01:01 -05:00
|
|
|
GENERIC: all-unique? ( set -- ? )
|
2010-04-17 17:25:51 -04:00
|
|
|
GENERIC: null? ( set -- ? )
|
2010-12-27 22:22:36 -05:00
|
|
|
GENERIC: cardinality ( set -- n )
|
2013-03-07 21:48:15 -05:00
|
|
|
GENERIC: clear-set ( set -- )
|
2010-12-27 22:22:36 -05:00
|
|
|
|
2013-03-23 17:46:54 -04:00
|
|
|
M: f members drop f ;
|
|
|
|
|
2010-12-27 22:22:36 -05:00
|
|
|
M: f cardinality drop 0 ;
|
2010-02-26 16:01:01 -05:00
|
|
|
|
2013-03-09 01:26:56 -05:00
|
|
|
M: f delete 2drop ;
|
|
|
|
|
2013-03-07 21:48:15 -05:00
|
|
|
M: f clear-set drop ; inline
|
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
! Defaults for some methods.
|
|
|
|
! Override them for efficiency
|
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set ?adjoin 2dup in? [ 2drop f ] [ adjoin t ] if ;
|
2013-03-23 19:56:35 -04:00
|
|
|
|
2017-02-07 16:31:07 -05:00
|
|
|
M: set ?delete 2dup in? [ delete t ] [ 2drop f ] if ;
|
|
|
|
|
2017-02-07 17:54:57 -05:00
|
|
|
M: set null? cardinality 0 = ; inline
|
2010-04-17 17:25:51 -04:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set cardinality members length ;
|
2010-12-27 22:22:36 -05:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set clear-set [ members ] keep [ delete ] curry each ;
|
2013-03-07 21:48:15 -05:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set set-like drop ; inline
|
2010-02-27 00:27:40 -05:00
|
|
|
|
2012-08-24 19:36:30 -04:00
|
|
|
<PRIVATE
|
|
|
|
|
|
|
|
: ?members ( set -- seq )
|
|
|
|
dup sequence? [ members ] unless ; inline
|
|
|
|
|
|
|
|
: (union) ( set1 set2 -- seq )
|
|
|
|
[ ?members ] bi@ append ; inline
|
|
|
|
|
|
|
|
PRIVATE>
|
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set union [ (union) ] keep set-like ;
|
2008-05-25 20:44:37 -04:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
<PRIVATE
|
2009-07-21 04:02:06 -04:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
: tester ( set -- quot )
|
|
|
|
fast-set [ in? ] curry ; inline
|
2008-05-25 20:44:37 -04:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
: sequence/tester ( set1 set2 -- set1' quot )
|
|
|
|
[ members ] [ tester ] bi* ; inline
|
2008-04-14 03:20:37 -04:00
|
|
|
|
2010-12-29 07:53:22 -05:00
|
|
|
: small/large ( set1 set2 -- set1' set2' )
|
2013-03-26 18:49:37 -04:00
|
|
|
2dup [ cardinality ] bi@ > [ swap ] when ; inline
|
2010-12-29 07:53:22 -05:00
|
|
|
|
2013-03-26 18:16:26 -04:00
|
|
|
: (intersect) ( set1 set2 -- seq )
|
|
|
|
small/large sequence/tester filter ; inline
|
|
|
|
|
|
|
|
: (diff) ( set1 set2 -- seq )
|
2017-01-06 17:08:42 -05:00
|
|
|
sequence/tester reject ; inline
|
2013-03-26 18:16:26 -04:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
PRIVATE>
|
2008-04-14 03:20:37 -04:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set intersect [ (intersect) ] keep set-like ;
|
2008-07-13 21:46:41 -04:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set diff [ (diff) ] keep set-like ;
|
2008-06-12 06:49:46 -04:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set intersects?
|
2010-12-29 07:53:22 -05:00
|
|
|
small/large sequence/tester any? ;
|
2010-02-26 16:01:01 -05:00
|
|
|
|
2011-08-27 23:20:56 -04:00
|
|
|
<PRIVATE
|
|
|
|
|
|
|
|
: (subset?) ( set1 set2 -- ? )
|
|
|
|
sequence/tester all? ; inline
|
|
|
|
|
|
|
|
PRIVATE>
|
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set subset?
|
2011-08-27 23:20:56 -04:00
|
|
|
2dup [ cardinality ] bi@ > [ 2drop f ] [ (subset?) ] if ;
|
2010-12-27 22:22:36 -05:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set set=
|
2017-02-07 17:54:57 -05:00
|
|
|
2dup [ cardinality ] bi@ = [ (subset?) ] [ 2drop f ] if ;
|
2008-04-14 03:20:37 -04:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set fast-set ;
|
2008-04-14 03:20:37 -04:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set duplicates drop f ;
|
2010-02-26 16:01:01 -05:00
|
|
|
|
2016-03-29 18:46:29 -04:00
|
|
|
M: set all-unique? drop t ;
|
2008-04-14 03:20:37 -04:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
! Sequences are sets
|
2016-03-29 18:46:29 -04:00
|
|
|
INSTANCE: sequence set
|
2009-01-12 02:51:38 -05:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
M: sequence in?
|
|
|
|
member? ; inline
|
2008-04-14 03:20:37 -04:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
M: sequence adjoin
|
|
|
|
[ delete ] [ push ] 2bi ;
|
2008-04-14 03:20:37 -04:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
M: sequence delete
|
|
|
|
remove! drop ; inline
|
2008-05-01 21:01:57 -04:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
M: sequence set-like
|
|
|
|
[ members ] dip like ;
|
2008-05-01 21:01:57 -04:00
|
|
|
|
2010-02-26 16:01:01 -05:00
|
|
|
M: sequence members
|
2017-02-07 17:50:58 -05:00
|
|
|
f fast-set [ ?adjoin ] curry filter ;
|
2010-12-27 22:22:36 -05:00
|
|
|
|
2010-04-17 17:25:51 -04:00
|
|
|
M: sequence null?
|
|
|
|
empty? ; inline
|
2010-02-26 16:01:01 -05:00
|
|
|
|
2010-12-27 22:22:36 -05:00
|
|
|
M: sequence cardinality
|
2012-08-24 19:36:30 -04:00
|
|
|
fast-set cardinality ;
|
2010-12-27 22:22:36 -05:00
|
|
|
|
2013-03-07 21:48:15 -05:00
|
|
|
M: sequence clear-set
|
|
|
|
delete-all ; inline
|
|
|
|
|
2011-09-17 11:11:48 -04:00
|
|
|
: combine ( sets -- set/f )
|
2010-03-16 20:17:26 -04:00
|
|
|
[ f ]
|
2012-08-24 19:36:30 -04:00
|
|
|
[ [ [ ?members ] map concat ] [ first ] bi set-like ]
|
2010-03-16 20:17:26 -04:00
|
|
|
if-empty ;
|
2010-02-26 16:01:01 -05:00
|
|
|
|
2013-03-08 10:57:45 -05:00
|
|
|
: intersection ( sets -- set/f )
|
|
|
|
[ f ] [ [ ] [ intersect ] map-reduce ] if-empty ;
|
|
|
|
|
2016-08-29 20:34:37 -04:00
|
|
|
: refine ( sets -- set/f )
|
|
|
|
[ f ] [ [ ] [ intersect ] map-reduce ] if-empty ;
|
|
|
|
|
2011-09-22 20:19:51 -04:00
|
|
|
: gather ( ... seq quot: ( ... elt -- ... elt' ) -- ... newseq )
|
2010-02-26 16:01:01 -05:00
|
|
|
map concat members ; inline
|
|
|
|
|
|
|
|
: adjoin-at ( value key assoc -- )
|
|
|
|
[ [ f fast-set ] unless* [ adjoin ] keep ] change-at ;
|
|
|
|
|
2010-03-16 20:17:26 -04:00
|
|
|
: within ( seq set -- subseq )
|
2011-10-14 13:23:52 -04:00
|
|
|
tester filter ;
|
2010-03-16 20:17:26 -04:00
|
|
|
|
|
|
|
: without ( seq set -- subseq )
|
2017-01-06 17:08:42 -05:00
|
|
|
tester reject ;
|
2010-03-16 20:17:26 -04:00
|
|
|
|
2013-03-10 12:11:05 -04:00
|
|
|
: adjoin-all ( seq set -- )
|
|
|
|
[ adjoin ] curry each ;
|
|
|
|
|
2013-03-08 10:57:45 -05:00
|
|
|
: union! ( set1 set2 -- set1 )
|
2013-03-10 12:11:05 -04:00
|
|
|
?members over adjoin-all ;
|
2013-03-08 10:57:45 -05:00
|
|
|
|
2013-03-08 11:21:16 -05:00
|
|
|
: diff! ( set1 set2 -- set1 )
|
|
|
|
dupd sequence/tester [ dup ] prepose pick
|
|
|
|
[ delete ] curry [ [ drop ] if ] curry compose each ;
|
|
|
|
|
2013-03-24 19:48:45 -04:00
|
|
|
: intersect! ( set1 set2 -- set1 )
|
|
|
|
dupd sequence/tester [ dup ] prepose [ not ] compose pick
|
|
|
|
[ delete ] curry [ [ drop ] if ] curry compose each ;
|