#lang racket/base

#|

This library is the part of the 2htdp/image 
teachpack that has to be shared between drracket
and the user's program to make copy and paste
work right.

Most of the exports are just for use in 2htdp/image
(technically, 2htdp/private/image-more). The main
use of this library is the snip class addition it
does (and any code that does not depend on that
has been moved out).

|#

(require racket/class
         racket/list
         racket/match
         (except-in racket/draw 
                    make-pen make-color)
         (for-syntax racket/base)
         file/convertible
         pict/convert
         (prefix-in pict: (only-in pict dc))
         racket/math
         racket/contract
         "private/image-core-bitmap.rkt"
         "private/image-core-snipclass.rkt"
         "private/regmk.rkt"
         racket/snip
         (prefix-in cis: "cache-image-snip.rkt"))




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


;; a image is 
;;  (make-image shape bb boolean (or/c point #f))
;; NOTE: the shape field is mutated when normalized, as
;;       is the normalized? field.
(define (make-image shape bb normalized? [pinhole #f])
  (new image% [shape shape] [bb bb] [normalized? normalized?] [pinhole pinhole]))
(define (image-shape p) (send p get-shape))
(define (image-bb p) (send p get-bb))
(define (image-normalized? p) (send p get-normalized?))
(define (set-image-shape! p s) (send p set-shape s))
(define (set-image-normalized?! p n?) (send p set-normalized? n?))
(define (image? p) 
  (or (is-a? p image<%>)
      (is-a? p image-snip%)
      (is-a? p bitmap%)))

(define (un/cache-image img bitmap-cache?)
  (unless (image? img)
    (raise-argument-error 'un/cache-image
                          "image?"
                          0
                          img bitmap-cache?))
  (cond
    [(is-a? img snip%)
     (define res (send img copy))
     (when (is-a? res image%)
       (send res set-use-bitmap-cache?! (and bitmap-cache? #t)))
     res]
    [else img]))

(define (compute-image-cache img)
  (unless (image? img)
    (error 'compute-cached-bitmap "expected an image as the first argument, got ~e" img))
  (when (is-a? img image<%>)
    (send img compute-cached-bitmap))
  (void))
  
;; a shape is either:
;;
;;  - (make-overlay shape shape)
;;    the shapes are in the order passed to the overlay or beside,
;;    which means the bottom one should be drawn first so as to appear
;;    underneath the top one.
(define-struct/reg-mk overlay (top bottom) #:transparent #:omit-define-syntaxes) 
;;
;;  - (make-translate dx dy shape)
(define-struct/reg-mk translate (dx dy shape) #:transparent #:omit-define-syntaxes)
;;
;;  - (make-scale x-factor y-factor shape)
(define-struct/reg-mk scale (x y shape) #:transparent #:omit-define-syntaxes)
;;
;;  - (make-crop (listof vector) shape)
(define-struct/reg-mk crop (points shape) #:transparent #:omit-define-syntaxes)
;;
;;  - atomic-shape

;; an atomic-shape is either:
;;  - polygon
;;  - line-segment
;;  - curve-segment
;;  - bitmap
;;  - np-atomic-shape

;; a np-atomic-shape is:
;;
;;  - (make-ellipse width height angle mode color)
(define-struct/reg-mk ellipse (width height angle mode color) #:transparent #:omit-define-syntaxes)
;;
;;  - (make-text string angle number color
;;               number (or/c #f string) family 
;;               (or/c 'normal 'italic) (or/c 'normal 'light 'bold) boolean)
;;    NOTE: font can't be the raw mred font or else copy & paste won't work
(define-struct/reg-mk text (string angle y-scale color size face family style weight underline) 
  #:omit-define-syntaxes #:transparent)
;;
;;  - flip

;; a bitmap is:
;;  - (make-ibitmap (and/c (is-a?/c bitmap%) (lambda (x) (send x has-alpha-channel?)))
;;                  angle positive-real 
;;                  hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle])
;;                       -o> (is-a?/c bitmap%)])
;;    NOTE: bitmap copying needs to happen in 'write' and 'read' methods
(define-struct/reg-mk ibitmap #:reflect-id bitmap (raw-bitmap angle x-scale y-scale cache)
  #:omit-define-syntaxes #:transparent
  #:property prop:custom-write (λ (x y z) (bitmap-write x y z)))

;; a flip is:
;;   - (make-flip boolean bitmap)
;; * the boolean is #t if the bitmap should be flipped vertically
;;   (after applying whatever rotation is in there)
;; * this struct is here to avoid adding a field to bitmaps, so that old save files
;;   from when the library did not support flipping still load
;;   (since normalization will add a flip structure if necessary)
(define-struct/reg-mk flip (flipped? shape) #:transparent)

;; a polygon is:
;;
;;  - (make-polygon (listof vector) mode color)
(define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes)

;; a line-segment is
;;
;;  - (make-line-segment point point color)
(define-struct/reg-mk line-segment (start end color) #:transparent #:omit-define-syntaxes)

;; a curve-segment is
;;
;;  - (make-curve-segment point real real point real real color)
(define-struct/reg-mk curve-segment (start s-angle s-pull end e-angle e-pull mode color)
  #:transparent #:omit-define-syntaxes)

;; a normalized-shape (subtype of shape) is either
;;  - (make-overlay normalized-shape cn-or-simple-shape)
;;  - cn-or-simple-shape

;; an cn-or-simple-shape is either:
;;  - simple-shape
;;  - (make-crop (listof points) normalized-shape)

;; a simple-shape (subtype of shape) is
;;  - (make-translate dx dy np-atomic-shape)
;;  - polygon
;;  - line-segment
;;  - curve-segment

;; an angle is a number between 0 and 360 (degrees)

;; a mode is either 'solid or 'outline (indicating a pen width for outline mode)

;; a pen is
;;  - (make-pen color?  ;; <- the struct, not a string
;;              (<=/c 0 255)
;;              (or/c 'solid 'dot 'long-dash 'short-dash 'dot-dash)
;;              (or/c 'round 'projecting 'butt)
;;              (or/c 'round 'bevel 'miter))
(define-struct/reg-mk pen (color width style cap join) #:transparent)

;; an color is
;;  - (make-color (<=/c 0 255) (<=/c 0 255) (<=/c 0 255))
;;  - string
(define-struct/reg-mk color (red green blue alpha) #:transparent)
(define -make-color
  ;; this let is here just for the name
  (let ([make-color
         (λ (r g b [a 255])
           (make-color r g b a))])
    make-color))


;; a pulled-point is
;;  - (make-pulled-point real real real real real real)
(define-struct/reg-mk pulled-point (lpull langle x y rpull rangle) #:transparent)
(define (build-pulled-point lpull langle x y rpull rangle)
  (make-pulled-point lpull
                     (if (zero? lpull) 0 langle)
                     x y
                     rpull
                     (if (zero? rpull) 0 rangle)))
;                                                   
;                                                   
;                                                   
;   ;;                                    ;;   ;;   
;   ;;                                   ;;;;  ;    
;   ;                                    ; ;; ;     
;   ;;  ;;;;;;;;; ;;;;;   ;;;;;;  ;;;;   ; ;; ;     
;   ;;  ;; ;;; ;;;;   ;;  ;; ;;  ;;; ;;   ;; ;      
;   ;;  ;; ;;; ;;;  ;;;; ;;; ;;  ;;;;;;      ; ;;;  
;   ;;  ;; ;;; ;;;;;  ;;   ;;;   ;;          ;;; ;; 
;   ;;  ;; ;;; ;;;;;  ;;  ;;;;;  ;;;  ;     ; ;; ;; 
;   ;;  ;; ;;; ;;;;;;;;;; ;;;;;;  ;;;;     ;;  ;;;  
;                        ;;   ;;                    
;                        ;;   ;                     
;                         ;;;;                      

(define skip-image-equality-fast-path (make-parameter #f))
(define render-normalized (make-parameter #f))

(define convertible<%>
  (interface* ()
              ([prop:convertible
                (lambda (img format default)
                  (case format
                    [(png-bytes)
                     (let ([s (open-output-bytes)])
                       (send (to-bitmap (to-img img)) save-file s 'png)
                       (get-output-bytes s))]
                    [(svg-bytes) (to-svg-bytes img)]
                    [else default]))]
               [prop:pict-convertible
                (λ (image)
                  (define the-bb (send image get-bb))
                  (pict:dc
                   (λ (dc dx dy)
                     (render-image image dc dx dy))
                   (ceiling (inexact->exact (bb-right the-bb)))
                   (ceiling (inexact->exact (bb-bottom the-bb)))
                   0
                   (ceiling (inexact->exact (- (bb-bottom the-bb) 
                                               (bb-baseline the-bb))))))])))

(define (to-bitmap img)
  (define-values (w h) (get-size/but-subject-to-max (send img get-bb)))
  (define bm (make-bitmap w h))
  (define bdc (new bitmap-dc% [bitmap bm]))
  (render-image img bdc 0 0)
  (send bdc set-bitmap #f)
  bm)

(define (to-svg-bytes img)
  (define bb (send img get-bb))
  (define w (inexact->exact (ceiling (bb-right bb))))
  (define h (inexact->exact (ceiling (bb-bottom bb))))
  (define s (open-output-bytes))
  (define svg-dc (new svg-dc% [width w] [height h] [output s]))
  (send svg-dc start-doc "")
  (send svg-dc start-page)
  (render-image img svg-dc 0 0)
  (send svg-dc end-page)
  (send svg-dc end-doc)
  (get-output-bytes s))

(define max-size (* 5000 5000))
(define (get-size/but-subject-to-max bb)
  (define w (inexact->exact (ceiling (bb-right bb))))
  (define h (inexact->exact (ceiling (bb-bottom bb))))
  (get-size/but-subject-to-max/wh w h))

(define (get-size/but-subject-to-max/wh w h)
  (cond
    [(<= (* w h) max-size) (values w h)]
    [(< w h) (values w (ceiling (/ max-size w)))]
    [else (values (ceiling (/ max-size h)) h)]))

(module+ test 
  (require rackunit)
  (check-equal? (call-with-values
                 (λ () (get-size/but-subject-to-max/wh 10 10))
                 list)
                '(10 10))
  (check-equal? (call-with-values
                 (λ () (get-size/but-subject-to-max/wh 5000 10000))
                 list)
                '(5000 5000))
  (check-equal? (call-with-values
                 (λ () (get-size/but-subject-to-max/wh 10000 5000))
                 list)
                '(5000 5000))
  (check-equal? (call-with-values
                 (λ () (get-size/but-subject-to-max/wh 5001 5000))
                 list)
                '(5000 5000))
  (check-equal? (call-with-values
                 (λ () (get-size/but-subject-to-max/wh 6000 6001))
                 list)
                '(6000 4167)))

(define-local-member-name 
  set-use-bitmap-cache?!
  set-cached-bitmap
  compute-cached-bitmap)

(define image%
  (class* snip% (convertible<%> image<%>)
    (init-field shape bb normalized? pinhole)
    
    (define/override (equal-to? that eq-recur) (compare-em that eq-recur))
    (define/override (other-equal-to? that eq-recur) (compare-em that eq-recur))
    
    (define/private (compare-em that eq-recur)
      (or (eq? this that)
          (let ([that 
                 (cond
                   [(is-a? that image-snip%) (image-snip->image that)]
                   [(is-a? that bitmap%) (bitmap->image that)]
                   [else that])])
            (and (is-a? that image%)
                 (same-width/height? bb (send that get-bb))
                 (equal? pinhole (send that get-pinhole))
                 (or (and (not (skip-image-equality-fast-path))  ;; this makes testing more effective
                          (equal? (get-normalized-shape) (send that get-normalized-shape)))
                     
                     ;; some shapes (ie, outline rectangles with a 1 pixel edge) draw 1 outside
                     ;; the bounding box so we make the bitmap slightly bigger to accommodate that.
                     (let ([w (+ 1 (round (inexact->exact (bb-right bb))))]
                           [h (+ 1 (round (inexact->exact (bb-bottom bb))))])
                       (or ;(zero? w)
                           ;(zero? h)
                           (let ([bm1 (make-bitmap w h #t)]
                                 [bm2 (make-bitmap w h #t)]
                                 [bytes1 (make-bytes (* w h 4) 0)]
                                 [bytes2 (make-bytes (* w h 4) 0)]
                                 [bdc (make-object bitmap-dc%)])
                             (draw-into bm1 bdc bytes1 this)
                             (draw-into bm2 bdc bytes2 that)
                             (equal? bytes1 bytes2)))))))))
    
    (define/private (draw-into bm bdc bytes obj)
      (send bdc set-bitmap bm)
      (send bdc erase)
      (render-image obj bdc 0 0)
      (send bdc get-argb-pixels 0 0 (send bm get-width) (send bm get-height) bytes #f #t))
    
    ;; this could render the image into a bitmap and then get the hash code of the bytes
    ;; cannot render the tree into a string and then get the hash code of that string
    ;;   b/c that might make equal things have the same code.
    (define/override (equal-hash-code-of y) 42)
    (define/override (equal-secondary-hash-code-of y) 3)

    (define/public (get-shape) shape)
    (define/public (set-shape s) (set! shape s))
    (define/public (get-bb) bb)
    (define/public (get-pinhole) pinhole)
    (define/public (get-normalized?) normalized?)
    (define/public (set-normalized? n?) (set! normalized? n?))
    
    (define/public (get-normalized-shape)
      (unless normalized?
        (set! shape (normalize-shape shape))
        (set! normalized? #t))
      shape)
    
    (inherit get-admin)
    (define scroll-step #f)
    (define/private (calc-scroll-step)
      (unless scroll-step
        ;; try to set scroll step by font size of the standard style
        (let ([admin (get-admin)])
          (when admin
            (let* ([ed (send admin get-editor)]
                   [sl (send ed get-style-list)]
                   [standard (send sl find-named-style "Standard")])
              (when standard
                (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))])
                  (let-values ([(w h d a) (send dc get-text-extent "X" (send standard get-font))])
                    (set! scroll-step (+ h (send admin get-line-spacing)))))))))
        ;; if that didn't happen, set it to 12.
        (unless scroll-step (set! scroll-step 12))))
    
    (define/override (get-num-scroll-steps)
      (calc-scroll-step)
      (inexact->exact (ceiling (/ (bb-bottom bb) scroll-step))))
    (define/override (get-scroll-step-offset offset)
      (calc-scroll-step)
      (min (inexact->exact (ceiling (* offset scroll-step))) 
           (bb-bottom bb)))
    (define/override (find-scroll-step y)
      (calc-scroll-step)
      (inexact->exact (ceiling (/ y scroll-step))))

    (define/override (copy) 
      (define res (make-image shape bb normalized? pinhole))
      (when cached-bitmap
        (send res set-cached-bitmap cached-bitmap))
      res)
    
    (define cached-bitmap #f)
    (define use-cached-bitmap? #t)
    
    ;; this method is only used by the 'copy' method
    (define/public (set-cached-bitmap bm) (set! cached-bitmap bm))
    
    (define/public (compute-cached-bitmap)
      (when use-cached-bitmap?
        (unless cached-bitmap
          (define-values (w h) (get-size/but-subject-to-max bb))
          (set! cached-bitmap (make-bitmap (+ w 1) (+ h 1)))
          (define bdc (make-object bitmap-dc% cached-bitmap))
          (send bdc erase)
          (render-image this bdc 0 0)
          (send bdc set-bitmap #f))))
    
    (define/public (set-use-bitmap-cache?! u-b-c?) 
      (set! use-cached-bitmap? u-b-c?)
      (unless use-cached-bitmap?
        (set! cached-bitmap #f)))
    
    (define/override (draw dc x y left top right bottom dx dy draw-caret)
      (compute-cached-bitmap)
      
      (let ([alpha (send dc get-alpha)])
        (when (pair? draw-caret)
          (send dc set-alpha (* alpha .5)))
        (if use-cached-bitmap?
            (send dc draw-bitmap cached-bitmap x y)
            (render-image this dc x y))
        (send dc set-alpha alpha)))
    
    (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
      (send (get-the-snip-class-list) add snip-class)
      (let ([bottom (round (bb-bottom bb))]
            [right (round (bb-right bb))])
        (set-box/f! w right)
        (set-box/f! h bottom)
        (set-box/f! descent (- bottom (round (bb-baseline bb))))
        (set-box/f! space 0)
        (set-box/f! lspace 0)
        (set-box/f! rspace 0)))

    (define/override (write f) 
      (let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb pinhole)))])
        (send f put (bytes-length bytes) bytes)))
    
    (super-new)
    
    (inherit set-snipclass)
    (set-snipclass snip-class)))

(define (definitely-same-image? i1 i2)
  (cond
    [(and (is-a? i1 image<%>) (is-a? i2 image<%>))
     (equal? (send i1 get-normalized-shape)
             (send i2 get-normalized-shape))]
    [(or (is-a? i1 image<%>) (is-a? i2 image<%>))
     #f]
    [else
     (define bm1 (if (is-a? i1 image-snip%)
                     (send i1 get-bitmap)
                     i2))
     (define bm2 (if (is-a? i2 image-snip%)
                     (send i2 get-bitmap)
                     i2))
     (eq? bm1 bm2)]))

(define (same-bb? bb1 bb2)
  (and (same-width/height? bb1 bb2)
       (= (round (bb-baseline bb1)) (round (bb-baseline bb2)))))

(define (same-width/height? bb1 bb2)
  (and (= (round (bb-right bb1)) (round (bb-right bb2)))
       (= (round (bb-bottom bb1)) (round (bb-bottom bb2)))))

(define racket/base:read read)
(define image-snipclass% 
  (class snip-class%
    (define/override (read f) (snipclass-bytes->image (send f get-unterminated-bytes)))
    (super-new)))

(define (snipclass-bytes->image bytes)
  (define lst (parse (fetch bytes)))
  (cond
    [(not lst)
     (make-image (make-translate 50 50 (make-ellipse 100 100 0 'solid "black"))
                 (make-bb 100 100 100)
                 #f
                 #f)]
    [else
     (make-image (list-ref lst 0)
                 (list-ref lst 1)
                 #f
                 (list-ref lst 2))]))

(provide snip-class) 
(define snip-class (new image-snipclass%))
(send snip-class set-classname (format "~s" (list '(lib "image-core.ss" "mrlib")
                                                  '(lib "image-core-wxme.rkt" "mrlib"))))
(send snip-class set-version 1)
(send (get-the-snip-class-list) add snip-class)

(define (set-box/f! b v) (when (box? b) (set-box! b v)))
 
(define (parse sexp)
  (let/ec k
    (let loop ([sexp sexp])
      (cond
        [(pair? sexp) (cons (loop (car sexp)) (loop (cdr sexp)))]
        [(and (immutable? sexp) (hash? sexp))
         (hash-copy sexp)]
        [(vector? sexp)
         (if (= (vector-length sexp) 0)
             (k #f)
             (cond
               [(bytes? (vector-ref sexp 0))
                ;; bitmaps are vectors with a bytes in the first field
                (apply bytes->bitmap (vector->list sexp))]
               [else
                (let* ([tag (vector-ref sexp 0)]
                       [args (cdr (vector->list sexp))]
                       [constructor (id->constructor tag)]
                       [arg-count (length args)]
                       [parsed-args (map loop args)])
                  (cond
                    [(and constructor
                          (procedure-arity-includes? constructor arg-count)
                          (equal? tag 'struct:polygon))
                     (define points (list-ref parsed-args 0))
                     ;; in older versions, polygons had points as the
                     ;; first argument, but now they have pulled-points
                     (define adjusted-points
                       (for/list ([p (in-list points)])
                         (cond
                           [(point? p)
                            (make-pulled-point 0 0
                                               (point-x p)
                                               (point-y p)
                                               0 0)]
                           [else p])))
                     (apply constructor adjusted-points (cdr parsed-args))]
                    [(and constructor (procedure-arity-includes? constructor arg-count))
                     (apply constructor parsed-args)]
                    [(and (eq? tag 'struct:bitmap)
                          (= arg-count 7))
                     ;; we changed the arity of the bitmap constructor from old versions,
                     ;; so fix it up here.
                     (make-ibitmap (list-ref parsed-args 0)
                                   (list-ref parsed-args 2)
                                   (list-ref parsed-args 3)
                                   (list-ref parsed-args 4)
                                   (make-hash))]
                    [(and (eq? tag 'struct:bitmap)
                          (= arg-count 6))
                     ;; we changed the arity of the bitmap constructor from old versions,
                     ;; so fix it up here. it used to have these fields: 
                     ;; (raw-bitmap raw-mask angle x-scale y-scale cache)
                     ;; and the mask field was dropped in favor of always having an alpha bitmap in
                     ;; the raw-bitmap field. The bytes that were written out always had the mask
                     ;; factored in, tho (which led to a bug) so we can just ignore the mask here
                     (make-ibitmap (list-ref parsed-args 0)
                                   (list-ref parsed-args 2)
                                   (list-ref parsed-args 3)
                                   (list-ref parsed-args 4)
                                   (make-hash))]
                    [(and (eq? tag 'struct:color)
                          (= arg-count 3))
                     ;; we changed the arity of the color constructor from old versions,
                     ;; so fix it up here.
                     (make-color (list-ref parsed-args 0)
                                 (list-ref parsed-args 1)
                                 (list-ref parsed-args 2)
                                 255)]
                    [(and (eq? tag 'struct:curve-segment)
                          (= arg-count 7))
                     ;; new version (start s-angle s-pull end e-angle e-pull mode color)
                     ;; old version (start s-angle s-pull end e-angle e-pull color)
                     ;; with mode defaulting to 'outline
                     (make-curve-segment (list-ref parsed-args 0)
                                         (list-ref parsed-args 1)
                                         (list-ref parsed-args 2)
                                         (list-ref parsed-args 3)
                                         (list-ref parsed-args 4)
                                         (list-ref parsed-args 5)
                                         'outline
                                         (list-ref parsed-args 6))]
                    [else
                     (k #f)]))]))]
        [else sexp]))))

(define (normalized-shape? s)
  (cond
    [(overlay? s)
     (and (normalized-shape? (overlay-top s))
          (cn-or-simple-shape? (overlay-bottom s)))]
    [else
     (cn-or-simple-shape? s)]))

(define (cn-or-simple-shape? s)
  (cond
    [(crop? s)
     (normalized-shape? (crop-shape s))]
    [else
     (simple-shape? s)]))

(define (simple-shape? shape)
  (or (and (translate? shape)
           (np-atomic-shape? (translate-shape shape)))
      (polygon? shape)
      (line-segment? shape)
      (curve-segment? shape)))

(define (atomic-shape? shape)
  (or (polygon? shape)
      (line-segment? shape)
      (curve-segment? shape)
      (ibitmap? shape)
      (np-atomic-shape? shape)))

(define (np-atomic-shape? shape)
  (or (ellipse? shape)
      (text? shape)
      (and (flip? shape)
           (boolean? (flip-flipped? shape))
           (ibitmap? (flip-shape shape)))))

;; normalize-shape : shape -> normalized-shape
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
(define/contract (normalize-shape shape)
  (-> any/c ;; should be shape?
      normalized-shape?)
  (let loop ([shape shape]
             [dx 0]
             [dy 0]
             [x-scale 1]
             [y-scale 1]
             [bottom #f])
    (define (scale-point p)
      (make-point (+ dx (* x-scale (point-x p)))
                  (+ dy (* y-scale (point-y p)))))
    (define (scale-pulled-point p)
      (make-pulled-point (pulled-point-lpull p)
                         (pulled-point-langle p)
                         (+ dx (* x-scale (pulled-point-x p)))
                         (+ dy (* y-scale (pulled-point-y p)))
                         (pulled-point-rpull p)
                         (pulled-point-rangle p)))
    (cond
      [(translate? shape)
       (loop (translate-shape shape)
             (+ dx (* x-scale (translate-dx shape)))
             (+ dy (* y-scale (translate-dy shape)))
             x-scale
             y-scale
             bottom)]
      [(scale? shape)
       (loop (scale-shape shape)
             dx
             dy
             (* x-scale (scale-x shape))
             (* y-scale (scale-y shape))
             bottom)]
      [(overlay? shape)
       (loop (overlay-bottom shape)
             dx dy x-scale y-scale 
             (loop (overlay-top shape)
                   dx dy x-scale y-scale 
                   bottom))]
      [(crop? shape)
       (let* ([inside (loop (crop-shape shape)
                            dx dy x-scale y-scale 
                            #f)]
              [this-one
               (make-crop (map scale-point (crop-points shape))
                          inside)])
         (if bottom
             (make-overlay bottom this-one)
             this-one))]
      [(polygon? shape)
       (define this-one
         (make-polygon (map scale-pulled-point (polygon-points shape))
                       (polygon-mode shape)
                       (scale-color (polygon-color shape) x-scale y-scale)))
       (if bottom
           (make-overlay bottom this-one)
           this-one)]
      [(line-segment? shape)
       (let ([this-one 
              (make-line-segment (scale-point (line-segment-start shape))
                                 (scale-point (line-segment-end shape))
                                 (scale-color (line-segment-color shape) x-scale y-scale))])
         (if bottom
             (make-overlay bottom this-one)
             this-one))]
      [(curve-segment? shape)
       ;; the pull is multiplied by the distance 
       ;; between the two points when it is drawn,
       ;; so we don't need to scale it here
       (let ([this-one 
              (make-curve-segment (scale-point (curve-segment-start shape))
                                  (curve-segment-s-angle shape)
                                  (curve-segment-s-pull shape)
                                  (scale-point (curve-segment-end shape))
                                  (curve-segment-e-angle shape)
                                  (curve-segment-e-pull shape)
                                  (curve-segment-mode shape)
                                  (scale-color (curve-segment-color shape) x-scale y-scale))])
         (if bottom
             (make-overlay bottom this-one)
             this-one))]
      [(or (ibitmap? shape) (np-atomic-shape? shape))
       (let ([shape (if (ibitmap? shape) 
                        (make-flip #f shape)
                        shape)])
         (let ([this-one 
                (make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
           (if bottom
               (make-overlay bottom this-one)
               this-one)))]
      [else 
       (error 'normalize-shape "unknown shape ~s\n" shape)])))

(define/contract (scale-np-atomic x-scale y-scale shape)
  (-> number? number? np-atomic-shape? np-atomic-shape?)
  (cond
    [(ellipse? shape)
     (make-ellipse (* x-scale (ellipse-width shape))
                   (* y-scale (ellipse-height shape))
                   (ellipse-angle shape)
                   (ellipse-mode shape)
                   (scale-color (ellipse-color shape) x-scale y-scale))]
    [(text? shape)
     ;; should probably do something different here so that
     ;; the y-scale is always greater than 1
     ;; (or else always smaller than 1)
     (make-text (text-string shape)
                (text-angle shape)
                (* (text-y-scale shape) (/ y-scale x-scale))
                (text-color shape)
                (* (text-size shape) x-scale)
                (text-face shape)
                (text-family shape)
                (text-style shape)
                (text-weight shape)
                (text-underline shape))]
    [(flip? shape)
     (cond
       [(and (= 1 x-scale) (= 1 y-scale))
        shape]
       [else
        (let ([bitmap (flip-shape shape)])
          (make-flip (flip-flipped? shape)
                     (make-ibitmap (ibitmap-raw-bitmap bitmap)
                                   (ibitmap-angle bitmap)
                                   (* x-scale (ibitmap-x-scale bitmap))
                                   (* y-scale (ibitmap-y-scale bitmap))
                                   (ibitmap-cache bitmap))))])]))

(define (scale-color color x-scale y-scale)
  (cond
    [(pen? color)
     (make-pen (pen-color color)
               (* (pen-width color) (/ (+ x-scale y-scale) 2))
               (pen-style color)
               (pen-cap color)
               (pen-join color))]
    [else color]))

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

;; render-image : image dc dx dy -> void
(define (render-image image dc dx dy)
  (let ([pen (send dc get-pen)]
        [brush (send dc get-brush)]
        [font (send dc get-font)]
        [fg (send dc get-text-foreground)]
        [smoothing (send dc get-smoothing)]
        [alpha (send dc get-alpha)])
    (cond
      [(is-a? image bitmap%)
       (send dc draw-bitmap image dx dy)]
      [(is-a? image image-snip%)
       (send dc draw-bitmap (send image get-bitmap) dx dy)]
      [else
       (if (render-normalized)
           (render-normalized-shape (send image get-normalized-shape) dc dx dy)
           (render-arbitrary-shape (send image get-shape) dc dx dy))
       (let ([ph (send image get-pinhole)])
         (when ph
           (let* ([px (point-x ph)]
                  [py (point-y ph)]
                  [bb (image-bb image)]
                  [w (bb-right bb)]
                  [h (bb-bottom bb)])
             (send dc set-alpha (* alpha .5))
             (send dc set-smoothing 'smoothed)
             
             (send dc set-pen "white" 1 'solid)
             (send dc draw-line (+ dx px .5) (+ dy .5) (+ dx px .5) (+ dy h -.5))
             (send dc draw-line (+ dx .5) (+ dy py .5) (+ dx w -.5) (+ dy py .5))
             
             (send dc set-pen "black" 1 'solid)
             (send dc draw-line (+ dx px -.5) (+ dy .5) (+ dx px -.5) (+ dy h -.5))
             (send dc draw-line (+ dx .5) (+ dy py -.5) (+ dx w -.5) (+ dy py -.5)))))])
    (send dc set-pen pen)
    (send dc set-brush brush)
    (send dc set-font font)
    (send dc set-text-foreground fg)
    (send dc set-smoothing smoothing)
    (send dc set-alpha alpha)))

(define (save-image-as-bitmap image filename kind)
  (let* ([bb (send image get-bb)]
         [bm (make-object bitmap% 
               (+ 1 (ceiling (inexact->exact (bb-right bb))))
               (+ 1 (ceiling (inexact->exact (bb-bottom bb)))))]
         [bdc (make-object bitmap-dc% bm)])
    (send bdc erase)
    (render-image image bdc 0 0)
    (send bdc set-bitmap #f)
    (send bm save-file filename kind)))

(define (render-normalized-shape shape dc dx dy)
  (cond
    [(overlay? shape)
     (render-cn-or-simple-shape (overlay-bottom shape) dc dx dy)
     (render-normalized-shape (overlay-top shape) dc dx dy)]
    [else
     (render-cn-or-simple-shape shape dc dx dy)]))

(define last-cropped-points (make-parameter #f))

(define (render-cn-or-simple-shape shape dc dx dy)
  (cond
    [(crop? shape)
     (render-cropped-shape (crop-points shape)
                           (crop-shape shape)
                           (λ (s) (render-normalized-shape s dc dx dy))
                           dc dx dy)]
    [else
     (render-simple-shape shape dc dx dy)]))

(define (render-cropped-shape points inner-shape continue dc dx dy)
  (cond
    [(equal? points (last-cropped-points))
     (continue inner-shape)]
    [else
     (let ([old-region (send dc get-clipping-region)]
           [new-region (new region% [dc dc])]
           [path (polygon-points->path points)])
       (send new-region set-path path dx dy)
       (when old-region (send new-region intersect old-region))
       (send dc set-clipping-region new-region)
       (parameterize ([last-cropped-points points])
         (continue inner-shape))
       (send dc set-clipping-region old-region))]))

(define (render-simple-shape simple-shape dc dx dy)
  (cond
    [(translate? simple-shape)
     (let ([dx (+ dx (translate-dx simple-shape))]
           [dy (+ dy (translate-dy simple-shape))]
           [np-atomic-shape (translate-shape simple-shape)])
       (render-np-atomic-shape np-atomic-shape
                               dc
                               dx dy))]
    [else
     (render-poly/line-segment/curve-segment simple-shape dc dx dy)]))

(define (render-arbitrary-shape shape dc dx dy)
  (let loop ([shape shape]
             [dx dx]
             [dy dy]
             [x-scale 1]
             [y-scale 1])
    (define (scale-point p)
      (make-point (* x-scale (point-x p))
                  (* y-scale (point-y p))))
    (define (scale-pulled-point p)
      (make-pulled-point (pulled-point-lpull p)
                         (pulled-point-langle p)
                         (* x-scale (pulled-point-x p))
                         (* y-scale (pulled-point-y p))
                         (pulled-point-rpull p)
                         (pulled-point-rangle p)))
    (cond
      [(translate? shape)
       (loop (translate-shape shape)
             (+ dx (* x-scale (translate-dx shape)))
             (+ dy (* y-scale (translate-dy shape)))
             x-scale
             y-scale)]
      [(scale? shape)
       (loop (scale-shape shape)
             dx
             dy
             (* x-scale (scale-x shape))
             (* y-scale (scale-y shape)))]
      [(overlay? shape)
       (loop (overlay-bottom shape) dx dy x-scale y-scale)
       (loop (overlay-top shape) dx dy x-scale y-scale)]
      [(crop? shape)
       (render-cropped-shape
        (map scale-point (crop-points shape))
        (crop-shape shape)
        (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)]
      [(polygon? shape)
       (define this-one
         (make-polygon (map scale-pulled-point (polygon-points shape))
                       (polygon-mode shape)
                       (scale-color (polygon-color shape) x-scale y-scale)))
       (render-poly/line-segment/curve-segment this-one dc dx dy)]
      [(line-segment? shape)
       (let ([this-one 
              (make-line-segment (scale-point (line-segment-start shape))
                                 (scale-point (line-segment-end shape))
                                 (scale-color (line-segment-color shape) x-scale y-scale))])
         (render-poly/line-segment/curve-segment this-one dc dx dy))]
      [(curve-segment? shape)
       ;; the pull is multiplied by the distance 
       ;; between the two points when it is drawn,
       ;; so we don't need to scale it here
       (define this-one
         (make-curve-segment (scale-point (curve-segment-start shape))
                             (curve-segment-s-angle shape)
                             (curve-segment-s-pull shape)
                             (scale-point (curve-segment-end shape))
                             (curve-segment-e-angle shape)
                             (curve-segment-e-pull shape)
                             (curve-segment-mode shape)
                             (scale-color (curve-segment-color shape) x-scale y-scale)))
       (render-poly/line-segment/curve-segment this-one dc dx dy)]
      [(or (ibitmap? shape) (np-atomic-shape? shape))
       (let* ([shape (if (ibitmap? shape) 
                         (make-flip #f shape)
                         shape)]
              [this-one (scale-np-atomic x-scale y-scale shape)])
         (render-np-atomic-shape this-one dc dx dy))]
      [else 
       (error 'normalize-shape "unknown shape ~s\n" shape)])))

(define/contract (render-poly/line-segment/curve-segment simple-shape dc dx dy)
  (-> (or/c polygon? line-segment? curve-segment?) any/c any/c any/c void?)
  (cond
    [(polygon? simple-shape)
     (let ([mode (polygon-mode simple-shape)]
           [color (polygon-color simple-shape)]
           [path (polygon-pulled-points->path (polygon-points simple-shape))])
       (send dc set-pen (mode-color->pen mode color))
       (send dc set-brush (mode-color->brush mode color))
       (send dc set-smoothing (mode-color->smoothing mode color))
       (send dc draw-path path dx dy 'winding))]
    [(line-segment? simple-shape)
     (let* ([start (line-segment-start simple-shape)]
            [end (line-segment-end simple-shape)]
            [path (new dc-path%)]
            [sx (point-x start)]
            [sy (point-y start)]
            [ex (point-x end)]
            [ey (point-y end)])
       (send path move-to sx sy)
       (send path line-to ex ey)
       (send dc set-pen (mode-color->pen 'outline (line-segment-color simple-shape)))
       (send dc set-brush "black" 'transparent)
       (send dc set-smoothing 'smoothed)
       (send dc draw-path path dx dy))]
    [(curve-segment? simple-shape)
     (define path (curve-segment->path simple-shape))
     (send dc set-pen (mode-color->pen (curve-segment-mode simple-shape)
                                       (curve-segment-color simple-shape)))
     (send dc set-brush (mode-color->brush (curve-segment-mode simple-shape)
                                           (curve-segment-color simple-shape)))
     (send dc set-smoothing 'smoothed)
     (send dc draw-path path dx dy)]))

(define (curve-segment->path simple-shape)
  (define start (curve-segment-start simple-shape))
  (define end (curve-segment-end simple-shape))
  (define sx (point-x start))
  (define sy (point-y start))
  (define ex (point-x end))
  (define ey (point-y end))
  (define sa (degrees->radians (curve-segment-s-angle simple-shape)))
  (define ea (degrees->radians (curve-segment-e-angle simple-shape)))

  (define path (new dc-path%))
  (define d (sqrt (+ (sqr (- ey sy)) (sqr (- ex sx)))))
  (define sp (* (curve-segment-s-pull simple-shape) d))
  (define ep (* (curve-segment-e-pull simple-shape) d))
  (send path move-to sx sy)
  (send path curve-to
        (+ sx (* sp (cos sa)))
        (- sy (* sp (sin sa)))
        (- ex (* ep (cos ea)))
        (+ ey (* ep (sin ea)))
        ex
        ey)
  path)

(define (render-np-atomic-shape np-atomic-shape dc dx dy)
  (cond
    [(ellipse? np-atomic-shape)
     (let* ([path (new dc-path%)]
            [ew (ellipse-width np-atomic-shape)]
            [eh (ellipse-height np-atomic-shape)]
            [θ (degrees->radians (ellipse-angle np-atomic-shape))]
            [color (ellipse-color np-atomic-shape)]
            [mode (ellipse-mode np-atomic-shape)])
       (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
         (send path ellipse 0 0 ew eh)
         (send path translate (- (/ ew 2)) (- (/ eh 2)))
         (send path rotate θ)
         (send dc set-pen (mode-color->pen mode color))
         (send dc set-brush (mode-color->brush mode color))
         (send dc set-smoothing (mode-color->smoothing mode color))
         (send dc draw-path path dx dy)))]
    [(flip? np-atomic-shape) 
     (cond
       [(flip-flipped? np-atomic-shape)
        (define key (get-bitmap-cache-key np-atomic-shape))
        (define bm (lookup/calc-rendered-bitmap np-atomic-shape key))
        (send dc set-smoothing 'smoothed)
        (send dc draw-bitmap 
              bm
              (- dx (/ (send bm get-width) 2))
              (- dy (/ (send bm get-height) 2)))]
       [else
        (define transformation (send dc get-transformation))
        (define bitmap (flip-shape np-atomic-shape))
        (define bitmap-obj (ibitmap-raw-bitmap bitmap))
         
        (define θ (degrees->radians (ibitmap-angle bitmap)))
        
        (send dc translate dx dy)
        (send dc rotate θ)
        
        (define bw (send bitmap-obj get-width))
        (define bh (send bitmap-obj get-height))
  
        (send dc translate 
              (* (ibitmap-x-scale bitmap) (- (/ bw 2)))
              (* (ibitmap-y-scale bitmap) (- (/ bh 2))))
        (send dc set-scale (ibitmap-x-scale bitmap) (ibitmap-y-scale bitmap))
        
        (send dc draw-bitmap bitmap-obj 0 0)
        
        (send dc set-transformation transformation)
        bitmap-obj])]
    [(text? np-atomic-shape)
     (let ([θ (degrees->radians (text-angle np-atomic-shape))]
           [font (send dc get-font)])
       (send dc set-font (text->font np-atomic-shape))
       (send dc set-smoothing 'aligned) ;; should this be smoothed?
       (let ([color (get-color-arg (text-color np-atomic-shape))])
         (send dc set-text-foreground 
               (cond
                 [(equal? color "transparent") transparent-color]
                 [(string? color)
                  (or (send the-color-database find-color color)
                      (send the-color-database find-color "black"))]
                 [else color])))
       (let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))])
         (let ([p (- (make-rectangular dx dy)
                     (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
           (send dc draw-text (text-string np-atomic-shape) 
                 (real-part p)
                 (imag-part p) 
                 #f 0 θ))))]))

(define (polygon-pulled-points->path pulled-points)
  (define path (new dc-path%))
  (define first-point (car pulled-points))
  (send path move-to (pulled-point-x first-point) (pulled-point-y first-point))
  (let loop ([prev-point (car pulled-points)]
             [pulled-points (cdr pulled-points)])
    (define this-point (if (null? pulled-points)
                           first-point
                           (car pulled-points)))
    (match-define (pulled-point slpull slangle sx sy srpull srangle) prev-point)
    (match-define (pulled-point elpull elangle ex ey erpull erangle) this-point)
    (define vec (- (make-rectangular ex ey) (make-rectangular sx sy)))
    (define sa (degrees->radians srangle))
    (define ea (degrees->radians elangle))
    (define p1 (* vec (make-polar srpull sa)))
    (define p2 (* (- vec) (make-polar elpull ea)))
    
    (send path curve-to
          (+ sx (real-part p1))
          (+ sy (imag-part p1))
          (+ ex (real-part p2))
          (+ ey (imag-part p2))
          ex
          ey)
    (unless (null? pulled-points)
      (loop (car pulled-points) (cdr pulled-points))))
  (send path close)
  path)

(define (polygon-points->path points)
  (define path (new dc-path%))
  (send path move-to (point-x (car points)) (point-y (car points)))
  (let loop ([points (cdr points)])
    (unless (null? points)
      (define pt (car points))
      (send path line-to (point-x pt) (point-y pt))
      (loop (cdr points))))
  (send path close)
  path)

;; points->ltrb-values : (cons point (listof points)) -> (values number number number number)
(define (points->ltrb-values points)
  (unless (and (list? points)
               (pair? points)
               (andmap (or/c point? pulled-point?) points))
    (raise-argument-error 'points->ltrb-values
                          "(non-empty-listof (or/c point? pulled-point?))"
                          0 points))
  (define fx (pp->x (car points)))
  (define fy (pp->y (car points)))
  (define left fx)
  (define top fy)
  (define right fx)
  (define bottom fy)
  (for ([point (in-list (cdr points))])
    (define new-x (pp->x point))
    (define new-y (pp->y point))
    (set! left (min new-x left))
    (set! top (min new-y top))
    (set! right (max new-x right))
    (set! bottom (max new-y bottom)))
  (values left top right bottom))

(define (pp->x p)
  (if (pulled-point? p)
      (pulled-point-x p)
      (point-x p)))

(define (pp->y p)
  (if (pulled-point? p)
      (pulled-point-y p)
      (point-y p)))
  
#|

the mask bitmap and the original bitmap are all together in a single bytes!

|#


(define (get-bitmap-cache-key flip-bitmap)
  (define bm (flip-shape flip-bitmap))
  (list (flip-flipped? flip-bitmap)
        (ibitmap-x-scale bm)
        (ibitmap-y-scale bm)
        (ibitmap-angle bm)))

(define (lookup/calc-rendered-bitmap flip-bitmap key)
  (let ([bitmap (flip-shape flip-bitmap)])
    (cond
      [(hash-ref (ibitmap-cache bitmap) key #f) => values]
      [else
       (let ([flipped? (flip-flipped? flip-bitmap)])
         (define orig-bitmap-obj (ibitmap-raw-bitmap bitmap))
         (define bitmap-obj
           (cond
             [(<= (* (ibitmap-x-scale bitmap) 
                     (ibitmap-y-scale bitmap))
                  1)
              ;; since we prefer to rotate big things, we rotate first
              (do-scale bitmap (do-rotate bitmap orig-bitmap-obj flipped?))]
             [else
              ;; since we prefer to rotate big things, we scale first
              (do-rotate bitmap (do-scale bitmap orig-bitmap-obj) flipped?)]))
         (hash-set! (ibitmap-cache bitmap) key bitmap-obj)
         bitmap-obj)])))

(define (do-rotate bitmap bitmap-obj flip?)
  (cond
    [(and (not flip?) (zero? (ibitmap-angle bitmap)))
     ;; don't rotate anything in this case.
     bitmap-obj]
    ;; speed up rotated (but not flipped) bitmaps
    [(not flip?)
     (define θ (degrees->radians (ibitmap-angle bitmap)))
     (define ow (send bitmap-obj get-width))
     (define oh (send bitmap-obj get-height))
     (define unrotated-pts
       (list (make-rectangular 0 0)
             (make-rectangular ow 0)
             (make-rectangular ow oh)
             (make-rectangular 0 oh)))
     (define pts (map (λ (p) (* p (make-polar 1 θ))) unrotated-pts))
     (define longitudes (map real-part pts))
     (define latitudes (map imag-part pts))
     (define east (apply max longitudes))
     (define west (apply min longitudes))
     (define nrth (apply min latitudes))
     (define sth  (apply max latitudes))
     (define new-w (ceiling (inexact->exact (- east west))))
     (define new-h (ceiling (inexact->exact (- sth nrth))))

     (define new-bm (make-bitmap new-w new-h))
     (define bdc (make-object bitmap-dc% new-bm))
     (send bdc set-smoothing 'smoothed)
     (send bdc rotate (- θ))
     
     ;; would like to just translate by 'tp', but
     ;; the dc applies the translations before applying
     ;; the rotation, so we have to unrotate the translation
     ;; before telling the dc about it
     (define tp (make-rectangular (- west) (- nrth)))
     (define tp-translated (* tp (make-polar 1 (- θ))))
     
     (send bdc translate (real-part tp-translated) (imag-part tp-translated))
     
     (send bdc draw-bitmap bitmap-obj 0 0)
     (send bdc set-bitmap #f)
     new-bm]
    
    [else
     (define θ (degrees->radians (ibitmap-angle bitmap)))
     (define-values (bytes w h) (bitmap->bytes bitmap-obj #f))
     (define-values (rotated-bytes rotated-w rotated-h) (rotate-bytes bytes w h θ))
     (define flipped-bytes (if flip?
                               (flip-bytes rotated-bytes rotated-w rotated-h)
                               rotated-bytes))
     (define bm (bytes->bitmap flipped-bytes rotated-w rotated-h))
     bm]))

(define (do-scale bitmap orig-bm)
  (define x-scale (ibitmap-x-scale bitmap))
  (define y-scale (ibitmap-y-scale bitmap))
  (cond
    [(and (= 1 x-scale) (= 1 y-scale))
     ;; no need to scale in this case
     orig-bm]
    [else
     (define bdc (make-object bitmap-dc%))
     (define orig-w (send orig-bm get-width))
     (define orig-h (send orig-bm get-height))
     (define scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width)))))
     (define scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height)))))
     (define new-bm (make-bitmap scale-w scale-h))
     
     (send bdc set-bitmap new-bm)
     (send bdc set-scale x-scale y-scale)
     (send bdc erase)
     (send bdc draw-bitmap orig-bm 0 0)
     
     (send bdc set-bitmap #f)
     
     new-bm]))

(define (text->font text)
  (define adjusted-size (min (max (inexact->exact (round (text-size text))) 1) 255))
  (cond
    [(text-face text)
     (send the-font-list find-or-create-font
           adjusted-size
           (text-face text)
           (text-family text)
           (text-style text) 
           (text-weight text)
           (text-underline text)
           'default
           #t)]
    [else
     (send the-font-list find-or-create-font
           adjusted-size
           (text-family text)
           (text-style text) 
           (text-weight text)
           (text-underline text)
           'default
           #t)]))

(define (ellipse-rotated-size ew eh θ)
  (cond
    [(and (zero? ew) (zero? eh))
     (values 0 0)]
    [(zero? eh)
     (values (* (cos θ) ew)
             (* (sin θ) ew))]
    [(zero? ew)
     (values (* (sin θ) eh)
             (* (cos θ) eh))]
    [else
     (let* ([t1 (atan (/ eh ew (exact->inexact (tan θ))))]
            ; a*cos(t1),b*sin(t1) is the point on *original* ellipse which gets rotated to top.
            [t2 (atan (/ (* (- eh) (tan θ)) ew))] ; the original point rotated to right side.
            [rotated-height (+ (* ew (sin θ) (cos t1)) (* eh (cos θ) (sin t1)))]
            [rotated-width  (- (* ew (cos θ) (cos t2)) (* eh (sin θ) (sin t2)))])
       (values (abs rotated-width)
               (abs rotated-height)))]))

(define (mode-color->smoothing mode color)
  (cond
    [(and (eq? mode 'outline)
          (not (pen? color)))
     'aligned]
    [else 'smoothed]))

(define (mode-color->pen mode color)
  (cond
    [(eq? mode 'outline)
     (cond
       [(pen? color)
        (pen->pen-obj/cache color)]
       [else
        (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])]
    [else
     (send the-pen-list find-or-create-pen "black" 1 'transparent)]))

(define (mode-color->brush mode color)
  (cond
    [(eq? mode 'outline)
     (send the-brush-list find-or-create-brush "black" 'transparent)]
    [else
     ;; this should only be 'solid if we have an old image from a save file somewhere
     (define extra-alpha (if (eq? mode 'solid)
                             255
                             mode))
     (send the-brush-list find-or-create-brush (get-color-arg color extra-alpha) 'solid)]))

(define (get-color-arg color [extra-alpha 255])
  (cond
    [(equal? color "transparent") transparent-color]
    [(string? color) 
     (define color-obj 
       (or (send the-color-database find-color color)
           (send the-color-database find-color "black")))
     (make-object color%
       (send color-obj red)
       (send color-obj green)
       (send color-obj blue)
       (/ extra-alpha 255))]
    [else
     (make-object color% 
       (color-red color)
       (color-green color)
       (color-blue color)
       (* (/ (color-alpha color) 255)
          (/ extra-alpha 255)))]))

(define transparent-color (make-object color% 255 255 255 0))

(define (pen->pen-obj/cache pen)
  (send the-pen-list find-or-create-pen 
        (get-color-arg (pen-color pen))
        (pen-width pen)
        (pen-style pen)
        (pen-cap pen)
        (pen-join pen)))
       
(define (to-img arg)
  (cond
    [(is-a? arg image-snip%) (image-snip->image arg)]
    [(is-a? arg bitmap%) (bitmap->image arg)]
    [else arg]))

(define (image-snip->image is)
  (let ([bm (send is get-bitmap)])
    (cond
      [(not bm)
       ;; this might mean we have a cache-image-snip% 
       ;; or it might mean we have a useless snip.
       (let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
                               (send is get-size)
                               (values 0 0))])
         (make-image (construct-polygon
                      (list (make-point 0 0)
                            (make-point w 0)
                            (make-point w h)
                            (make-point 0 h))
                      'solid "black")
                     (make-bb w h h)
                     #f))]
      [else
       (bitmap->image bm
                      (or (send is get-bitmap-mask)
                          (send bm get-loaded-mask)))])))

(define (construct-polygon points mode color)
  (make-polygon
   (for/list ([prev (in-list (cons (last points) points))]
              [p (in-list points)]
              [next (in-list (append (cdr points) (list (car points))))])
     (cond
       [(point? p)
        (define x (point-x p))
        (define y (point-y p))
        (make-pulled-point 0 0 x y 0 0)]
       [else p]))
   mode color))

(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
  (define w (send bm get-width))
  (define h (send bm get-height))
  (define alpha-bm
    (cond
      [(send bm has-alpha-channel?)
       bm]
      [else
       (define new-bm (make-bitmap w h))
       (define bdc (make-object bitmap-dc% new-bm))
       (send bdc draw-bitmap bm 0 0 'solid
             (send the-color-database find-color "black")
             mask-bm)
       (send bdc set-bitmap #f)
       new-bm]))
  (make-image (make-translate (/ w 2)
                              (/ h 2)
                              (make-ibitmap alpha-bm 0 1 1 (make-hash)))
              (make-bb w h h)
              #f))

(define (bitmap-write bitmap port mode)
  (let* ([v (struct->vector bitmap)]
         [recur (case mode
                  [(#t) write]
                  [(#f) display]
                  [else (lambda (p port) (print p port mode))])]
         [update 
          (λ (i)
            (let ([o (vector-ref v i)])
              (let ([nv (and o 
                             (call-with-values (λ () (bitmap->bytes o #f)) vector))])
                (vector-set! v i nv))))])
    (update 1)
    ;; don't save the cache
    (vector-set! v 5 (make-hash))
    (recur v port)))

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


(provide make-image image-shape image-bb image-normalized? image%
        
         un/cache-image compute-image-cache
         
         (struct-out bb)
         (struct-out point) (struct-out pulled-point) build-pulled-point
         make-overlay overlay? overlay-top overlay-bottom
         make-translate translate? translate-dx translate-dy translate-shape
         make-scale scale? scale-x scale-y scale-shape
         make-crop crop? crop-points crop-shape
         make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color
         make-text text? text-string text-angle text-y-scale text-color
         text-angle text-size text-face text-family text-style text-weight text-underline
         (contract-out [rename construct-polygon make-polygon
                               (-> (listof (or/c point? pulled-point?)) any/c any/c polygon?)])
         polygon? polygon-points polygon-mode polygon-color
         make-line-segment line-segment? line-segment-start line-segment-end line-segment-color
         make-curve-segment curve-segment? 
         curve-segment-start curve-segment-s-angle curve-segment-s-pull
         curve-segment-end curve-segment-e-angle curve-segment-e-pull 
         curve-segment-mode curve-segment-color
         make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen
         
         make-ibitmap ibitmap? ibitmap-raw-bitmap ibitmap-angle ibitmap-x-scale ibitmap-y-scale 
         ibitmap-cache

         make-flip flip? flip-flipped? flip-shape
         
         (except-out (struct-out color) make-color)
         (rename-out [-make-color make-color]) 
         
         degrees->radians
         normalize-shape
         ellipse-rotated-size
         points->ltrb-values

         image?
         
         text->font
         render-image
         save-image-as-bitmap
         
         skip-image-equality-fast-path
         render-normalized
         
         scale-np-atomic
         
         to-img
         bitmap->image
         image-snip->image
         image-snip%
         
         curve-segment->path
         mode-color->pen
         
         snipclass-bytes->image
         (contract-out
          [definitely-same-image? (-> image? image? boolean?)]))

;; method names
(provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape)

(provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?)