4add15d40994

--- a/package.lisp	Sat Jan 14 15:00:24 2017 +0000
+++ b/package.lisp	Sat Jan 14 15:00:33 2017 +0000
@@ -257,6 +257,17 @@
   (:export
     ))
 
+(defpackage :sand.qud
+  (:use
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.quickutils
+    :sand.utils)
+  (:export
+    ))
+
 
 (defpackage :sand.sketch
   (:use

--- a/sand.asd	Sat Jan 14 15:00:24 2017 +0000
+++ b/sand.asd	Sat Jan 14 15:00:33 2017 +0000
@@ -24,6 +24,7 @@
                :html-entities
                :iterate
                :losh
+               :parse-float
                :parenscript
                :plump
                :rs-colors
@@ -74,6 +75,7 @@
                  (:file "sketch")
                  (:file "mandelbrot")
                  (:file "story")
+                 (:file "qud")
                  (:module "turing-omnibus"
                   :serial t
                   :components ((:file "wallpaper")

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/qud.lisp	Sat Jan 14 15:00:33 2017 +0000
@@ -0,0 +1,83 @@
+(in-package :sand.qud)
+
+(setf *print-length* 10)
+
+(defparameter *object-blueprints-path*
+  #p"/Users/sjl/Library/Application Support/Steam/steamapps/common/Caves of Qud/CoQ.app/Contents/Resources/Data/StreamingAssets/Base/ObjectBlueprints.xml")
+
+(defparameter *blueprints*
+  (plump:parse *object-blueprints-path*))
+
+(defparameter *objects*
+  (clss:select "object" *blueprints*))
+
+(defparameter *index* (make-hash-table))
+
+(defun symbolize (string)
+  (if (null string)
+    nil
+    (-<> string
+      (string-upcase <>)
+      (substitute #\- #\Space <>)
+      (intern <>)
+      (nth-value 0 <>))))
+
+(defun build-part-attributes (part-node)
+  (iterate (with attrs = (plump:attributes part-node))
+           (with name = (symbolize (gethash "name" attrs)))
+           (for (key val) :in-hashtable (plump:attributes part-node))
+           (unless (string-equal "name" key)
+             (collect (symb name "." (symbolize key)))
+             (collect val))))
+
+(defun build-object-attributes (object-node)
+  (iterate (for part :in-whatever (clss:select "part" object-node))
+           (appending (build-part-attributes part))))
+
+(defun insert-object-into-index (object-node)
+  (let ((name (symbolize (plump:attribute object-node "name")))
+        (parent (symbolize (plump:attribute object-node "inherits"))))
+    (setf (gethash name *index*)
+          (list name parent (build-object-attributes object-node)))))
+
+(defun build-object-index (object-nodes)
+  (map nil #'insert-object-into-index object-nodes)
+  (values))
+
+
+(defun lookup-object (name)
+  (gethash name *index*))
+
+(defun lookup-attribute (name attribute)
+  (destructuring-bind (_ parent attributes)
+      (lookup-object name)
+    (declare (ignore _))
+    (or (getf attributes attribute)
+        (when parent
+          (lookup-attribute parent attribute)))))
+
+
+(defun floatize (string)
+  (when string (parse-float:parse-float string)))
+
+(defun list-prices ()
+  (iterate
+    (for (object nil) :in-hashtable *index*)
+    (for price = (floatize (lookup-attribute object 'commerce.value)))
+    (for weight = (floatize (lookup-attribute object 'physics.weight)))
+    (for name = (lookup-attribute object 'render.displayname))
+    (when (and price weight (plusp weight))
+      (collect (list (/ price weight) object name price weight)))))
+
+(defun list-best-prices ()
+  (let ((prices (list-prices)))
+    (sort prices #'> :key #'first)))
+
+(defun dump ()
+  (write-string-into-file
+    (with-output-to-string (*standard-output*)
+      (print-table (cons '(price/weight item-key display-name price weight)
+                         (list-best-prices))))
+    "qud-items.txt"
+    :if-exists :supersede)
+  (values))

--- a/vendor/make-quickutils.lisp	Sat Jan 14 15:00:24 2017 +0000
+++ b/vendor/make-quickutils.lisp	Sat Jan 14 15:00:33 2017 +0000
@@ -17,6 +17,7 @@
                :hash-table-keys
                :hash-table-plist
                :hash-table-values
+               :write-string-into-file
                :iota
                :n-grams
                :once-only

--- a/vendor/quickutils.lisp	Sat Jan 14 15:00:24 2017 +0000
+++ b/vendor/quickutils.lisp	Sat Jan 14 15:00:33 2017 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-ARRAY :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLIP :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :IOTA :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SEPARATED-STRING-APPEND :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-ARRAY :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLIP :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :WRITE-STRING-INTO-FILE :IOTA :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SEPARATED-STRING-APPEND :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "SAND.QUICKUTILS")
@@ -20,8 +20,10 @@
                                          :FLIP :HASH-TABLE-ALIST :MAPHASH-KEYS
                                          :HASH-TABLE-KEYS :HASH-TABLE-PLIST
                                          :MAPHASH-VALUES :HASH-TABLE-VALUES
-                                         :IOTA :TAKE :N-GRAMS :ONCE-ONLY :RANGE
-                                         :RCURRY :WITH-OPEN-FILE*
+                                         :ONCE-ONLY :WITH-OPEN-FILE*
+                                         :WITH-OUTPUT-TO-FILE
+                                         :WRITE-STRING-INTO-FILE :IOTA :TAKE
+                                         :N-GRAMS :RANGE :RCURRY
                                          :WITH-INPUT-FROM-FILE
                                          :READ-FILE-INTO-STRING
                                          :REQUIRED-ARGUMENT :RIFFLE
@@ -284,6 +286,94 @@
       values))
   
 
+  (defmacro once-only (specs &body forms)
+    "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+    (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+    (symbol symbol)
+
+Example:
+
+    (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+      (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+    (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+          (names-and-forms (mapcar (lambda (spec)
+                                     (etypecase spec
+                                       (list
+                                        (destructuring-bind (name form) spec
+                                          (cons name form)))
+                                       (symbol
+                                        (cons spec spec))))
+                                   specs)))
+      ;; bind in user-macro
+      `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+              gensyms names-and-forms)
+         ;; bind in final expansion
+         `(let (,,@(mapcar (lambda (g n)
+                             ``(,,g ,,(cdr n)))
+                           gensyms names-and-forms))
+            ;; bind in user-macro
+            ,(let ,(mapcar (lambda (n g) (list (car n) g))
+                    names-and-forms gensyms)
+               ,@forms)))))
+  
+
+  (defmacro with-open-file* ((stream filespec &key direction element-type
+                                                   if-exists if-does-not-exist external-format)
+                             &body body)
+    "Just like `with-open-file`, but `nil` values in the keyword arguments mean to use
+the default value specified for `open`."
+    (once-only (direction element-type if-exists if-does-not-exist external-format)
+      `(with-open-stream
+           (,stream (apply #'open ,filespec
+                           (append
+                            (when ,direction
+                              (list :direction ,direction))
+                            (when ,element-type
+                              (list :element-type ,element-type))
+                            (when ,if-exists
+                              (list :if-exists ,if-exists))
+                            (when ,if-does-not-exist
+                              (list :if-does-not-exist ,if-does-not-exist))
+                            (when ,external-format
+                              (list :external-format ,external-format)))))
+         ,@body)))
+  
+
+  (defmacro with-output-to-file ((stream-name file-name &rest args
+                                                        &key (direction nil direction-p)
+                                                        &allow-other-keys)
+                                 &body body)
+    "Evaluate `body` with `stream-name` to an output stream on the file
+`file-name`. `args` is sent as is to the call to `open` except `external-format`,
+which is only sent to `with-open-file` when it's not `nil`."
+    (declare (ignore direction))
+    (when direction-p
+      (error "Can't specifiy :DIRECTION for WITH-OUTPUT-TO-FILE."))
+    `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
+       ,@body))
+  
+
+  (defun write-string-into-file (string pathname &key (if-exists :error)
+                                                      if-does-not-exist
+                                                      external-format)
+    "Write `string` to `pathname`.
+
+The `external-format` parameter will be passed directly to `with-open-file`
+unless it's `nil`, which means the system default."
+    (with-output-to-file (file-stream pathname :if-exists if-exists
+                                               :if-does-not-exist if-does-not-exist
+                                               :external-format external-format)
+      (write-sequence string file-stream)))
+  
+
   (declaim (inline iota))
   (defun iota (n &key (start 0) (step 1))
     "Return a list of `n` numbers, starting from `start` (with numeric contagion
@@ -323,45 +413,6 @@
                       :collect (subseq sequence i (+ i n))))))
   
 
-  (defmacro once-only (specs &body forms)
-    "Evaluates `forms` with symbols specified in `specs` rebound to temporary
-variables, ensuring that each initform is evaluated only once.
-
-Each of `specs` must either be a symbol naming the variable to be rebound, or of
-the form:
-
-    (symbol initform)
-
-Bare symbols in `specs` are equivalent to
-
-    (symbol symbol)
-
-Example:
-
-    (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
-      (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
-    (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
-          (names-and-forms (mapcar (lambda (spec)
-                                     (etypecase spec
-                                       (list
-                                        (destructuring-bind (name form) spec
-                                          (cons name form)))
-                                       (symbol
-                                        (cons spec spec))))
-                                   specs)))
-      ;; bind in user-macro
-      `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
-              gensyms names-and-forms)
-         ;; bind in final expansion
-         `(let (,,@(mapcar (lambda (g n)
-                             ``(,,g ,,(cdr n)))
-                           gensyms names-and-forms))
-            ;; bind in user-macro
-            ,(let ,(mapcar (lambda (n g) (list (car n) g))
-                    names-and-forms gensyms)
-               ,@forms)))))
-  
-
   (defun range (start end &key (step 1) (key 'identity))
     "Return the list of numbers `n` such that `start <= n < end` and
 `n = start + k*step` for suitable integers `k`. If a function `key` is
@@ -380,28 +431,6 @@
         (multiple-value-call fn (values-list more) (values-list arguments)))))
   
 
-  (defmacro with-open-file* ((stream filespec &key direction element-type
-                                                   if-exists if-does-not-exist external-format)
-                             &body body)
-    "Just like `with-open-file`, but `nil` values in the keyword arguments mean to use
-the default value specified for `open`."
-    (once-only (direction element-type if-exists if-does-not-exist external-format)
-      `(with-open-stream
-           (,stream (apply #'open ,filespec
-                           (append
-                            (when ,direction
-                              (list :direction ,direction))
-                            (when ,element-type
-                              (list :element-type ,element-type))
-                            (when ,if-exists
-                              (list :if-exists ,if-exists))
-                            (when ,if-does-not-exist
-                              (list :if-does-not-exist ,if-does-not-exist))
-                            (when ,external-format
-                              (list :external-format ,external-format)))))
-         ,@body)))
-  
-
   (defmacro with-input-from-file ((stream-name file-name &rest args
                                                          &key (direction nil direction-p)
                                                          &allow-other-keys)
@@ -579,9 +608,10 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(compose copy-array curry define-constant ensure-boolean
             ensure-gethash ensure-list extremum flip hash-table-alist
-            hash-table-keys hash-table-plist hash-table-values iota n-grams
-            once-only range rcurry read-file-into-string required-argument
-            riffle separated-string-append separated-string-append* subdivide
-            symb tree-collect with-gensyms with-unique-names)))
+            hash-table-keys hash-table-plist hash-table-values
+            write-string-into-file iota n-grams once-only range rcurry
+            read-file-into-string required-argument riffle
+            separated-string-append separated-string-append* subdivide symb
+            tree-collect with-gensyms with-unique-names)))
 
 ;;;; END OF quickutils.lisp ;;;;