From c41161277dd084bf358fbb19440b0acda290a4f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 26 Jan 2009 23:19:49 -0600 Subject: [PATCH] Add assoc-partition combinator, and re-implement assoc-filter in a more straightforward fashion --- core/assocs/assocs-docs.factor | 26 ++------------- core/assocs/assocs-tests.factor | 9 +++++ core/assocs/assocs.factor | 59 ++++++++++++++++----------------- 3 files changed, 40 insertions(+), 54 deletions(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 627d4aeb80..e9269373b0 100644 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -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 } diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index ac82da7b9b..5617888148 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -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 \ No newline at end of file diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index a2eb2d25ec..b074fa1b92 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -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 ) +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 ;