factor/core/assocs/assocs.factor

223 lines
5.4 KiB
Factor
Raw Normal View History

2008-04-02 03:44:10 -04:00
! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
2007-09-20 18:09:08 -04:00
! See http://factorcode.org/license.txt for BSD license.
2008-04-02 03:44:10 -04:00
USING: kernel sequences arrays math sequences.private vectors
accessors ;
2007-09-20 18:09:08 -04:00
IN: assocs
MIXIN: assoc
GENERIC: at* ( key assoc -- value/f ? )
GENERIC: set-at ( value key assoc -- )
GENERIC: new-assoc ( capacity exemplar -- newassoc )
GENERIC: delete-at ( key assoc -- )
GENERIC: clear-assoc ( assoc -- )
GENERIC: assoc-size ( assoc -- n )
GENERIC: assoc-like ( assoc exemplar -- newassoc )
M: assoc assoc-like drop ;
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
2008-06-15 01:32:48 -04:00
: (assoc-each) ( assoc quot -- seq quot' )
>r >alist r> [ first2 ] prepose ; inline
2008-06-09 06:22:21 -04:00
: assoc-find ( assoc quot -- key value ? )
2008-06-15 01:32:48 -04:00
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
2007-09-20 18:09:08 -04:00
: key? ( key assoc -- ? ) at* nip ; inline
: assoc-each ( assoc quot -- )
2008-06-15 01:32:48 -04:00
(assoc-each) each ; inline
2007-09-20 18:09:08 -04:00
: assoc>map ( assoc quot exemplar -- seq )
2008-06-15 01:32:48 -04:00
>r accumulator >r assoc-each r> r> like ; inline
: assoc-map-as ( assoc quot exemplar -- newassoc )
>r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline
2007-09-20 18:09:08 -04:00
: assoc-map ( assoc quot -- newassoc )
2008-06-15 01:32:48 -04:00
over assoc-map-as ; inline
2007-09-20 18:09:08 -04:00
: assoc-push-if ( key value quot accum -- )
2008-01-13 13:29:04 -05:00
>r 2keep r> roll
2007-09-20 18:09:08 -04:00
[ >r 2array r> push ] [ 3drop ] if ; inline
: assoc-pusher ( quot -- quot' accum )
V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
: assoc-filter ( assoc quot -- subassoc )
2007-09-20 18:09:08 -04:00
over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
: assoc-contains? ( assoc quot -- ? )
assoc-find 2nip ; inline
2008-01-13 15:02:02 -05:00
: assoc-all? ( assoc quot -- ? )
[ not ] compose assoc-contains? not ; inline
2007-09-20 18:09:08 -04:00
: at ( key assoc -- value/f )
at* drop ; inline
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
over assoc-size swap new-assoc
swap [ swap pick set-at ] assoc-each ;
: keys ( assoc -- keys )
[ drop ] { } assoc>map ;
: values ( assoc -- values )
[ nip ] { } assoc>map ;
: delete-at* ( key assoc -- old ? )
[ at* ] 2keep delete-at ;
: rename-at ( newkey key assoc -- )
tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
: assoc-empty? ( assoc -- ? )
assoc-size zero? ;
: (assoc-stack) ( key i seq -- value )
over 0 < [
3drop f
] [
3dup nth-unsafe at*
[ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if
2008-07-18 20:22:59 -04:00
] if ; inline recursive
2007-09-20 18:09:08 -04:00
: assoc-stack ( key seq -- value )
dup length 1- swap (assoc-stack) ;
: assoc-subset? ( assoc1 assoc2 -- ? )
2007-09-20 18:09:08 -04:00
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
: assoc= ( assoc1 assoc2 -- ? )
[ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
2007-09-20 18:09:08 -04:00
: assoc-hashcode ( n assoc -- code )
2007-10-29 01:46:34 -04:00
[
>r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
] { } assoc>map hashcode* ;
2007-09-20 18:09:08 -04:00
: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-filter ;
2007-09-20 18:09:08 -04:00
: update ( assoc1 assoc2 -- )
swap [ swapd set-at ] curry assoc-each ;
: assoc-union ( assoc1 assoc2 -- union )
2008-03-29 21:36:58 -04:00
2dup [ assoc-size ] bi@ + pick new-assoc
2007-09-20 18:09:08 -04:00
[ rot update ] keep [ swap update ] keep ;
2008-08-31 02:34:00 -04:00
: assoc-combine ( seq -- union )
H{ } clone [ dupd update ] reduce ;
: assoc-diff ( assoc1 assoc2 -- diff )
[ nip key? not ] curry assoc-filter ;
2007-09-20 18:09:08 -04:00
: remove-all ( assoc seq -- subseq )
swap [ key? not ] curry filter ;
2007-09-20 18:09:08 -04:00
: (substitute)
[ dupd at* [ nip ] [ drop ] if ] curry ; inline
: substitute-here ( seq assoc -- )
(substitute) change-each ;
: substitute ( seq assoc -- newseq )
(substitute) map ;
2007-09-20 18:09:08 -04:00
: cache ( key assoc quot -- value )
2008-03-26 04:57:48 -04:00
2over at* [
2007-09-20 18:09:08 -04:00
>r 3drop r>
] [
2008-03-26 04:57:48 -04:00
drop pick rot >r >r call dup r> r> set-at
] if ; inline
2007-09-20 18:09:08 -04:00
: change-at ( key assoc quot -- )
[ >r at r> call ] 3keep drop set-at ; inline
: at+ ( n key assoc -- )
[ 0 or + ] change-at ;
: map>assoc ( seq quot exemplar -- assoc )
>r [ 2array ] compose { } map-as r> assoc-like ; inline
2007-09-20 18:09:08 -04:00
2008-05-22 23:41:48 -04:00
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
2008-07-12 19:52:31 -04:00
GENERIC: value-at* ( value assoc -- key/f ? )
2007-09-20 18:09:08 -04:00
2008-07-12 19:52:31 -04:00
M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
: value-at ( value assoc -- key/f ) value-at* drop ;
: value? ( value assoc -- ? ) value-at* nip ;
2007-09-20 18:09:08 -04:00
2008-06-13 03:09:16 -04:00
: push-at ( value key assoc -- )
[ ?push ] change-at ;
: zip ( keys values -- alist )
2array flip ; inline
2008-07-20 02:12:15 -04:00
: unzip ( assoc -- keys values )
dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
2008-09-05 16:52:13 -04:00
: search-alist ( key alist -- pair/f i/f )
2008-01-09 17:36:30 -05:00
[ first = ] with find swap ; inline
2007-09-20 18:09:08 -04:00
M: sequence at*
search-alist [ second t ] [ f ] if ;
M: sequence set-at
2dup search-alist
[ 2nip set-second ]
[ drop >r swap 2array r> push ] if ;
M: sequence new-assoc drop <vector> ;
M: sequence clear-assoc delete-all ;
M: sequence delete-at
tuck search-alist nip
[ swap delete-nth ] [ drop ] if* ;
M: sequence assoc-size length ;
M: sequence assoc-clone-like
>r >alist r> clone-like ;
M: sequence assoc-like
>r >alist r> like ;
2007-09-20 18:09:08 -04:00
M: sequence >alist ;
! Override sequence => assoc instance for f
M: f clear-assoc drop ;
M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
INSTANCE: sequence assoc
2008-04-02 03:44:10 -04:00
TUPLE: enum seq ;
C: <enum> enum
M: enum at*
seq>> 2dup bounds-check?
[ nth t ] [ 2drop f f ] if ;
M: enum set-at seq>> set-nth ;
M: enum delete-at seq>> delete-nth ;
2008-04-02 03:44:10 -04:00
M: enum >alist ( enum -- alist )
seq>> [ length ] keep zip ;
2008-04-02 03:44:10 -04:00
M: enum assoc-size seq>> length ;
M: enum clear-assoc seq>> delete-all ;
INSTANCE: enum assoc