102 lines
4.3 KiB
Racket
102 lines
4.3 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/contract racket/draw racket/class unstable/contract unstable/latent-contract
|
|
unstable/latent-contract/defthing)
|
|
|
|
(provide (except-out (all-defined-out)
|
|
treeof
|
|
maybe-function/c maybe-apply
|
|
plot-colors/c pen-widths/c plot-pen-styles/c plot-brush-styles/c alphas/c
|
|
labels/c)
|
|
(activate-contract-out
|
|
treeof
|
|
maybe-function/c maybe-apply
|
|
plot-colors/c pen-widths/c plot-pen-styles/c plot-brush-styles/c alphas/c
|
|
labels/c)
|
|
(rename-out [natural-number/c nat/c])
|
|
truth/c)
|
|
|
|
;; ===================================================================================================
|
|
;; Convenience
|
|
|
|
(defcontract contract/c (or/c contract? (any/c . -> . any/c)))
|
|
|
|
(defcontract (treeof [elem-contract contract/c])
|
|
(or/c elem-contract
|
|
(listof (recursive-contract (treeof elem-contract)))))
|
|
|
|
;; ===================================================================================================
|
|
;; Plot-specific contracts
|
|
|
|
(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?)
|
|
string? symbol?
|
|
(is-a?/c color%)))
|
|
|
|
(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)))
|
|
|
|
(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)))
|
|
|
|
(defcontract font-family/c (one-of/c 'default 'decorative 'roman 'script 'swiss
|
|
'modern 'symbol 'system))
|
|
|
|
(defthing known-point-symbols (listof symbol?) #:document-value
|
|
(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)))
|
|
|
|
(defcontract (maybe-function/c [in-contract contract/c] [out-contract contract/c])
|
|
(or/c out-contract (in-contract . -> . out-contract)))
|
|
|
|
(defproc (maybe-apply [f (maybe-function/c any/c any/c)]
|
|
[arg any/c]) any/c
|
|
(cond [(procedure? f) (f arg)]
|
|
[else f]))
|
|
|
|
(defcontract (plot-colors/c [in-contract contract/c])
|
|
(maybe-function/c in-contract (listof plot-color/c)))
|
|
|
|
(defcontract (pen-widths/c [in-contract contract/c])
|
|
(maybe-function/c in-contract (listof (>=/c 0))))
|
|
|
|
(defcontract (plot-pen-styles/c [in-contract contract/c])
|
|
(maybe-function/c in-contract (listof plot-pen-style/c)))
|
|
|
|
(defcontract (plot-brush-styles/c [in-contract contract/c])
|
|
(maybe-function/c in-contract (listof plot-brush-style/c)))
|
|
|
|
(defcontract (alphas/c [in-contract contract/c])
|
|
(maybe-function/c in-contract (listof (real-in 0 1))))
|
|
|
|
(defcontract (labels/c [in-contract contract/c])
|
|
(maybe-function/c in-contract (listof (or/c string? #f))))
|