# HG changeset patch # User Steve Losh # Date 1484406033 0 # Node ID 4add15d40994c4c1a0bb0fba4fe95923cd0cec8c # Parent 048f414a1c4022e3ef6c70f37fd02c15f3fec9c7 Add CoQ item thing diff -r 048f414a1c40 -r 4add15d40994 package.lisp --- 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 diff -r 048f414a1c40 -r 4add15d40994 sand.asd --- 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") diff -r 048f414a1c40 -r 4add15d40994 src/qud.lisp --- /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)) diff -r 048f414a1c40 -r 4add15d40994 vendor/make-quickutils.lisp --- 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 diff -r 048f414a1c40 -r 4add15d40994 vendor/quickutils.lisp --- 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 ;;;;