Visual guarding and predicate cleanup

engine/components.scm

@@ -65,7 +65,7 @@
 	       (record? vec2)))
   (assert (eq? (rtd-name (record-rtd vec1))
 	       (rtd-name (record-rtd vec2))))
-  (assert (any (lambda (pred) (pred vec1)) (list vector2?)))
+  (assert ((disjoin vector2?) vec1))
   (cond
    ((vector2? vec1)
     (and (= (vector-x vec1) (vector-x vec2))
@@ -77,7 +77,7 @@
 	       (record? vec2)))
   (assert (eq? (rtd-name (record-rtd vec1))
 	       (rtd-name (record-rtd vec2))))
-  (assert (any (lambda (pred) (pred vec1)) (list vector2?)))
+  (assert ((disjoin vector2?) vec1))
   (cond
    ((vector2? vec1)
     (make-vector2 (+ (vector-x vec1) (vector-x vec2))
@@ -89,7 +89,7 @@
 	       (record? vec2)))
   (assert (eq? (rtd-name (record-rtd vec1))
 	       (rtd-name (record-rtd vec2))))
-  (assert (any (lambda (pred) (pred vec1)) (list vector2?)))
+  (assert ((disjoin vector2?) vec1))
   (cond
    ((vector2? vec1)
     (make-vector2 (- (vector-x vec1) (vector-x vec2))
@@ -101,7 +101,7 @@
 	       (record? vec2)))
   (assert (eq? (rtd-name (record-rtd vec1))
 	       (rtd-name (record-rtd vec2))))
-  (assert (any (lambda (pred) (pred vec1)) (list vector2?)))
+  (assert ((disjoin vector2?) vec1))
   (cond
    ((vector2? vec1)
     (make-vector2 (* (vector-x vec1) (vector-x vec2))
@@ -113,7 +113,7 @@
 	       (record? vec2)))
   (assert (eq? (rtd-name (record-rtd vec1))
 	       (rtd-name (record-rtd vec2))))
-  (assert (any (lambda (pred) (pred vec1)) (list vector2?)))
+  (assert ((disjoin vector2?) vec1))
   (cond
    ((vector2? vec1)
     (make-vector2 (/ (vector-x vec1) (vector-x vec2))
@@ -121,7 +121,7 @@
 
 ;; Magnitude
 (define (vector-magnitude vec)
-  (assert (any (lambda (pred) (pred vec)) (list vector2?)))
+  (assert ((disjoin vector2?) vec))
   (cond
    ((vector2? vec)
     (sqrt (+ (expt (vector-x vec) 2)
@@ -132,7 +132,7 @@
 	       (record? vec2)))
   (assert (eq? (rtd-name (record-rtd vec1))
 	       (rtd-name (record-rtd vec2))))
-  (assert (any (lambda (pred) (pred vec1)) (list vector2?)))
+  (assert ((disjoin vector2?) vec1))
   (cond
    ((vector2? vec1)
     (+ (* (vector-x vec1) (vector-x vec2))
@@ -143,7 +143,7 @@
 	       (record? vec2)))
   (assert (eq? (rtd-name (record-rtd vec1))
 	       (rtd-name (record-rtd vec2))))
-  (assert (any (lambda (pred) (pred vec1)) (list vector2?)))
+  (assert ((disjoin vector2?) vec1))
   (cond
    ((vector2? vec1)
     (acos (/ (vector-dot vec1 vec2)
@@ -152,7 +152,7 @@
 
 ;; Normalization
 (define (vector-normalize vec)
-  (assert (any (lambda (pred) (pred vec)) (list vector2?))) ;; TODO: This assertion should be moved out of here
+  (assert ((disjoin vector2?) vec)) ;; TODO: This assertion should be moved out of here
   (let ((magnitude (vector-magnitude vec)))
     (cond
      ((vector2? vec)
@@ -310,6 +310,13 @@
   pixel-2d?
   (position pixel-2d-position int:set-pixel-2d-position!))
 
+(define (make-pixel-2d position)
+  (assert (vector2? position))
+  (int:make-pixel-2d position))
+
+(define set-pixel-2d-position!
+  (guarded-mutator pixel-2d? 'position vector2?))
+
 (define-record-type <line-2d>
   (int:make-line-2d start-pos end-pos thickness)
   line-2d?
@@ -317,6 +324,19 @@
   (end-pos line-2d-end-pos int:set-line-2d-end-pos!)
   (thickness line-2d-thickness int:set-line-2d-thickness!))
 
+(define (make-line-2d start-pos end-pos thickness)
+  (assert (vector2? start-pos))
+  (assert (vector2? end-pos))
+  (assert ((conjoin integer? positive?) thickness))
+  (int:make-line-2d start-pos end-pos thickness))
+
+(define set-line-2d-start-pos!
+  (guarded-mutator line-2d? 'start-pos vector2?))
+(define set-line-2d-end-pos!
+  (guarded-mutator line-2d? 'end-pos vector2?))
+(define set-line-2d-thickness!
+  (guarded-mutator line-2d? 'start-pos (conjoin integer? positive?)))
+
 (define-record-type <circle-2d>
   (int:make-circle-2d center radius filled)
   circle-2d?
@@ -324,6 +344,19 @@
   (radius circle-2d-radius int:set-circle-2d-radius!)
   (filled circle-2d-filled? int:set-circle-2d-filled!))
 
+(define (make-circle-2d center radius filled)
+  (assert (vector2? center))
+  (assert ((conjoin integer? positive?) radius))
+  (assert (boolean? filled))
+  (int:make-circle-2d center radius filled))
+
+(define set-circle-2d-center!
+  (guarded-mutator circle-2d? 'center vector2?))
+(define set-circle-2d-radius!
+  (guarded-mutator circle-2d? 'radius ((conjoin integer? positive?) radius)))
+(define set-circle-2d-filled!
+  (guarded-mutator circle-2d? 'filled boolean?))
+
 ;; TODO: might be nicer to have the origin and width/height inside a rect-2d type or similar
 (define-record-type <rectangle-2d>
   (int:make-rectangle-2d origin width height filled thickness)

engine/guards.scm

@@ -1,7 +1,8 @@
 (module (engine guards) ()
 (import scheme
 	(chicken base)
-	(chicken module))
+	(chicken module)
+	(srfi 99))
 
 ;; Utility function for guarding parameter values
 (export guarded-parameter)
@@ -10,4 +11,15 @@
 			    (if (predicate val)
 				val
 				default))))
+
+;; Shorthand for defining a guarded mutator for a record field
+(define (guarded-mutator record-type field predicate)
+  (lambda (rec val)
+    (assert (record-type rec))
+    (assert (predicate val))
+    ((rtd-mutator (record-rtd rec) field) rec val)))
+
+;; TODO: define a similar function here for record constructor
+
+;; TODO: define a similar function here for binary operations on records
 )