add flip-x and flip-y

Close #29.

Co-authored-by: Jens Axel Søgaard <[email protected]>

Author: 2 people

pict-doc/pict/scribblings/pict.scrbl

@@ -938,6 +938,20 @@ scale while drawing the original @racket[pict].
 
 }
 
+@defproc*[([(flip-x [pict pict-convertible?]) pict?]
+           [(flip-y [pict pict-convertible?]) pict?])]{
+Flips a pict drawing horizontally or vertically.
+
+@examples[#:eval ss-eval
+          (standard-fish 100 50)
+          (flip-x (standard-fish 100 50))
+          (flip-x (flip-x (standard-fish 100 50)))
+          (flip-y (standard-fish 100 50))
+          (flip-y (flip-y (standard-fish 100 50)))
+          (flip-y (flip-x (standard-fish 100 50)))
+          (flip-x (flip-y (standard-fish 100 50)))]
+}
+
 @defproc*[([(scale-to-fit [pict pict-convertible?] [size-pict pict-convertible?]
                           [#:mode mode (or/c 'preserve 'inset
                                              'preserve/max 'inset/max

pict-lib/pict/private/utils.rkt

@@ -67,6 +67,8 @@
   (provide/contract 
    [scale (case-> (-> pict-convertible? number? number? pict?)
                   (-> pict-convertible? number? pict?))]
+   [flip-x (-> pict-convertible? pict?)]
+   [flip-y (-> pict-convertible? pict?)]
    [scale-to-fit (->* (pict-convertible? (or/c number? pict-convertible?))
                       (number? #:mode (or/c 'preserve 'inset 'preserve/max 'inset/max 'distort))
                       pict?)]
@@ -1305,6 +1307,62 @@
                 (pict-last p))]
     [(p factor) (scale p factor factor)]))
 
+(define/match (compose-trans _t1 _t2)
+  [{(vector a d b e c f) (vector g j h k i l)}
+   (vector (+ (* a g) (* b j))   (+ (* d g) (* e j))
+           (+ (* a h) (* b k))   (+ (* d h) (* e k))
+           (+ (* a i) (* b l) c) (+ (* d i) (* e l) f))])
+
+(define (compose-trans* t0 . ts)
+  (foldl (λ (t acc) (compose-trans acc t)) t0 ts))
+
+(define (make-translate h k)
+  (vector 1 0 0 1 h k))
+
+(define (make-flip-x) ; around y-axis
+  (vector -1 0 0 1 0 0))
+
+(define (flip-x p)
+  (define w (pict-width p))
+  (define h (pict-height p))
+  (dc (λ (dc x y)
+        ;; ( x, y) is the top-left corner
+        ;; (cx,cy) is the center of the pict
+        (define cx (+ x (/ w 2)))
+        (define cy (+ y (/ h 2)))
+        (define old-t (send dc get-initial-matrix))
+        (define new-t (compose-trans*
+                        (make-translate cx cy)
+                        (make-flip-x)
+                        (make-translate (- cx) (- cy))
+                        old-t))
+        (send dc set-initial-matrix new-t)
+        (draw-pict p dc x y)
+        (send dc set-initial-matrix old-t))
+      w h))
+
+(define (make-flip-y)
+  (vector 1 0 0 -1 0 0))
+
+(define (flip-y p)
+  (define w (pict-width p))
+  (define h (pict-height p))
+  (dc (λ (dc x y)
+        ;; ( x, y) is the top-left corner
+        ;; (cx,cy) is the center of the pict
+        (define cx (+ x (/ w 2)))
+        (define cy (+ y (/ h 2)))
+        (define old-t (send dc get-initial-matrix))
+        (define new-t (compose-trans*
+                        (make-translate cx cy)
+                        (make-flip-y)
+                        (make-translate (- cx) (- cy))
+                        old-t))
+        (send dc set-initial-matrix new-t)
+        (draw-pict p dc x y)
+        (send dc set-initial-matrix old-t))
+      w h))
+
 (define (translate p dx dy #:extend-bb? [bb? #f])
   (define nw (if (not bb?) (pict-width p) (+ (pict-width p) (abs dx))))
   (define nh (if (not bb?) (pict-height p) (+ (pict-height p) (abs dy))))

pict-test/tests/pict/main.rkt

@@ -740,3 +740,25 @@
          [alg (in-list layout-algs)])
     (define t (rand-bin-tree))
     (check-pict=? (alg t) (alg t #:transform values))))
+
+(test-case "Flips"
+  (define fish (standard-fish 100 50))
+  (check-pict=? (flip-x (flip-x fish)) fish)
+  (check-pict=? (flip-y (flip-y fish)) fish)
+  (check-pict=? (flip-x (flip-y fish))
+                (flip-y (flip-x fish)))
+  ;; borders cause problems:
+  ;; https://github.com/racket/pict/pull/78#issuecomment-1479939570
+  ;; https://github.com/racket/draw/pull/26
+  (define oval (filled-ellipse 20 30 #:draw-border? #f))
+  (check-pict=? (flip-x oval) oval)
+  (check-pict=? (flip-y oval) oval)
+  (define (get-bounding-box p)
+    (map (λ (f) (f p)) (list pict-width pict-height pict-descent pict-ascent)))
+  ;; proof that "scale" with -1 factors is "wrong"
+  (check-not-equal? (get-bounding-box (flip-x fish))
+                    (get-bounding-box (scale fish -1 1)))
+  (check-not-equal? (get-bounding-box (flip-y fish))
+                    (get-bounding-box (scale fish 1 -1)))
+  (check-not-equal? (get-bounding-box (flip-x oval)) (get-bounding-box (scale oval -1 1)))
+  (check-not-equal? (get-bounding-box (flip-y oval)) (get-bounding-box (scale oval 1 -1))))