740 lines
28 KiB
Scheme
740 lines
28 KiB
Scheme
#lang scheme/base
|
|
|
|
#|
|
|
|
|
This library is the part of the 2htdp/image
|
|
teachpack that has to be shared between drscheme
|
|
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 that does not depend on
|
|
has been moved out).
|
|
|
|
|
|
-- in the middle of text:
|
|
|
|
- bounding boxes
|
|
- rotating (and bounding boxes)
|
|
- hbl append(?)
|
|
- this doesn't work (how to test?)
|
|
(beside/places "baseline"
|
|
(text "ijy" 12 'black)
|
|
(text "ijy" 24 'black))
|
|
- /places => /align
|
|
|
|
|#
|
|
|
|
(require scheme/class
|
|
scheme/gui/base
|
|
scheme/math
|
|
"private/image-core-bitmap.ss"
|
|
(for-syntax scheme/base))
|
|
|
|
(define-for-syntax id-constructor-pairs '())
|
|
(define-for-syntax (add-id-constructor-pair a b)
|
|
(set! id-constructor-pairs (cons (list a b) id-constructor-pairs)))
|
|
|
|
(define-syntax (define-struct/reg-mk stx)
|
|
(syntax-case stx ()
|
|
[(_ id . rest)
|
|
(let ([build-name
|
|
(λ (fmt)
|
|
(datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))])
|
|
(add-id-constructor-pair (build-name "struct:~a")
|
|
(build-name "make-~a"))
|
|
#'(define-struct id . rest))]))
|
|
|
|
(define-syntax (define-id->constructor stx)
|
|
(syntax-case stx ()
|
|
[(_ fn)
|
|
#`(define (fn x)
|
|
(case x
|
|
#,@(map (λ (x)
|
|
(with-syntax ([(struct: maker) x])
|
|
#`[(struct:) maker]))
|
|
id-constructor-pairs)))]))
|
|
|
|
(define-struct/reg-mk point (x y) #:transparent)
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;; ;; ;; ;;;
|
|
; ;; ;;; ;; ;;;
|
|
; ;;;;; ;;;; ;;;;; ;;;; ;;;;; ;;;; ;;;;; ;; ;;;
|
|
; ;;;;;; ;; ;; ;;;; ;; ;; ;;;;;; ;; ;; ;;;; ;;;;;;
|
|
; ;;; ;; ;;;; ;;; ;;;; ;;; ;; ;;;;;;;; ;; ;; ;;
|
|
; ;;; ;; ;;; ;; ;;; ;;; ;; ;;; ;; ;;; ;; ;; ;;
|
|
; ;;;;;; ;;; ;; ;;;;;;; ;; ;;;;;; ;;; ;; ;; ;; ;;
|
|
; ;;;;; ;;;;;; ;;; ;;;;;; ;;;;; ;;;; ;; ;; ;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
;; a image is
|
|
;; (make-image shape bb boolean)
|
|
;; NOTE: the shape field is mutated when normalized, as
|
|
;; is the normalized? field.
|
|
(define (make-image shape bb normalized?) (new image% [shape shape] [bb bb] [normalized? normalized?]))
|
|
(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-right image) (bb-right (image-bb image)))
|
|
(define (image-bottom image) (bb-bottom (image-bb image)))
|
|
(define (image-baseline image) (bb-baseline (image-bb image)))
|
|
(define (image? p)
|
|
(or (is-a? p image%)
|
|
(is-a? p image-snip%)
|
|
(is-a? p bitmap%)))
|
|
|
|
|
|
;; a bb is (bounding box)
|
|
;; (make-bb number number number)
|
|
(define-struct/reg-mk bb (right bottom baseline) #:transparent)
|
|
|
|
;; 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)
|
|
;;
|
|
;; - atomic-shape
|
|
|
|
;; an atomic-shape is either:
|
|
;; - polygon
|
|
;; - line-segment
|
|
;; - 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)
|
|
;;
|
|
;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%)))
|
|
;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods
|
|
(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable])
|
|
#:omit-define-syntaxes #:transparent)
|
|
|
|
;; a polygon is:
|
|
;;
|
|
;; - (make-polygon (listof vector) mode color)
|
|
(define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes
|
|
#:property prop:equal+hash
|
|
(list (λ (a b rec) (polygon-equal? a b rec)) (λ (x y) 42) (λ (x y) 3)))
|
|
|
|
;; a line-segment is
|
|
;;
|
|
;; - (make-line-segment point point color)
|
|
(define-struct/reg-mk line-segment (start end color) #:transparent #:omit-define-syntaxes
|
|
#:property prop:equal+hash
|
|
(list (λ (a b rec) (and (or (and (rec (line-segment-start a) (line-segment-start b))
|
|
(rec (line-segment-end a) (line-segment-end b)))
|
|
(and (rec (line-segment-start a) (line-segment-end b))
|
|
(rec (line-segment-end a) (line-segment-start b))))
|
|
(rec (line-segment-color a) (line-segment-color b))))
|
|
(λ (x y) 42)
|
|
(λ (x y) 3)))
|
|
;; a normalized-shape (subtype of shape) is either
|
|
;; - (make-overlay normalized-shape simple-shape)
|
|
;; - simple-shape
|
|
|
|
;; a simple-shape (subtype of shape) is
|
|
;; - (make-translate dx dy np-atomic-shape)
|
|
;; - polygon
|
|
;; - line-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)
|
|
|
|
(define (polygon-equal? p1 p2 eq-recur)
|
|
(and (eq-recur (polygon-mode p1) (polygon-mode p2))
|
|
(eq-recur (polygon-color p1) (polygon-color p2))
|
|
(let ([p1-points (polygon-points p1)]
|
|
[p2-points (polygon-points p2)])
|
|
(or (and (null? p1-points)
|
|
(null? p2-points))
|
|
(and (not (or (null? p1-points)
|
|
(null? p2-points)))
|
|
(or (compare-all-rotations p1-points p2-points eq-recur)
|
|
(compare-all-rotations p1-points (reverse p2-points) eq-recur)))))))
|
|
|
|
|
|
;; returns #t when there is some rotation of l1 that is equal to l2
|
|
(define (compare-all-rotations l1 l2 compare)
|
|
(cond
|
|
[(and (null? l1) (null? l2)) #t]
|
|
[else
|
|
(let ([v1 (list->vector l1)]
|
|
[v2 (list->vector l2)])
|
|
(and (= (vector-length v1)
|
|
(vector-length v2))
|
|
(let o-loop ([init 0])
|
|
(cond
|
|
[(= init (vector-length v1)) #f]
|
|
[else
|
|
(or (let i-loop ([i 0])
|
|
(cond
|
|
[(= i (vector-length v2))
|
|
#t]
|
|
[else
|
|
(let ([j (modulo (+ init i) (vector-length v1))])
|
|
(and (compare (vector-ref v1 j)
|
|
(vector-ref v2 i))
|
|
(i-loop (+ i 1))))]))
|
|
(o-loop (+ init 1)))]))))]))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;; ;; ;;
|
|
; ;; ;;;; ;
|
|
; ; ; ;; ;
|
|
; ;; ;;;;;;;;; ;;;;; ;;;;;; ;;;; ; ;; ;
|
|
; ;; ;; ;;; ;;;; ;; ;; ;; ;;; ;; ;; ;
|
|
; ;; ;; ;;; ;;; ;;;; ;;; ;; ;;;;;; ; ;;;
|
|
; ;; ;; ;;; ;;;;; ;; ;;; ;; ;;; ;;
|
|
; ;; ;; ;;; ;;;;; ;; ;;;;; ;;; ; ; ;; ;;
|
|
; ;; ;; ;;; ;;;;;;;;;; ;;;;;; ;;;; ;; ;;;
|
|
; ;; ;;
|
|
; ;; ;
|
|
; ;;;;
|
|
|
|
(define-local-member-name get-shape set-shape get-bb get-normalized? set-normalized get-normalized-shape)
|
|
|
|
(define image%
|
|
(class* snip% (equal<%>)
|
|
(init-field shape bb normalized?)
|
|
(define/public (equal-to? that eq-recur)
|
|
(eq-recur (get-normalized-shape)
|
|
(send that get-normalized-shape)))
|
|
(define/public (equal-hash-code-of y) 42)
|
|
(define/public (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-normalized?) normalized?)
|
|
(define/public (set-normalized? n?) (set! normalized? n?))
|
|
|
|
(define/public (get-normalized-shape)
|
|
(unless normalized?
|
|
(set! shape (normalize-shape shape values))
|
|
(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
|
|
(if (is-a? ed text%)
|
|
(send ed get-line-spacing)
|
|
0)))))))))
|
|
;; 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) (make-image shape bb normalized?))
|
|
(define/override (draw dc x y left top right bottom dx dy draw-caret?)
|
|
(let ([smoothing (send dc get-smoothing)])
|
|
(send dc set-smoothing 'aligned)
|
|
(render-image this dc x y)
|
|
(send dc set-smoothing smoothing)))
|
|
(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 (bb-bottom bb)])
|
|
(set-box/f! w (bb-right bb))
|
|
(set-box/f! h bottom)
|
|
(set-box/f! descent (- bottom (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)))])
|
|
(send f put (bytes-length bytes) bytes)))
|
|
|
|
(super-new)
|
|
|
|
(inherit set-snipclass)
|
|
(set-snipclass snip-class)))
|
|
|
|
(define scheme/base:read read)
|
|
|
|
(define image-snipclass%
|
|
(class snip-class%
|
|
(define/override (read f)
|
|
(let* ([bytes (send f get-unterminated-bytes)]
|
|
[str
|
|
(and bytes
|
|
(with-handlers ((exn:fail? (λ (x) #f)))
|
|
(bytes->string/utf-8 bytes)))]
|
|
[lst
|
|
(and str
|
|
(with-handlers ((exn:fail:read? (λ (x) #f)))
|
|
(parse
|
|
(scheme/base:read
|
|
(open-input-string
|
|
str)))))])
|
|
(if lst
|
|
(make-image (list-ref lst 0)
|
|
(list-ref lst 1)
|
|
#f)
|
|
(make-image (make-ellipse 100 100 0 'solid "black")
|
|
(make-bb 100 100 100)
|
|
#f))))
|
|
(super-new)))
|
|
|
|
(provide snip-class)
|
|
(define snip-class (new image-snipclass%))
|
|
(send snip-class set-classname (format "~s" '(lib "image-core.ss" "2htdp" "private")))
|
|
(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)))]
|
|
[(vector? sexp)
|
|
(if (= (vector-length sexp) 0)
|
|
(k #f)
|
|
(let ([constructor (id->constructor (vector-ref sexp 0))]
|
|
[args (cdr (vector->list sexp))])
|
|
(if (and constructor
|
|
(procedure-arity-includes? constructor (length args)))
|
|
(apply constructor (map loop args))
|
|
(k #f))))]
|
|
[else sexp]))))
|
|
|
|
(define-id->constructor id->constructor)
|
|
|
|
;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape
|
|
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
|
|
(define (normalize-shape shape [f values])
|
|
(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)))))
|
|
(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))]
|
|
[(polygon? shape)
|
|
(let* ([this-one
|
|
(make-polygon (map scale-point (polygon-points shape))
|
|
(polygon-mode shape)
|
|
(polygon-color shape))])
|
|
(if bottom
|
|
(make-overlay bottom (f this-one))
|
|
(f this-one)))]
|
|
[(line-segment? shape)
|
|
(let ([this-one
|
|
(make-line-segment (scale-point (line-segment-start shape))
|
|
(scale-point (line-segment-end shape))
|
|
(line-segment-color shape))])
|
|
(if bottom
|
|
(make-overlay bottom (f this-one))
|
|
(f this-one)))]
|
|
[(np-atomic-shape? shape)
|
|
(let ([this-one (make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
|
|
(if bottom
|
|
(make-overlay bottom (f this-one))
|
|
(f this-one)))]
|
|
[else
|
|
(error 'normalize-shape "unknown shape ~s\n" shape)])))
|
|
|
|
(define (simple-shape? shape)
|
|
(or (and (translate? shape)
|
|
(np-atomic-shape? (translate-shape shape)))
|
|
(polygon? shape)
|
|
(line-segment? shape)))
|
|
|
|
(define (atomic-shape? shape)
|
|
(or (polygon? shape)
|
|
(line-segment? shape)
|
|
(np-atomic-shape? shape)))
|
|
|
|
(define (np-atomic-shape? shape)
|
|
(or (ellipse? shape)
|
|
(text? shape)
|
|
(bitmap? shape)
|
|
(point? shape)))
|
|
|
|
(define (scale-np-atomic x-scale y-scale shape)
|
|
(cond
|
|
[(ellipse? shape)
|
|
(make-ellipse (* x-scale (ellipse-width shape))
|
|
(* y-scale (ellipse-height shape))
|
|
(ellipse-angle shape)
|
|
(ellipse-mode shape)
|
|
(ellipse-color shape))]
|
|
[(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))]
|
|
[(bitmap? shape)
|
|
(make-bitmap (bitmap-raw-bitmap shape)
|
|
(bitmap-raw-mask shape)
|
|
(bitmap-angle shape)
|
|
(* x-scale (bitmap-x-scale shape))
|
|
(* y-scale (bitmap-y-scale shape))
|
|
#f #f)]))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ;; ;;
|
|
; ;; ;;
|
|
; ;;;; ;;;; ;; ;;; ;;;;; ;;;; ;;;;;;; ;; ;;; ;;;;;;
|
|
; ;;;; ;; ;; ;;;;;; ;;;;;; ;; ;; ;;;; ;; ;;;;;; ;;;;;;
|
|
; ;; ;;;;;;;; ;; ;; ;;; ;; ;;;;;;;; ;; ;; ;; ;; ;;; ;;
|
|
; ;; ;;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;; ;;; ;;
|
|
; ;; ;;; ;; ;; ;; ;;;;;; ;;; ;; ;; ;; ;; ;; ;;;;;;
|
|
; ;; ;;;; ;; ;; ;;;;; ;;;; ;; ;; ;; ;; ;;;;;
|
|
; ;; ;;;
|
|
; ;;;;;
|
|
;
|
|
;
|
|
|
|
;; render-image : normalized-shape 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)])
|
|
(let loop ([shape (send image get-normalized-shape)])
|
|
(cond
|
|
[(overlay? shape)
|
|
(render-simple-shape (overlay-bottom shape) dc dx dy)
|
|
(loop (overlay-top shape))]
|
|
[else
|
|
(render-simple-shape shape dc dx dy)]))
|
|
(send dc set-pen pen)
|
|
(send dc set-brush brush)
|
|
(send dc set-font font)
|
|
(send dc set-text-foreground fg)))
|
|
|
|
(define (render-simple-shape simple-shape dc dx dy)
|
|
(cond
|
|
[(polygon? simple-shape)
|
|
(let ([path (new dc-path%)]
|
|
[points (polygon-points simple-shape)])
|
|
(send path move-to (point-x (car points)) (point-y (car points)))
|
|
(let loop ([point (make-rectangular (point-x (car points)) (point-y (car points)))]
|
|
[last-point (car points)]
|
|
[points (cdr points)])
|
|
(unless (null? points)
|
|
(let* ([vec (make-rectangular (- (point-x (car points))
|
|
(point-x last-point))
|
|
(- (point-y (car points))
|
|
(point-y last-point)))]
|
|
[endpoint (+ point vec (make-polar -1 (angle vec)))])
|
|
(send path line-to (real-part endpoint) (imag-part endpoint))
|
|
(loop endpoint (car points) (cdr points)))))
|
|
(send path line-to (point-x (car points)) (point-y (car points)))
|
|
(send dc set-pen (mode-color->pen (polygon-mode simple-shape) (polygon-color simple-shape)))
|
|
(send dc set-brush (mode-color->brush (polygon-mode simple-shape) (polygon-color simple-shape)))
|
|
(send dc draw-path path dx dy 'winding))]
|
|
[(line-segment? simple-shape)
|
|
(let ([path (new dc-path%)]
|
|
[start (line-segment-start simple-shape)]
|
|
[end (line-segment-end simple-shape)])
|
|
(send dc set-pen (line-segment-color simple-shape) 1 'solid)
|
|
(send dc set-brush "black" 'transparent)
|
|
(send dc draw-line
|
|
(+ dx (point-x start)) (+ dy (point-y start))
|
|
(+ dx (point-x end)) (+ dy (point-y end))))]
|
|
[else
|
|
(let ([dx (+ dx (translate-dx simple-shape))]
|
|
[dy (+ dy (translate-dy simple-shape))]
|
|
[atomic-shape (translate-shape simple-shape)])
|
|
(cond
|
|
[(ellipse? atomic-shape)
|
|
(let* ([path (new dc-path%)]
|
|
[ew (ellipse-width atomic-shape)]
|
|
[eh (ellipse-height atomic-shape)]
|
|
[θ (degrees->radians (ellipse-angle 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 (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
|
|
(send dc set-brush (mode-color->brush (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
|
|
(send dc draw-path path dx dy)))]
|
|
[(bitmap? atomic-shape)
|
|
(let ([bm (get-rendered-bitmap atomic-shape)])
|
|
(send dc draw-bitmap
|
|
bm
|
|
(- dx (/ (send bm get-width) 2))
|
|
(- dy (/ (send bm get-height) 2))
|
|
'solid
|
|
(send the-color-database find-color "black")
|
|
(get-rendered-mask atomic-shape)))]
|
|
[(text? atomic-shape)
|
|
(let ([θ (degrees->radians (text-angle atomic-shape))]
|
|
[font (send dc get-font)])
|
|
(send dc set-font (text->font atomic-shape))
|
|
(send dc set-text-foreground
|
|
(or (send the-color-database find-color (text-color atomic-shape))
|
|
(send the-color-database find-color "black")))
|
|
(let-values ([(w h _1 _2) (send dc get-text-extent (text-string atomic-shape))])
|
|
(let ([p (- (make-rectangular dx dy)
|
|
(* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
|
|
(send dc draw-text (text-string atomic-shape)
|
|
(real-part p)
|
|
(imag-part p)
|
|
#f 0 θ))))]))]))
|
|
|
|
#|
|
|
|
|
the mask bitmap and the original bitmap are all together in a single bytes!
|
|
|
|
|#
|
|
|
|
|
|
(define (get-rendered-bitmap bitmap)
|
|
(calc-renered-bitmap bitmap)
|
|
(bitmap-rendered-bitmap bitmap))
|
|
|
|
(define (get-rendered-mask bitmap)
|
|
(calc-renered-bitmap bitmap)
|
|
(bitmap-rendered-mask bitmap))
|
|
|
|
(define (calc-renered-bitmap bitmap)
|
|
(unless (bitmap-rendered-bitmap bitmap)
|
|
;; fill in the rendered bitmap with the raw bitmaps.
|
|
(set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap))
|
|
(set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))
|
|
(cond
|
|
[(and (= 1 (bitmap-x-scale bitmap))
|
|
(= 1 (bitmap-y-scale bitmap))
|
|
(= 0 (bitmap-angle bitmap)))
|
|
;; if there's no scaling or rotation, we can just keep that bitmap.
|
|
(void)]
|
|
[(<= (* (bitmap-x-scale bitmap)
|
|
(bitmap-y-scale bitmap))
|
|
1)
|
|
;; since we prefer to rotate big things, we rotate first
|
|
(do-rotate bitmap)
|
|
(do-scale bitmap)]
|
|
[else
|
|
;; since we prefer to rotate big things, we scale first
|
|
(do-scale bitmap)
|
|
(do-rotate bitmap)])))
|
|
|
|
(define (do-rotate bitmap)
|
|
(let ([θ (degrees->radians (bitmap-angle bitmap))])
|
|
(let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap) (bitmap-rendered-mask bitmap))])
|
|
(let-values ([(rotated-bytes rotated-w rotated-h)
|
|
(rotate-bytes bytes w h θ)])
|
|
(set-bitmap-rendered-bitmap!
|
|
bitmap
|
|
(bytes->bitmap rotated-bytes rotated-w rotated-h))
|
|
(set-bitmap-rendered-mask!
|
|
bitmap
|
|
(send (bitmap-rendered-bitmap bitmap) get-loaded-mask))))))
|
|
|
|
(define (do-scale bitmap)
|
|
(let* ([bdc (make-object bitmap-dc%)]
|
|
[orig-bm (bitmap-rendered-bitmap bitmap)]
|
|
[orig-mask (bitmap-rendered-mask bitmap)]
|
|
[orig-w (send orig-bm get-width)]
|
|
[orig-h (send orig-bm get-height)]
|
|
[x-scale (bitmap-x-scale bitmap)]
|
|
[y-scale (bitmap-y-scale bitmap)]
|
|
[scale-w (* x-scale (send orig-bm get-width))]
|
|
[scale-h (* y-scale (send orig-bm get-height))]
|
|
[new-bm (make-object bitmap% scale-w scale-h)]
|
|
[new-mask (make-object bitmap% scale-w scale-h)])
|
|
(send new-bm set-loaded-mask new-mask)
|
|
|
|
(send bdc set-bitmap new-bm)
|
|
(send bdc set-scale x-scale y-scale)
|
|
(send bdc clear)
|
|
(send bdc draw-bitmap orig-bm 0 0)
|
|
|
|
(send bdc set-bitmap new-mask)
|
|
(send bdc set-scale x-scale y-scale)
|
|
(send bdc clear)
|
|
(send bdc draw-bitmap orig-mask 0 0)
|
|
|
|
(send bdc set-bitmap #f)
|
|
|
|
(set-bitmap-rendered-bitmap! bitmap new-bm)
|
|
(set-bitmap-rendered-mask! bitmap new-mask)))
|
|
|
|
(define (text->font text)
|
|
(cond
|
|
[(text-face text)
|
|
(send the-font-list find-or-create-font
|
|
(text-size text)
|
|
(text-face text)
|
|
(text-family text)
|
|
(text-style text)
|
|
(text-weight text)
|
|
(text-underline text))]
|
|
[else
|
|
(send the-font-list find-or-create-font
|
|
(text-size text)
|
|
(text-family text)
|
|
(text-style text)
|
|
(text-weight text)
|
|
(text-underline text))]))
|
|
|
|
(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 (degrees->radians θ)
|
|
(* θ 2 pi (/ 360)))
|
|
|
|
(define (mode-color->pen mode color)
|
|
(cond
|
|
[(eq? mode 'solid)
|
|
(send the-pen-list find-or-create-pen "black" 1 'transparent)]
|
|
[else
|
|
(send the-pen-list find-or-create-pen color 1 'solid)]))
|
|
|
|
(define (mode-color->brush mode color)
|
|
(cond
|
|
[(eq? mode 'solid)
|
|
(send the-brush-list find-or-create-brush color 'solid)]
|
|
[else
|
|
(send the-brush-list find-or-create-brush "black" 'transparent)]))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(provide make-image image-shape image-bb image-normalized? image%
|
|
|
|
(struct-out bb)
|
|
(struct-out point)
|
|
make-overlay overlay? overlay-top overlay-bottom
|
|
make-translate translate? translate-dx translate-dy translate-shape
|
|
make-scale scale-x scale-y scale-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
|
|
make-polygon polygon? polygon-points polygon-mode polygon-color
|
|
make-line-segment line-segment? line-segment-start line-segment-end line-segment-color
|
|
|
|
make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale
|
|
bitmap-rendered-bitmap bitmap-rendered-mask
|
|
|
|
degrees->radians
|
|
normalize-shape
|
|
ellipse-rotated-size
|
|
|
|
image?
|
|
image-right
|
|
image-bottom
|
|
image-baseline
|
|
|
|
text->font
|
|
compare-all-rotations
|
|
render-image)
|
|
|
|
;; method names
|
|
(provide get-shape get-bb get-normalized?)
|
|
|
|
(provide np-atomic-shape? atomic-shape? simple-shape?)
|