add histogram and sequence>assoc to sets

diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor
index 3670b10d3ce30c746a3ef7a6b9715089aa33a967..1e4ceb5680e2595ea5475bf1ea1b4b9d10cc08f0 100755 (executable)
--- 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 838a0a82b8ae44dbf74b7bd8aba1a76a8ee9ba95..be195a62cdf26cb388b26878612ca5064f62170a 100644 (file)
--- 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 062b624e8fec0f327b45b06b045893a7dbd8d20d..421d43bb3dff024bda75b6d032d2110a23a797b4 100755 (executable)
--- a/core/sets/sets.factor
+++ b/core/sets/sets.factor
@@ -54,3 +54,25 @@ PRIVATE>
 
 : set= ( seq1 seq2 -- ? )
     [ unique ] bi@ = ;
+
+<PRIVATE
+
+: (sequence>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 ;