Skip to content

Commit

Permalink
whitespace cleanup
Browse files Browse the repository at this point in the history
  • Loading branch information
@bobbysmith007
bobbysmith007 committed May 19, 2011
1 parent 745ac77 commit b15eba6
Showing 1 changed file with 113 additions and 112 deletions.
225 changes: 113 additions & 112 deletions group-by.lisp
View file
@@ -1,20 +1,21 @@
(defpackage :group-by
(:use :cl :cl-user :iter)
(:export :group-by
:categorize-item
:grouped-list
:make-grouped-list
:add-item-to-grouping
:key-value
:child-groupings
:items-in-group
:parent-grouping
:keys :tests
:make-child-grouped-list
:group-by-repeated
:group-by-repeated-in-hash-table
:group-by-repeated-in-tree
:grouped-list-speed-tester))
(:use :cl :cl-user :iter)
(:export
:group-by
:categorize-item
:grouped-list
:make-grouped-list
:add-item-to-grouping
:key-value
:child-groupings
:items-in-group
:parent-grouping
:keys :tests
:make-child-grouped-list
:group-by-repeated
:group-by-repeated-in-hash-table
:group-by-repeated-in-tree
:grouped-list-speed-tester))

(in-package :group-by)

Expand All @@ -26,8 +27,8 @@

