#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?)