update scripts

1 files changed, 80 insertions, 0 deletions

diff --git a/scripts/structs.scm b/scripts/structs.scm
new file mode 100644
index 0000000..c3fa6ea
--- /dev/null
+++ b/scripts/structs.scm
@@ -0,0 +1,80 @@
+;; ============================================================
+;; define defstruct macro
+(define-macro (defstruct struct-name . fields)
+  (let* ((name (if (list? struct-name) (car struct-name) struct-name))
+	 (sname (if (string? name) name (symbol->string name)))
+
+	 (fsname (if (list? struct-name)
+		     (let ((cname (assoc :conc-name (cdr struct-name))))
+		       (if cname
+			   (symbol->string (cadr cname))
+			   sname))
+		     sname))
+
+	 (make-name (if (list? struct-name)
+			(let ((cname (assoc :constructor (cdr struct-name))))
+			  (if cname
+			      (cadr cname)
+			      (symbol "make-" sname)))
+			(symbol "make-" sname)))
+
+	 (copy-name (if (list? struct-name)
+			(let ((cname (assoc :copier (cdr struct-name))))
+			  (if cname
+			      (cadr cname)
+			      (symbol "copy-" sname)))
+			(symbol "copy-" sname)))
+
+	 (field-names (map (lambda (n)
+			     (symbol->string (if (list? n) (car n) n)))
+			   fields))
+
+	 (field-types (map (lambda (field)
+			     (if (list? field)
+				 (apply (lambda* (val type read-only) type) (cdr field))
+				 #f))
+			   fields))
+
+	 (field-read-onlys (map (lambda (field)
+				  (if (list? field)
+				      (apply (lambda* (val type read-only) read-only) (cdr field))
+				      #f))
+				fields)))
+    
+    `(begin
+       (define ,(symbol sname "?")
+	 (lambda (obj)
+	   (and (vector? obj)
+		(eq? (obj 0) ',(string->symbol sname)))))
+
+       (define* (,make-name
+		 ,@(map (lambda (n)
+			  (if (and (list? n)
+				   (>= (length n) 2))
+			      (list (car n) (cadr n))
+			      (list n #f)))
+			fields))
+	 (vector ',(string->symbol sname) ,@(map string->symbol field-names)))
+
+       (define ,copy-name copy)
+
+       ,@(map (let ((ctr 1))
+		(lambda (n type read-only)
+		  (let ((val (if read-only
+				 `(define ,(symbol fsname "-" n)
+				    (lambda (arg) (arg ,ctr)))
+				 `(define ,(symbol fsname "-" n)
+				    (dilambda
+				     (lambda (arg) (arg ,ctr))
+				     (lambda (arg val) (set! (arg ,ctr) val)))))))
+		    (set! ctr (+ 1 ctr))
+		    val)))
+	      field-names field-types field-read-onlys))))
+
+
+;; ============================================================
+;; Structures
+
+(defstruct rect (x 0.0) (y 0.0) (width 0.0) (height 0.0))
+(defstruct point (x 0.0) (y 0.0))
+(defstruct stage (width 0) (height 0) (generations 0) (final-state #f))