|
- #|
-
- src/models/category.lisp
-
- TODO All of this needs a serious rewrite.
-
- |#
-
- (in-package #:cl-deck-builder2.models.category)
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (defclass category ()
- ((name :accessor name-of
- :col-type (:varchar 64)
- :initarg :name)
- (left :accessor category-left-of
- :col-type :integer
- :initarg :left)
- (right :accessor category-right-of
- :col-type :integer
- :initarg :right))
- (:metaclass registered-table-class)
- (:unique-key name)
- (:documentation "Category implementation based on Joe Celko's Nested Set Hierarchy from one of his books."))
-
- (defun create-category (name left right)
- (create-dao 'category :name name
- :left left
- :right right))
-
- ;; (defmacro category (&body body)
- ;; `(select-dao 'category ,@body))
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (defmethod category-rename ((category category) new-name)
- (setf (category-name-of category) new-name)
- (update-dao category))
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;; Joe Celko Nested Set Hierarchy
- ;;;;
- ;;;; <https://mikehillyer.com/articles/managing-hierarchical-data-in-mysql/>
- ;;;;
- ;;;; * The Nested Set Model
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; CREATE TABLE nested_category (
- ;;;; category_id INT AUTO_INCREMENT PRIMARY KEY,
- ;;;; name VARCHAR(20) NOT NULL,
- ;;;; lft INT NOT NULL,
- ;;;; rgt INT NOT NULL
- ;;;; );
- ;;;;
- ;;;; INSERT INTO nested_category VALUES
- ;;;; (1,'ELECTRONICS',1,20),
- ;;;; (2,'TELEVISIONS',2,9),
- ;;;; (3,'TUBE',3,4),
- ;;;; (4,'LCD',5,6),
- ;;;; (5,'PLASMA',7,8),
- ;;;; (6,'PORTABLE ELECTRONICS',10,19),
- ;;;; (7,'MP3 PLAYERS',11,14),
- ;;;; (8,'FLASH',12,13),
- ;;;; (9,'CD PLAYERS',15,16),
- ;;;; (10,'2 WAY RADIOS',17,18);
- ;;;;
- ;;;; SELECT * FROM nested_category ORDER BY category_id;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-insert-fake-data ()
- "Insert Fake Data. These LEFT-IDs will mess with your stuff...
-
- TODO Figure out how to fix that."
- (with-connection (db)
- (with-transaction
- (mapcar (lambda (values-list)
- (destructuring-bind (name left right)
- values-list
- (mito:create-dao 'category
- :name name
- :left left
- :right right)))
- '(("ELECTRONICS" 1 20)
- ("TELEVISIONS" 2 9)
- ("TUBE" 3 4)
- ("LCD" 5 6)
- ("PLASMA" 7 8)
- ("PORTABLE ELECTRONICS" 10 19)
- ("MP3 PLAYERS" 11 14)
- ("FLASH" 12 13)
- ("CD PLAYERS" 15 16)
- ("2 WAY RADIOS" 17 18))))))
-
- ;;;; #+END_SRC
- ;;;;
- ;;;;
- ;;;; +-------------+----------------------+-----+-----+
- ;;;; | category_id | name | lft | rgt |
- ;;;; +-------------+----------------------+-----+-----+
- ;;;; | 1 | ELECTRONICS | 1 | 20 |
- ;;;; | 2 | TELEVISIONS | 2 | 9 |
- ;;;; | 3 | TUBE | 3 | 4 |
- ;;;; | 4 | LCD | 5 | 6 |
- ;;;; | 5 | PLASMA | 7 | 8 |
- ;;;; | 6 | PORTABLE ELECTRONICS | 10 | 19 |
- ;;;; | 7 | MP3 PLAYERS | 11 | 14 |
- ;;;; | 8 | FLASH | 12 | 13 |
- ;;;; | 9 | CD PLAYERS | 15 | 16 |
- ;;;; | 10 | 2 WAY RADIOS | 17 | 18 |
- ;;;; +-------------+----------------------+-----+-----+
- ;;;;
- ;;;; * Retrieving a Full Tree
- ;;;;
- ;;;; We can retrieve the full tree through the use of a self-join that
- ;;;; links parents with nodes on the basis that a node’s lft value will
- ;;;; always appear between its parent’s lft and rgt values:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; SELECT node.name
- ;;;; FROM nested_category AS node,
- ;;;; nested_category AS parent
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; AND parent.name = 'ELECTRONICS'
- ;;;; ORDER BY node.lft;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-full-tree (fields name)
- (retrieve-by-sql
- (sxql:select fields
- (sxql:from (:as :category :node)
- (:as :category :parent))
- (sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
- (:= :parent.name name)))
- (sxql:order-by :node.left))))
-
- ;;;; #+END_SRC
- ;;;;
- ;;;; +----------------------+
- ;;;; | name |
- ;;;; +----------------------+
- ;;;; | ELECTRONICS |
- ;;;; | TELEVISIONS |
- ;;;; | TUBE |
- ;;;; | LCD |
- ;;;; | PLASMA |
- ;;;; | PORTABLE ELECTRONICS |
- ;;;; | MP3 PLAYERS |
- ;;;; | FLASH |
- ;;;; | CD PLAYERS |
- ;;;; | 2 WAY RADIOS |
- ;;;; +----------------------+
- ;;;;
- ;;;; * Finding all the Leaf Nodes
- ;;;;
- ;;;; Finding all leaf nodes in the nested set model even simpler than the
- ;;;; LEFT JOIN method used in the adjacency list model. If you look at the
- ;;;; nested_category table, you may notice that the lft and rgt values for
- ;;;; leaf nodes are consecutive numbers. To find the leaf nodes, we look
- ;;;; for nodes where rgt = lft + 1:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; SELECT name
- ;;;; FROM nested_category
- ;;;; WHERE rgt = lft + 1;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-leaf-nodes ()
- "Finding all the Leaf Nodes"
- (select-dao 'category
- (sxql:where (:= :right (sxql:make-op :+ :left 1)))))
-
-
- ;;;; #+END_SRC
- ;;;;
- ;;;; +--------------+
- ;;;; | name |
- ;;;; +--------------+
- ;;;; | TUBE |
- ;;;; | LCD |
- ;;;; | PLASMA |
- ;;;; | FLASH |
- ;;;; | CD PLAYERS |
- ;;;; | 2 WAY RADIOS |
- ;;;; +--------------+
- ;;;;
- ;;;; * Retrieving a Single Path
- ;;;;
- ;;;; With the nested set model, we can retrieve a single path without
- ;;;; having multiple self-joins:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; SELECT parent.name
- ;;;; FROM nested_category AS node,
- ;;;; nested_category AS parent
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; AND node.name = 'FLASH'
- ;;;; ORDER BY parent.lft;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-path-of (name)
- (retrieve-by-sql
- (sxql:select :parent.name
- (sxql:from (:as :category :node)
- (:as :category :parent))
- (sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
- (:= :node.name name)))
- (sxql:order-by :parent.left))))
-
-
- ;;;; #+END_SRC
- ;;;;
- ;;;; +----------------------+
- ;;;; | name |
- ;;;; +----------------------+
- ;;;; | ELECTRONICS |
- ;;;; | PORTABLE ELECTRONICS |
- ;;;; | MP3 PLAYERS |
- ;;;; | FLASH |
- ;;;; +----------------------+
- ;;;;
- ;;;; * Finding the Depth of the Nodes
- ;;;;
- ;;;; We have already looked at how to show the entire tree, but what if we
- ;;;; want to also show the depth of each node in the tree, to better
- ;;;; identify how each node fits in the hierarchy? This can be done by
- ;;;; adding a COUNT function and a GROUP BY clause to our existing query
- ;;;; for showing the entire tree:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; SELECT node.name, (COUNT(parent.name) - 1) AS depth
- ;;;; FROM nested_category AS node,
- ;;;; nested_category AS parent
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; GROUP BY node.name
- ;;;; ORDER BY node.lft;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-node-depth (name)
- "Find the depth of a specific CATEGORY node named NAME."
- (retrieve-by-sql
- (sxql:select
- (:node.name (:as (:- (:count :parent.name) 1) :depth))
- (sxql:from (:as :category :node)
- (:as :category :parent))
- (sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
- (:= :node.name name)))
- (sxql:group-by :node.name)
- (sxql:order-by :node.left))))
-
- (defun category-tree-depth ()
- "Show the depths of all nodes in the CATEGORY tree."
- (retrieve-by-sql
- (sxql:select
- (:node.name (:as (:- (:count :parent.name) 1) :depth))
- (sxql:from (:as :category :node)
- (:as :category :parent))
- (sxql:where (sxql:make-op :raw "node.left between parent.left and parent.right"))
- (sxql:group-by :node.name)
- (sxql:order-by :node.left))))
-
- ;;;; #+END_SRC
- ;;;;
- ;;;; +----------------------+-------+
- ;;;; | name | depth |
- ;;;; +----------------------+-------+
- ;;;; | ELECTRONICS | 0 |
- ;;;; | TELEVISIONS | 1 |
- ;;;; | TUBE | 2 |
- ;;;; | LCD | 2 |
- ;;;; | PLASMA | 2 |
- ;;;; | PORTABLE ELECTRONICS | 1 |
- ;;;; | MP3 PLAYERS | 2 |
- ;;;; | FLASH | 3 |
- ;;;; | CD PLAYERS | 2 |
- ;;;; | 2 WAY RADIOS | 2 |
- ;;;; +----------------------+-------+
- ;;;;
- ;;;; We can use the depth value to indent our category names with the
- ;;;; CONCAT and REPEAT string functions:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; SELECT CONCAT( REPEAT(' ', COUNT(parent.name) - 1), node.name) AS name
- ;;;; FROM nested_category AS node,
- ;;;; nested_category AS parent
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; GROUP BY node.name
- ;;;; ORDER BY node.lft;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-full-tree-format (&optional (depths (category-tree-depth)))
- "Output a formatted display of the CATEGORY tree.
-
- DEPTHS is the depth tree provided by default by CATEGORY-TREE-DEPTH."
- (with-output-to-string (s)
- (mapcar (lambda (node)
- (format s (format nil "~~~d@a~~a~~%"
- (getf node :depth))
- "" (getf node :name)))
- depths)))
-
- ;;;; #+END_SRC
- ;;;;
- ;;;; +-----------------------+
- ;;;; | name |
- ;;;; +-----------------------+
- ;;;; | ELECTRONICS |
- ;;;; | TELEVISIONS |
- ;;;; | TUBE |
- ;;;; | LCD |
- ;;;; | PLASMA |
- ;;;; | PORTABLE ELECTRONICS |
- ;;;; | MP3 PLAYERS |
- ;;;; | FLASH |
- ;;;; | CD PLAYERS |
- ;;;; | 2 WAY RADIOS |
- ;;;; +-----------------------+
- ;;;;
- ;;;; Of course, in a client-side application you will be more likely to use
- ;;;; the depth value directly to display your hierarchy. Web developers
- ;;;; could loop through the tree, adding <li></li> and <ul></ul> tags as
- ;;;; the depth number increases and decreases.
- ;;;;
- ;;;; * Depth of a Sub-Tree
- ;;;;
- ;;;; When we need depth information for a sub-tree, we cannot limit either
- ;;;; the node or parent tables in our self-join because it will corrupt our
- ;;;; results. Instead, we add a third self-join, along with a sub-query to
- ;;;; determine the depth that will be the new starting point for our
- ;;;; sub-tree:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; SELECT node.name, (COUNT(parent.name) - (sub_tree.depth + 1)) AS depth
- ;;;; FROM nested_category AS node,
- ;;;; nested_category AS parent,
- ;;;; nested_category AS sub_parent,
- ;;;; (
- ;;;; SELECT node.name, (COUNT(parent.name) - 1) AS depth
- ;;;; FROM nested_category AS node,
- ;;;; nested_category AS parent
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; AND node.name = 'PORTABLE ELECTRONICS'
- ;;;; GROUP BY node.name
- ;;;; ORDER BY node.lft
- ;;;; ) AS sub_tree
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; AND node.lft BETWEEN sub_parent.lft AND sub_parent.rgt
- ;;;; AND sub_parent.name = sub_tree.name
- ;;;; GROUP BY node.name
- ;;;; ORDER BY node.lft;
- ;;;; #+END_SRC
-
- (defun category-subtree-depth (name)
- (retrieve-by-sql
- (sxql:select
- (:node.name (:as (:- (:count :parent.name) (:+ :sub_tree.depth 1)) :depth))
- (sxql:from (:as :category :node)
- (:as :category :parent)
- (:as :category :sub_parent)
- (:as (sxql:select
- (:node.name (:as (:- (:count :parent.name) 1) :depth))
- (sxql:from (:as :category :node)
- (:as :category :parent))
- (sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
- (:= :node.name name)))
- (sxql:group-by :node.name)
- (sxql:order-by :node.left))
- :sub_tree))
- (sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
- (sxql:make-op :raw "node.left between sub_parent.left and sub_parent.right")
- (:= :sub_parent.name :sub_tree.name)))
- (sxql:group-by :node.name)
- (sxql:order-by :node.left))))
-
- ;;;;
- ;;;; +----------------------+-------+
- ;;;; | name | depth |
- ;;;; +----------------------+-------+
- ;;;; | PORTABLE ELECTRONICS | 0 |
- ;;;; | MP3 PLAYERS | 1 |
- ;;;; | FLASH | 2 |
- ;;;; | CD PLAYERS | 1 |
- ;;;; | 2 WAY RADIOS | 1 |
- ;;;; +----------------------+-------+
- ;;;;
- ;;;; This function can be used with any node name, including the root
- ;;;; node. The depth values are always relative to the named node.
- ;;;;
- ;;;; * Find the Immediate Subordinates of a Node
- ;;;;
- ;;;; Imagine you are showing a category of electronics products on a
- ;;;; retailer web site. When a user clicks on a category, you would want to
- ;;;; show the products of that category, as well as list its immediate
- ;;;; sub-categories, but not the entire tree of categories beneath it. For
- ;;;; this, we need to show the node and its immediate sub-nodes, but no
- ;;;; further down the tree. For example, when showing the PORTABLE
- ;;;; ELECTRONICS category, we will want to show MP3 PLAYERS, CD PLAYERS,
- ;;;; and 2 WAY RADIOS, but not FLASH.
- ;;;;
- ;;;; This can be easily accomplished by adding a HAVING clause to our previous query:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; SELECT node.name, (COUNT(parent.name) - (sub_tree.depth + 1)) AS depth
- ;;;; FROM nested_category AS node,
- ;;;; nested_category AS parent,
- ;;;; nested_category AS sub_parent,
- ;;;; (
- ;;;; SELECT node.name, (COUNT(parent.name) - 1) AS depth
- ;;;; FROM nested_category AS node,
- ;;;; nested_category AS parent
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; AND node.name = 'PORTABLE ELECTRONICS'
- ;;;; GROUP BY node.name
- ;;;; ORDER BY node.lft
- ;;;; ) AS sub_tree
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; AND node.lft BETWEEN sub_parent.lft AND sub_parent.rgt
- ;;;; AND sub_parent.name = sub_tree.name
- ;;;; GROUP BY node.name
- ;;;; HAVING depth <= 1
- ;;;; ORDER BY node.lft;
- ;;;; #+END_SRC
-
- (defun category-subtree-max-depth (name &optional (max-depth 1))
- "TODO This doesn't seem to work. It returns FLASH with DEPTH = 2"
- (retrieve-by-sql
- (sxql:select
- (:node.name (:as (:- (:count :parent.name) (:+ :sub_tree.depth 1)) :depth))
- (sxql:from (:as :category :node)
- (:as :category :parent)
- (:as :category :sub_parent)
- (:as (sxql:select
- (:node.name (:as (:- (:count :parent.name) 1) :depth))
- (sxql:from (:as :category :node)
- (:as :category :parent))
- (sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
- (:= :node.name name)))
- (sxql:group-by :node.name)
- (sxql:order-by :node.left))
- :sub_tree))
- (sxql:where (:and (sxql:make-op :raw "node.left between parent.left and parent.right")
- (sxql:make-op :raw "node.left between sub_parent.left and sub_parent.right")
- (:= :sub_parent.name :sub_tree.name)))
- (sxql:group-by :node.name)
- (sxql:having (:<= :depth max-depth))
- (sxql:order-by :node.left))))
-
- ;;;;
- ;;;; +----------------------+-------+
- ;;;; | name | depth |
- ;;;; +----------------------+-------+
- ;;;; | PORTABLE ELECTRONICS | 0 |
- ;;;; | MP3 PLAYERS | 1 |
- ;;;; | CD PLAYERS | 1 |
- ;;;; | 2 WAY RADIOS | 1 |
- ;;;; +----------------------+-------+
- ;;;;
- ;;;; If you do not wish to show the parent node, change the HAVING depth <= 1 line to HAVING depth = 1.
- ;;;;
- ;;;; * Aggregate Functions in a Nested Set
- ;;;;
- ;;;; Let’s add a table of products that we can use to demonstrate aggregate
- ;;;; functions with:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; CREATE TABLE product
- ;;;; (
- ;;;; product_id INT AUTO_INCREMENT PRIMARY KEY,
- ;;;; name VARCHAR(40),
- ;;;; category_id INT NOT NULL
- ;;;; );
- ;;;;
- ;;;; INSERT INTO product(name, category_id)
- ;;;; VALUES
- ;;;; ('20" TV',3),
- ;;;; ('36" TV',3),
- ;;;; ('Super-LCD 42"',4),
- ;;;; ('Ultra-Plasma 62"',5),
- ;;;; ('Value Plasma 38"',5),
- ;;;; ('Power-MP3 5gb',7),
- ;;;; ('Super-Player 1gb',8),
- ;;;; ('Porta CD',9),
- ;;;; ('CD To go!',9),
- ;;;; ('Family Talk 360',10);
- ;;;;
- ;;;; SELECT * FROM product;
- ;;;; #+END_SRC
- ;;;;
- ;;;; +------------+-------------------+-------------+
- ;;;; | product_id | name | category_id |
- ;;;; +------------+-------------------+-------------+
- ;;;; | 1 | 20" TV | 3 |
- ;;;; | 2 | 36" TV | 3 |
- ;;;; | 3 | Super-LCD 42" | 4 |
- ;;;; | 4 | Ultra-Plasma 62" | 5 |
- ;;;; | 5 | Value Plasma 38" | 5 |
- ;;;; | 6 | Power-MP3 128mb | 7 |
- ;;;; | 7 | Super-Shuffle 1gb | 8 |
- ;;;; | 8 | Porta CD | 9 |
- ;;;; | 9 | CD To go! | 9 |
- ;;;; | 10 | Family Talk 360 | 10 |
- ;;;; +------------+-------------------+-------------+
- ;;;;
- ;;;; Now let’s produce a query that can retrieve our category tree, along
- ;;;; with a product count for each category:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; SELECT parent.name, COUNT(product.name)
- ;;;; FROM nested_category AS node ,
- ;;;; nested_category AS parent,
- ;;;; product
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; AND node.category_id = product.category_id
- ;;;; GROUP BY parent.name
- ;;;; ORDER BY node.lft;
- ;;;; #+END_SRC
- ;;;;
- ;;;; +----------------------+---------------------+
- ;;;; | name | COUNT(product.name) |
- ;;;; +----------------------+---------------------+
- ;;;; | ELECTRONICS | 10 |
- ;;;; | TELEVISIONS | 5 |
- ;;;; | TUBE | 2 |
- ;;;; | LCD | 1 |
- ;;;; | PLASMA | 2 |
- ;;;; | PORTABLE ELECTRONICS | 5 |
- ;;;; | MP3 PLAYERS | 2 |
- ;;;; | FLASH | 1 |
- ;;;; | CD PLAYERS | 2 |
- ;;;; | 2 WAY RADIOS | 1 |
- ;;;; +----------------------+---------------------+
- ;;;;
- ;;;; This is our typical whole tree query with a COUNT and GROUP BY added,
- ;;;; along with a reference to the product table and a join between the
- ;;;; node and product table in the WHERE clause. As you can see, there is a
- ;;;; count for each category and the count of subcategories is reflected in
- ;;;; the parent categories.
- ;;;;
- ;;;; * Adding New Nodes
- ;;;;
- ;;;; ** category-insert-right-of
- ;;;;
- ;;;; If we wanted to add a new node between the TELEVISIONS and PORTABLE
- ;;;; ELECTRONICS nodes, the new node would have lft and rgt values of 10
- ;;;; and 11, and all nodes to its right would have their lft and rgt values
- ;;;; increased by two. We would then add the new node with the appropriate
- ;;;; lft and rgt values. While this can be done with a stored procedure in
- ;;;; MySQL 5, I will assume for the moment that most readers are using 4.1,
- ;;;; as it is the latest stable version, and I will isolate my queries with
- ;;;; a LOCK TABLES statement instead:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; LOCK TABLE nested_category WRITE;
- ;;;;
- ;;;; SELECT @myRight := rgt FROM nested_category
- ;;;; WHERE name = 'TELEVISIONS';
- ;;;;
- ;;;; UPDATE nested_category SET rgt = rgt + 2 WHERE rgt > @myRight;
- ;;;; UPDATE nested_category SET lft = lft + 2 WHERE lft > @myRight;
- ;;;;
- ;;;; INSERT INTO nested_category(name, lft, rgt) VALUES('GAME CONSOLES', @myRight + 1, @myRight + 2);
- ;;;;
- ;;;; UNLOCK TABLES;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-insert-right-of (name &optional left-of)
- "Create a new category tree. LEFT-OF is the NAME of the node to the
- left of this new node named NAME. If LEFT-OF is NIL, insert
- all-the-way at the right."
- (with-connection (db)
- (let* ((found (ignore-errors
- (mito:find-dao 'category :name left-of)))
- (my-right (if (and left-of found)
- (ignore-errors
- (category-right-of found))
- (max-dao 'category))))
- (with-transaction
- (mapcar #'mito:execute-sql
- (list
- (sxql:update :category
- (sxql:set= :right (:+ :right 2))
- (sxql:where (:> :right my-right)))
- (sxql:update :category
- (sxql:set= :left (:+ :left 2))
- (sxql:where (:> :left my-right)))))
- (mito:create-dao 'category :name name
- :left (+ my-right 1)
- :right (+ my-right 2))))))
-
- ;;;; #+END_SRC
- ;;;;
- ;;;; We can then check our nesting with our indented tree query:
- ;;;;
- ;;;; +-----------------------+
- ;;;; | name |
- ;;;; +-----------------------+
- ;;;; | ELECTRONICS |
- ;;;; | TELEVISIONS |
- ;;;; | TUBE |
- ;;;; | LCD |
- ;;;; | PLASMA |
- ;;;; | GAME CONSOLES |
- ;;;; | PORTABLE ELECTRONICS |
- ;;;; | MP3 PLAYERS |
- ;;;; | FLASH |
- ;;;; | CD PLAYERS |
- ;;;; | 2 WAY RADIOS |
- ;;;; +-----------------------+
- ;;;;
- ;;;; ** category-insert-new-child
- ;;;;
- ;;;; If we instead want to add a node as a child of a node that has no
- ;;;; existing children, we need to modify our procedure slightly. Let’s add
- ;;;; a new FRS node below the 2 WAY RADIOS node:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; LOCK TABLE nested_category WRITE;
- ;;;;
- ;;;; SELECT @myLeft := lft FROM nested_category
- ;;;;
- ;;;; WHERE name = '2 WAY RADIOS';
- ;;;;
- ;;;; UPDATE nested_category SET rgt = rgt + 2 WHERE rgt > @myLeft;
- ;;;; UPDATE nested_category SET lft = lft + 2 WHERE lft > @myLeft;
- ;;;;
- ;;;; INSERT INTO nested_category(name, lft, rgt) VALUES('FRS', @myLeft + 1, @myLeft + 2);
- ;;;;
- ;;;; UNLOCK TABLES;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-insert-new-child (name left-of)
- "Create a new category tree. LEFT-OF is the NAME of the node to the
- left of this new node named NAME."
- (with-connection (db)
- (let* ((my-left (category-left-of
- (mito:find-dao 'category :name left-of))))
- (with-transaction
- (mapcar #'mito:execute-sql
- (list
- (sxql:update :category
- (sxql:set= :right (:+ :right 2))
- (sxql:where (:> :right my-left)))
- (sxql:update :category
- (sxql:set= :left (:+ :left 2))
- (sxql:where (:> :left my-left)))))
- (mito:create-dao 'category :name name
- :left (+ my-left 1)
- :right (+ my-left 2))))))
-
- ;;;; #+END_SRC
- ;;;;
- ;;;; In this example we expand everything to the right of the left-hand
- ;;;; number of our proud new parent node, then place the node to the right
- ;;;; of the left-hand value. As you can see, our new node is now properly
- ;;;; nested:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; SELECT CONCAT( REPEAT( ' ', (COUNT(parent.name) - 1) ), node.name) AS name
- ;;;; FROM nested_category AS node,
- ;;;; nested_category AS parent
- ;;;; WHERE node.lft BETWEEN parent.lft AND parent.rgt
- ;;;; GROUP BY node.name
- ;;;; ORDER BY node.lft;
- ;;;; #+END_SRC
- ;;;;
- ;;;; +-----------------------+
- ;;;; | name |
- ;;;; +-----------------------+
- ;;;; | ELECTRONICS |
- ;;;; | TELEVISIONS |
- ;;;; | TUBE |
- ;;;; | LCD |
- ;;;; | PLASMA |
- ;;;; | GAME CONSOLES |
- ;;;; | PORTABLE ELECTRONICS |
- ;;;; | MP3 PLAYERS |
- ;;;; | FLASH |
- ;;;; | CD PLAYERS |
- ;;;; | 2 WAY RADIOS |
- ;;;; | FRS |
- ;;;; +-----------------------+
- ;;;;
- ;;;; * Deleting Nodes
- ;;;;
- ;;;; ** DONE category-delete-tree
- ;;;;
- ;;;; The last basic task involved in working with nested sets is the
- ;;;; removal of nodes. The course of action you take when deleting a node
- ;;;; depends on the node’s position in the hierarchy; deleting leaf nodes
- ;;;; is easier than deleting nodes with children because we have to handle
- ;;;; the orphaned nodes.
- ;;;;
- ;;;; When deleting a leaf node, the process if just the opposite of adding
- ;;;; a new node, we delete the node and its width from every node to its
- ;;;; right:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; LOCK TABLE nested_category WRITE;
- ;;;;
- ;;;; SELECT @myLeft := lft, @myRight := rgt, @myWidth := rgt - lft + 1
- ;;;; FROM nested_category
- ;;;; WHERE name = 'GAME CONSOLES';
- ;;;;
- ;;;; DELETE FROM nested_category WHERE lft BETWEEN @myLeft AND @myRight;
- ;;;;
- ;;;; UPDATE nested_category SET rgt = rgt - @myWidth WHERE rgt > @myRight;
- ;;;; UPDATE nested_category SET lft = lft - @myWidth WHERE lft > @myRight;
- ;;;;
- ;;;; UNLOCK TABLES;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-delete-tree (name)
- (with-connection (db)
- (with-transaction
- (let ((found (mito:find-dao 'category :name name)))
- (if found
- (let* ((my-left (category-left-of found))
- (my-right (category-right-of found))
- (my-width (1+ (- my-right my-left))))
- (mapcar #'mito:execute-sql
- (list
- (sxql:delete-from :category
- (sxql:where (sxql:make-op :raw
- (format nil "left between ~d and ~d"
- my-left my-right))))
- (sxql:update :category
- (sxql:set= :right (:- :right my-width))
- (sxql:where (:> :right my-right)))
- (sxql:update :category
- (sxql:set= :left (:- :left my-width))
- (sxql:where (:> :left my-right)))))))))))
-
- ;;;; #+END_SRC
- ;;;;
- ;;;; And once again, we execute our indented tree query to confirm that our
- ;;;; node has been deleted without corrupting the hierarchy:
- ;;;;
- ;;;; +-----------------------+
- ;;;; | name |
- ;;;; +-----------------------+
- ;;;; | ELECTRONICS |
- ;;;; | TELEVISIONS |
- ;;;; | TUBE |
- ;;;; | LCD |
- ;;;; | PLASMA |
- ;;;; | PORTABLE ELECTRONICS |
- ;;;; | MP3 PLAYERS |
- ;;;; | FLASH |
- ;;;; | CD PLAYERS |
- ;;;; | 2 WAY RADIOS |
- ;;;; | FRS |
- ;;;; +-----------------------+
- ;;;;
- ;;;; This approach works equally well to delete a node and all its children:
- ;;;;
- ;;;; And once again, we query to see that we have successfully deleted an entire sub-tree:
- ;;;;
- ;;;; +-----------------------+
- ;;;; | name |
- ;;;; +-----------------------+
- ;;;; | ELECTRONICS |
- ;;;; | TELEVISIONS |
- ;;;; | TUBE |
- ;;;; | LCD |
- ;;;; | PLASMA |
- ;;;; | PORTABLE ELECTRONICS |
- ;;;; | CD PLAYERS |
- ;;;; | 2 WAY RADIOS |
- ;;;; | FRS |
- ;;;; +-----------------------+
- ;;;;
- ;;;; ** category-delete-and-reparent
- ;;;;
- ;;;; The other scenario we have to deal with is the deletion of a parent
- ;;;; node but not the children. In some cases you may wish to just change
- ;;;; the name to a placeholder until a replacement is presented, such as
- ;;;; when a supervisor is fired. In other cases, the child nodes should all
- ;;;; be moved up to the level of the deleted parent:
- ;;;;
- ;;;; #+BEGIN_SRC sql
- ;;;; LOCK TABLE nested_category WRITE;
- ;;;;
- ;;;; SELECT @myLeft := lft, @myRight := rgt, @myWidth := rgt - lft + 1
- ;;;; FROM nested_category
- ;;;; WHERE name = 'PORTABLE ELECTRONICS';
- ;;;;
- ;;;; DELETE FROM nested_category WHERE lft = @myLeft;
- ;;;;
- ;;;; UPDATE nested_category SET rgt = rgt - 1, lft = lft - 1 WHERE lft BETWEEN @myLeft AND @myRight;
- ;;;; UPDATE nested_category SET rgt = rgt - 2 WHERE rgt > @myRight;
- ;;;; UPDATE nested_category SET lft = lft - 2 WHERE lft > @myRight;
- ;;;;
- ;;;; UNLOCK TABLES;
- ;;;; #+END_SRC
- ;;;;
- ;;;; #+BEGIN_SRC lisp
-
- (defun category-delete-and-reparent (name)
- (with-connection (db)
- (with-transaction
- (let ((found (mito:find-dao 'category :name name)))
- (if found
- (let* ((my-left (category-left-of found))
- (my-right (category-right-of found)))
- (mapcar #'mito:execute-sql
- (list
- (sxql:delete-from :category
- (sxql:where (:= :left my-left)))
- (sxql:update :category
- (sxql:set= :right (:- :right 1)
- :left (:- :left 1))
- (sxql:where (sxql:make-op
- :raw (format nil "left between ~d and ~d"
- my-left my-right))))
- (sxql:update :category
- (sxql:set= :right (:- :right 2))
- (sxql:where (:> :right my-right)))
- (sxql:update :category
- (sxql:set= :left (:- :left 2))
- (sxql:where (:> :left my-right)))))))))))
-
- ;;;; #+END_SRC
- ;;;;
- ;;;; In this case we subtract two from all elements to the right of the
- ;;;; node (since without children it would have a width of two), and one
- ;;;; from the nodes that are its children (to close the gap created by the
- ;;;; loss of the parent’s left value). Once again, we can confirm our
- ;;;; elements have been promoted:
- ;;;;
- ;;;; +---------------+
- ;;;; | name |
- ;;;; +---------------+
- ;;;; | ELECTRONICS |
- ;;;; | TELEVISIONS |
- ;;;; | TUBE |
- ;;;; | LCD |
- ;;;; | PLASMA |
- ;;;; | CD PLAYERS |
- ;;;; | 2 WAY RADIOS |
- ;;;; | FRS |
- ;;;; +---------------+
- ;;;;
- ;;;; ** category-delete-and-promote
- ;;;;
- ;;;; Other scenarios when deleting nodes would include promoting one of the
- ;;;; children to the parent position and moving the child nodes under a
- ;;;; sibling of the parent node, but for the sake of space these scenarios
- ;;;; will not be covered in this article.
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; TODO SELECT-CATEGORY ?
- (defgeneric by-category (class maybe-category-id)
- (:method ((class t) (id category))
- (select-dao class (sxql:where (:= :category id))))
- (:method ((class t) (id integer))
- (select-dao class (sxql:where (:= :category-id id))))
- (:method ((class t) (id string))
- (by-category class (parse-integer id))))
-
|