suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ensure snips handle rendering errors

Browse Source 
Fraction tick formatting more reasonable for non-ticks (e.g. selection bounds, eventually plot labels)
This commit is contained in:
Neil Toronto 2011-11-22 17:32:11 -07:00
parent 547ac9c7d8
commit bddcd76f7f
8 changed files with 169 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/plot/common/format.rkt
View File

@ -51,9 +51,10 @@
;; Returns the number of fractional digits needed to distinguish numbers [x-min..x-max]
(defproc (digits-for-range [x-min real?] [x-max real?]
[base (and/c exact-integer? (>=/c 2)) 10]
[extra-digits exact-integer? 3]) exact-integer?
(define range (abs (- x-max x-min)))
(+ extra-digits (if (zero? range) 0 (- (floor-log/base 10 range)))))
(+ extra-digits (if (zero? range) 0 (- (floor-log/base base range)))))
(define (int-str->e-str str)
(define n (string-length str))
@ -144,14 +145,14 @@
[(-inf.0) "-inf.0"]
[else "<unknown>"]))
(defproc (ivl->string [i ivl?] [extra-digits exact-integer? 3]) string?
(defproc (ivl->plot-label [i ivl?] [extra-digits exact-integer? 3]) string?
(match-define (ivl a b) i)
(cond [(and (not (rational? a)) (not (rational? b)))
(format "[~a,~a]" (format-special a) (format-special b))]
[(not (rational? a)) (format "[~a,~a]" (format-special a) (real->plot-label b 15))]
[(not (rational? b)) (format "[~a,~a]" (real->plot-label a 15) (format-special b))]
[else
(define digits (digits-for-range a b extra-digits))
(define digits (digits-for-range a b 10 extra-digits))
(format "[~a,~a]"
(real->plot-label a digits)
(real->plot-label b digits))]))
@ -161,6 +162,7 @@
(cond [(string? a) a]
[(symbol? a) (symbol->string a)]
[(real? a) (real->plot-label a digits)]
[(ivl? a) (ivl->plot-label a)]
[(list? a) (string-append "(" (string-join (map loop a) " ") ")")]
[(cons? a) (string-append "(" (loop (car a)) " . " (loop (cdr a)) ")")]
[(boolean? a) (if a "true" "false")]

29
collects/plot/common/snip.rkt
View File

@ -21,6 +21,13 @@
(define/public (get-saved-plot-parameters) saved-plot-parameters)
(define x-mid (* 1/2 (send bm get-width)))
(define y-mid (* 1/2 (send bm get-height)))
(define/public (set-message-center new-x-mid new-y-mid)
(set! x-mid new-x-mid)
(set! y-mid new-y-mid))
(define/public (refresh)
;(printf "~a: refresh~n" (current-milliseconds))
(set-bitmap (get-bitmap)))
@ -58,14 +65,24 @@
(define box-x-size (apply max line-widths))
(define box-y-size (+ baseline (* (length lines) (+ char-height baseline))))
(define box-x-min (+ dc-x-min (* 1/2 (- width box-x-size))))
(define box-y-min (+ dc-y-min (* 1/2 (- height box-y-size))))
(define box-x-max (+ box-x-min box-x-size))
(define box-y-max (+ box-y-min box-y-size))
(define box-x-min (+ dc-x-min (- x-mid (* 1/2 box-x-size))))
(define box-x-max (+ dc-x-min (+ x-mid (* 1/2 box-x-size))))
(define box-y-min (+ dc-y-min (- y-mid (* 1/2 box-y-size))))
(define box-y-max (+ dc-y-min (+ y-mid (* 1/2 box-y-size))))
(send pd set-alpha 2/3)
(define box-rect (vector (ivl box-x-min box-x-max) (ivl box-y-min box-y-max)))
;; inside selection
(send pd set-pen (plot-foreground) 1 'transparent)
(send pd set-brush (plot-background) 'solid)
(send pd set-alpha 1/4)
(send pd draw-rect box-rect)
;; selection border
(send pd set-minor-pen)
(send pd draw-rect (vector (ivl box-x-min box-x-max) (ivl box-y-min box-y-max)))
(send pd set-brush (plot-background) 'transparent)
(send pd set-alpha 3/4)
(send pd draw-rect box-rect)
(send pd set-alpha 1)
(for ([line (in-list lines)] [i (in-naturals)])

15
collects/plot/common/ticks.rkt
View File

@ -593,16 +593,25 @@
(let ([x (- x w)])
(format "~a ~a/~a" w (numerator x) (denominator x)))])]))
(defproc (fraction-ticks-format) ticks-format/c
(defproc (fraction-ticks-format [#:base base (and/c exact-integer? (>=/c 2)) 10]
[#:divisors divisors (listof exact-positive-integer?) '(1 2 3 4 5)]
) ticks-format/c
(define fracs (remove-duplicates (map (λ (d) (/ d base)) divisors)))
(λ (x-min x-max ts)
(define digits (digits-for-range x-min x-max base (ceiling-log/base base 1000)))
(define fracs (remove-duplicates (map (λ (d) (* (/ base d) (expt base (- digits)))) divisors)))
(for/list ([t (in-list ts)])
(format-fraction (pre-tick-value t)))))
(define x (inexact->exact (pre-tick-value t)))
(define xs
(for/list ([frac (in-list fracs)])
(* frac (round (/ x frac)))))
(format-fraction (argmin (λ (y) (abs (- x y))) xs)))))
(defproc (fraction-ticks [#:base base (and/c exact-integer? (>=/c 2)) 10]
[#:divisors divisors (listof exact-positive-integer?) '(1 2 3 4 5)]
) ticks? #:document-body
(ticks (linear-ticks #:base base #:divisors divisors)
(fraction-ticks-format)))
(fraction-ticks-format #:base base #:divisors divisors)))
;; ===================================================================================================
;; Tick combinators

2
collects/plot/contracted/format.rkt
View File

@ -7,5 +7,5 @@
integer->superscript
digits-for-range
real->decimal-string* real->string/trunc
real->plot-label ivl->string ->plot-label
real->plot-label ivl->plot-label ->plot-label
parse-format-string apply-formatter))

2
collects/plot/plot2d/plot.rkt
View File

@ -41,7 +41,7 @@
(rect-zero-area? plot-bounds-rect))
(match-define (vector x-ivl y-ivl) plot-bounds-rect)
(error 'plot "could not determine sensible plot bounds; got x ∈ ~a, y ∈ ~a"
(ivl->string x-ivl) (ivl->string y-ivl)))
(ivl->plot-label x-ivl) (ivl->plot-label y-ivl)))
plot-bounds-rect)
(define (get-ticks renderer-list bounds-rect)

188
collects/plot/plot2d/snip.rkt
View File

@ -25,6 +25,12 @@
(super-make-object bm saved-plot-parameters)
(define (set-message-center)
(match-define (vector x-mid y-mid) (rect-center area-bounds-rect))
(send this set-message-center x-mid y-mid))
(set-message-center)
(define/override (copy)
(make-object this%
(get-bitmap) (get-saved-plot-parameters)
@ -37,7 +43,7 @@
(define plot-bounds-rects empty)
(define (get-area-bounds-rect)
(define (get-new-area-bounds-rect)
(rect-meet area-bounds-rect
(rect-inexact->exact
(vector (ivl left-click-x left-drag-x) (ivl left-click-y left-drag-y)))))
@ -58,12 +64,32 @@
(set-message "Click and drag to zoom\n Click to unzoom once")))
(define (update-plot new-plot-bounds-rect)
(define-values (new-bm new-area-bounds-rect new-area-bounds->plot-bounds)
(make-plot new-plot-bounds-rect))
(set! plot-bounds-rect new-plot-bounds-rect)
(set! area-bounds-rect new-area-bounds-rect)
(set! area-bounds->plot-bounds new-area-bounds->plot-bounds)
(set-bitmap new-bm))
(with-handlers ([(λ (e) #t) (λ (e)
(refresh)
(make-object timer% (λ () (raise e)) 1))])
(define-values (new-bm new-area-bounds-rect new-area-bounds->plot-bounds)
(make-plot new-plot-bounds-rect))
(set! plot-bounds-rect new-plot-bounds-rect)
(set! area-bounds-rect new-area-bounds-rect)
(set! area-bounds->plot-bounds new-area-bounds->plot-bounds)
(set-bitmap new-bm)
(set-message-center)))
(define (zoom-or-unzoom)
(cond [dragging?
(set! dragging? #f)
(define new-rect (area-bounds->plot-bounds (get-new-area-bounds-rect)))
(cond [(and (rect-rational? new-rect) (not (rect-zero-area? new-rect)))
#;(printf "~a: new-plot-bounds-rect = ~v~n"
(current-milliseconds) new-rect)
(set! plot-bounds-rects (cons plot-bounds-rect plot-bounds-rects))
(update-plot new-rect)]
[else (refresh)])]
[(not (empty? plot-bounds-rects))
(define new-rect (first plot-bounds-rects))
(set! plot-bounds-rects (rest plot-bounds-rects))
(set! show-zoom-message? #f)
(update-plot new-rect)]))
(define/override (on-event dc x y editorx editory evt)
(define evt-type (send evt get-event-type))
@ -79,21 +105,8 @@
(set-zoom-timer)]
[(left-up) (set! left-drag-x mouse-x)
(set! left-drag-y mouse-y)
(cond [dragging?
(set! dragging? #f)
(define new-rect (area-bounds->plot-bounds (get-area-bounds-rect)))
(cond [(and (rect-rational? new-rect) (not (rect-zero-area? new-rect)))
#;(printf "~a: new-plot-bounds-rect = ~v~n"
(current-milliseconds) new-rect)
(set! plot-bounds-rects (cons plot-bounds-rect plot-bounds-rects))
(update-plot new-rect)]
[else (refresh)])]
[(not (empty? plot-bounds-rects))
(define new-rect (first plot-bounds-rects))
(set! plot-bounds-rects (rest plot-bounds-rects))
(update-plot new-rect)
(set! show-zoom-message? #f)])]
[(motion) (cond [(get-left-down-here?) ; not event's left-down: only #t if clicked on snip
(zoom-or-unzoom)]
[(motion) (cond [(get-left-down-here?) ; only #t if clicked on snip
(when (not (and (= left-drag-x mouse-x)
(= left-drag-y mouse-y)))
(set! left-drag-x mouse-x)
@ -106,72 +119,75 @@
(set-click-message)])])
(super on-event dc x y editorx editory evt))
(define/override (draw dc dc-x-min dc-y-min left top right bottom dx dy draw-caret)
(define (draw-selection dc dc-x-min dc-y-min rect)
(when (and (rect-rational? rect) (not (rect-zero-area? rect)))
(define width (send (get-bitmap) get-width))
(define height (send (get-bitmap) get-height))
(define pd (make-object plot-device% dc dc-x-min dc-y-min width height))
(send pd reset-drawing-params #f)
(define select-color (get-highlight-background-color))
(define select-rect (rect-translate rect (vector dc-x-min dc-y-min)))
;; inside selection
(send pd set-pen select-color 1 'transparent)
(send pd set-brush select-color 'solid)
(send pd set-alpha 1/4)
(send pd draw-rect select-rect)
;; selection border
(send pd set-minor-pen)
(send pd set-brush select-color 'transparent)
(send pd set-alpha 3/4)
(send pd draw-rect select-rect)
;; format side labels
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) plot-bounds-rect)
(match-define (vector (ivl new-x-min new-x-max) (ivl new-y-min new-y-max))
(area-bounds->plot-bounds rect))
(match-define (list new-x-min-str new-x-max-str)
((ticks-format (plot-x-ticks))
x-min x-max (list (pre-tick new-x-min #t) (pre-tick new-x-max #t))))
(match-define (list new-y-min-str new-y-max-str)
((ticks-format (plot-y-ticks))
y-min y-max (list (pre-tick new-y-min #t) (pre-tick new-y-max #t))))
;; draw side labels
(match-define (vector (ivl new-area-x-min new-area-x-max)
(ivl new-area-y-min new-area-y-max))
rect)
(define new-area-x-mid (* 1/2 (+ new-area-x-min new-area-x-max)))
(define new-area-y-mid (* 1/2 (+ new-area-y-min new-area-y-max)))
(send pd set-alpha 1)
(send pd draw-text new-x-min-str
(vector (+ dc-x-min new-area-x-min) (+ dc-y-min new-area-y-mid))
'center (* 1/2 pi) #:outline? #t)
(send pd draw-text new-x-max-str
(vector (+ dc-x-min new-area-x-max) (+ dc-y-min new-area-y-mid))
'center (* 1/2 pi) #:outline? #t)
(send pd draw-text new-y-min-str
(vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-max))
'center #:outline? #t)
(send pd draw-text new-y-max-str
(vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-min))
'center #:outline? #t)
(send pd restore-drawing-params)))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
;(printf "~a: drawing~n" (current-milliseconds))
(super draw dc dc-x-min dc-y-min left top right bottom dx dy draw-caret)
(super draw dc x y left top right bottom dx dy draw-caret)
(when dragging?
(define new-rect (get-area-bounds-rect))
(when (and (rect-rational? new-rect) (not (rect-zero-area? new-rect)))
(define width (send (get-bitmap) get-width))
(define height (send (get-bitmap) get-height))
(define pd (make-object plot-device% dc dc-x-min dc-y-min width height))
(send pd reset-drawing-params #f)
(define select-color (get-highlight-background-color))
(define draw-rect (rect-translate new-rect (vector dc-x-min dc-y-min)))
;; inside of selection box
(send pd set-pen select-color 1 'transparent)
(send pd set-brush select-color 'solid)
(send pd set-alpha 1/4)
(send pd draw-rect draw-rect)
;; border of selection box
(send pd set-minor-pen)
(send pd set-brush select-color 'transparent)
(send pd set-alpha 3/4)
(send pd draw-rect draw-rect)
;; side labels
(parameterize/group ([plot-parameters (get-saved-plot-parameters)])
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) plot-bounds-rect)
(match-define (vector (ivl new-area-x-min new-area-x-max)
(ivl new-area-y-min new-area-y-max))
new-rect)
(match-define (vector (ivl new-x-min new-x-max) (ivl new-y-min new-y-max))
(area-bounds->plot-bounds new-rect))
(define new-area-x-mid (* 1/2 (+ new-area-x-min new-area-x-max)))
(define new-area-y-mid (* 1/2 (+ new-area-y-min new-area-y-max)))
;; format new-x-min and new-x-max
(match-define (list new-x-min-str new-x-max-str)
((ticks-format (plot-x-ticks))
x-min x-max (list (pre-tick new-x-min #t) (pre-tick new-x-max #t))))
;; draw new-x-min
(send pd draw-text new-x-min-str
(vector (+ dc-x-min new-area-x-min) (+ dc-y-min new-area-y-mid))
'center (* 1/2 pi) #:outline? #t)
;; draw new-x-max
(send pd draw-text new-x-max-str
(vector (+ dc-x-min new-area-x-max) (+ dc-y-min new-area-y-mid))
'center (* 1/2 pi) #:outline? #t)
;; format new-y-min and new-y-max
(match-define (list new-y-min-str new-y-max-str)
((ticks-format (plot-y-ticks))
y-min y-max (list (pre-tick new-y-min #t) (pre-tick new-y-max #t))))
;; draw new-y-min
(send pd draw-text new-y-min-str
(vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-max))
'center #:outline? #t)
;; draw new-y-max
(send pd draw-text new-y-max-str
(vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-min))
'center #:outline? #t))
(send pd restore-drawing-params))))
(parameterize/group ([plot-parameters (get-saved-plot-parameters)])
(draw-selection dc x y (get-new-area-bounds-rect)))))
))
(define (make-2d-plot-snip bm saved-plot-parameters

2
collects/plot/plot3d/plot.rkt
View File

@ -41,7 +41,7 @@
(rect-zero-area? plot-bounds-rect))
(match-define (vector x-ivl y-ivl z-ivl) plot-bounds-rect)
(error 'plot "could not determine sensible plot bounds; got x ∈ ~a, y ∈ ~a, z ∈ ~a"
(ivl->string x-ivl) (ivl->string y-ivl) (ivl->string z-ivl)))
(ivl->plot-label x-ivl) (ivl->plot-label y-ivl) (ivl->plot-label z-ivl)))
plot-bounds-rect)
(define (get-ticks renderer-list bounds-rect)

24
collects/plot/tests/selection-tests.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang racket
;; These tests aren't meant to be run so much as manipulated after running
(require plot plot/utils)
(parameterize ([plot-x-transform log-transform])
(plot (function values +min.0 1)))
(define raise-error? #f)
(plot (function (λ (x)
(when raise-error?
(error 'buh "buh buh"))
(sin x))
-4 4))
(plot3d (surface3d (λ (x y)
(when raise-error?
(error 'buh "buh buh buh"))
(- (sqr x) (sqr y)))
-1 1 -1 1))
(set! raise-error? #t)