(defmethod add-child ((tree n-ary-tree) child)
(setf child (typecase child
(n-ary-tree child)
(T (make-instance 'n-ary-tree :key child))))
(n-ary-tree child)
(T (make-instance 'n-ary-tree :key child))))
(setf (parent child) tree)
(push child (children tree))
child)
Expand All @@ -44,17 +45,17 @@ test is passed as the :test to assoc
eg: (group-by '((a 1 2) (a 3 4) (b 5 6)))
=> ((A (1 2) (3 4)) (B (5 6)))"
(iter (for i in list)
(for k = (funcall key i))
(for v = (funcall value i))
(for cell = (assoc k results :test test :key key-fn))
(if cell
(push v (cdr cell))
(collect (list k v) into results))
(finally
;; reverse the values so that they appear in the same
;; sort order as previously
(return (iter (for (k . vals) in results)
(collect (cons k (nreverse vals))))))))
(for k = (funcall key i))
(for v = (funcall value i))
(for cell = (assoc k results :test test :key key-fn))
(if cell
(push v (cdr cell))
(collect (list k v) into results))
(finally
;; reverse the values so that they appear in the same
;; sort order as previously
(return (iter (for (k . vals) in results)
(collect (cons k (nreverse vals))))))))

(defgeneric categorize-item (item root &key keys tests)
(:documentation "Insert a new item into a grouped list "))
Expand All @@ -65,47 +66,47 @@ eg: (group-by '((a 1 2) (a 3 4) (b 5 6)))
(if (null keys)
(push item root)
(let ((key (funcall (first keys) item)))
(let ((data (assoc key root :test (or (first tests) #'equal))))
(if data
;; Add the rest of the categorization to the
;; data of this item
(setf (cdr data) (categorize-item
item (cdr data)
:keys (rest keys)
:tests (rest tests)))
;; we have no data for this node, build a new subtree
(push (cons key (categorize-item
item nil
:keys (rest keys)
:tests (rest tests)))
root)))))
(let ((data (assoc key root :test (or (first tests) #'equal))))
(if data
;; Add the rest of the categorization to the
;; data of this item
(setf (cdr data) (categorize-item
item (cdr data)
:keys (rest keys)
:tests (rest tests)))
;; we have no data for this node, build a new subtree
(push (cons key (categorize-item
item nil
:keys (rest keys)
:tests (rest tests)))
root)))))
root)

(defun group-by-repeated (list &key keys tests)
"Returns an alist tree that represents the items in the list as categorized
by keys (compared with tests)
ex: ((a 3 sam) (c 4 bob) (a 3 ted))
keys: a list of key functions that describe the categorizations in order
tests: how we are testing whether or not two keys are equal, defaults to #'equal
"
(let (root)
(iter (for item in list)
(setf root (categorize-item item root :keys keys :tests tests)))
(setf root (categorize-item item root :keys keys :tests tests)))
root))

(defmethod categorize-item (item (root n-ary-tree) &key keys tests)
(iter (with node = root)
(with tests = tests)
(for keyfn in keys)
(for testfn = (or (first tests) #'equal))
(setf tests (rest tests))
(for key = (funcall keyfn item))
(setf node
(or (find key (children node) :key #'key :test testfn)
(add-child node key)))
(finally (push item (data node))))
(with tests = tests)
(for keyfn in keys)
(for testfn = (or (first tests) #'equal))
(setf tests (rest tests))
(for key = (funcall keyfn item))
(setf node
(or (find key (children node) :key #'key :test testfn)
(add-child node key)))
(finally (push item (data node))))
root)

(defun group-by-repeated-in-tree (list &key keys tests)
Expand All @@ -123,19 +124,19 @@ tests is a list of test functions to use to compare the keys (default is #'equal
(defmethod categorize-item (item (root hash-table) &key keys tests)
"puts an item in a hash-table grouping as produced by group-by-repeated-in-hash-table"
(iter (with node = root)
(for keyfn on keys)
(for key = (funcall (first keyfn) item))
(for testsym = (or (typecase (first tests)
(symbol (first tests)))
'equal))
(setf tests (rest tests))
(when (rest keyfn)
(setf node (alexandria:ensure-gethash
key node
(make-hash-table :test testsym))))
(finally (let ((data (gethash key node)))
(push item data)
(setf (gethash key node) data))))
(for keyfn on keys)
(for key = (funcall (first keyfn) item))
(for testsym = (or (typecase (first tests)
(symbol (first tests)))
'equal))
(setf tests (rest tests))
(when (rest keyfn)
(setf node (alexandria:ensure-gethash
key node
(make-hash-table :test testsym))))
(finally (let ((data (gethash key node)))
(push item data)
(setf (gethash key node) data))))
root)

(defun group-by-repeated-in-hash-table (list &key keys tests)
Expand All @@ -146,12 +147,12 @@ tests is a list of hashtable tests to use (default is 'equal)
*no significant speed increase was noticed by using differnt tests*
"
(flet ((mk-tbl () (make-hash-table :test (or (typecase (first tests)
(symbol (first tests)))
'equal))))
(symbol (first tests)))
'equal))))
(iter
(with root = (mk-tbl))
(for item in list)
;;ensure the leaf node
;;ensure the leaf node
(categorize-item item root :keys keys :tests (rest tests))
(finally (return root)))))

Expand All @@ -163,13 +164,13 @@ tests is a list of hashtable tests to use (default is 'equal)
"What data structure should be used to perform the grouping
:alist, :tree , :hash-table")
(keys :accessor keys :initarg :keys :initform nil
:documentation "A list of key functions we will use to group the list")
:documentation "A list of key functions we will use to group the list")
(tests :accessor tests :initarg :tests :initform nil
:documentation "A list of test functions we will use to test key equality
:documentation "A list of test functions we will use to test key equality
tree: defaults to #'equal
hash-table: this be a single hash-equality symbol (defaults to 'equal)")
(grouped-list :accessor grouped-list :initarg :grouped-list :initform nil
:documentation "a list grouped according to the grouping-implementation")
:documentation "a list grouped according to the grouping-implementation")
(parent-grouping :accessor parent-grouping :initarg :parent :initform nil
:documentation "If this is a subgrouping of another grouped-list, what is the parent grouping we are apart of (mostly for testing)")
(key-value :accessor key-value :initarg :key-value :initform nil
Expand All @@ -192,26 +193,26 @@ of grouped-list objects
grouped-list-speed-tester for help deciding which to use)
"
(make-instance 'grouped-list
:tests tests
:keys keys
:grouping-implementation grouping-implementation
:orig-list inp))
:tests tests
:keys keys
:grouping-implementation grouping-implementation
:orig-list inp))

(defmethod initialize-instance :after ((o grouped-list) &key list &allow-other-keys)
(when list (setf (orig-list o) list))
(unless (grouped-list o)
(setf (grouped-list o)
(apply
(ecase (grouping-implementation o)
(:hash-table #'group-by-repeated-in-hash-table)
(:tree #'group-by-repeated-in-tree)
(:alist #'group-by-repeated ))
(list (orig-list o) :keys (keys o) :tests (tests o))))))
(apply
(ecase (grouping-implementation o)
(:hash-table #'group-by-repeated-in-hash-table)
(:tree #'group-by-repeated-in-tree)
(:alist #'group-by-repeated ))
(list (orig-list o) :keys (keys o) :tests (tests o))))))

(defmethod add-item-to-grouping (item (gl grouped-list))
"puts a new item in the grouping of the grouped list (but not in the original list)"
(setf (grouped-list gl)
(categorize-item item (grouped-list gl) :keys (keys gl) :tests (tests gl))))
(categorize-item item (grouped-list gl) :keys (keys gl) :tests (tests gl))))

(defmethod %group-subgroups ((l list) key-value test &optional default)
"Returns the sub groups for the different grouping implementations"
Expand All @@ -236,15 +237,15 @@ of grouped-list objects
(defmethod %grouping-items ((ht hash-table))
"Returns the items in a given group"
(iter (for (k v) in-hashtable ht)
(appending (%grouping-items v))))
(appending (%grouping-items v))))

(defmethod %grouping-items ((n null)) n)

(defmethod %grouping-items ((tn n-ary-tree))
"Returns the items in a given group"
(append (data tn)
(iter (for kid in (children tn))
(appending (%grouping-items kid)))))
(iter (for kid in (children tn))
(appending (%grouping-items kid)))))

(defmethod make-child-grouped-list ((gl grouped-list) key-value grouped-list)
(make-instance
Expand All @@ -260,38 +261,38 @@ of grouped-list objects
(defmethod %grouping-children ((gl grouped-list) (l list))
(when (keys gl)
(iter (for (key . value) in l)
(collect (make-child-grouped-list gl key value)))))
(collect (make-child-grouped-list gl key value)))))

(defmethod %grouping-children ((gl grouped-list) (tn n-ary-tree))
(when (keys gl)
(iter (for i in (children tn))
(collect (make-child-grouped-list gl (key i) i)))))
(collect (make-child-grouped-list gl (key i) i)))))

(defmethod %grouping-children ((gl grouped-list) (h hash-table))
(when (keys gl)
(iter (for (key value) in-hashtable h)
(collect (make-child-grouped-list gl key value)))))
(collect (make-child-grouped-list gl key value)))))

(defmethod child-groupings ((gl grouped-list))
(%grouping-children gl (grouped-list gl)))

(defmethod items-in-group ((gl grouped-list) &rest key-values)
" a list of key values that will produce a list of all the items in a given group"
(let ((subgroup (grouped-list gl))
(tests (tests gl)))
(tests (tests gl)))
(iter (for key in key-values)
(for test = (or (first tests) #'equal))
(setf tests (rest tests))
(setf subgroup (%group-subgroups subgroup key test)))
(for test = (or (first tests) #'equal))
(setf tests (rest tests))
(setf subgroup (%group-subgroups subgroup key test)))

;; alists are indistinguishable from lists containing cons cells so...
;; do what we know is correct right here
(when (and (eql :alist (grouping-implementation gl)))
;; find the number of levels of alist that we still have left
(let ((depth-left (- (length (keys gl)) (length key-values) 1 )))
(iter (for i from 0 to depth-left)
(setf subgroup (iter (for (key . values) in subgroup)
(appending values))))))
(iter (for i from 0 to depth-left)
(setf subgroup (iter (for (key . values) in subgroup)
(appending values))))))
;; Get all the items for that subgrouping (for alists this is a list we just produced)
;; and that list will simply pass through
(%grouping-items subgroup)))
Expand All @@ -306,22 +307,22 @@ of grouped-list objects
(format *trace-output* "~%~%HASH-TABLE Implementation~%" )
(time
(iter (for i from 1 to iterations)
(let ((gl (make-instance
'grouped-list
:list list :keys keys :tests hash-tests
:grouping-implementation :hash-table)))
(when actions (funcall actions gl)))))
(let ((gl (make-instance
'grouped-list
:list list :keys keys :tests hash-tests
:grouping-implementation :hash-table)))
(when actions (funcall actions gl)))))
(format *trace-output* "~%~%TREE Implementation~%" )
(time
(iter (for i from 1 to iterations)
(let ((gl (make-instance 'grouped-list :list list :keys keys :tests tests
:grouping-implementation :tree)))
(when actions (funcall actions gl)))
))
(let ((gl (make-instance 'grouped-list :list list :keys keys :tests tests
:grouping-implementation :tree)))
(when actions (funcall actions gl)))
))
(format *trace-output* "~%~%ALIST Implementation~%" )
(time
(iter (for i from 1 to iterations)
(let ((gl (make-instance 'grouped-list :list list :keys keys :tests tests
:grouping-implementation :alist)))
(when actions (funcall actions gl)))
)))
(let ((gl (make-instance 'grouped-list :list list :keys keys :tests tests
:grouping-implementation :alist)))
(when actions (funcall actions gl)))
)))

0 comments on commit b15eba6

Please sign in to comment.