-! Copyright (C) 2007 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
+! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences
-sequences.private namespaces math quotations ;
+sequences.private namespaces math quotations assocs.private ;
IN: assocs
ARTICLE: "alists" "Association lists"
{ $subsection assoc-each }
{ $subsection assoc-find }
{ $subsection assoc-map }
-{ $subsection assoc-push-if }
{ $subsection assoc-filter }
{ $subsection assoc-filter-as }
{ $subsection assoc-contains? }
{ $subsection cache }
{ $subsection map>assoc }
{ $subsection assoc>map }
-{ $subsection assoc-map-as }
-{ $subsection search-alist }
-"Utility word:"
-{ $subsection assoc-pusher } ;
+{ $subsection assoc-map-as } ;
ARTICLE: "assocs" "Associative mapping operations"
"An " { $emphasis "associative mapping" } ", abbreviated " { $emphasis "assoc" } ", is a collection of key/value pairs which provides efficient lookup and storage indexed by key."
{ assoc-map assoc-map-as } related-words
-HELP: assoc-push-if
-{ $values { "accum" "a resizable mutable sequence" } { "quot" { $quotation "( key value -- ? )" } } { "key" object } { "value" object } }
-{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
-
HELP: assoc-filter
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." }
{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ;
-HELP: assoc-pusher
-{ $values
- { "quot" "a predicate quotation" }
- { "quot'" quotation } { "accum" assoc } }
-{ $description "Creates a new " { $snippet "assoc" } " to accumulate the key/value pairs which return true for a predicate. Returns a new quotation which accepts a pair of object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
-{ $example "! Find only the pairs that sum to 5:" "USING: prettyprint assocs math kernel ;"
- "{ { 1 2 } { 2 3 } { 3 4 } } [ + 5 = ] assoc-pusher [ assoc-each ] dip ."
- "V{ { 2 3 } }"
-}
-{ $notes "Used to implement the " { $link assoc-filter } " word." } ;
-
-
HELP: extract-keys
{ $values
{ "seq" sequence } { "assoc" assoc }
MIXIN: assoc
GENERIC: at* ( key assoc -- value/f ? )
+GENERIC: value-at* ( value assoc -- key/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 )
+GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
+GENERIC: >alist ( assoc -- newassoc )
M: assoc assoc-like drop ;
-GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
-
-GENERIC: >alist ( assoc -- newassoc )
+<PRIVATE
: (assoc-each) ( assoc quot -- seq quot' )
[ >alist ] dip [ first2 ] prepose ; inline
+: (assoc-stack) ( key i seq -- value )
+ over 0 < [
+ 3drop f
+ ] [
+ 3dup nth-unsafe at*
+ [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
+ ] if ; inline recursive
+
+: search-alist ( key alist -- pair/f i/f )
+ [ first = ] with find swap ; inline
+
+: substituter ( assoc -- quot )
+ [ dupd at* [ nip ] [ drop ] if ] curry ; inline
+
+PRIVATE>
+
: assoc-find ( assoc quot -- key value ? )
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
: assoc-map ( assoc quot -- newassoc )
over assoc-map-as ; inline
-: assoc-push-if ( key value quot accum -- )
- [ 2keep ] dip [ [ 2array ] dip push ] 3curry when ; inline
-
-: assoc-pusher ( quot -- quot' accum )
- V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
-
: assoc-filter-as ( assoc quot exemplar -- subassoc )
- [ assoc-pusher [ assoc-each ] dip ] dip assoc-like ; inline
+ [ (assoc-each) filter ] dip assoc-like ; inline
: assoc-filter ( assoc quot -- subassoc )
over assoc-filter-as ; inline
+: assoc-partition ( assoc quot -- true-assoc false-assoc )
+ [ (assoc-each) partition ] [ drop ] 2bi
+ tuck [ assoc-like ] 2bi@ ; inline
+
: assoc-contains? ( assoc quot -- ? )
assoc-find 2nip ; inline
2dup at* [ 2nip ] [ 2drop ] if ; inline
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
- over assoc-size swap new-assoc
+ [ dup assoc-size ] dip new-assoc
[ [ swapd set-at ] curry assoc-each ] keep ;
: keys ( assoc -- keys )
[ delete-at* ] keep [ swapd set-at ] curry [ 2drop ] if ;
: assoc-empty? ( assoc -- ? )
- assoc-size zero? ;
-
-: (assoc-stack) ( key i seq -- value )
- over 0 < [
- 3drop f
- ] [
- 3dup nth-unsafe at*
- [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
- ] if ; inline recursive
+ assoc-size 0 = ;
: assoc-stack ( key seq -- value )
[ length 1- ] keep (assoc-stack) ; flushable
[ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
: assoc-hashcode ( n assoc -- code )
- [
- [ over ] dip hashcode* 2/ [ dupd hashcode* ] dip bitxor
- ] { } assoc>map hashcode* ;
+ >alist hashcode* ;
: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-filter ;
: remove-all ( assoc seq -- subseq )
swap [ key? not ] curry filter ;
-: substituter ( assoc -- quot )
- [ dupd at* [ nip ] [ drop ] if ] curry ; inline
-
: substitute-here ( seq assoc -- )
substituter change-each ;
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
-GENERIC: value-at* ( value assoc -- key/f ? )
-
M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
: value-at ( value assoc -- key/f ) value-at* drop ;
: unzip ( assoc -- keys values )
dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
-: search-alist ( key alist -- pair/f i/f )
- [ first = ] with find swap ; inline
-
M: sequence at*
search-alist [ second t ] [ f ] if ;
projects / factor.git / commitdiff