StatefulCounterFactory

A factory macro for stateful counters

A recent project required that I maintain counts of different things, for example the number of occurrences of specific words in text. Association lists are one easy way to do this

(("Burt" 3)('counter-list 7)(13 43))

but I had to increment the counts from several different functions. Keeping the list as a global variable would work, but risked accidentally clobbering the counts.

Instead I used Emacs Lisp’s lexical binding option to create closures—functions that maintain their internal state. The following factory macro creates counters that count “things”—meaning anything that can be used as a key in an association list, e.g. strings, symbols, numbers, …. You can define multiple counters, each of which will maintain its own state.

You need to establish lexical binding using one of the following two lines.

;;;-*- mode: Emacs-lisp; lexical-binding: t ; -*-

(setq lexical-binding t)

This code depends on lexical binding as established above.

(defmacro make-counter (counter-closure)
  "This macro creates a closure used for counting things.
The produced function counts things using an association list.
You can think of thie as an array indexed by the things
being couinted.  The first element of each of the association
cells is one of the things to be counted (analogous to an
array index).  The second is a list containing a count of
those things.  This function always returns the current list
of counts.  Calling this function with a non-nil value of thing
either increments the count, or, if thing hasn't been seen
before, it creates a count for thing initializing it to 1.
Calling it with a nil argument returns the
count-list without changing any of the counts.
Calling it with two non-nil arguments resets the 
current counter to the first argument.
;;; Usage examples for make-counter
;; (make-counter named-counter) ;; creates a counter named \"named-counter\"
;; (funcall named-counter 1) ;; starts the count for 1 yielding ((1 1))
;; (funcall named-counter 1) ;; bumps the count for 1 yielding ((1 2))
;; (funcall named-counter 1) ;; bumps the count for 1 yielding ((1 3))
;; (funcall named-counter \"a\") ;; starts the count for \"a\" yielding (((1 3)(\"a\" 1))
;; (funcall named-counter) ;; returns the count list unchanged yielding (((1 3)(\"a\" 1))
;; (funcall named-counter '((1 3)(2 4)) t) ;; resets the counter to '((1 3)(2 4))"
  (list 'let (list (list 'count-list nil))
        (list 'setq counter-closure
              (list 'lambda (list '&optional 'thing 'thing2)
                    (list 'cond
			  (list (list 'and 'thing 'thing2)
				(list 'if (list 'listp 'thing)
				      (list 'setq 'count-list 'thing)
				       (list 'error "In make-counter closure: reset argument must be list, was: %s"
					    'thing)))
			  (list (list 'and 'thing 'count-list) ;; bump the count for thing
                                (list 'let (list (list 'count-pair (list 'assoc 'thing 'count-list)))
                                      (list 'if 'count-pair
                                            (list 'let (list (list 'current-count (list 'car (list 'cdr 'count-pair))))
                                                  (list 'setcdr 'count-pair (list 'list (list  '1+ 'current-count))))
                                            (list 'setq 'count-list (list 'cons (list 'list 'thing 1) 'count-list)))
                                      'count-list))
                          (list 'thing ;; start the count list
				;; (list 'message "starting new count")
                                (list 'setq 'count-list (list 'list (list 'list 'thing 1))))
                          (list t
				'count-list))))))

(provide 'make-counter)

(defun test-make-counter ()
  "This function tests that the result of a local counter
is equal to a local known result list.  Firt it prints both 
the local counter and the local test list, then prints
a pass/fail message.  This should still run after you
make changes to make-counter."
  (let ((test-list '(("b" 1)(c 1)("a" 4)(1 4)))
	(test-list2 '((1 1) (2 2)))
	(junk (make-counter local-counter)))
    (setq junk nil)
    (funcall local-counter 1)
    ;; (message (concat "local-counter was: " (format "%s" (funcall local-counter))))
    (funcall local-counter "a")
    (funcall local-counter "a")
    (funcall local-counter "a")
    (funcall local-counter 1)
    (funcall local-counter 1)
    (funcall local-counter 'c)
    (funcall local-counter "b")
    (funcall local-counter "a")
    (funcall local-counter 1)
    (message "Counting these things 1 \"a\" \"a\" \"a\" 1 1 'c \"b\" \"a\" 1 ")
    (let ((check-list (funcall local-counter)))
      (message (concat "result of counter test list was: " (format "%s" check-list)))
      (message (concat "       desired counter list was: " (format "%s" test-list))))
    (let ((check-list2 (funcall local-counter test-list2 t)))
      (message (concat "result of counter reset test list was: " (format "%s" check-list2)))
      (message (concat "       desired counter reset list was: " (format "%s" test-list2))))
    (message "The function should exit with an error immediately after this message")
    (funcall local-counter 0 t)
    (message "You shouldn't see this.")))

(test-make-counter)