diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 3670b10d3c..1e4ceb5680 100755 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -1,4 +1,5 @@ -USING: kernel help.markup help.syntax sequences quotations assocs ; +USING: assocs hashtables help.markup help.syntax kernel +quotations sequences ; IN: sets ARTICLE: "sets" "Set-theoretic operations on sequences" @@ -19,6 +20,13 @@ $nl { $subsection set= } "A word used to implement the above:" { $subsection unique } +"Counting elements in a sequence:" +{ $subsection histogram } +{ $subsection histogram* } +"Combinators for implementing histogram:" +{ $subsection sequence>assoc } +{ $subsection sequence>assoc* } +{ $subsection sequence>hashtable } "Adding elements to sets:" { $subsection adjoin } { $subsection conjoin } @@ -125,3 +133,73 @@ HELP: gather { "seq" sequence } { "quot" quotation } { "newseq" sequence } } { $description "Maps a quotation onto a sequence, concatenates the results of the mapping, and removes duplicates." } ; + +HELP: histogram +{ $values + { "seq" sequence } + { "hashtable" hashtable } +} +{ $examples + { $example "! Count the number of times an element appears in a sequence." + "USING: prettyprint sets ;" + "\"aaabc\" histogram ." + "H{ { 97 3 } { 98 1 } { 99 1 } }" + } +} +{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ; + +HELP: histogram* +{ $values + { "hashtable" hashtable } { "seq" sequence } + { "hashtable" hashtable } +} +{ $examples + { $example "! Count the number of times the elements of two sequences appear." + "USING: prettyprint sets ;" + "\"aaabc\" histogram \"aaaaaabc\" histogram* ." + "H{ { 97 9 } { 98 2 } { 99 2 } }" + } +} +{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ; + +HELP: sequence>assoc +{ $values + { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" } + { "assoc" assoc } +} +{ $examples + { $example "! Count the number of times the elements of two sequences appear." + "USING: prettyprint sets ;" + "\"aaabc\" [ inc-at ] H{ } sequence>assoc ." + "H{ { 97 3 } { 98 1 } { 99 1 } }" + } +} +{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ; + +HELP: sequence>assoc* +{ $values + { "assoc" assoc } { "seq" sequence } { "quot" quotation } + { "assoc" assoc } +} +{ $examples + { $example "! Count the number of times the elements of two sequences appear." + "USING: prettyprint sets ;" + "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ." + "H{ { 97 5 } { 98 2 } { 99 1 } }" + } +} +{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } ; + +HELP: sequence>hashtable +{ $values + { "seq" sequence } { "quot" quotation } + { "hashtable" hashtable } +} +{ $examples + { $example "! Count the number of times the elements of two sequences appear." + "USING: prettyprint sets ;" + "\"aaabc\" [ inc-at ] sequence>hashtable ." + "H{ { 97 3 } { 98 1 } { 99 1 } }" + } +} +{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } ; diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor index 838a0a82b8..be195a62cd 100644 --- a/core/sets/sets-tests.factor +++ b/core/sets/sets-tests.factor @@ -29,3 +29,13 @@ IN: sets.tests [ f ] [ { } { 1 } intersects? ] unit-test [ f ] [ { 1 } { } intersects? ] unit-test + +[ + H{ + { 97 2 } + { 98 2 } + { 99 2 } + } +] [ + "aabbcc" histogram +] unit-test diff --git a/core/sets/sets.factor b/core/sets/sets.factor index 062b624e8f..421d43bb3d 100755 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -54,3 +54,25 @@ PRIVATE> : set= ( seq1 seq2 -- ? ) [ unique ] bi@ = ; + +assoc) ( seq quot assoc -- assoc ) + [ swap curry each ] keep ; inline + +PRIVATE> + +: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc ) + rot (sequence>assoc) ; inline + +: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc ) + clone (sequence>assoc) ; inline + +: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable ) + H{ } sequence>assoc ; inline + +: histogram* ( hashtable seq -- hashtable ) + [ inc-at ] sequence>assoc* ; + +: histogram ( seq -- hashtable ) + [ inc-at ] sequence>hashtable ;