Jank in qud tier dumping, implement wu
author |
Steve Losh <steve@stevelosh.com> |
date |
Thu, 01 Feb 2018 22:22:26 -0500 |
parents |
de5ea4119ef4
|
children |
ea247d3d5953
|
branches/tags |
(none) |
files |
.hgignore sand.asd src/art/simple.lisp src/qud.lisp |
Changes
--- 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))