5c5070c21269

Add little immutable struct thing
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Tue, 17 Jan 2017 18:37:07 +0000
parents 8cf52a515a48
children 326c2d62fceb
branches/tags (none)
files package.lisp sand.asd src/istruct.lisp vendor/make-quickutils.lisp vendor/quickutils.lisp

Changes

--- 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 ;;;;