#lang racket/base

(require mrlib/image-core
         "img-err.rkt"
         racket/match
         racket/contract
         racket/class
         (except-in racket/draw
                    make-pen make-color)
         ;(only-in racket/gui/base frame% canvas% slider% horizontal-panel% button%)
         htdp/error
         racket/math
         (for-syntax racket/base
                     racket/list)
         lang/posn
         net/url)

;; for testing
; (require racket/gui/base)
#;
(define (show-image arg [extra-space 0])
  (letrec ([g (to-img arg)]
           [f (new frame% [label ""])]
           [c (new canvas% 
                   [parent f]
                   [min-width (+ extra-space (image-width g))]
                   [min-height (+ extra-space (image-height g))]
                   [paint-callback
                    (λ (c dc)
                      (send dc set-smoothing 'aligned)
                      (let-values ([(w h) (send c get-client-size)])
                        (let ([scale (send sl get-value)])
                          (send dc set-scale scale scale)
                          (render-image 
                           g
                           dc
                           (inexact->exact (floor (- (/ w 2 scale) (/ (get-right g) 2))))
                           (inexact->exact (floor (- (/ h 2 scale) (/ (get-bottom g) 2))))))))])]
           [min-scale 1]
           [max-scale 10]
           [sl (new slider% 
                    [label "Scale factor"] 
                    [parent f] 
                    [min-value min-scale]
                    [max-value max-scale]
                    [callback (λ ignore (send c refresh))])]
           [bp (new horizontal-panel% 
                    [parent f]
                    [alignment '(center center)]
                    [stretchable-height #f])]
           [scale-adjust
            (λ (f)
              (send sl set-value 
                    (max min-scale (min max-scale (f (send sl get-value)))))
              (send c refresh))])
    (send (new button% 
               [label "√"] 
               [callback (λ x (scale-adjust sub1))] 
               [parent bp]) min-width 100)
    (send (new button% 
               [label "2"]
               [callback (λ x (scale-adjust add1))]
               [parent bp]) min-width 100)
    (send f show #t)))

;; the obfuscation in the width and height defaults is so that error checking happens in the right order
(define/chk (save-image image
                        filename 
                        [width (if (image? image) (image-width image) 0)] 
                        [height (if (image? image) (image-height image) 0)])
  (let* ([bm (make-bitmap (inexact->exact (ceiling width)) 
                          (inexact->exact (ceiling height)))]
         [bdc (make-object bitmap-dc% bm)])
    (send bdc set-smoothing 'aligned)
    (send bdc erase)
    (render-image image bdc 0 0)
    (send bdc set-bitmap #f)
    (send bm save-file filename 'png)))

(define/chk (save-svg-image image
                            filename 
                            [width (if (image? image) (image-width image) 0)] 
                            [height (if (image? image) (image-height image) 0)])
  (call-with-output-file filename
    (λ (port)
      (define sdc (new svg-dc% [width width] [height height] [output port]))
      (send sdc start-doc "")
      (send sdc start-page)
      (send sdc set-smoothing 'aligned)
      (render-image image sdc 0 0)
      (send sdc end-page)
      (send sdc end-doc))
    #:exists 'truncate))

(define (get-right img) (bb-right (send img get-bb)))
(define (get-bottom img) (bb-bottom (send img get-bb)))
(define (get-baseline img) (bb-baseline (send img get-bb)))

;                                              
;                                              
;                                              
;                              ;;              
;                              ;;              
;                              ;;              
;    ;;;;  ;;;  ;;;;;;   ;; ;  ;; ;;;;;  ;;;  ;
;   ;;  ;;  ;;  ;;;; ;;  ;;;;  ;; ;   ;;  ;; ;;
;  ;;;  ;;  ;;;; ;;;;;;  ;;    ;;   ;;;;  ;;;; 
;  ;;;  ;;  ;;;; ;;      ;;    ;; ;;  ;;   ;;; 
;   ;;  ;;   ;;; ;;;  ;  ;;    ;; ;;  ;;   ;;; 
;    ;;;;    ;;   ;;;;   ;;    ;; ;;;;;;;  ;;  
;                                          ;;  
;                                          ;   
;                                         ;;   
                                                                            

;; scale : number image -> image
(define/chk (scale factor image)
  (scale-internal factor factor image))

(define/chk (scale/xy x-factor y-factor image)
  (scale-internal x-factor y-factor image))

(define (scale-internal x-factor y-factor image)
  (let ([ph (send image get-pinhole)])
    (make-image (make-scale x-factor y-factor (image-shape image))
                (make-bb (* x-factor (get-right image))
                         (* y-factor (get-bottom image))
                         (* y-factor (get-baseline image)))
                #f
                (and ph 
                     (make-point (* x-factor (point-x ph))
                                 (* y-factor (point-y ph)))))))

;; overlay : image image image ... -> image
;; places images on top of each other with their upper left corners aligned. 
;; last one goes on the bottom
(define/chk (overlay image image2 . image3)
  (overlay/internal 'middle 'middle image (cons image2 image3)))

;; underlay : image image image ... -> image
(define/chk (underlay image image2 . image3)
  (let ([imgs (reverse (list* image image2 image3))])
    (overlay/internal 'middle 'middle (car imgs) (cdr imgs))))

;; overlay/align : string string image image image ... -> image
;; the first string has to be one of "center" "middle" "left" or "right" (or symbols)
;; the second string has to be one of "center" "middle" "top" "bottom" or "baseline" (or symbols)
;; behaves like overlay, but lines up the images in the various places.
;; overlay without string arguments is the same as passing "left" and "top"
;; for the two string arguments. Passing, eg, "center" "center" lines the
;; images up at their centers.

(define/chk (overlay/align x-place y-place image image2 . image3)
  (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole))
    (check-dependencies 'overlay/align
                        (and (send image get-pinhole)
                             (send image2 get-pinhole)
                             (andmap (λ (x) (send x get-pinhole))
                                     image3))
                        "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes"
                        'pinhole "pinhole"))
  (overlay/internal x-place y-place image (cons image2 image3)))

(define/chk (underlay/align x-place y-place image image2 . image3)
  (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole))
    (check-dependencies 'underlay/align
                        (and (send image get-pinhole)
                             (send image2 get-pinhole)
                             (andmap (λ (x) (send x get-pinhole))
                                     image3))
                        "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes"
                        'pinhole "pinhole"))
  (let ([imgs (reverse (list* image image2 image3))])
    (overlay/internal x-place y-place (car imgs) (cdr imgs))))

(define/chk (overlay/pinhole image1 image2 . image3)
  (overlay/internal 'pinhole 'pinhole 
                    (maybe-center-pinhole image1)
                    (map maybe-center-pinhole (cons image2 image3))))

(define/chk (underlay/pinhole image1 image2 . image3)
  (let ([imgs (map maybe-center-pinhole (reverse (list* image1 image2 image3)))])
    (overlay/internal 'pinhole 'pinhole
                      (car imgs)
                      (cdr imgs))))

(define (maybe-center-pinhole img)
  (if (send img get-pinhole)
      img
      (center-pinhole img)))

(define (overlay/internal x-place y-place fst rst)
  (let loop ([fst fst]
             [rst rst])
    (cond
      [(null? rst) fst]
      [else 
       (let* ([fst-x-spot (find-x-spot x-place fst)]
              [fst-y-spot (find-y-spot y-place fst)]
              [snd-x-spot (find-x-spot x-place (car rst))]
              [snd-y-spot (find-y-spot y-place (car rst))]
              [dx (- fst-x-spot snd-x-spot)]
              [dy (- fst-y-spot snd-y-spot)])
         (loop (overlay/δ fst
                          (if (< dx 0) (- dx) 0) 
                          (if (< dy 0) (- dy) 0)
                          (car rst)
                          (if (< dx 0) 0 dx)
                          (if (< dy 0) 0 dy)
                          #t)
               (cdr rst)))])))

(define (find-x-spot x-place image)
  (case x-place
    [(left) 0]
    [(middle) (/ (get-right image) 2)]
    [(right) (get-right image)]
    [(pinhole) (point-x (send image get-pinhole))]
    [else (error 'find-x-spot "~s" x-place)]))

(define (find-y-spot y-place image)
  (case y-place
    [(top) 0]
    [(middle) (/ (get-bottom image) 2)]
    [(bottom) (get-bottom image)]
    [(baseline) (get-baseline image)]
    [(pinhole) (point-y (send image get-pinhole))]
    [else (error 'find-y-spot "~s" y-place)]))

;; overlay/xy : image number number image -> image
;; places images on top of each other with their upper-left corners offset by the two numbers

(define/chk (overlay/xy image dx dy image2) 
  (overlay/δ image
             (if (< dx 0) (- dx) 0)
             (if (< dy 0) (- dy) 0)
             image2
             (if (< dx 0) 0 dx)
             (if (< dy 0) 0 dy)
             #t))

(define/chk (underlay/xy image dx dy image2)
  (overlay/δ image2
             (if (< dx 0) 0 dx)
             (if (< dy 0) 0 dy)
             image
             (if (< dx 0) (- dx) 0)
             (if (< dy 0) (- dy) 0)
             #f))

(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2 first-pinhole?)
    (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
                              (make-translate dx2 dy2 (image-shape image2)))
                (make-bb (max (+ (get-right image1) dx1)
                              (+ (get-right image2) dx2))
                         (max (+ (get-bottom image1) dy1)
                              (+ (get-bottom image2) dy2))
                         (max (+ (get-baseline image1) dy1)
                              (+ (get-baseline image2) dy2)))
                #f
                (if first-pinhole?
                    (let ([ph (send image1 get-pinhole)])
                      (and ph
                           (make-point (+ (point-x ph) dx1)
                                       (+ (point-y ph) dy1))))
                    (let ([ph (send image2 get-pinhole)])
                      (and ph
                           (make-point (+ (point-x ph) dx2)
                                       (+ (point-y ph) dy2)))))))

;; beside : image image image ... -> image
;; places images in a single horizontal row, top aligned
(define/chk (beside image1 image2 . image3)
  (beside/internal 'middle image1 (cons image2 image3)))

;; beside/align : string image image image ... -> image
;; places images in a horizontal row where the vertical alignment is
;; covered by the string argument
(define/chk (beside/align y-place image1 image2 . image3)
  (when (eq? y-place 'pinhole)
    (check-dependencies 'beside/align
                        (and (send image1 get-pinhole)
                             (send image2 get-pinhole)
                             (andmap (λ (x) (send x get-pinhole))
                                     image3))
                        "when y-place is ~e or ~e, then all of the arguments must have pinholes"
                        'pinhole "pinhole"))
  (beside/internal y-place image1 (cons image2 image3)))

(define (beside/internal y-place fst rst)
  (let loop ([fst fst]
             [rst rst])
    (cond
      [(null? rst) fst]
      [else
       (let* ([snd (car rst)]
              [fst-y-spot (find-y-spot y-place fst)]
              [snd-y-spot (find-y-spot y-place (car rst))]
              [dy (- fst-y-spot snd-y-spot)])
         (loop (overlay/δ fst
                          0 
                          (if (< dy 0) (- dy) 0)
                          (car rst)
                          (get-right fst)
                          (if (< dy 0) 0 dy)
                          #t)
               (cdr rst)))])))

;; above : image image image ... -> image
;; places images in a single vertical row, left aligned
(define/chk (above image1 image2 . image3)
  (above/internal 'middle image1 (cons image2 image3)))

;; beside/align : string image image image ... -> image
;; places images in a horizontal row where the vertical alignment is
;; covered by the string argument
(define/chk (above/align x-place image1 image2 . image3)
  (when (eq? x-place 'pinhole)
    (check-dependencies 'above/align
                        (and (send image1 get-pinhole)
                             (send image2 get-pinhole)
                             (andmap (λ (x) (send x get-pinhole))
                                     image3))
                        "when x-place is ~e or ~e, then all of the arguments must have pinholes"
                        'pinhole "pinhole"))
  (above/internal x-place image1 (cons image2 image3)))

(define (above/internal x-place fst rst)
  (let loop ([fst fst]
             [rst rst])
    (cond
      [(null? rst) fst]
      [else
       (let* ([snd (car rst)]
              [fst-x-spot (find-x-spot x-place fst)]
              [snd-x-spot (find-x-spot x-place (car rst))]
              [dx (- fst-x-spot snd-x-spot)])
         (loop (overlay/δ fst
                          (if (< dx 0) (- dx) 0) 
                          0
                          (car rst)
                          (if (< dx 0) 0 dx)
                          (get-bottom fst)
                          #t)
               (cdr rst)))])))

(define/chk (overlay/offset image1 dx dy image2)
  (overlay/offset/internal 'middle 'middle image1 dx dy image2))

(define/chk (overlay/align/offset x-place y-place image1 dx dy image2)
  (overlay/offset/internal x-place y-place image1 dx dy image2))

(define/chk (underlay/offset image1 dx dy image2)
  (overlay/offset/internal 'middle 'middle  image2 (- dx) (- dy) image1))

(define/chk (underlay/align/offset x-place y-place image1 dx dy image2)
  (overlay/offset/internal x-place y-place image2 (- dx) (- dy) image1))

(define (overlay/offset/internal x-place y-place fst orig-dx orig-dy snd)
  (let* ([fst-x-spot (find-x-spot x-place fst)]
         [fst-y-spot (find-y-spot y-place fst)]
         [snd-x-spot (find-x-spot x-place snd)]
         [snd-y-spot (find-y-spot y-place snd)]
         [dx (+ (- fst-x-spot snd-x-spot) orig-dx)]
         [dy (+ (- fst-y-spot snd-y-spot) orig-dy)])
    (overlay/δ fst
               (if (< dx 0) (- dx) 0) 
               (if (< dy 0) (- dy) 0)
               snd
               (if (< dx 0) 0 dx)
               (if (< dy 0) 0 dy)
               #t)))


;                                                                                                  
;                                                                                                  
;                                                                                                  
;                                 ;;;;        ;;                        ;                          
;                                 ;;;;        ;;                       ;;                          
;    ;;;;;   ;;;;   ;;;;;;; ;;;;  ;;;;;;;        ;;;; ;;;  ;;;;;;;   ;;;;;   ;;;;   ;;; ;;;  ;;;;; 
;   ;;;;;;  ;;;;;;  ;;;;;;;;;;;;; ;;;;;;;;  ;;;; ;;;;;;;;; ;;;;;;;; ;;;;;;  ;;;;;;  ;;;;;;; ;;;;;; 
;  ;;;;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;;     ;;;;  ;;;;  ;;;;;;;; ;;;; ;; ;;;;   
;  ;;;;    ;;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;  ;;;;;;;  ;;;;  ;;;; ;;; ;;;;     ;;;;  
;  ;;;;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;; ;;  ;;;;  ;;;;; ;;;;;;;; ;;;;      ;;;; 
;   ;;;;;;  ;;;;;;  ;;;; ;;; ;;;; ;;;;;;;;  ;;;; ;;;; ;;;; ;;;;;;;;  ;;;;;  ;;;;;;  ;;;;    ;;;;;; 
;    ;;;;;   ;;;;   ;;;; ;;; ;;;; ;;;;;;;   ;;;; ;;;; ;;;;  ;; ;;;;   ;;;;   ;;;;   ;;;;    ;;;;;  
;                                                                                                  
;                                                                                                  
;                                                                                                  
    

;; crop : number number number number image -> image
;; crops an image to be w x h from (x,y)
(define/chk (crop x1 y1 width height image)
  (crop/internal x1 y1 width height image))

(define (crop/internal x1 y1 width height image)
  (let ([points (rectangle-points width height)]
        [ph (send image get-pinhole)])
    (make-image (make-crop points
                           (make-translate (- x1) (- y1) (image-shape image)))
                (make-bb width
                         height
                         (min height (get-baseline image)))
                #f
                (and ph 
                     (make-point (- (point-x ph) x1)
                                 (- (point-y ph) y1))))))

;; place-image : image x y scene -> scene
(define/chk (place-image image1 x1 y1 image2) 
  (place-image/internal image1 x1 y1 image2 'middle 'middle))
(define/chk (place-image/align image1 x1 y1 x-place y-place image2)
  (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole))
    (check-dependencies 'place-image/align
                        (send image1 get-pinhole)
                        "when x-place or y-place is ~e or ~e, the the first image argument must have a pinhole"
                        'pinhole "pinhole"))
  (place-image/internal image1 x1 y1 image2 x-place y-place))

(define (place-image/internal image orig-dx orig-dy scene x-place y-place)
  (let ([dx (- orig-dx (find-x-spot x-place image))]
        [dy (- orig-dy (find-y-spot y-place image))])
    (crop/internal
     (if (< dx 0) (- dx) 0)
     (if (< dy 0) (- dy) 0)
     (get-right scene)
     (get-bottom scene)
     (overlay/δ image
                (if (< dx 0) 0 dx)
                (if (< dy 0) 0 dy)
                scene
                (if (< dx 0) (- dx) 0)
                (if (< dy 0) (- dy) 0)
                #f))))

(define/chk (scene+line image x1 y1 x2 y2 color)
  (let* ([dx (abs (min 0 x1 x2))]
         [dy (abs (min 0 y1 y2))])
    (make-image (make-overlay
                 (make-crop (rectangle-points (get-right image) (get-bottom image))
                            (make-line-segment (make-point x1 y1) (make-point x2 y2) color))
                 (image-shape image))
                (image-bb image)
                #f
                (send image get-pinhole))))

(define/chk (scene+curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color)
  (let* ([dx (abs (min 0 x1 x2))]
         [dy (abs (min 0 y1 y2))])
    (make-image (make-overlay
                 (make-crop (rectangle-points (get-right image) (get-bottom image))
                            (make-curve-segment (make-point x1 y1) angle1 pull1
                                                (make-point x2 y2) angle2 pull2
                                                color))
                 (image-shape image))
                (image-bb image)
                #f
                (send image get-pinhole))))

;; frame : image -> image
;; draws a black frame around a image where the bounding box is
;; (useful for debugging images)

(define/chk (frame image)
  (make-image (make-overlay (image-shape 
                             (crop 0 0
                                   (get-right image)
                                   (get-bottom image)
                                   (rectangle (get-right image)
                                              (get-bottom image)
                                              'outline
                                              (pen "black" 2 'solid 'round 'round))))
                            (image-shape image))
              (make-bb (get-right image)
                       (get-bottom image)
                       (get-baseline image))
              #f
              (send image get-pinhole)))

;; scale : I number -> I
;; scales the I by the given factor

;; rotate : number I -> I
;; rotates the I around the top-left corner by the given angle (in degrees)
(define/chk (rotate angle image)
  (let* ([rotated-shape (rotate-normalized-shape 
                         angle
                         (send image get-normalized-shape))]
         [ltrb (normalized-shape-bb rotated-shape)]
         [ph (send image get-pinhole)])
    (make-image (make-translate (- (ltrb-left ltrb)) (- (ltrb-top ltrb)) rotated-shape)
                (make-bb (- (ltrb-right ltrb) (ltrb-left ltrb))
                         (- (ltrb-bottom ltrb) (ltrb-top ltrb))
                         (- (ltrb-bottom ltrb) (ltrb-top ltrb)))
                #f
                (and ph
                     (let ([rp (rotate-point ph angle)])
                       (make-point (- (point-x rp) (ltrb-left ltrb))
                                   (- (point-y rp) (ltrb-top ltrb))))))))

(define/contract (rotate-normalized-shape angle shape)
  (-> number? normalized-shape? normalized-shape?)
  (cond
    [(overlay? shape)
     (let ([top-shape (rotate-normalized-shape angle (overlay-top shape))]
           [bottom-shape (rotate-cn-or-simple-shape angle (overlay-bottom shape))])
       (make-overlay top-shape bottom-shape))]
    [else 
     (rotate-cn-or-simple-shape angle shape)]))

(define/contract (rotate-cn-or-simple-shape angle shape)
  (-> number? cn-or-simple-shape? cn-or-simple-shape?)
  (cond
    [(crop? shape)
     (make-crop (rotate-points (crop-points shape) angle)
                (rotate-normalized-shape angle (crop-shape shape)))]
    [else
     (rotate-simple angle shape)]))

;; rotate-simple : angle simple-shape -> simple-shape
(define/contract (rotate-simple θ simple-shape)
  (-> number? simple-shape? simple-shape?)
  (cond
    [(line-segment? simple-shape)
     (make-line-segment (rotate-point (line-segment-start simple-shape)
                                      θ)
                        (rotate-point (line-segment-end simple-shape)
                                      θ)
                        (line-segment-color simple-shape))]
    [(curve-segment? simple-shape)
     (make-curve-segment (rotate-point (curve-segment-start simple-shape)
                                       θ)
                         (bring-between (+ (curve-segment-s-angle simple-shape) θ) 360)
                         (curve-segment-s-pull simple-shape)
                         (rotate-point (curve-segment-end simple-shape)
                                       θ)
                         (bring-between (+ (curve-segment-e-angle simple-shape) θ) 360)
                         (curve-segment-e-pull simple-shape)
                         (curve-segment-color simple-shape))]
    [(polygon? simple-shape)
     (make-polygon (rotate-points (polygon-points simple-shape) θ)
                   (polygon-mode simple-shape)
                   (polygon-color simple-shape))]
    [else
     (let* ([unrotated (translate-shape simple-shape)]
            [rotated (rotate-atomic θ unrotated)])
       (let-values ([(dx dy) 
                     (c->xy (* (degrees->complex θ)
                               (xy->c (translate-dx simple-shape)
                                      (translate-dy simple-shape))))])
         (make-translate dx dy rotated)))]))

(struct ltrb (left top right bottom) #:transparent)
(define (union-ltrb ltrb1 ltrb2)
  (ltrb (min (ltrb-left ltrb1) (ltrb-left ltrb2))
        (min (ltrb-top ltrb1) (ltrb-top ltrb2))
        (max (ltrb-right ltrb1) (ltrb-right ltrb2))
        (max (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))

;; only intersection if they already overlap.
(define (intersect-ltrb ltrb1 ltrb2)
  (ltrb (max (ltrb-left ltrb1) (ltrb-left ltrb2))
        (max (ltrb-top ltrb1) (ltrb-top ltrb2))
        (min (ltrb-right ltrb1) (ltrb-right ltrb2))
        (min (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))

(define/contract (normalized-shape-bb shape)
  (-> normalized-shape? ltrb?)
  (cond
    [(overlay? shape)
     (let ([top-ltrb (normalized-shape-bb (overlay-top shape))]
           [bottom-ltrb (cn-or-simple-shape-bb (overlay-bottom shape))])
       (union-ltrb top-ltrb bottom-ltrb))]
    [else 
     (cn-or-simple-shape-bb shape)]))

(define/contract (cn-or-simple-shape-bb shape)
  (-> cn-or-simple-shape? ltrb?)
  (cond
    [(crop? shape)
     (let ([ltrb (normalized-shape-bb (crop-shape shape))]
           [crop-ltrb (points->ltrb (crop-points shape))])
       (intersect-ltrb crop-ltrb ltrb))]
    [else
     (simple-bb shape)]))

;; simple-bb : simple-shape -> ltrb
;; returns the bounding box of 'shape' 
;; (only called for rotated shapes, so bottom=baseline)
(define/contract (simple-bb simple-shape)
  (-> simple-shape? ltrb?)
  (cond
    [(line-segment? simple-shape)
     (let ([x1 (point-x (line-segment-start simple-shape))]
           [y1 (point-y (line-segment-start simple-shape))]
           [x2 (point-x (line-segment-end simple-shape))]
           [y2 (point-y (line-segment-end simple-shape))])
       (ltrb (min x1 x2)
             (min y1 y2)
             (+ (max x1 x2) 1)
             (+ (max y1 y2) 1)))]
    [(curve-segment? simple-shape)
     (let ([x1 (point-x (curve-segment-start simple-shape))]
           [y1 (point-y (curve-segment-start simple-shape))]
           [x2 (point-x (curve-segment-end simple-shape))]
           [y2 (point-y (curve-segment-end simple-shape))])
       (ltrb (min x1 x2)
             (min y1 y2)
             (+ (max x1 x2) 1)
             (+ (max y1 y2) 1)))]
    [(polygon? simple-shape)
     (points->ltrb (polygon-points simple-shape))]
    [else
     (let ([dx (translate-dx simple-shape)]
           [dy (translate-dy simple-shape)])
       (let-values ([(l t r b) (np-atomic-bb (translate-shape simple-shape))])
         (ltrb (+ l dx)
               (+ t dy)
               (+ r dx)
               (+ b dy))))]))

(define (points->ltrb points)
  (let-values ([(left top right bottom) (points->ltrb-values points)])
    (ltrb left top right bottom)))

(define/contract (np-atomic-bb atomic-shape)
  (-> np-atomic-shape? (values number? number? number? number?))
  (cond
    [(ellipse? atomic-shape)
     (let ([θ (ellipse-angle atomic-shape)])
       (let-values ([(w h) (ellipse-rotated-size (ellipse-width atomic-shape)
                                                 (ellipse-height atomic-shape)
                                                 (degrees->radians θ))])
         
         (values (- (/ w 2))
                 (- (/ h 2))
                 (/ w 2)
                 (/ h 2))))]
    [(text? atomic-shape)
     (let-values ([(w h a d) (send text-sizing-bm get-text-extent 
                                   (text-string atomic-shape) 
                                   (text->font atomic-shape))])
       (rotated-rectangular-bounding-box w h (text-angle atomic-shape)))]
    [(flip? atomic-shape)
     (let* ([bitmap (flip-shape atomic-shape)]
            [bb (ibitmap-raw-bitmap bitmap)])
       (let-values ([(l t r b)
                     (rotated-rectangular-bounding-box (* (send bb get-width) (ibitmap-x-scale bitmap))
                                                       (* (send bb get-height) (ibitmap-y-scale bitmap))
                                                       (ibitmap-angle bitmap))])
         (values l t r b)))]
    [else
     (eprintf "using bad bounding box for ~s\n" atomic-shape)
     (values 0 0 100 100)]))

(define (rotated-rectangular-bounding-box w h θ)
  (let*-values ([(ax ay) (rotate-xy (- (/ w 2)) (- (/ h 2)) θ)]
                [(bx by) (rotate-xy (- (/ w 2)) (/ h 2) θ)]
                [(cx cy) (rotate-xy (/ w 2) (- (/ h 2)) θ)]
                [(dx dy) (rotate-xy (/ w 2) (/ h 2) θ)])
    (values (min ax bx cx dx)
            (min ay by cy dy)
            (max ax bx cx dx)
            (max ay by cy dy))))

(define (rotate-points in-points θ)
  (let* ([cs (map point->c in-points)]
         [vectors (points->vectors cs)]
         [rotated-vectors (map (λ (c) (rotate-c c θ)) vectors)]
         [points (vectors->points rotated-vectors)])
    points))

(define (points->vectors orig-points)
  (let loop ([points (cons 0 orig-points)])
    (cond
      [(null? (cdr points)) '()]
      [else
       (cons (- (cadr points) (car points))
             (loop (cdr points)))])))

(define (vectors->points vecs)
  (let loop ([vecs vecs]
             [p 0])
    (cond
      [(null? vecs) '()]
      [else 
       (let ([next-p (+ (car vecs) p)])
         (cons (c->point next-p)
               (loop (cdr vecs)
                     next-p)))])))

(define (center-point np-atomic-shape)
  (let-values ([(l t r b) (np-atomic-bb np-atomic-shape)])
    (xy->c (/ (- r l) 2)
           (/ (- b t) 2))))

;; rotate-atomic : angle np-atomic-shape -> np-atomic-shape
(define (rotate-atomic θ atomic-shape)
  (-> number? np-atomic-shape? np-atomic-shape?)
  (cond
    [(ellipse? atomic-shape)
     (cond
       [(= (ellipse-width atomic-shape)
           (ellipse-height atomic-shape))
        atomic-shape]
       [else
        (let ([new-angle (bring-between (+ θ (ellipse-angle atomic-shape)) 180)])
          (cond
            [(< new-angle 90)
             (make-ellipse (ellipse-width atomic-shape)
                           (ellipse-height atomic-shape)
                           new-angle
                           (ellipse-mode atomic-shape)
                           (ellipse-color atomic-shape))]
            [else
             (make-ellipse (ellipse-height atomic-shape)
                           (ellipse-width atomic-shape)
                           (- new-angle 90)
                           (ellipse-mode atomic-shape)
                           (ellipse-color atomic-shape))]))])]
    [(text? atomic-shape)
     (make-text (text-string atomic-shape)
                (bring-between (+ θ (text-angle atomic-shape)) 360)
                (text-y-scale atomic-shape)
                (text-color atomic-shape)
                (text-size  atomic-shape)
                (text-face  atomic-shape)
                (text-family atomic-shape)
                (text-style atomic-shape)
                (text-weight  atomic-shape)
                (text-underline atomic-shape))]
    [(flip? atomic-shape)
     (let ([bitmap (flip-shape atomic-shape)]
           [flipped? (flip-flipped? atomic-shape)])
       (make-flip flipped?
                  (make-ibitmap (ibitmap-raw-bitmap bitmap)
                                (bring-between (if flipped? 
                                                   (+ (ibitmap-angle bitmap) θ)
                                                   (- (ibitmap-angle bitmap) θ))
                                               360)
                                (ibitmap-x-scale bitmap)
                                (ibitmap-y-scale bitmap)
                                (make-hash))))]))

;; rotate-point : point angle -> point
(define (rotate-point p θ)
  (let-values ([(x y) (rotate-xy (point-x p) (point-y p) θ)])
    (make-point x y)))

(define (rotate-c c θ)
  (* (degrees->complex θ) c))

(define (degrees->complex θ) 
  (unless (and (<= 0 θ)
               (< θ 360))
    (error 'degrees->complex "~s" θ))
  (case (and (integer? θ) (modulo θ 360))
    [(0)    1+0i]
    [(90)   0+1i]
    [(180) -1+0i]
    [(270)  0-1i]
    [else (make-polar 1 (degrees->radians θ))]))

;; rotate-xy : x,y angle -> x,y
(define (rotate-xy x y θ)
  (c->xy (rotate-c (xy->c x y) θ)))

(define (xy->c x y) (make-rectangular x (- y)))
(define (c->xy c) 
  (values (real-part c)
          (- (imag-part c))))
(define (point->c p) (xy->c (point-x p) (point-y p)))
(define (c->point c) 
  (let-values ([(x y) (c->xy c)])
    (make-point x y)))


;; bring-between : rational integer -> rational
;; returns a number that is much like the modulo of 'x' and 'upper-bound',
;; since modulo only works on integers
(define (bring-between x upper-bound)
  (let* ([x-floor (floor x)]
         [fraction (- x x-floor)])
    (+ (modulo x-floor upper-bound) 
       fraction)))

(define/chk (flip-horizontal image)
  (rotate 90 (flip-vertical (rotate -90 image))))

(define/chk (flip-vertical image)
  (let* ([flipped-shape (flip-normalized-shape 
                         (send image get-normalized-shape))]
         [ltrb (normalized-shape-bb flipped-shape)]
         [ph (send image get-pinhole)])
    (make-image (make-translate (- (ltrb-left ltrb)) (- (ltrb-top ltrb)) flipped-shape)
                (make-bb (- (ltrb-right ltrb) (ltrb-left ltrb))
                         (- (ltrb-bottom ltrb) (ltrb-top ltrb))
                         (- (ltrb-bottom ltrb) (ltrb-top ltrb)))
                #f
                (and ph
                     (make-point (+ (point-x ph) (- (ltrb-left ltrb)))
                                 (+ (- (point-y ph)) (- (ltrb-top ltrb))))))))

(define/contract (flip-normalized-shape shape)
  (-> normalized-shape? normalized-shape?)
  (cond
    [(overlay? shape)
     (let ([top-shape (flip-normalized-shape (overlay-top shape))]
           [bottom-shape (flip-cn-or-simple-shape (overlay-bottom shape))])
       (make-overlay top-shape bottom-shape))]
    [else 
     (flip-cn-or-simple-shape shape)]))

(define/contract (flip-cn-or-simple-shape shape)
  (-> cn-or-simple-shape? cn-or-simple-shape?)
  (cond
    [(crop? shape)
     (make-crop (flip-points (crop-points shape))
                (flip-normalized-shape (crop-shape shape)))]
    [else
     (flip-simple shape)]))

(define/contract (flip-simple simple-shape)
  (-> simple-shape? simple-shape?)
  (cond
    [(line-segment? simple-shape)
     (make-line-segment (flip-point (line-segment-start simple-shape))
                        (flip-point (line-segment-end simple-shape))
                        (line-segment-color simple-shape))]
    [(curve-segment? simple-shape)
     (make-curve-segment (flip-point (curve-segment-start simple-shape))
                         (bring-between (- (curve-segment-s-angle simple-shape)) 360)
                         (curve-segment-s-pull simple-shape)
                         (flip-point (curve-segment-end simple-shape))
                         (bring-between (- (curve-segment-e-angle simple-shape)) 360)
                         (curve-segment-e-pull simple-shape)
                         (curve-segment-color simple-shape))]
    [(polygon? simple-shape)
     (make-polygon (flip-points (polygon-points simple-shape))
                   (polygon-mode simple-shape)
                   (polygon-color simple-shape))]
    [else
     (make-translate (translate-dx simple-shape) 
                     (- (translate-dy simple-shape))
                     (flip-atomic (translate-shape simple-shape)))]))

(define/contract (flip-atomic atomic-shape)
  (-> np-atomic-shape? np-atomic-shape?)
  (cond
    [(ellipse? atomic-shape)
     (cond
       [(= (ellipse-width atomic-shape)
           (ellipse-height atomic-shape))
        atomic-shape]
       [else
        (let ([new-angle (bring-between (- 180 (ellipse-angle atomic-shape)) 180)])
          (cond
            [(< new-angle 90)
             (make-ellipse (ellipse-width atomic-shape)
                           (ellipse-height atomic-shape)
                           new-angle
                           (ellipse-mode atomic-shape)
                           (ellipse-color atomic-shape))]
            [else
             (make-ellipse (ellipse-height atomic-shape)
                           (ellipse-width atomic-shape)
                           (- new-angle 90)
                           (ellipse-mode atomic-shape)
                           (ellipse-color atomic-shape))]))])]
    [(text? atomic-shape)
     (error 'flip "cannot flip shapes that contain text")]
    [(flip? atomic-shape)
     (make-flip (not (flip-flipped? atomic-shape))
                (flip-shape atomic-shape))]))

(define (flip-point point) (make-point (point-x point) (- (point-y point))))
(define (flip-points points) (map flip-point points))
;                                                                                                 
;                                                                                                 
;                                                                                                 
;  ;;;;                        ;;               ;;                                                
;  ;;;;                        ;;               ;;                                                
;  ;;;;;;;   ;;;;;;;   ;;;;;        ;;;;;          ;;;;;;; ;;;;  ;;;;;;;   ;;;;;;;   ;;;    ;;;;; 
;  ;;;;;;;;  ;;;;;;;; ;;;;;; ;;;;  ;;;;;;     ;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;;  ;;;;;  ;;;;;; 
;  ;;;;;;;;;     ;;;; ;;;;   ;;;; ;;;;;;;     ;;;; ;;;; ;;; ;;;;     ;;;; ;;; ;;;; ;;;; ;; ;;;;   
;  ;;;; ;;;;  ;;;;;;;  ;;;;  ;;;; ;;;;        ;;;; ;;;; ;;; ;;;;  ;;;;;;; ;;;;;;;; ;;;;;;;  ;;;;  
;  ;;;;;;;;; ;;  ;;;;   ;;;; ;;;; ;;;;;;;     ;;;; ;;;; ;;; ;;;; ;;  ;;;;  ;;;;;;; ;;;;;     ;;;; 
;  ;;;;;;;;  ;;;;;;;; ;;;;;; ;;;;  ;;;;;;     ;;;; ;;;; ;;; ;;;; ;;;;;;;; ;   ;;;;  ;;;;;; ;;;;;; 
;  ;;;;;;;    ;; ;;;; ;;;;;  ;;;;   ;;;;;     ;;;; ;;;; ;;; ;;;;  ;; ;;;; ;;;;;;;;   ;;;;  ;;;;;  
;                                                                         ;;;;;;;;                
;                                                                          ;;;;;;                 
;                                                                                                 


(define/chk (polygon posns mode color)
  (check-mode/color-combination 'polygon 3 mode color)
  (make-a-polygon (map (λ (p) (make-point (posn-x p) (posn-y p))) posns)
                  mode
                  color))

(define/chk (rectangle width height mode color)
  (check-mode/color-combination 'rectangle 4 mode color)
  (make-a-polygon (rectangle-points width height) mode color))

(define/chk (square side-length mode color)
  (check-mode/color-combination 'square 3 mode color)
  (make-a-polygon (rectangle-points side-length side-length) mode color))

(define/chk (empty-scene width height [color 'white])
  (crop 0 0 width height
        (overlay (rectangle width height 'outline (pen "black" 2 'solid 'round 'round))
                 (rectangle width height 'solid color))))

(define/chk (rhombus side-length angle mode color)
  (check-mode/color-combination 'rhombus 3 mode color)
  (let* ([left-corner (make-polar side-length (+ (* pi 1/2) (/ (degrees->radians angle) 2)))]
         [right-corner (make-polar side-length (- (* pi 1/2) (/ (degrees->radians angle) 2)))]
         [bottom-corner (+ left-corner right-corner)])
    (make-a-polygon (list (make-point 0 0)
                          (make-point (real-part right-corner) (imag-part right-corner))
                          (make-point (real-part bottom-corner) (imag-part bottom-corner))
                          (make-point (real-part left-corner) (imag-part left-corner)))
                    mode
                    color)))

(define (rectangle-points width height [dx 0] [dy 0])
  (list (make-point dx dy)
        (make-point (+ dx width) dy)
        (make-point (+ dx width) (+ height dy))
        (make-point dx (+ dy height))))
  

(define/chk (line x1 y1 color)
  (let-values ([(shape w h) (line-shape x1 y1 color)])
    (make-image shape
                (make-bb w h h)
                #f)))

(define (line-shape x1 y1 color)
  (let ([dx (- (min x1 0))]
        [dy (- (min y1 0))]
        [w (+ (abs x1) 1)]
        [h (+ (abs y1) 1)])
    (values (make-translate
             dx dy
             (make-line-segment (make-point 0 0)
                                (make-point x1 y1)
                                color))
            w h)))

(define/chk (add-line image x1 y1 x2 y2 color)
  (let* ([dx (abs (min 0 x1 x2))]
         [dy (abs (min 0 y1 y2))]
         [bottom (max (+ y1 dy)
                      (+ y2 dy)
                      (+ dy (get-bottom image)))]
         [right (max (+ x1 dx)
                     (+ x2 dx)
                     (+ dx (get-right image)))]
         [baseline (+ dy (get-baseline image))])
    (make-image (make-translate
                 dx dy
                 (make-overlay
                  (make-line-segment (make-point x1 y1) (make-point x2 y2) color)
                  (image-shape image)))
                (make-bb right bottom baseline)
                #f
                (send image get-pinhole))))

(define/chk (add-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color)
  (let* ([dx (abs (min 0 x1 x2))]
         [dy (abs (min 0 y1 y2))]
         [bottom (max (+ y1 dy)
                      (+ y2 dy)
                      (+ dy (get-bottom image)))]
         [right (max (+ x1 dx)
                     (+ x2 dx)
                     (+ dx (get-right image)))]
         [baseline (+ dy (get-baseline image))])
    (make-image (make-translate
                 dx dy
                 (make-overlay
                  (make-curve-segment (make-point x1 y1) angle1 pull1
                                      (make-point x2 y2) angle2 pull2
                                      color)
                  (image-shape image)))
                (make-bb right bottom baseline)
                #f
                (send image get-pinhole))))

;; this is just so that 'text' objects can be sized.
(define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1)))

(define/chk (text string font-size color)
  (mk-text string font-size color #f 'swiss 'normal 'normal #f))

(define/chk (text/font string font-size color face family style weight underline)
  (mk-text string font-size color face family style weight underline))

(define (mk-text str font-size color face family style weight underline)
  (cond
    [(<= (string-length str) 1)
     (mk-single-text str font-size color face family style weight underline)]
    [else
     (let ([letters (string->list str)])
       (beside/internal
        'baseline
        (mk-single-text (string (car letters)) font-size color face family style weight underline)
        (map (λ (letter)
               (mk-single-text (string letter) font-size color face family style weight underline))
             (cdr letters))))]))

(define (mk-single-text letter font-size color face family style weight underline)
  (let ([text (make-text letter 0 1 color font-size face family style weight underline)])
    (let-values ([(w h d a) (send text-sizing-bm get-text-extent letter (text->font text))])
      (make-image (make-translate (/ w 2) (/ h 2) text)
                  (make-bb w h (- h d))
                  #f))))

(define/chk (isosceles-triangle side-length angle mode color)
  (check-mode/color-combination 'isosceles-triangle 4 mode color)
  (let ([left-corner (make-polar side-length (+ (* pi 1/2) (/ (degrees->radians angle) 2)))]
        [right-corner (make-polar side-length (- (* pi 1/2) (/ (degrees->radians angle) 2)))])
    (make-a-polygon (list (make-point 0 0)
                          (make-point (real-part right-corner) (imag-part right-corner))
                          (make-point (real-part left-corner) (imag-part left-corner)))
                    mode
                    color)))

(define/chk (right-triangle side-length1 side-length2 mode color)
  (check-mode/color-combination 'right-triangle 4 mode color)
  (make-a-polygon (list (make-point 0 (- side-length2))
                        (make-point 0 0)
                        (make-point side-length1 0))
                  mode
                  color))

(define/chk (triangle side-length mode color)
  (check-mode/color-combination 'triangle 3 mode color)
  (make-polygon/star side-length 3 mode color values))

; excess : R+ R+ -> R
;  compute the Euclidean excess
;  Note: If the excess is 0, then C is 90 deg.
;        If the excess is negative, then C is obtuse.
;        If the excess is positive, then C is acuse.
(define (excess a b c)
  (+ (sqr a) (sqr b) (- (sqr c))))

; polar->posn : R+ R -> (posn R R)
;  return a position with x and y coordinates
(define (polar->posn radius angle)
  (make-posn (* radius (cos angle))
             (* radius (sin angle))))

; cos-rel : R R R -> R+
;   return c^2 = a^2 + b^2 - 2ab cos(C)
(define (cos-rel a b C)
  (+ (sqr a) (sqr b) (* -2 a b (cos C))))

; sin-rel : R R R -> R
;  return the side b
(define (sin-rel A a B)
  (/ (* a (sin B)) (sin A)))

; last-angle : R R -> R
;   return pi-(A+B)
(define (last-angle A B)
  (- pi A B))

(define (radians degree)
  (* (/ degree 180.0) pi))


(define (triangle/sss side-a side-b side-c mode color)
  (define (triangle-vertices/sss a b c)
    (let ([A (acos (/ (excess b c a) (* 2 b c)))])
      (list (make-posn 0 0)
            (make-posn c 0)
            (polar->posn b A))))
  (check-dependencies 'triangle/sss
                      (and (>= (+ side-a side-b) side-c) 
                           (>= (+ side-a side-c) side-b) 
                           (>= (+ side-b side-c) side-a))
                      "the given side lengths will not form a triangle ~a, ~a, and, ~a."
                      side-a side-b side-c)
  (polygon (triangle-vertices/sss side-a side-b side-c) mode color))

(define/chk (triangle/ass angle-a side-b side-c mode color)
  (define (triangle-vertices/ass A b c)
    (list (make-posn 0 0) (make-posn c 0) (polar->posn b A)))
  (polygon (triangle-vertices/ass (radians angle-a) side-b side-c) mode color))

(define/chk (triangle/sas side-a angle-b side-c mode color)
  (define (triangle-vertices/sas a B c)
    (let ([b^2 (cos-rel a c B)])
      (check-dependencies 'triangle/sas
                          "the given side, angle, and, side will not form a triangle ~a, ~a, and, ~a."
                          side-a angle-b side-c)
      (let* ([b (sqrt b^2)]
             [A (acos (/ (excess b c a) (* 2 b c)))])
        (list (make-posn 0 0) (make-posn c 0) (polar->posn b A)))))
  (polygon (triangle-vertices/sas side-a (radians angle-b) side-c) mode color))
(define/chk (triangle/ssa side-a side-b angle-c mode color)
  (define (triangle-vertices/ssa a b C)
    (let ([c^2 (cos-rel a b C)])
      (check-dependencies 'triangle/ssa 
                          (positive? c^2)
                          "the given side, side, and, angle will not form a triangle ~a, ~a, and, ~a."
                          side-a side-b angle-c)
      (let*([c (sqrt c^2)]
            [A (acos (/ (excess b c a) (* 2 b c)))])
        (list (make-posn 0 0)
              (make-posn c 0)
              (polar->posn b A)))))
  (polygon (triangle-vertices/ssa side-a side-b (radians angle-c)) mode color))

(define/chk (triangle/aas angle-a angle-b side-c mode color)
  (define (triangle-vertices/aas A B c)
    (let* ([C (last-angle A B)]
           [b (sin-rel C c B)])
      (list (make-posn 0 0) (make-posn c 0) (polar->posn b A))))
  (polygon (triangle-vertices/aas (radians angle-a) (radians angle-b) side-c) mode color))

(define/chk (triangle/asa angle-a side-b angle-c mode color)
  (define (triangle-vertices/asa A b C)
    (let* ([B (last-angle A C)]
           [c (sin-rel B b C)])
      (list (make-posn 0 0) (make-posn c 0) (polar->posn b A))))
  (polygon (triangle-vertices/asa (radians angle-a) side-b (radians angle-c)) mode color))

(define/chk (triangle/saa side-a angle-b angle-c mode color)
  (define (triangle-vertices/saa a B C)
    (let* ([A (last-angle B C)]
           [b (sin-rel A a B)]
           [c (sin-rel A a C)])
      (list (make-posn 0 0)
            (make-posn c 0)
            (polar->posn b A))))
  (polygon (triangle-vertices/saa side-a (radians angle-b) (radians angle-c)) mode color))

(define/chk (regular-polygon side-length side-count mode color)
  (check-mode/color-combination 'regular-polygon 4 mode color)
  (make-polygon/star side-length side-count mode color values))

(define/chk (star-polygon side-length side-count step-count mode color)
  (check-mode/color-combination 'star-polygon 5 mode color)
  (check-arg 'star-polygon
             (step-count . < . side-count)
             (format "number that is smaller than the side-count (~a)" side-count)
             3
             step-count)
  (check-arg 'star-polygon
             (= 1 (gcd side-count step-count))
             (format "number that is relatively prime to the side-count (~a)" side-count)
             3
             step-count)
  (make-polygon/star side-length side-count mode color (λ (l) (swizzle l step-count))))

(define/chk (star side-length mode color)
  (check-mode/color-combination 'star 3 mode color)
  (make-polygon/star side-length 5 mode color (λ (l) (swizzle l 2))))

(define (make-polygon/star side-length side-count mode color adjust)
  (make-a-polygon (adjust (regular-polygon-points side-length side-count)) 
                  mode color))

(define/chk (radial-star point-count radius1 radius2 mode color)
  (make-a-polygon (star-points radius1 radius2 point-count) mode color))
  
(define (star-points in-small-rad in-large-rad points)
  (let* ([small-rad (- in-small-rad 1)]
         [large-rad (- in-large-rad 1)]
         [roff (floor (/ large-rad 2))])
    (let loop ([i points])
      (cond
        [(zero? i) '()]
        [else 
         (let* ([this-p (- i 1)]
                [theta1 (* 2 pi (/ this-p points))]
                [theta2 (* 2 pi (/ (- this-p 1/2) points))])
           (let-values ([(x1 y1) (find-xy small-rad theta1)]
                        [(x2 y2) (find-xy large-rad theta2)])
             (let ([p1 (make-point (+ large-rad x1)
                                   (+ large-rad y1))]
                   [p2 (make-point (+ large-rad x2)
                                   (+ large-rad y2))])
               (list* p1 p2 (loop (- i 1))))))]))))

(define (find-xy radius theta)
  (values (* radius (cos theta))
          (* radius (sin theta))))

(define (make-a-polygon points mode color)
  (let* ([poly (make-polygon points mode color)]
         [ltrb (simple-bb poly)]
         [l (ltrb-left ltrb)]
         [t (ltrb-top ltrb)]
         [r (ltrb-right ltrb)]
         [b (ltrb-bottom ltrb)])
    (make-image (make-translate (- l) (- t) poly)
                (make-bb (- r l) (- b t) (- b t))
                #f)))
(define (gcd a b)
  (cond
    [(zero? b) a]
    [else (gcd b (modulo a b))]))



;; swizzle : (listof X)[odd-length] -> (listof X)
;; returns a list with the same elements, 
;; but reordered according to the step. Eg, if the step
;; is 2, we get the even elements and then the odd ones.
(define (swizzle l step)
  (let ([v (list->vector l)])
    (let loop ([i 0])
      (cond
        [(= i (vector-length v)) '()]
        [else
         (cons (vector-ref v (modulo (* i step) (vector-length v)))
               (loop (+ i 1)))]))))

;; regular-polygon-points : number number -> (listof point)
(define (regular-polygon-points side-length side-count)
  (let loop ([p (make-rectangular 0 0)]
             [i 0])
    (cond
      [(= i side-count) '()]
      [else (cons (make-point (real-part p) (imag-part p)) 
                  (loop (+ p (make-polar side-length
                                         (* -1 (* 2 pi) (/ i side-count))))
                        (+ i 1)))])))

(define/chk (ellipse width height mode color)
  (check-mode/color-combination 'ellipse 4 mode color)
  (make-image (make-translate (/ width 2) (/ height 2)
                              (make-ellipse width height 
                                            0
                                            mode
                                            color))
              (make-bb width height height)
              #f))

(define/chk (circle radius mode color)
  (check-mode/color-combination 'circle 3 mode color)
  (let ([w/h (* 2 radius)])
    (make-image (make-translate radius radius (make-ellipse w/h w/h 0 mode color))
                (make-bb w/h w/h w/h)
                #f)))

(define empty-image (rectangle 0 0 'solid 'black))

(define/chk (image-width image) (bb-select/round/exact bb-right image))
(define/chk (image-height image) (bb-select/round/exact bb-bottom image))
(define/chk (image-baseline image) (bb-select/round/exact bb-baseline image))
(define (bb-select/round/exact select image) (inexact->exact (round (select (send image get-bb)))))

(define-syntax (bitmap stx)
  (syntax-case stx ()
    [(_ arg)
     (let* ([arg (syntax->datum #'arg)]
            [path/lst
             (cond
               [(and (pair? arg)
                     (eq? (car arg) 'planet))
                (raise-syntax-error 'bitmap "planet paths not yet supported" stx)]
               [(symbol? arg)
                (let ([pieces (regexp-split #rx"/" (symbol->string arg))])
                  (cond
                    [(null? pieces)
                     (raise-syntax-error 'bitmap "expected a path with a / in it" stx)]
                    [else
                     (define fn (last pieces))
                     (define colls (reverse (cdr (reverse pieces))))
                     (define candidate
                       (apply collection-file-path fn colls
                              #:fail
                              (λ (msg) (raise-syntax-error 'bitmap msg stx))))
                     (unless (file-exists? candidate)
                       (raise-syntax-error 'bitmap 
                                           (format "could not find ~s, expected it to be in ~a"
                                                   arg candidate)
                                           stx))
                     (cons fn colls)]))]
               [(string? arg)
                (path->complete-path 
                 arg
                 (or (current-load-relative-directory)
                     (current-directory)))]
               [else (raise-syntax-error 
                      'bitmap 
                      "expected the argument to specify a local path (via a string) or a module path (e.g. `icons/b-run.png')"
                      stx)])])
       #`(bitmap/proc '#,path/lst))]))

(define (bitmap/proc arg)
  (define pth (if (path? arg)
                  arg
                  (apply collection-file-path arg
                         #:fail
                         (λ (msg) (error 'bitmap msg)))))
  (when (and (path? pth)
             (not (file-exists? pth)))
    (error 'bitmap "could not find the file ~a" (path->string pth)))
  ;; the rotate does a coercion to a 2htdp/image image
  (rotate 0 (make-object image-snip% (make-object bitmap% pth 'unknown/alpha))))

(define/chk (bitmap/url string)
  ;; the rotate does a coercion to a 2htdp/image image
  (rotate
   0
   (call/input-url (string->url string)
                   get-pure-port
                   (λ (port)
                     (make-object bitmap% port 'unknown #f #t)))))
                      
(define/chk (bitmap/file filename)
  (unless (file-exists? filename)
    (error 'bitmap/file 
           "could not find the file ~a" 
           filename))
  (rotate
   0
   (read-bitmap filename)))

(define/chk (image->color-list image)
  (let* ([w (image-width image)]
         [h (image-height image)]
         [bm (make-bitmap w h)]
         [bdc (make-object bitmap-dc% bm)]
         [c (make-object color%)]
         [bytes (make-bytes (* w h 4))])
    (send bdc erase)
    (render-image image bdc 0 0)
    (send bdc get-argb-pixels 0 0 w h bytes)
    (for/list ([i (in-range 0 (* w h 4) 4)])
      (color (bytes-ref bytes (+ i 1))
             (bytes-ref bytes (+ i 2))
             (bytes-ref bytes (+ i 3))
             (bytes-ref bytes i)))))

(define/chk (color-list->bitmap color-list width height)
  (check-dependencies 'color-list->bitmap
                      (= (* width height) (length color-list))
                      "the length of the color list to match the product of the width and the height, but the list has ~a elements and the width and height are ~a and ~a respectively"
                      (length color-list) width height)
  (let* ([bmp (make-bitmap width height)]
         [bytes (make-bytes (* width height 4) 0)]
         [o (make-object color%)])
    (for ([c (in-list color-list)]
          [i (in-naturals)])
      (define j (* i 4))
      (cond
        [(color? c)
         (bytes-set! bytes j (color-alpha c))
         (bytes-set! bytes (+ j 1) (color-red c))
         (bytes-set! bytes (+ j 2) (color-green c))
         (bytes-set! bytes (+ j 3) (color-blue c))]
        [else
         (let* ([str (if (string? c) c (symbol->string c))]
                [clr (or (send the-color-database find-color str)
                         (send the-color-database find-color "black"))])
           (bytes-set! bytes j 255)  ;; this should probably (send clr alpha) when that's possible
           (bytes-set! bytes (+ j 1) (send clr red))
           (bytes-set! bytes (+ j 2) (send clr green))
           (bytes-set! bytes (+ j 3) (send clr blue)))]))
    (send bmp set-argb-pixels 0 0 width height bytes)
    (bitmap->image bmp)))
      
(define build-color/make-color
  (let ([orig-make-color make-color])
    (define/chk make-color
      (case-lambda 
        [(int0-255-1 int0-255-2 int0-255-3) 
         (orig-make-color int0-255-1 int0-255-2 int0-255-3)]
        [(int0-255-1 int0-255-2 int0-255-3 int0-255-4) 
         (orig-make-color int0-255-1 int0-255-2 int0-255-3 int0-255-4)]))
    make-color))

(define/chk (pinhole-x image) (let ([ph (send image get-pinhole)]) (and ph (point-x ph))))
(define/chk (pinhole-y image) (let ([ph (send image get-pinhole)]) (and ph (point-y ph))))
(define/chk (put-pinhole x1 y1 image) (make-image (image-shape image) (image-bb image) (image-normalized? image) (make-point x1 y1)))
(define/chk (center-pinhole image) 
  (let ([bb (send image get-bb)])
    (make-image (image-shape image)
                (image-bb image)
                (image-normalized? image) 
                (make-point (/ (bb-right bb) 2)
                            (/ (bb-baseline bb) 2)))))
(define/chk (clear-pinhole image) (make-image (image-shape image) (image-bb image) (image-normalized? image) #f))

(define build-color/color
  (let ([orig-make-color make-color])
    (define/chk color
      (case-lambda
        [(int0-255-1 int0-255-2 int0-255-3) 
         (orig-make-color int0-255-1 int0-255-2 int0-255-3)]
        [(int0-255-1 int0-255-2 int0-255-3 int0-255-4) 
         (orig-make-color int0-255-1 int0-255-2 int0-255-3 int0-255-4)]))
    color))

(define build-pen/make-pen
  (let ([orig-make-pen make-pen])
    (define/chk (make-pen color int-0-255 pen-style pen-cap pen-join)
      (orig-make-pen color int-0-255 pen-style pen-cap pen-join))
    make-pen))

(define build-pen/pen
  (let ([orig-make-pen make-pen])
    (define/chk (pen color int-0-255 pen-style pen-cap pen-join)
      (orig-make-pen color int-0-255 pen-style pen-cap pen-join))
    pen))

(define/chk freeze
  (case-lambda 
    [(image) (freeze/internal 0 0 (image-width image) (image-height image) image)]
    [(width height image) (freeze/internal 0 0 width height image)]
    [(x y width height image) (freeze/internal x y width height image)]))

(define (freeze/internal x y w h image)
  (define bm (make-bitmap w h))
  (define bdc (make-object bitmap-dc% bm))
  (render-image image bdc (- x) (- y))
  (send bdc set-bitmap #f)
  (to-img bm))

(provide overlay
         overlay/align
         overlay/offset
         overlay/align/offset
         overlay/xy
         
         underlay
         underlay/align
         underlay/align/offset
         underlay/offset
         underlay/xy
         
         beside
         beside/align
         above
         above/align
         
         rotate
         crop
         flip-vertical
         flip-horizontal
         frame

         place-image
         place-image/align
         
         
         save-image
         save-svg-image
         bring-between
         
         
         scale
         scale/xy
         
         image-width
         image-height
         image-baseline
         
         circle
         ellipse
         rectangle
         empty-scene
         square
         rhombus
         empty-image
         
         polygon
         regular-polygon
         triangle 
         triangle/sss
         triangle/ssa
         triangle/sas
         triangle/ass
         triangle/aas
         triangle/asa
         triangle/saa

         isosceles-triangle
         right-triangle
         star
         star-polygon
         radial-star
         
         line
         add-line
         add-curve
         scene+line
         scene+curve
         text
         text/font
         image->color-list
         color-list->bitmap
         
         bitmap
         bitmap/url
         bitmap/file
         
         swizzle
         
         rotate-xy
         
         put-pinhole
         pinhole-x
         pinhole-y
         clear-pinhole
         center-pinhole
         overlay/pinhole
         underlay/pinhole
         
         build-color/make-color
         build-color/color
         build-pen/make-pen
         build-pen/pen
         
         freeze
         
         render-image)

(provide/contract
 [np-atomic-bb (-> np-atomic-shape? (values real? real? real? real?))]
 [center-point (-> np-atomic-shape? number?)])