# HG changeset patch # User Steve Losh # Date 1517541746 18000 # Node ID e7c56841f0f4c0ca7126736505087dce1adbc5d4 # Parent de5ea4119ef4658c741f521e5b6347cc65a83765 Jank in qud tier dumping, implement wu diff -r de5ea4119ef4 -r e7c56841f0f4 .hgignore --- 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 diff -r de5ea4119ef4 -r e7c56841f0f4 sand.asd --- 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"))) + )) diff -r de5ea4119ef4 -r e7c56841f0f4 src/art/simple.lisp --- 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))) diff -r de5ea4119ef4 -r e7c56841f0f4 src/qud.lisp --- 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))