Speed improvements in clipping

collects/plot/common/plot-device.rkt

@@ -151,7 +151,8 @@
 (define plot-device%
   (class object%
     (init-field dc dc-x-min dc-y-min dc-x-size dc-y-size)
-    
+
+    ;(init-field the-dc dc-x-min dc-y-min dc-x-size dc-y-size)
     ;(define dc (make-object null-dc%))
     
     (super-new)

collects/plot/plot2d/clip.rkt

@@ -11,7 +11,7 @@
 
 (define (point-in-bounds? v x-min x-max y-min y-max)
   (match-define (vector x y) v)
-  (and (x . >= . x-min) (x . <= . x-max) (y . >= . y-min) (y . <= . y-max)))
+  (and (<= x-min x x-max) (<= y-min y y-max)))
 
 ;; ===================================================================================================
 ;; Rectangle clipping
@@ -69,13 +69,13 @@
 
 (define (clip-line v1 v2 x-min x-max y-min y-max)
   (let/ec return
-    ; early accept: both endpoints in bounds
-    (when (and (point-in-bounds? v1 x-min x-max y-min y-max)
-               (point-in-bounds? v2 x-min x-max y-min y-max))
-      (return v1 v2))
-    ; early reject: both endpoints on the outside of the same plane
     (match-define (vector x1 y1) v1)
     (match-define (vector x2 y2) v2)
+    ;; early accept: both endpoints in bounds
+    (when (and (<= x-min x1 x-max) (<= y-min y1 y-max)
+               (<= x-min x2 x-max) (<= y-min y2 y-max))
+      (return v1 v2))
+    ;; early reject: both endpoints on the outside of the same plane
     (when (or (and (x1 . < . x-min) (x2 . < . x-min)) (and (x1 . > . x-max) (x2 . > . x-max))
               (and (y1 . < . y-min) (y2 . < . y-min)) (and (y1 . > . y-max) (y2 . > . y-max)))
       (return #f #f))
@@ -88,60 +88,65 @@
 ;; ===================================================================================================
 ;; Polygon clipping
 
-(define ((make-clip-polygon idx test? clip-line) val vs)
-  (reverse
-   (for/fold ([res empty]) ([v1  (in-list (cons (last vs) vs))] [v2  (in-list vs)])
-     (define v1-in-bounds? (test? (vector-ref v1 idx) val))
-     (define v2-in-bounds? (test? (vector-ref v2 idx) val))
-     (cond [(and v1-in-bounds? v2-in-bounds?)              (cons v2 res)]
-           [(and (not v1-in-bounds?) (not v2-in-bounds?))  res]
-           [else  (match-define (vector x1 y1) v1)
-                  (match-define (vector x2 y2) v2)
-                  (let-values ([(x1 y1 x2 y2)  (clip-line v1-in-bounds? val x1 y1 x2 y2)])
-                    (cond [v2-in-bounds?  (list* (vector x2 y2) (vector x1 y1) res)]
-                          [else           (cons (vector x2 y2) res)]))]))))
+(define-syntax-rule (make-clip-polygon in-bounds? clip-line)
+  (λ (val xs ys)
+    (cond [(empty? xs)  (values empty empty)]
+          [else
+           (for/fold ([res-xs empty] [res-ys empty]) ([x1  (in-list (cons (last xs) xs))]
+                                                      [x2  (in-list xs)]
+                                                      [y1  (in-list (cons (last ys) ys))]
+                                                      [y2  (in-list ys)])
+             (define v1-in-bounds? (in-bounds? x1 y1 val))
+             (define v2-in-bounds? (in-bounds? x2 y2 val))
+             (cond [(and v1-in-bounds? v2-in-bounds?)              (values (cons x2 res-xs)
+                                                                           (cons y2 res-ys))]
+                   [(and (not v1-in-bounds?) (not v2-in-bounds?))  (values res-xs res-ys)]
+                   [else  (let-values ([(x1 y1 x2 y2)  (clip-line v1-in-bounds? val x1 y1 x2 y2)])
+                            (cond [v2-in-bounds?  (values (list* x2 x1 res-xs)
+                                                          (list* y2 y1 res-ys))]
+                                  [else           (values (cons x2 res-xs) (cons y2 res-ys))]))]))])))
 
-(define clip-polygon-x-min (make-clip-polygon 0 >= clip-line-x))
-(define clip-polygon-x-max (make-clip-polygon 0 <= clip-line-x))
-(define clip-polygon-y-min (make-clip-polygon 1 >= clip-line-y))
-(define clip-polygon-y-max (make-clip-polygon 1 <= clip-line-y))
+(define-syntax-rule (x-min-in-bounds? x y x-min) (x . >= . x-min)) 
+(define-syntax-rule (x-max-in-bounds? x y x-max) (x . <= . x-max))
+(define-syntax-rule (y-min-in-bounds? x y y-min) (y . >= . y-min))
+(define-syntax-rule (y-max-in-bounds? x y y-max) (y . <= . y-max))
+
+(define clip-polygon-x-min (make-clip-polygon x-min-in-bounds? clip-line-x))
+(define clip-polygon-x-max (make-clip-polygon x-max-in-bounds? clip-line-x))
+(define clip-polygon-y-min (make-clip-polygon y-min-in-bounds? clip-line-y))
+(define clip-polygon-y-max (make-clip-polygon y-max-in-bounds? clip-line-y))
 
 (define (clip-polygon vs x-min x-max y-min y-max)
   (let/ec return
-    ; early reject: no polygon
+    ;; early reject: no polygon
     (when (empty? vs) (return empty))
-    ; early accept: all endpoints in bounds
-    (when (andmap (λ (v) (point-in-bounds? v x-min x-max y-min y-max)) vs)
-      (return vs))
     (match-define (list (vector xs ys) ...) vs)
-    ; early reject: all endpoints on the outside of the same plane
+    ;; early accept: all endpoints in bounds
+    (when (and (andmap (λ (x) (<= x-min x x-max)) xs)
+               (andmap (λ (y) (<= y-min y y-max)) ys))
+      (return vs))
+    ;; early reject: all endpoints on the outside of the same plane
     (when (or (andmap (λ (x) (x . < . x-min)) xs) (andmap (λ (x) (x . > . x-max)) xs)
               (andmap (λ (y) (y . < . y-min)) ys) (andmap (λ (y) (y . > . y-max)) ys))
       (return empty))
-    (let* ([vs  (clip-polygon-x-min x-min vs)]
-           [_   (when (empty? vs) (return empty))]
-           [vs  (clip-polygon-x-max x-max vs)]
-           [_   (when (empty? vs) (return empty))]
-           [vs  (clip-polygon-y-min y-min vs)]
-           [_   (when (empty? vs) (return empty))]
-           [vs  (clip-polygon-y-max y-max vs)])
-      vs)))
+    (let*-values ([(xs ys)  (clip-polygon-x-min x-min xs ys)]
+                  [(xs ys)  (clip-polygon-x-max x-max xs ys)]
+                  [(xs ys)  (clip-polygon-y-min y-min xs ys)]
+                  [(xs ys)  (clip-polygon-y-max y-max xs ys)])
+      (map vector xs ys))))
 
-;; =============================================================================
+;; ===================================================================================================
 ;; Lines clipping
 
-;; This could be done a lot faster...
-
-(define (join-lines lines [current-line empty])
-  (cond [(empty? lines)         (list (reverse current-line))]
-        [(empty? current-line)  (join-lines (rest lines)
-                                            (reverse (first lines)))]
-        [else
-         (match-define v (first current-line))
-         (match-define (list v1 v2) (first lines))
-         (cond [(equal? v v1)  (join-lines (rest lines) (cons v2 current-line))]
-               [else (cons (reverse current-line)
-                           (join-lines lines empty))])]))
+(define (join-lines lines)
+  (let loop ([lines lines] [current-line empty])
+    (cond [(empty? lines)         (list (reverse current-line))]
+          [(empty? current-line)  (loop (rest lines) (reverse (first lines)))]
+          [else
+           (match-define v (first current-line))
+           (match-define (list v1 v2) (first lines))
+           (cond [(equal? v v1)  (loop (rest lines) (cons v2 current-line))]
+                 [else           (cons (reverse current-line) (loop lines empty))])])))
 
 #;
 (join-lines
@@ -151,12 +156,20 @@
    (#(7 8) #(9 10))))
 
 (define (clip-lines vs x-min x-max y-min y-max)
-  (if (empty? vs)
-      empty
-      (join-lines
-       (reverse
-        (for/fold ([res empty]) ([v1  (in-list vs)] [v2  (in-list (rest vs))])
-          (let-values ([(v1 v2)  (clip-line v1 v2 x-min x-max y-min y-max)])
-            (if (and v1 v2)
-                (cons (list v1 v2) res)
-                res)))))))
+  (let/ec return
+    ;; early reject: no lines
+    (when (empty? vs) (return empty))
+    (match-define (list (vector xs ys) ...) vs)
+    ;; early accept: all endpoints in bounds
+    (when (and (andmap (λ (x) (<= x-min x x-max)) xs) (andmap (λ (y) (<= y-min y y-max)) ys))
+      (return (list vs)))
+    ;; early reject: all endpoints on the outside of the same plane
+    (when (or (andmap (λ (x) (x . < . x-min)) xs) (andmap (λ (x) (x . > . x-max)) xs)
+              (andmap (λ (y) (y . < . y-min)) ys) (andmap (λ (y) (y . > . y-max)) ys))
+      (return empty))
+    (join-lines
+     (reverse
+      (for/fold ([res empty]) ([v1  (in-list vs)] [v2  (in-list (rest vs))])
+        (let-values ([(v1 v2)  (clip-line v1 v2 x-min x-max y-min y-max)])
+          (cond [(and v1 v2)  (cons (list v1 v2) res)]
+                [else  res])))))))

collects/plot/plot3d/clip.rkt

@@ -2,7 +2,7 @@
 
 ;; Small library for clipping points, lines and polygons against axial planes.
 
-(require racket/match racket/list)
+(require racket/match racket/list racket/unsafe/ops)
 
 (provide point-in-bounds? clip-line clip-polygon)
 
@@ -11,9 +11,7 @@
 
 (define (point-in-bounds? v x-min x-max y-min y-max z-min z-max)
   (match-define (vector x y z) v)
-  (and (x . >= . x-min) (x . <= . x-max) 
-       (y . >= . y-min) (y . <= . y-max)
-       (z . >= . z-min) (z . <= . z-max)))
+  (and (<= x-min x x-max) (<= y-min y y-max) (<= z-min z z-max)))
 
 ;; ===================================================================================================
 ;; Lines
@@ -65,13 +63,13 @@
 
 (define (clip-line v1 v2 x-min x-max y-min y-max z-min z-max)
   (let/ec return
-    ; early accept: both endpoints in bounds
-    (when (and (point-in-bounds? v1 x-min x-max y-min y-max z-min z-max)
-               (point-in-bounds? v2 x-min x-max y-min y-max z-min z-max))
-      (return v1 v2))
-    ; early reject: both endpoints on the outside of the same plane
     (match-define (vector x1 y1 z1) v1)
     (match-define (vector x2 y2 z2) v2)
+    ;; early accept: both endpoints in bounds
+    (when (and (<= x-min x1 x-max) (<= y-min y1 y-max) (<= z-min z1 z-max)
+               (<= x-min x2 x-max) (<= y-min y2 y-max) (<= z-min z2 z-max))
+      (return v1 v2))
+    ;; early reject: both endpoints on the outside of the same plane
     (when (or (and (x1 . < . x-min) (x2 . < . x-min)) (and (x1 . > . x-max) (x2 . > . x-max))
               (and (y1 . < . y-min) (y2 . < . y-min)) (and (y1 . > . y-max) (y2 . > . y-max))
               (and (z1 . < . z-min) (z2 . < . z-min)) (and (z1 . > . z-max) (z2 . > . z-max)))
@@ -87,13 +85,13 @@
 ;; ===================================================================================================
 ;; Polygons
 
-(define ((make-clip-polygon idx test? clip-line) val vs)
-  (reverse
-   (for/fold ([res empty]) ([v1  (in-list (cons (last vs) vs))] [v2  (in-list vs)])
-     (define v1-in-bounds? (test? (vector-ref v1 idx) val))
-     (define v2-in-bounds? (test? (vector-ref v2 idx) val))
-     (cond [(and v1-in-bounds? v2-in-bounds?)              (cons v2 res)]
-           [(and (not v1-in-bounds?) (not v2-in-bounds?))  res]
+(define-syntax-rule (make-clip-polygon idx test? clip-line)
+  (λ (val vs)
+    (for/fold ([res empty]) ([v1  (in-list (cons (last vs) vs))] [v2  (in-list vs)])
+      (define v1-in-bounds? (test? (unsafe-vector-ref v1 idx) val))
+      (define v2-in-bounds? (test? (unsafe-vector-ref v2 idx) val))
+      (cond [(and v1-in-bounds? v2-in-bounds?)              (cons v2 res)]
+            [(and (not v1-in-bounds?) (not v2-in-bounds?))  res]
             [else  (match-define (vector x1 y1 z1) v1)
                    (match-define (vector x2 y2 z2) v2)
                    (let-values ([(x1 y1 z1 x2 y2 z2) (clip-line v1-in-bounds? val x1 y1 z1 x2 y2 z2)])
@@ -109,13 +107,15 @@
 
 (define (clip-polygon vs x-min x-max y-min y-max z-min z-max)
   (let/ec return
-    ; early reject: no polygon
+    ;; early reject: no polygon
     (when (empty? vs) (return empty))
-    ; early accept: all endpoints in bounds
-    (when (andmap (λ (v) (point-in-bounds? v x-min x-max y-min y-max z-min z-max)) vs)
-      (return vs))
     (match-define (list (vector xs ys zs) ...) vs)
-    ; early reject: all endpoints on the outside of the same plane
+    ;; early accept: all endpoints in bounds
+    (when (and (andmap (λ (x) (<= x-min x x-max)) xs)
+               (andmap (λ (y) (<= y-min y y-max)) ys)
+               (andmap (λ (z) (<= z-min z z-max)) zs))
+      (return vs))
+    ;; early reject: all endpoints on the outside of the same plane
     (when (or (andmap (λ (x) (x . < . x-min)) xs) (andmap (λ (x) (x . > . x-max)) xs)
               (andmap (λ (y) (y . < . y-min)) ys) (andmap (λ (y) (y . > . y-max)) ys)
               (andmap (λ (z) (z . < . z-min)) zs) (andmap (λ (z) (z . > . z-max)) zs))

collects/plot/plot3d/plot-area.rkt

@@ -645,12 +645,13 @@
     
     (define/public (end-renderers)
       (draw-shapes render-list)
+      #;(
       (clip-to-none)
       (send pd reset-drawing-params)
       (draw-title)
       (draw-near-axes)
       (draw-ticks (get-front-tick-params))
-      (draw-labels (get-front-label-params)))
+      (draw-labels (get-front-label-params))))
     
     (define (draw-angles*)
       (define angle-str (format " angle = ~a " (number->string (round angle))))

collects/plot/scribblings/todo.scrbl

@@ -9,24 +9,11 @@
        @itemlist[
         @item{2D kernel density estimator}
         @item{3D kernel density estimator}
-        @item{2D implicit curve}
-        @item{3D implicit surface}
         @item{3D decorations: labeled points, axes, grids}
-       ]
- }
- @item{Possible new renderers
-       @itemlist[
-        @item{R × R -> R parametric (turn into 3D implicit surface by solving for minimum distance?)}
         @item{3D vector field}
-        @item{Head-to-tail vector fields}
        ]
  }
- @item{Minor fixes
-       @itemlist[
-        @item{Subdivide nonlinearly transformed 3D lines/polygons (port from @(racket 2d-plot-area%))}
-       ]
- }
- @item{Minor enhancements
+ @item{Possible minor enhancements
        @itemlist[
         @item{Better depth sorting (possibly split intersecting polygons; look into BSP tree)}
         @item{Legend entries have minimum sizes}