Add assoc-partition combinator, and re-implement assoc-filter in a more straightforward fashion
Slava Pestov
parent
b2a294fac7
commit
c41161277d
|
|
@ -1,7 +1,7 @@
|
|||
! 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"
|
||||
|
|
@ -113,7 +113,6 @@ $nl
|
|||
{ $subsection assoc-each }
|
||||
{ $subsection assoc-find }
|
||||
{ $subsection assoc-map }
|
||||
{ $subsection assoc-push-if }
|
||||
{ $subsection assoc-filter }
|
||||
{ $subsection assoc-filter-as }
|
||||
{ $subsection assoc-contains? }
|
||||
|
|
@ -122,10 +121,7 @@ $nl
|
|||
{ $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."
|
||||
|
|
@ -225,10 +221,6 @@ HELP: assoc-map
|
|||
|
||||
{ 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." } ;
|
||||
|
|
@ -388,18 +380,6 @@ HELP: assoc-map-as
|
|||
{ $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 }
|
||||
|
|
|
|||
|
|
@ -129,4 +129,13 @@ unit-test
|
|||
|
||||
[ "x" ] [
|
||||
"a" H{ { "a" "x" } } at-default
|
||||
] unit-test
|
||||
|
||||
[ H{ { "b" [ 2 ] } { "d" [ 4 ] } } H{ { "a" [ 1 ] } { "c" [ 3 ] } } ] [
|
||||
H{
|
||||
{ "a" [ 1 ] }
|
||||
{ "b" [ 2 ] }
|
||||
{ "c" [ 3 ] }
|
||||
{ "d" [ 4 ] }
|
||||
} [ nip first even? ] assoc-partition
|
||||
] unit-test
|
||||
|
|
@ -7,22 +7,39 @@ IN: assocs
|
|||
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
|
||||
|
||||
|
|
@ -40,18 +57,16 @@ GENERIC: >alist ( assoc -- newassoc )
|
|||
: 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
|
||||
|
||||
|
|
@ -65,7 +80,7 @@ GENERIC: >alist ( assoc -- newassoc )
|
|||
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 )
|
||||
|
|
@ -81,15 +96,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
[ 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
|
||||
|
|
@ -101,9 +108,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
[ 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 ;
|
||||
|
|
@ -124,9 +129,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
: 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 ;
|
||||
|
||||
|
|
@ -155,8 +157,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
: 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 ;
|
||||
|
|
@ -172,9 +172,6 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue