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

Added 'isoline' and 'isoline*' aliases for contour functions.

Browse Source 
Added #:family argument to 2D label functions.
Various little fixes.
This commit is contained in:
Neil Toronto 2011-11-02 10:16:27 -06:00
parent dab5caf67c
commit 639ec15125
13 changed files with 307 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
collects/plot/common/contract.rkt
View File

@ -15,8 +15,8 @@
;; ===================================================================================================
;; Plot-specific contracts
(defcontract anchor/c (one-of/c 'top-left 'top 'top-right
'left 'center 'right
(defcontract anchor/c (one-of/c 'top-left 'top 'top-right
'left 'center 'right
'bottom-left 'bottom 'bottom-right))
(defcontract color/c (or/c (list/c real? real? real?)
@ -26,31 +26,38 @@
(defcontract plot-color/c (or/c exact-integer? color/c))
(defcontract plot-pen-style/c (or/c exact-integer?
(one-of/c 'transparent 'solid 'dot 'long-dash
'short-dash 'dot-dash)))
(one-of/c 'transparent 'solid 'dot 'long-dash
'short-dash 'dot-dash)))
(defcontract plot-brush-style/c (or/c exact-integer?
(one-of/c 'transparent 'solid
'bdiagonal-hatch 'fdiagonal-hatch 'crossdiag-hatch
'horizontal-hatch 'vertical-hatch 'cross-hatch)))
(one-of/c 'transparent 'solid
'bdiagonal-hatch 'fdiagonal-hatch 'crossdiag-hatch
'horizontal-hatch 'vertical-hatch 'cross-hatch)))
(defcontract font-family/c (one-of/c 'default 'decorative 'roman 'script 'swiss
'modern 'symbol 'system))
(defcontract font-family/c (one-of/c 'default 'decorative 'roman 'script 'swiss
'modern 'symbol 'system))
(defthing known-point-symbols (listof symbol?) #:document-value
'(dot point pixel
plus times asterisk 5asterisk
odot oplus otimes oasterisk o5asterisk
circle square diamond triangle
fullcircle fullsquare fulldiamond fulltriangle
triangleup triangledown triangleleft triangleright
fulltriangleup fulltriangledown fulltriangleleft fulltriangleright
rightarrow leftarrow uparrow downarrow
4star 5star 6star 7star 8star
full4star full5star full6star full7star full8star
circle1 circle2 circle3 circle4 circle5 circle6 circle7 circle8
bullet fullcircle1 fullcircle2 fullcircle3 fullcircle4
fullcircle5 fullcircle6 fullcircle7 fullcircle8))
(list 'dot 'point 'pixel
'plus 'times 'asterisk
'5asterisk 'odot 'oplus
'otimes 'oasterisk 'o5asterisk
'circle 'square 'diamond
'triangle 'fullcircle 'fullsquare
'fulldiamond 'fulltriangle 'triangleup
'triangledown 'triangleleft 'triangleright
'fulltriangleup 'fulltriangledown 'fulltriangleleft
'fulltriangleright 'rightarrow 'leftarrow
'uparrow 'downarrow '4star
'5star '6star '7star
'8star 'full4star 'full5star
'full6star 'full7star 'full8star
'circle1 'circle2 'circle3
'circle4 'circle5 'circle6
'circle7 'circle8 'bullet
'fullcircle1 'fullcircle2 'fullcircle3
'fullcircle4 'fullcircle5 'fullcircle6
'fullcircle7 'fullcircle8))
(defcontract point-sym/c (or/c char? string? integer? (apply one-of/c known-point-symbols)))

14
collects/plot/common/math.rkt
View File

@ -42,16 +42,16 @@
(define fldistance
(case-lambda
[() 0]
[(x) (if (flonum? x) (abs x) (raise-type-error 'distance "flonum" x))]
[(x y) (cond [(not (flonum? x)) (raise-type-error 'distance "flonum" 0 x y)]
[(not (flonum? y)) (raise-type-error 'distance "flonum" 1 x y)]
[(x) (if (flonum? x) (abs x) (raise-type-error 'fldistance "flonum" x))]
[(x y) (cond [(not (flonum? x)) (raise-type-error 'fldistance "flonum" 0 x y)]
[(not (flonum? y)) (raise-type-error 'fldistance "flonum" 1 x y)]
[else (unsafe-flsqrt (unsafe-fl+ (unsafe-fl* x x) (unsafe-fl* y y)))])]
[(x y z) (cond [(not (flonum? x)) (raise-type-error 'distance "flonum" 0 x y z)]
[(not (flonum? y)) (raise-type-error 'distance "flonum" 1 x y z)]
[(not (flonum? z)) (raise-type-error 'distance "flonum" 2 x y z)]
[(x y z) (cond [(not (flonum? x)) (raise-type-error 'fldistance "flonum" 0 x y z)]
[(not (flonum? y)) (raise-type-error 'fldistance "flonum" 1 x y z)]
[(not (flonum? z)) (raise-type-error 'fldistance "flonum" 2 x y z)]
[else (unsafe-flsqrt (unsafe-fl+ (unsafe-fl+ (unsafe-fl* x x) (unsafe-fl* y y))
(unsafe-fl* z z)))])]
[xs (cond [(not (andmap flonum? xs)) (raise-type-error 'distance "flonums" xs)]
[xs (cond [(not (andmap flonum? xs)) (raise-type-error 'fldistance "flonums" xs)]
[else (unsafe-flsqrt (flsum (λ (x) (unsafe-fl* x x)) xs))])]))
;; ===================================================================================================

2
collects/plot/common/parameters.rkt
View File

@ -28,7 +28,7 @@
(defparam plot-tick-size (>=/c 0) 10)
(defparam plot-font-size size (>=/c 0) 11)
(defparam plot-font-family family font-family/c 'roman)
(defparam plot-legend-anchor anchor anchor/c 'top-right)
(defparam plot-legend-anchor anchor anchor/c 'top-left)
(defparam plot-legend-box-alpha alpha (real-in 0 1) 2/3)
(defparam plot-animating? boolean? #f)

2
collects/plot/deprecated/renderers.rkt
View File

@ -30,7 +30,7 @@
#:samples samples #:width width #:color color)])]))
(define (contour-renderer f samples width color levels)
(contours f #:samples samples #:levels (if (exact-integer? levels) (sub1 levels) levels)
(isolines f #:samples samples #:levels (if (exact-integer? levels) (sub1 levels) levels)
#:colors (list color) #:widths (list width) #:styles '(solid)))
(define (shade-fill-colors zs)

6
collects/plot/main.rkt
View File

@ -44,7 +44,8 @@
lines-interval parametric-interval polar-interval function-interval inverse-interval))
(require "plot2d/contour.rkt")
(provide (activate-contract-out contours contour-intervals))
(provide (activate-contract-out contours contour-intervals
isoline isolines isoline-intervals))
(require "plot2d/rectangle.rkt")
(provide (activate-contract-out rectangles area-histogram discrete-histogram))
@ -69,7 +70,8 @@
(provide (activate-contract-out surface3d))
(require "plot3d/contour.rkt")
(provide (activate-contract-out contours3d contour-intervals3d))
(provide (activate-contract-out contour3d contours3d contour-intervals3d
isoline3d isolines3d isoline-intervals3d))
(require "plot3d/line.rkt")
(provide (activate-contract-out lines3d parametric3d))

7
collects/plot/plot2d/area.rkt
View File

@ -42,6 +42,9 @@
(define x-size (- x-max x-min))
(define y-size (- y-max y-min))
(define x-mid (* 1/2 (+ x-min x-max)))
(define y-mid (* 1/2 (+ y-min y-max)))
(define clipping? #f)
(define clip-x-min x-min)
(define clip-x-max x-max)
@ -98,6 +101,10 @@
(define view->dc #f)
(define/public (plot->dc v) (view->dc (plot->view v)))
(define/public (plot-line->dc-angle v1 v2)
(match-define (vector dx dy) (v- (plot->dc v1) (plot->dc v2)))
(- (atan2 (- dy) dx)))
(define (make-view->dc left right top bottom)
(define corners (list (vector x-min y-min) (vector x-min y-max)
(vector x-max y-min) (vector x-max y-max)))

60
collects/plot/plot2d/contour.rkt
View File

@ -2,19 +2,66 @@
;; Renderers for contour lines and contour intervals
(require racket/contract racket/class racket/match racket/list racket/flonum racket/vector
(require racket/contract racket/class racket/match racket/list racket/flonum racket/vector racket/math
plot/utils
"../common/contract-doc.rkt")
(provide (all-defined-out))
(provide (all-defined-out)
(rename-out [contours isolines]
[contour-intervals isoline-intervals]))
;; ===================================================================================================
;; One contour line
(define ((isoline-render-proc f z samples color width style alpha label) area)
(define-values (x-min x-max y-min y-max) (send area get-bounds))
(match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples))
(define zs (2d-sample->list zss))
(define z-min (apply min* zs))
(define z-max (apply max* zs))
(when (<= z-min z z-max)
(send area set-alpha alpha)
(send area set-pen color width style)
(for ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for/list ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
(send/apply area put-line (map (λ (v) (vector-take v 2)) line)))))
(cond [label (line-legend-entry label color width style)]
[else empty]))
(defproc (isoline
[f (real? real? . -> . real?)] [z real?]
[x-min (or/c real? #f) #f] [x-max (or/c real? #f) #f]
[y-min (or/c real? #f) #f] [y-max (or/c real? #f) #f]
[#:samples samples (and/c exact-integer? (>=/c 2)) (contour-samples)]
[#:color color plot-color/c (line-color)]
[#:width width (>=/c 0) (line-width)]
[#:style style plot-pen-style/c (line-style)]
[#:alpha alpha (real-in 0 1) (line-alpha)]
[#:label label (or/c string? #f) #f]
) renderer2d?
(define g (2d-function->sampler f))
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(isoline-render-proc g z samples color width style alpha label)))
;; ===================================================================================================
;; Contour lines
(define ((contours-render-proc f levels samples colors widths styles alphas label) area)
(define ((contours-render-proc f g levels samples colors widths styles alphas label) area)
(let/ec return
(define-values (x-min x-max y-min y-max) (send area get-bounds))
(match-define (list xs ys zss) (f x-min x-max samples y-min y-max samples))
(match-define (list xs ys zss) (g x-min x-max samples y-min y-max samples))
(define-values (z-min z-max)
(let ([zs (filter regular? (2d-sample->list zss))])
@ -47,7 +94,8 @@
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for/list ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
(send/apply area put-line (map (λ (v) (vector-take v 2)) line)))))
(match-define (list v1 v2) (map (λ (v) (vector-take v 2)) line))
(send area put-line v1 v2))))
(cond [label (line-legend-entries label zs labels colors widths styles)]
[else empty])))
@ -66,7 +114,7 @@
) renderer2d?
(define g (2d-function->sampler f))
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(contours-render-proc g levels samples colors widths styles alphas label)))
(contours-render-proc f g levels samples colors widths styles alphas label)))
;; ===================================================================================================
;; Contour intervals

19
collects/plot/plot2d/decoration.rkt
View File

@ -9,7 +9,6 @@
"line.rkt"
"interval.rkt"
"point.rkt"
"contour.rkt"
"clip.rkt")
(provide (all-defined-out))
@ -220,12 +219,13 @@
(match-define (vector x y) v)
(format "(~a,~a)" (format-x-coordinate x area) (format-y-coordinate y area)))
(define ((label-render-proc label v color size anchor angle point-size alpha) area)
(define ((label-render-proc label v color size family anchor angle point-size alpha) area)
(let ([label (if label label (format-coordinate v area))])
(send area set-alpha alpha)
; label
(send area set-text-foreground color)
(send area set-font-size size)
(send area set-font-family family)
(send area put-text (string-append " " label " ") v anchor angle #:outline? #t)
; point
(send area set-pen color 1 'solid)
@ -237,6 +237,7 @@
[v (vector/c real? real?)] [label (or/c string? #f) #f]
[#:color color plot-color/c (plot-foreground)]
[#:size size (>=/c 0) (plot-font-size)]
[#:family family font-family/c (plot-font-family)]
[#:anchor anchor anchor/c (label-anchor)]
[#:angle angle real? (label-angle)]
[#:point-size point-size (>=/c 0) (label-point-size)]
@ -244,13 +245,14 @@
) renderer2d?
(match-define (vector x y) v)
(renderer2d (vector (ivl x x) (ivl y y)) #f #f
(label-render-proc label v color size anchor angle point-size alpha)))
(label-render-proc label v color size family anchor angle point-size alpha)))
(defproc (parametric-label
[f (real? . -> . (vector/c real? real?))]
[t real?] [label (or/c string? #f) #f]
[#:color color plot-color/c (plot-foreground)]
[#:size size (>=/c 0) (plot-font-size)]
[#:family family font-family/c (plot-font-family)]
[#:anchor anchor anchor/c (label-anchor)]
[#:angle angle real? (label-angle)]
[#:point-size point-size (>=/c 0) (label-point-size)]
@ -259,44 +261,47 @@
(point-label (match f
[(vector fx fy) (vector (fx t) (fy t))]
[(? procedure?) (f t)])
label #:color color #:size size #:anchor anchor #:angle angle
label #:color color #:size size #:family family #:anchor anchor #:angle angle
#:point-size point-size #:alpha alpha))
(defproc (polar-label
[f (real? . -> . real?)] [θ real?] [label (or/c string? #f) #f]
[#:color color plot-color/c (plot-foreground)]
[#:size size (>=/c 0) (plot-font-size)]
[#:family family font-family/c (plot-font-family)]
[#:anchor anchor anchor/c (label-anchor)]
[#:angle angle real? (label-angle)]
[#:point-size point-size (>=/c 0) (label-point-size)]
[#:alpha alpha (real-in 0 1) (label-alpha)]
) renderer2d?
(point-label (polar->cartesian θ (f θ)) label
#:color color #:size size #:anchor anchor #:angle angle
#:color color #:size size #:family family #:anchor anchor #:angle angle
#:point-size point-size #:alpha alpha))
(defproc (function-label
[f (real? . -> . real?)] [x real?] [label (or/c string? #f) #f]
[#:color color plot-color/c (plot-foreground)]
[#:size size (>=/c 0) (plot-font-size)]
[#:family family font-family/c (plot-font-family)]
[#:anchor anchor anchor/c (label-anchor)]
[#:angle angle real? (label-angle)]
[#:point-size point-size (>=/c 0) (label-point-size)]
[#:alpha alpha (real-in 0 1) (label-alpha)]
) renderer2d?
(point-label (vector x (f x)) label
#:color color #:size size #:anchor anchor #:angle angle
#:color color #:size size #:family family #:anchor anchor #:angle angle
#:point-size point-size #:alpha alpha))
(defproc (inverse-label
[f (real? . -> . real?)] [y real?] [label (or/c string? #f) #f]
[#:color color plot-color/c (plot-foreground)]
[#:size size (>=/c 0) (plot-font-size)]
[#:family family font-family/c (plot-font-family)]
[#:anchor anchor anchor/c (label-anchor)]
[#:angle angle real? (label-angle)]
[#:point-size point-size (>=/c 0) (label-point-size)]
[#:alpha alpha (real-in 0 1) (label-alpha)]
) renderer2d?
(point-label (vector (f y) y) label
#:color color #:size size #:anchor anchor #:angle angle
#:color color #:size size #:family family #:anchor anchor #:angle angle
#:point-size point-size #:alpha alpha))

55
collects/plot/plot3d/contour.rkt
View File

@ -4,7 +4,60 @@
plot/utils
"../common/contract-doc.rkt")
(provide (all-defined-out))
(provide (all-defined-out)
(rename-out [contour3d isoline3d]
[contours3d isolines3d]
[contour-intervals3d isoline-intervals3d]))
;; ===================================================================================================
;; One contour line in 3D (using marching squares)
(define ((contour3d-render-proc f z samples color width style alpha label) area)
(define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds))
(match-define (list xs ys zss) (f x-min x-max (animated-samples samples)
y-min y-max (animated-samples samples)))
(when (<= z-min z z-max)
(send area put-alpha alpha)
(send area put-pen color width style)
(for ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)])
(for ([line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
(match-define (list v1 v2) line)
(define center (vector (* 1/2 (+ xa xb)) (* 1/2 (+ ya yb))
(* 1/2 (+ (min z1 z2 z3 z4) (max z1 z2 z3 z4)))))
(send area put-line v1 v2 center))))
(cond [label (line-legend-entry label color width style)]
[else empty]))
(defproc (contour3d
[f (real? real? . -> . real?)] [z real?]
[x-min (or/c real? #f) #f] [x-max (or/c real? #f) #f]
[y-min (or/c real? #f) #f] [y-max (or/c real? #f) #f]
[#:z-min z-min (or/c real? #f) #f] [#:z-max z-max (or/c real? #f) #f]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:color color plot-color/c (line-color)]
[#:width width (>=/c 0) (line-width)]
[#:style style plot-pen-style/c (line-style)]
[#:alpha alpha (real-in 0 1) (line-alpha)]
[#:label label (or/c string? #f) #f]
) renderer3d?
(define g (2d-function->sampler f))
(let ([z-min (if z-min z-min z)]
[z-max (if z-max z-max z)])
(renderer3d (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max))
#f default-ticks-fun
(contour3d-render-proc g z samples color width style alpha label))))
;; ===================================================================================================
;; Contour lines in 3D (using marching squares)

8
collects/plot/scribblings/contracts.scrbl
View File

@ -45,14 +45,6 @@ The contract for the @(racket #:sym) arguments in @(racket points) and @(racket
@doc-apply[known-point-symbols]{
A list containing the symbols that are valid @(racket points) symbols.
@interaction[#:eval plot-eval
(require (only-in srfi/13 string-pad-right))
(for ([sym (in-list known-point-symbols)]
[n (in-cycle (in-range 3))])
(display (string-pad-right (format "~v" sym) 22))
(when (= n 2) (newline)))
(length known-point-symbols)]
}
@section{Appearance Argument Sequence Contracts}

20
collects/plot/scribblings/renderer2d.scrbl
View File

@ -210,10 +210,18 @@ Corresponds with @(racket polar).
(polar-interval f1 f2 #:label "[f1,f2]"))))]
}
@section{2D Contour Renderers}
@section{2D Contour (Isoline) Renderers}
@doc-apply[isoline]{
Returns a renderer that plots a contour line, or a line of constant value (height).
A circle of radius @(racket r), for example, is the line of constant value @(racket r) for the distance function:
@interaction[#:eval plot-eval (plot (isoline (λ (x y) (sqrt (+ (sqr x) (sqr y)))) 1.5
-2 2 -2 2 #:label "z"))]
}
In this case, @(racket r) = @(racket 1.5).
@doc-apply[contours]{
Returns a renderer that plots contour lines, or lines of constant height.
Returns a renderer that plots contour lines, or lines of constant value (height).
When @(racket levels) is @(racket 'auto), the number of contour lines and their values are chosen the same way as axis tick positions; i.e. they are chosen to be simple.
When @(racket levels) is a number, @(racket contours) chooses that number of values, evenly spaced, within the output range of @(racket f).
@ -235,6 +243,10 @@ For example,
#:styles '(solid dot)))]
}
@defproc[(isolines ...) renderer2d?]{
A synonym of @(racket contours).
}
@doc-apply[contour-intervals]{
Returns a renderer that fills the area between contour lines, and additionally draws contour lines.
@ -246,6 +258,10 @@ For example, the canonical saddle, with its gradient field superimposed:
#:color "black" #:label "Gradient")))]
}
@defproc[(isoline-intervals ...) renderer2d?]{
A synonym of @(racket contour-intervals).
}
@section{2D Rectangle Renderers}
@defstruct[ivl ([min real?] [max real?])]{

18
collects/plot/scribblings/renderer3d.scrbl
View File

@ -96,7 +96,15 @@ Combining polar function renderers allows faking latitudes or longitudes in larg
#:title "A Seashell" #:x-label #f #:y-label #f))]
}
@section{3D Contour Renderers}
@section{3D Contour (Isoline) Renderers}
@doc-apply[contour3d]{
Returns a renderer that plots a single contour line on the surface of a function.
}
@defproc[(isoline3d ...) renderer3d?]{
A synonym of @(racket contour3d).
}
@doc-apply[contours3d]{
Returns a renderer that plots contour lines on the surface of a function.
@ -110,6 +118,10 @@ For example,
#:legend-anchor 'top-left)]
}
@defproc[(isolines3d ...) renderer3d?]{
A synonym of @(racket contours3d).
}
@doc-apply[contour-intervals3d]{
Returns a renderer that plots contour intervals and contour lines on the surface of a function.
The appearance keyword arguments are interpreted identically to the appearance keyword arguments to @(racket contour-intervals).
@ -121,6 +133,10 @@ For example,
#:legend-anchor 'top-left)]
}
@defproc[(isoline-intervals3d ...) renderer3d?]{
A synonym of @(racket contour-intervals3d).
}
@section{3D Isosurface Renderers}
@doc-apply[isosurface3d]{

103
collects/plot/tests/contour-labels-test.rkt Normal file
View File

@ -0,0 +1,103 @@
#lang racket
(require plot plot/utils plot/common/contract-doc)
(struct label-params (score z z-ivl str v) #:transparent)
(define (dnorm x m s^2)
(* (/ 1 (sqrt (* 2 pi s^2))) (exp (* -1/2 (/ (sqr (- x m)) s^2)))))
(define ((contour-labels-render-proc f g levels samples color size family alpha) area)
(let/ec return
(define-values (x-min x-max y-min y-max) (send area get-bounds))
(match-define (list xs ys zss) (g x-min x-max samples y-min y-max samples))
(define-values (z-min z-max)
(let ([zs (filter regular? (2d-sample->list zss))])
(when (empty? zs) (return empty))
(values (apply min* zs) (apply max* zs))))
(define z-ticks (contour-ticks z-min z-max levels #f))
(define zs (map pre-tick-value z-ticks))
(send area set-text-foreground color)
(send area set-font size family)
(send area set-alpha alpha)
(define labels
(append*
(for/list ([z-tick (in-list z-ticks)])
(match-define (tick z major? label) z-tick)
(for/list ([ya (in-list ys)]
[yb (in-list (rest ys))]
[zs0 (in-vector zss)]
[zs1 (in-vector zss 1)]
#:when #t
[xa (in-list xs)]
[xb (in-list (rest xs))]
[z1 (in-vector zs0)]
[z2 (in-vector zs0 1)]
[z3 (in-vector zs1 1)]
[z4 (in-vector zs1)]
#:when #t
[line (in-list (heights->lines xa xb ya yb z z1 z2 z3 z4))])
(match-define (vector x y _) (vcenter line))
(label-params 0 z
(ivl (min* z1 z2 z3 z4) (max* z1 z2 z3 z4))
label (send area plot->dc (vector x y)))))))
(match-define (vector dc-x-min dc-y-min) (send area plot->dc (vector x-min y-min)))
(match-define (vector dc-x-max dc-y-max) (send area plot->dc (vector x-max y-max)))
(define x-sigma (/ (plot-width) samples))
(define y-sigma (/ (plot-height) samples))
(define z-sigma (/ (- z-max z-min) (length z-ticks)))
(define new-labels
(for/fold ([labels labels]) ([keep (in-list (list 4))])
(define new-labels
(for/list ([l1 (in-list labels)])
(match-define (label-params s1 z1 (ivl z1-min z1-max) str1 (vector x1 y1)) l1)
(define new-score
(apply + (for/list ([l2 (in-list labels)])
(match-define (label-params s2 z2 _ str2 (vector x2 y2)) l2)
(* (exp (* -1/2 (sqr (/ (- s1 s2) 1))))
(exp (* -1/2 (sqr (/ (- x1 x2) x-sigma))))
(exp (* -1/2 (sqr (/ (- y1 y2) y-sigma))))
(exp (* -1/2 (sqr (/ (- z1 z2) z-sigma))))
))))
(label-params new-score z1 (ivl z1-min z1-max) str1 (vector x1 y1))))
(append*
(for/list ([z (in-list zs)])
(define z-labels (sort (filter (λ (l) (= z (label-params-z l))) new-labels)
> #:key label-params-score))
#;(define keep (min 4 (length z-labels) (round (* 1/8 (length z-labels)))))
(take z-labels (min keep (length z-labels)))))))
(for ([label (in-list new-labels)])
(match-define (label-params score z _ str (vector x y)) label)
(send area draw-text #;(real->plot-label score 3) str (vector x y) 'center 0 #:outline? #t))
empty))
(defproc (contour-labels
[f (real? real? . -> . real?)]
[x-min (or/c real? #f) #f] [x-max (or/c real? #f) #f]
[y-min (or/c real? #f) #f] [y-max (or/c real? #f) #f]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
[#:samples samples (and/c exact-integer? (>=/c 2)) (contour-samples)]
[#:color color plot-color/c (plot-foreground)]
[#:size size (>=/c 0) (plot-font-size)]
[#:family family font-family/c (plot-font-family)]
[#:alpha alpha (real-in 0 1) (label-alpha)]
) renderer2d?
(define g (2d-function->sampler f))
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f #f
(contour-labels-render-proc f g levels samples color size family alpha)))
;(contour-samples 11)
;(plot-z-max-ticks 50)
#;
(parameterize (#;[plot-x-transform log-transform]
#;[plot-y-transform log-transform])
(plot (list (contours (λ (x y) (sqrt (+ (sqr x) (sqr y)))) -1 4 -1 4)
(contour-labels (λ (x y) (sqrt (+ (sqr x) (sqr y))))))))