mlib: fixed "(incf (gethash..." with default value, added frequencies

CHANGES

@@ -9,7 +9,8 @@ Changes in JMurmel-1.5.0 relative to JMurmel-1.4.8
 
  * added fresh-line, make-string-writer, tabulate
 
- * mlib: added format, formatter, error, and*, or*
+ * mlib: added format, formatter, error, and*, or*, frequencies
+ * fixed mlib: "(incf (gethash..." with default value
 
 
 Changes in JMurmel-1.4.8 relative to JMurmel-1.4.7

mlib.completions

@@ -144,4 +144,5 @@ string-replace
 string-subseq
 maphash
 remhash
-gethash
+gethash
+frequencies

mlib.html

@@ -114,6 +114,8 @@
     - [scan](#function-scan), [scan-multiple](#function-scan-multiple), [scan-concat](#function-scan-concat)
 - strings
     - [string-trim](#function-string-trim), [string-subseq](#function-string-subseq), [string-replace](#function-string-replace), [string-split](#function-string-split), [string-join](#function-string-join)
+- hash tables
+    - [frequencies](#function-frequencies)
 
 ## Description of functions and macros
 
@@ -1020,6 +1022,14 @@
 Similar to CL's `maphash` but modifying the hash-table
 from within `function` is not supported.
 
+### Function: frequencies
+    (frequencies sequence [test]) -> hash-table
+
+Since: 1.5
+
+Count the number of times each value occurs in the sequence
+according to the test function `test` which defaults to `eql`.
+
 ### Function: identity
     (identity object) -> object
 

mlib.md

@@ -105,6 +105,8 @@ as well as the following additional functions and macros:
     - [scan](#function-scan), [scan-multiple](#function-scan-multiple), [scan-concat](#function-scan-concat)
 - strings
     - [string-trim](#function-string-trim), [string-subseq](#function-string-subseq), [string-replace](#function-string-replace), [string-split](#function-string-split), [string-join](#function-string-join)
+- hash tables
+    - [frequencies](#function-frequencies)
 
 ## Description of functions and macros
 
@@ -1011,6 +1013,14 @@ Since: 1.4
 Similar to CL's `maphash` but modifying the hash-table
 from within `function` is not supported.
 
+### Function: frequencies
+    (frequencies sequence [test]) -> hash-table
+
+Since: 1.5
+
+Count the number of times each value occurs in the sequence
+according to the test function `test` which defaults to `eql`.
+
 ### Function: identity
     (identity object) -> object
 

samples.murmel-mlib/mlib-test.lisp

@@ -1517,6 +1517,22 @@ all the result list to a single list. FUNCTION must return a list."
 ; =>  NIL
 )
 
+#+murmel
+(defun hash-equal (h1 h2)
+  (if (= (hash-table-count h1) (hash-table-count h2))
+      (let ((ok t))
+        (maphash (lambda (k v)
+                   (unless (eql v (hashref h2 k))
+                     (setq ok nil)))
+                 h1)
+        ok)
+      nil))
+
+#+murmel
+(tests frequencies
+  (hash-equal (frequencies '(1 2 2 3 3 3 4 4 4 4 5 5 5 5 5))  #H(eql 1 1 2 2 3 3 4 4 5 5)) => t
+  (hash-equal (frequencies #(1 2 2 3 3 3 4 4 4 4 5 5 5 5 5))  #H(eql 1 1 2 2 3 3 4 4 5 5)) => t)
+
 
 ;;; - higher order
 

samples.murmel-mlib/mlib.lisp

@@ -113,6 +113,8 @@
 ;;;     - [scan](#function-scan), [scan-multiple](#function-scan-multiple), [scan-concat](#function-scan-concat)
 ;;; - strings
 ;;;     - [string-trim](#function-string-trim), [string-subseq](#function-string-subseq), [string-replace](#function-string-replace), [string-split](#function-string-split), [string-join](#function-string-join)
+;;; - hash tables
+;;;     - [frequencies](#function-frequencies)
 
 
 ;;; == Description of functions and macros
@@ -1462,6 +1464,7 @@
   (let ((read-var (gensym "read-var"))
         (tmp1 (gensym "tmp1"))
         (tmp2 (gensym "tmp2"))
+        (tmp3 (gensym "tmp3"))
         (store-var (gensym "store-var")))
     (if (symbolp place) `(nil nil (,read-var) (setq ,place ,read-var) ,place)
       (let ((op (car place))
@@ -1492,22 +1495,22 @@
 
               ;; hashref with default value: setf (hashref h k def) - eval and ignore default value form
               ((and (eq 'hashref op) (cddr args))
-               `((,tmp1 ,tmp2)
+               `((,tmp1 ,tmp2 ,tmp3)
                  (,(car args) ,(cadr args) ,(caddr args))
                  (,store-var)
                  (hashset ,tmp1 ,tmp2 ,store-var)
-                 (hashref ,tmp1 ,tmp2)))
+                 (hashref ,tmp1 ,tmp2 ,tmp3)))
 
               ;; hashref w/o default value
               ((eq 'hashref op)                      (setf-helper args tmp1 tmp2 store-var 'hashref 'hashset))
 
               ;; gethash with default value: setf (gethash k hash def) - eval and ignore default value form
               ((and (eq 'gethash op) (cddr args))
-               `((,tmp1 ,tmp2)
+               `((,tmp1 ,tmp2 ,tmp3)
                  (,(cadr args) ,(car args) ,(caddr args))
                  (,store-var)
                  (hashset ,tmp1 ,tmp2 ,store-var)
-                 (hashref ,tmp1 ,tmp2)))
+                 (hashref ,tmp1 ,tmp2 ,tmp3)))
 
               ((eq 'gethash op)
                `((,tmp1 ,tmp2)
@@ -2703,6 +2706,23 @@
     (function (car pair) (cdr pair))))
 
 
+
+;;; = Function: frequencies
+;;;     (frequencies sequence [test]) -> hash-table
+;;;
+;;; Since: 1.5
+;;;
+;;; Count the number of times each value occurs in the sequence
+;;; according to the test function `test` which defaults to `eql`.
+(defun frequencies (seq . test)
+  (let ((counts (make-hash-table (car test))))
+    (if (listp seq)
+        (dolist (x seq counts)
+          (incf (hashref counts x 0)))
+        (dovector (x seq counts)
+          (incf (hashref counts x 0))))))
+
+
 ; higher order ********************************************************
 
 ;;; = Function: identity