# HG changeset patch # User Steve Losh # Date 1484678227 0 # Node ID 5c5070c212695a5ff0e85a241381c8d46359a592 # Parent 8cf52a515a48219b37a02be3caaaf5b8177949f4 Add little immutable struct thing diff -r 8cf52a515a48 -r 5c5070c21269 package.lisp --- 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 diff -r 8cf52a515a48 -r 5c5070c21269 sand.asd --- 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") diff -r 8cf52a515a48 -r 5c5070c21269 src/istruct.lisp --- /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)) + diff -r 8cf52a515a48 -r 5c5070c21269 vendor/make-quickutils.lisp --- 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") diff -r 8cf52a515a48 -r 5c5070c21269 vendor/quickutils.lisp --- 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 ;;;;