commit fa6b0cb5fe3ae4a39095143d82f0755498492114 Author: Jon Harper Date: Thu Feb 18 20:09:19 2016 +0100 poc move collect-by to core diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index fc25c01..da543be 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -208,31 +208,6 @@ PRIVATE> : trimean ( seq -- x ) quartile first3 [ 2 * ] dip + + 4 / ; -assoc) ( seq map-quot insert-quot assoc -- assoc ) - [ swap curry compose each ] keep ; inline - -: (sequence-index>assoc) ( seq map-quot insert-quot assoc -- assoc ) - [ swap curry compose each-index ] keep ; inline - -PRIVATE> - -: sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc ) - 4 nrot (sequence>assoc) ; inline - -: sequence>assoc ( seq map-quot insert-quot exemplar -- assoc ) - clone (sequence>assoc) ; inline - -: sequence-index>assoc ( seq map-quot insert-quot exemplar -- assoc ) - clone (sequence-index>assoc) ; inline - -: sequence-index>hashtable ( seq map-quot insert-quot -- hashtable ) - H{ } sequence-index>assoc ; inline - -: sequence>hashtable ( seq map-quot insert-quot -- hashtable ) - H{ } sequence>assoc ; inline - : histogram! ( hashtable seq -- hashtable ) [ ] [ inc-at ] sequence>assoc! ; @@ -248,12 +223,6 @@ PRIVATE> : normalized-histogram ( seq -- alist ) [ histogram ] [ length ] bi '[ _ / ] assoc-map ; -: collect-index-by ( ... seq quot: ( ... obj -- ... key ) -- ... hashtable ) - [ dip swap ] curry [ push-at ] sequence-index>hashtable ; inline - -: collect-by ( ... seq quot: ( ... obj -- ... key ) -- ... hashtable ) - [ keep swap ] curry [ push-at ] sequence>hashtable ; inline - : equal-probabilities ( n -- array ) dup recip ; inline diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index d8e6921..a0ea727 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs binary-search classes classes.struct combinators combinators.smart continuations fry generalizations generic grouping io io.styles kernel make math -math.order math.parser math.statistics memory layouts namespaces +math.order math.parser assocs math.statistics memory layouts namespaces parser prettyprint sequences sequences.generalizations sorting splitting strings system vm words hints hashtables ; IN: tools.memory diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 9e82bc8..c1677f9 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -204,6 +204,40 @@ M: assoc values [ nip ] { } assoc>map ; : map>alist ( ... seq quot: ( ... elt -- ... key value ) -- ... alist ) { } map>assoc ; inline +: push-at ( value key assoc -- ) + [ ?push ] change-at ; + +assoc) ( seq map-quot insert-quot assoc -- assoc ) + [ swap curry compose each ] keep ; inline + +: (sequence-index>assoc) ( seq map-quot insert-quot assoc -- assoc ) + [ swap curry compose each-index ] keep ; inline + +PRIVATE> + +: sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc ) + [ [ [ ] dip swap ] dip swap ] dip swap (sequence>assoc) ; inline + +: sequence>assoc ( seq map-quot insert-quot exemplar -- assoc ) + clone (sequence>assoc) ; inline + +: sequence-index>assoc ( seq map-quot insert-quot exemplar -- assoc ) + clone (sequence-index>assoc) ; inline + +: sequence-index>hashtable ( seq map-quot insert-quot -- hashtable ) + H{ } sequence-index>assoc ; inline + +: sequence>hashtable ( seq map-quot insert-quot -- hashtable ) + H{ } sequence>assoc ; inline + +: collect-index-by ( ... seq quot: ( ... obj -- ... key ) -- ... hashtable ) + [ dip swap ] curry [ push-at ] sequence-index>hashtable ; inline + +: collect-by ( ... seq quot: ( ... obj -- ... key ) -- ... hashtable ) + [ keep swap ] curry [ push-at ] sequence>hashtable ; inline + : extract-keys ( seq assoc -- subassoc ) [ [ dupd at ] curry ] keep map>assoc ; @@ -213,9 +247,6 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ; : value? ( value assoc -- ? ) value-at* nip ; -: push-at ( value key assoc -- ) - [ ?push ] change-at ; - : zip-as ( keys values exemplar -- assoc ) dup sequence? [ [ 2array ] swap 2map-as