cl-deck-builder2/src/models/category.lisp

#|

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))))