e7c56841f0f4

--- a/.hgignore	Fri Jan 26 23:15:34 2018 -0500
+++ b/.hgignore	Thu Feb 01 22:22:26 2018 -0500
@@ -3,7 +3,7 @@
 *.png
 *.dot
 sand.prof
-qud-items.txt
+qud-*.txt
 *.ppm
 *.pgm
 *.pbm

--- a/sand.asd	Fri Jan 26 23:15:34 2018 -0500
+++ b/sand.asd	Thu Feb 01 22:22:26 2018 -0500
@@ -44,4 +44,4 @@
   ((:module "vendor"
     :serial t
     :components ((:file "quickutils")))
-   (:file "package")))
+   ))

--- a/src/art/simple.lisp	Fri Jan 26 23:15:34 2018 -0500
+++ b/src/art/simple.lisp	Thu Feb 01 22:22:26 2018 -0500
@@ -40,43 +40,102 @@
   (make-triangle :a a :b b :c c))
 
 
+(defun-inline draw-pixel (image x y color)
+  (setf (aref image x y) color))
+
+(defun draw-vertical-line (image x y1 y2)
+  (iterate (for y :from (min y1 y2) :to (max y1 y2))
+           (draw-pixel image x y 0)))
+
+(defun draw-horizontal-line (image x1 x2 y)
+  (iterate (for x :from (min x1 x2) :to (max x1 x2))
+           (draw-pixel image x y 0)))
+
+
+(defconstant +wu-bits+ 16)
+(defconstant +color-bits+ 8)
+
+(deftype wu-unsigned ()
+  `(unsigned-byte ,+wu-bits+))
+
+(deftype wu-signed ()
+  `(signed-byte ,(1+ +wu-bits+)))
+
+(defun-inline wu+ (value increment)
+  (multiple-value-bind (overflow result)
+      (floor (+ value increment)
+             (expt 2 +wu-bits+))
+    (values result
+            (not (zerop overflow)))))
+
+(defmacro define-wu (name vertical?)
+  (destructuring-bind (main1 main2 aux1 aux2)
+      (if vertical?
+        '(y1 y2 x1 x2)
+        '(x1 x2 y1 y2))
+    `(defun ,name (image x1 y1 x2 y2)
+       (check-type image (simple-array t (* *)))
+       (check-type x1 (integer 0 100000))
+       (check-type y1 (integer 0 100000))
+       (check-type x2 (integer 0 100000))
+       (check-type y2 (integer 0 100000))
+       (iterate
+         (declare (optimize speed)
+                  (iterate:declare-variables)
+                  (type wu-unsigned d)
+                  (type wu-signed d-step))
+         (with slope = (/ (- ,aux2 ,aux1)
+                          (- ,main2 ,main1)))
+         (with d = 0)
+         (with d-step = (floor (+ (* slope (expt 2 +wu-bits+)) 1/2)))
+         (with aux-step = (if (minusp slope) -1 1))
+         (initially (draw-pixel image x1 y1 0)
+                    (draw-pixel image x2 y2 0))
+         (incf ,main1)
+         (decf ,main2)
+         (until (> ,main1 ,main2))
+         (multiple-value-bind (new-d overflow) (wu+ d d-step)
+           (setf d new-d)
+           (when overflow
+             (incf ,aux1 aux-step)
+             (decf ,aux2 aux-step)))
+         (for ca = (truncate d (expt 2 (- +wu-bits+ +color-bits+))))
+         (for cb = (- (expt 2 +color-bits+) 1 ca))
+         ,@(if vertical?
+             '((draw-pixel image x1 y1 ca)
+               (draw-pixel image (1+ x1) y1 cb)
+               (draw-pixel image x2 y2 ca)
+               (draw-pixel image (1- x2) y2 cb))
+             '((draw-pixel image x1 y1 ca)
+               (draw-pixel image x1 (1+ y1) cb)
+               (draw-pixel image x2 y2 ca)
+               (draw-pixel image x2 (1- y2) cb)))))))
+
+(define-wu wu-horizontal nil)
+(define-wu wu-vertical t)
+
+(defun draw-line (image x1 y1 x2 y2)
+  (let ((dx (abs (- x2 x1)))
+        (dy (abs (- y2 y1))))
+    (cond ((zerop dx) (draw-vertical-line image x1 y1 y2))
+          ((zerop dy) (draw-horizontal-line image x1 x2 y1))
+          ((> dy dx) (if (> y1 y2)
+                       (wu-vertical image x2 y2 x1 y1)
+                       (wu-vertical image x1 y1 x2 y2)))
+          (t (if (> x1 x2)
+               (wu-horizontal image x2 y2 x1 y1)
+               (wu-horizontal image x1 y1 x2 y2))))))
+
 (defun image-coords (image point)
   (destructuring-bind (width height) (array-dimensions image)
     (values (truncate (* (x point) (1- width)))
             (truncate (* (y point) (1- height))))))
 
-(defun draw-vertical-line (image p1 p2)
-  (if (< (y p2) (y p1))
-    (draw-vertical-line image p2 p1)
-    (nest
-      (multiple-value-bind (x1 y1) (image-coords image p1))
-      (multiple-value-bind (x2 y2) (image-coords image p2))
-      (iterate (for y :from y1 :below y2)
-               (for x = (floor (map-range y1 y2 x1 x2 y)))
-               (setf (aref image x y) 0)))))
-
-(defun draw-horizontal-line (image p1 p2)
-  (if (< (x p2) (x p1))
-    (draw-horizontal-line image p2 p1)
-    (nest
-      (multiple-value-bind (x1 y1) (image-coords image p1))
-      (multiple-value-bind (x2 y2) (image-coords image p2))
-      (iterate (for x :from x1 :below x2)
-               (for y = (floor (map-range x1 x2 y1 y2 x)))
-               (setf (aref image x y) 0)))))
-
 (defun slope (v1 v2)
   (let ((run (- (x v2) (x v1)))
         (rise (- (y v2) (y v1))))
     (/ rise run)))
 
-(defun draw-line (image p1 p2)
-  (if (or (= (x p1) (x p2))
-          (> (abs (slope p1 p2)) 1))
-    (if (= (y p1) (y p2))
-      nil
-      (draw-vertical-line image p1 p2))
-    (draw-horizontal-line image p1 p2)))
 
 (defun draw-triangle (image triangle)
     (draw-line image (a triangle) (b triangle))
@@ -96,14 +155,11 @@
 
 (defun draw (width height)
   (let ((image (make-array (list width height) :initial-element 255)))
-    (recursively ((triangle (triangle (v 0.05 0.05)
-                                      (v 0.05 0.95)
-                                      (v 0.95 0.05)))
-                  (depth 6))
-      (if (zerop depth)
-        (draw-triangle image triangle)
-        (dolist (tri (split-triangle triangle))
-          (recur tri (1- depth)))))
-    (trivial-ppm:write-to-file "triangles.pgm" image
+    (draw-line image 0 10 50 6)
+    (draw-line image 0 20 50 25)
+    (draw-line image 10 30 15 45)
+    (time (iterate (repeat 100000)
+                   (draw-line image 0 0 (1- width) (- height 5))))
+    (trivial-ppm:write-to-file "image.pgm" image
                                :format :pgm
                                :if-exists :supersede)))

--- a/src/qud.lisp	Fri Jan 26 23:15:34 2018 -0500
+++ b/src/qud.lisp	Thu Feb 01 22:22:26 2018 -0500
@@ -6,8 +6,7 @@
     :cl
     :losh
     :iterate
-    :sand.quickutils
-    :sand.utils)
+    :sand.quickutils)
   (:export))
 
 (in-package :sand.qud)
@@ -43,8 +42,12 @@
              (collect val))))
 
 (defun build-object-attributes (object-node)
-  (iterate (for part :in-whatever (clss:select "part" object-node))
-           (appending (build-part-attributes part))))
+  (append (iterate (for part :in-whatever (clss:select "part" object-node))
+                   (appending (build-part-attributes part)))
+          (iterate (for tag :in-whatever (clss:select "tag" object-node))
+                   (appending (build-part-attributes tag)))
+          (iterate (for tag :in-whatever (clss:select "stat" object-node))
+                   (appending (build-part-attributes tag)))))
 
 (defun insert-object-into-index (object-node)
   (let ((name (symbolize (plump:attribute object-node "name")))
@@ -56,17 +59,45 @@
   (map nil #'insert-object-into-index object-nodes)
   (values))
 
+(defun parent-name (name)
+  (second (lookup-object name)))
+
+(defun subtype-p (name parent-name)
+  (if (eq name parent-name)
+    t
+    (if-let ((parent (parent-name name)))
+      (subtype-p parent parent-name)
+      nil)))
+
+(defun level-to-tier (level)
+  (when level
+    (1+ (truncate (parse-integer level) 5))))
+
+(defun lookup-tier (name)
+  (let ((tier (lookup-attribute name 'tier.value))
+        (level (lookup-attribute name 'level.value)))
+    (if tier
+      (parse-integer tier)
+      (level-to-tier level))))
+
+(defun lookup-tier-explicit (name)
+  (let ((tier (lookup-attribute name 'tier.value :include-inherited nil))
+        (level (lookup-attribute name 'level.value :include-inherited nil)))
+    (if tier
+      (parse-integer tier)
+      (level-to-tier level))))
 
 (defun lookup-object (name)
   (gethash name *index*))
 
-(defun lookup-attribute (name attribute)
+(defun lookup-attribute (name attribute &key (include-inherited t))
   (destructuring-bind (_ parent attributes)
       (lookup-object name)
     (declare (ignore _))
     (or (getf attributes attribute)
-        (when parent
-          (lookup-attribute parent attribute)))))
+        (when (and parent include-inherited)
+          (lookup-attribute parent attribute
+                            :include-inherited include-inherited)))))
 
 
 (defun floatize (string)
@@ -81,6 +112,19 @@
     (when (and price weight (plusp weight))
       (collect (list (/ price weight) object name price weight)))))
 
+(defun list-tiers ()
+  (sort (iterate
+          (for (object nil) :in-hashtable *index*)
+          (for creature = (or (subtype-p object 'creature)
+                              (subtype-p object 'plant)))
+          (when creature
+            (for tier = (lookup-tier object))
+            (for etier = (lookup-tier-explicit object))
+            (for name = (lookup-attribute object 'render.displayname))
+            (when (null etier)
+              (collect (list (or tier 0) object name)))))
+        #'< :key #'first))
+
 (defun list-best-prices ()
   (let ((prices (list-prices)))
     (sort prices #'> :key #'first)))
@@ -94,3 +138,12 @@
     "qud-items.txt"
     :if-exists :supersede)
   (values))
+
+(defun dump-tiers ()
+  (build-object-index *objects*)
+  (write-string-into-file
+    (with-output-to-string (*standard-output*)
+      (print-table (cons '(tier item-key display-name) (list-tiers))))
+    "qud-tiers.txt"
+    :if-exists :supersede)
+  (values))