Advertisement
Guest User

Untitled

a guest
Jul 23rd, 2019
157
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Lisp 1.99 KB | None | 0 0
  1. (ql:quickload :closer-mop)
  2.  
  3. (defvar *counter* (make-hash-table :test 'equal))
  4. (defvar *obj-counter* (make-hash-table :test 'eq))
  5. (defvar *obj-equal-counter* (make-hash-table :test 'equal))
  6. (defvar *already-counted* (make-hash-table :test 'eql))
  7.  
  8. (defmethod count-nodes :around (object)
  9.   (incf (gethash object *obj-counter* 0))
  10.   (incf (gethash object *obj-equal-counter* 0))
  11.   (unless (gethash object *already-counted*)
  12.     (setf (gethash object *already-counted*) t)
  13.     (ignore-errors (call-next-method))))
  14. (defmethod count-nodes (object))
  15. (defmethod count-nodes ((string string))
  16.   (incf (gethash string *counter* 0) 1))
  17. (defmethod count-nodes ((cons cons))
  18.   (count-nodes (car cons))
  19.   (count-nodes (cdr cons)))
  20. (defmethod count-nodes ((seq sequence))
  21.   (map nil #'count-nodes seq))
  22. (defmethod count-nodes ((object standard-object))
  23.   (let* ((class (class-of object))
  24.          (slots (closer-mop:class-slots class))
  25.          (slot-names (mapcar #'closer-mop:slot-definition-name slots)))
  26.     (dolist (slot-name slot-names)
  27.       (count-nodes slot-name)
  28.       (when (slot-boundp object slot-name)
  29.         (count-nodes (slot-value object slot-name))))))
  30.  
  31. (defun average-count (table)
  32.   (/ (loop for count being the hash-values of table
  33.            sum count)
  34.      (hash-table-count table)))
  35.  
  36. (defun most-common (table)
  37.   (loop with best-values = '()
  38.         with best-count  = 0
  39.         for count being the hash-values of table
  40.         for value being the hash-keys   of table
  41.         when (= count best-count)
  42.           do (push value best-values)
  43.         when (> count best-count)
  44.           do (setf best-values (list value)
  45.                    best-count count)
  46.         finally (return (values best-values best-count))))
  47.  
  48. ;;; Stuff to run
  49.  
  50. (count-nodes (find-class 't))
  51. (format t "Duplication factors:
  52. Strings:       ~4$
  53. EQUAL objects: ~4$
  54. EQ    objects: ~4$"
  55.         (average-count *counter*)
  56.         (average-count *obj-equal-counter*)
  57.         (average-count *obj-counter*))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement