--- a/package.lisp Tue Jan 17 17:29:35 2017 +0000
+++ b/package.lisp Tue Jan 17 18:37:07 2017 +0000
@@ -258,6 +258,17 @@
(:export
))
+(defpackage :sand.istruct
+ (:use
+ :cl
+ :cl-arrows
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils)
+ (:export
+ ))
+
(defpackage :sand.sketch
(:use
--- a/sand.asd Tue Jan 17 17:29:35 2017 +0000
+++ b/sand.asd Tue Jan 17 18:37:07 2017 +0000
@@ -75,6 +75,7 @@
(:file "mandelbrot")
(:file "story")
(:file "qud")
+ (:file "istruct")
(:module "turing-omnibus"
:serial t
:components ((:file "wallpaper")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/istruct.lisp Tue Jan 17 18:37:07 2017 +0000
@@ -0,0 +1,115 @@
+(in-package :sand.istruct)
+
+;;;; Equality -----------------------------------------------------------------
+(defgeneric equal? (a b))
+
+(defmethod equal? ((a t) (b t))
+ nil)
+
+(defmethod equal? ((a number) (b number))
+ (= a b))
+
+(defmethod equal? ((a string) (b string))
+ (equal a b))
+
+(defmethod equal? ((a symbol) (b symbol))
+ (eq a b))
+
+
+;;;; Retrieval/Modification ---------------------------------------------------
+(defun iget (instance slot)
+ (slot-value instance slot))
+
+(defun iget-in (instance slot-path)
+ (iterate
+ (for result :first instance :then (slot-value result slot))
+ (for slot :in slot-path)
+ (finally (return result))))
+
+
+(defgeneric iset (instance slot new-value))
+
+(defun iset-in (instance slot-path new-value)
+ (destructuring-bind (slot . remaining) slot-path
+ (if (null remaining)
+ (iset instance slot new-value)
+ (iset instance slot (iset-in (iget instance slot)
+ remaining new-value)))))
+
+
+(defun iupdate (instance slot function &rest args)
+ (iset instance slot (apply function (iget instance slot) args)))
+
+(defun iupdate-in (instance slot-path function &rest args)
+ (destructuring-bind (slot . remaining) slot-path
+ (if (null remaining)
+ (apply #'iupdate instance slot function args)
+ (iset instance slot
+ (apply #'iupdate-in (iget instance slot)
+ remaining function args)))))
+
+
+;;;; Definition ---------------------------------------------------------------
+(defun required (name)
+ (error "Slot ~S is required" name))
+
+
+(defun build-slot (slot-spec)
+ (destructuring-bind (slot-name &key default type) slot-spec
+ `(,slot-name
+ ,(if default
+ default
+ `(required ',slot-name))
+ :read-only t
+ ,@(when type `(:type ,type)))))
+
+(defun build-immutable-struct-form (name slots)
+ `(defstruct ,name
+ ,@(mapcar #'build-slot slots)))
+
+(defun build-iset (name slots)
+ `(defmethod iset ((instance ,name) slot new-value)
+ (,(symb 'make- name)
+ ,@(iterate (for (slot . nil) :in slots)
+ (collect (ensure-keyword slot))
+ (collect `(if (eq slot ',slot)
+ new-value
+ (slot-value instance ',slot)))))))
+
+(defun build-equal? (name slots)
+ `(defmethod equal? ((a ,name) (b ,name))
+ (and ,@(iterate (for (slot . nil) :in slots)
+ (collect `(equal?
+ (slot-value a ',slot)
+ (slot-value b ',slot)))))))
+
+(defun build-constructor (name slots)
+ (let ((slot-names (mapcar #'first slots)))
+ `(defun ,name ,slot-names
+ (,(symb 'make- name)
+ ,@(iterate (for slot :in slot-names)
+ (collect (ensure-keyword slot))
+ (collect slot))))))
+
+
+(defmacro define-istruct (name-and-options &rest slots)
+ "Define an immutable structure."
+ (destructuring-bind (name) (ensure-list name-and-options)
+ (let ((slots (mapcar #'ensure-list slots)))
+ `(progn
+ ,(build-immutable-struct-form name slots)
+ ,(build-iset name slots)
+ ,(build-equal? name slots)
+ ,(build-constructor name slots)
+ ',name))))
+
+
+;;;; Scratch ------------------------------------------------------------------
+(define-istruct sword
+ material)
+
+(define-istruct monster
+ (hp :default 10)
+ species
+ (weapon :default nil))
+
--- a/vendor/make-quickutils.lisp Tue Jan 17 17:29:35 2017 +0000
+++ b/vendor/make-quickutils.lisp Tue Jan 17 18:37:07 2017 +0000
@@ -10,6 +10,7 @@
:define-constant
:ensure-boolean
:ensure-gethash
+ :ensure-keyword
:ensure-list
:extremum
:flip
@@ -17,7 +18,6 @@
:hash-table-keys
:hash-table-plist
:hash-table-values
- :write-string-into-file
:iota
:n-grams
:once-only
@@ -31,6 +31,7 @@
:symb
:tree-collect
:with-gensyms
+ :write-string-into-file
)
:package "SAND.QUICKUTILS")
--- a/vendor/quickutils.lisp Tue Jan 17 17:29:35 2017 +0000
+++ b/vendor/quickutils.lisp Tue Jan 17 18:37:07 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 :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")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-ARRAY :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-KEYWORD :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 :WRITE-STRING-INTO-FILE) :ensure-package T :package "SAND.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SAND.QUICKUTILS")
@@ -16,20 +16,21 @@
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:COMPOSE :COPY-ARRAY :CURRY
:DEFINE-CONSTANT :ENSURE-BOOLEAN
- :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM
- :FLIP :HASH-TABLE-ALIST :MAPHASH-KEYS
+ :ENSURE-GETHASH :ENSURE-KEYWORD
+ :ENSURE-LIST :EXTREMUM :FLIP
+ :HASH-TABLE-ALIST :MAPHASH-KEYS
:HASH-TABLE-KEYS :HASH-TABLE-PLIST
:MAPHASH-VALUES :HASH-TABLE-VALUES
- :ONCE-ONLY :WITH-OPEN-FILE*
- :WITH-OUTPUT-TO-FILE
- :WRITE-STRING-INTO-FILE :IOTA :TAKE
- :N-GRAMS :RANGE :RCURRY
+ :IOTA :TAKE :N-GRAMS :ONCE-ONLY :RANGE
+ :RCURRY :WITH-OPEN-FILE*
:WITH-INPUT-FROM-FILE
:READ-FILE-INTO-STRING
:REQUIRED-ARGUMENT :RIFFLE
:SEPARATED-STRING-APPEND :SUBDIVIDE
:MKSTR :SYMB :TREE-COLLECT
- :STRING-DESIGNATOR :WITH-GENSYMS))))
+ :STRING-DESIGNATOR :WITH-GENSYMS
+ :WITH-OUTPUT-TO-FILE
+ :WRITE-STRING-INTO-FILE))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
"Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -173,6 +174,11 @@
(values (setf (gethash ,key ,hash-table) ,default) nil))))
+ (defun ensure-keyword (x)
+ "Ensure that a keyword is returned for the string designator `x`."
+ (values (intern (string x) :keyword)))
+
+
(defun ensure-list (list)
"If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
(if (listp list)
@@ -286,6 +292,45 @@
values))
+ (declaim (inline iota))
+ (defun iota (n &key (start 0) (step 1))
+ "Return a list of `n` numbers, starting from `start` (with numeric contagion
+from `step` applied), each consequtive number being the sum of the previous one
+and `step`. `start` defaults to `0` and `step` to `1`.
+
+Examples:
+
+ (iota 4) => (0 1 2 3)
+ (iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0)
+ (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)"
+ (declare (type (integer 0) n) (number start step))
+ (loop repeat n
+ ;; KLUDGE: get numeric contagion right for the first element too
+ for i = (+ (- (+ start step) step)) then (+ i step)
+ collect i))
+
+
+ (defun take (n sequence)
+ "Take the first `n` elements from `sequence`."
+ (subseq sequence 0 n))
+
+
+ (defun n-grams (n sequence)
+ "Find all `n`-grams of the sequence `sequence`."
+ (assert (and (plusp n)
+ (<= n (length sequence))))
+
+ (etypecase sequence
+ ;; Lists
+ (list (loop :repeat (1+ (- (length sequence) n))
+ :for seq :on sequence
+ :collect (take n seq)))
+
+ ;; General sequences
+ (sequence (loop :for i :to (- (length sequence) n)
+ :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.
@@ -325,6 +370,24 @@
,@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
+provided, then apply it to each number."
+ (assert (<= start end))
+ (loop :for i :from start :below end :by step :collecting (funcall key i)))
+
+
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (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)
@@ -347,90 +410,6 @@
,@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
-from `step` applied), each consequtive number being the sum of the previous one
-and `step`. `start` defaults to `0` and `step` to `1`.
-
-Examples:
-
- (iota 4) => (0 1 2 3)
- (iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0)
- (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)"
- (declare (type (integer 0) n) (number start step))
- (loop repeat n
- ;; KLUDGE: get numeric contagion right for the first element too
- for i = (+ (- (+ start step) step)) then (+ i step)
- collect i))
-
-
- (defun take (n sequence)
- "Take the first `n` elements from `sequence`."
- (subseq sequence 0 n))
-
-
- (defun n-grams (n sequence)
- "Find all `n`-grams of the sequence `sequence`."
- (assert (and (plusp n)
- (<= n (length sequence))))
-
- (etypecase sequence
- ;; Lists
- (list (loop :repeat (1+ (- (length sequence) n))
- :for seq :on sequence
- :collect (take n seq)))
-
- ;; General sequences
- (sequence (loop :for i :to (- (length sequence) n)
- :collect (subseq sequence i (+ i n))))))
-
-
- (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
-provided, then apply it to each number."
- (assert (<= start end))
- (loop :for i :from start :below end :by step :collecting (funcall key i)))
-
-
- (defun rcurry (function &rest arguments)
- "Returns a function that applies the arguments it is called
-with and `arguments` to `function`."
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (let ((fn (ensure-function function)))
- (lambda (&rest more)
- (declare (dynamic-extent more))
- (multiple-value-call fn (values-list more) (values-list arguments)))))
-
-
(defmacro with-input-from-file ((stream-name file-name &rest args
&key (direction nil direction-p)
&allow-other-keys)
@@ -605,13 +584,40 @@
unique symbol the named variable will be bound to."
`(with-gensyms ,names ,@forms))
+
+ (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)))
+
(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
- 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)))
+ ensure-gethash ensure-keyword 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 write-string-into-file)))
;;;; END OF quickutils.lisp ;;;;