unstable/gui/pict: added shadow-frame and arch
This commit is contained in:
Ryan Culpepper
parent
2a0153cadb
commit
6442a2777b
|
|
@ -403,3 +403,31 @@
|
||||||
[find-tag*
|
[find-tag*
|
||||||
(-> pict? tag-path?
|
(-> pict? tag-path?
|
||||||
(listof pict-path?))])
|
(listof pict-path?))])
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;;
|
||||||
|
;; Shadow frame
|
||||||
|
;;
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(require "private/shframe.rkt")
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[shadow-frame
|
||||||
|
(->* ()
|
||||||
|
(#:background-color (or/c string? (is-a?/c color%))
|
||||||
|
#:frame-color (or/c string? (is-a?/c color%))
|
||||||
|
#:frame-line-width (or/c real? #f)
|
||||||
|
#:shadow-side-length real?
|
||||||
|
#:shadow-top-y-offset real?
|
||||||
|
#:shadow-bottom-y-offset real?
|
||||||
|
#:shadow-descent (and/c real? (not/c negative?))
|
||||||
|
#:shadow-alpha-factor real?
|
||||||
|
#:blur (and/c real? (not/c negative?))
|
||||||
|
#:margin real?
|
||||||
|
#:sep real?)
|
||||||
|
#:rest (listof pict?)
|
||||||
|
pict?)]
|
||||||
|
[arch
|
||||||
|
(-> real? real? real? real?
|
||||||
|
pict?)])
|
||||||
|
|
|
||||||
145
collects/unstable/gui/private/shframe.rkt
Normal file
145
collects/unstable/gui/private/shframe.rkt
Normal file
|
|
@ -0,0 +1,145 @@
|
||||||
|
#lang racket/base
|
||||||
|
(require racket/math
|
||||||
|
racket/class
|
||||||
|
racket/draw
|
||||||
|
slideshow/pict
|
||||||
|
"blur.rkt")
|
||||||
|
(provide shadow-frame
|
||||||
|
arch)
|
||||||
|
|
||||||
|
;; ============================================================
|
||||||
|
;; Boxes with Keynote-style shadows
|
||||||
|
|
||||||
|
(define (shadow-frame #:background-color [background-color "white"]
|
||||||
|
#:frame-color [frame-color "gray"]
|
||||||
|
#:frame-line-width [frame-line-width 0]
|
||||||
|
#:shadow-side-length [s-side-len 4.0]
|
||||||
|
#:shadow-top-y-offset [s-top-dy 10.0]
|
||||||
|
#:shadow-bottom-y-offset [s-bot-dy 4.0]
|
||||||
|
#:shadow-descent [s-desc 40.0]
|
||||||
|
#:shadow-alpha-factor [s-alpha 3/4]
|
||||||
|
#:blur [blur-radius 20]
|
||||||
|
#:margin [margin-len 20]
|
||||||
|
#:sep [sep 5]
|
||||||
|
. picts)
|
||||||
|
;; shadow-alpha-factor:
|
||||||
|
;; - default 3/4 good for a heavy shadow, if blur is enabled
|
||||||
|
;; - about 1/4 or 1/5 good for light shadow w/o blur
|
||||||
|
(let* ([pict (apply vl-append sep picts)]
|
||||||
|
[pict (inset pict margin-len)]
|
||||||
|
[w (pict-width pict)]
|
||||||
|
[h (pict-height pict)]
|
||||||
|
[main-box (frame (colorize (filled-rectangle w h) background-color)
|
||||||
|
#:color frame-color #:line-width frame-line-width)]
|
||||||
|
[w* (+ w s-side-len s-side-len)]
|
||||||
|
[shadow (arch w* w* (+ h (- s-bot-dy s-top-dy)) s-desc)]
|
||||||
|
[shadow (brush/linear-gradient
|
||||||
|
shadow
|
||||||
|
(mk-shadow-grad-stops w* s-side-len s-alpha))]
|
||||||
|
[shadow
|
||||||
|
(cond [(positive? blur-radius) (blur shadow blur-radius)]
|
||||||
|
[else shadow])]
|
||||||
|
[result
|
||||||
|
(pin-under (cc-superimpose main-box pict)
|
||||||
|
(- s-side-len) s-top-dy
|
||||||
|
shadow)]
|
||||||
|
[result
|
||||||
|
(inset result s-side-len 0
|
||||||
|
s-side-len (+ s-desc (- s-top-dy s-bot-dy)))])
|
||||||
|
(inset result blur-radius)))
|
||||||
|
|
||||||
|
(define (mk-shadow-grad-stops w s-side-len s-alpha)
|
||||||
|
(let* ([epsA (/ s-side-len w)]
|
||||||
|
[epsZ (- 1.0 epsA)]
|
||||||
|
[alphaA (max 0 (min 1 (* s-alpha 0.16)))]
|
||||||
|
[alphaB (max 0 (min 1 (* s-alpha 0.25)))]
|
||||||
|
[alphaC (max 0 (min 1 (* s-alpha 1.00)))])
|
||||||
|
(list (list 0.00 (make-object color% 0 0 0 alphaA))
|
||||||
|
(list epsA (make-object color% 0 0 0 alphaB))
|
||||||
|
(list 0.25 (make-object color% 0 0 0 alphaC))
|
||||||
|
(list 0.75 (make-object color% 0 0 0 alphaC))
|
||||||
|
(list epsZ (make-object color% 0 0 0 alphaB))
|
||||||
|
(list 1.00 (make-object color% 0 0 0 alphaA)))))
|
||||||
|
|
||||||
|
;; ----
|
||||||
|
|
||||||
|
(define (arch outer-w inner-w solid-h leg-h)
|
||||||
|
(dc (lambda (dc X Y)
|
||||||
|
(draw-arch dc X Y outer-w inner-w solid-h leg-h))
|
||||||
|
outer-w (+ solid-h leg-h)))
|
||||||
|
|
||||||
|
(define (draw-arch dc X Y outer-w inner-w solid-h leg-h)
|
||||||
|
(cond [(zero? leg-h)
|
||||||
|
(send dc draw-rectangle X Y outer-w solid-h)]
|
||||||
|
[else
|
||||||
|
(let ([path (new dc-path%)])
|
||||||
|
(dc-path-arch path X Y outer-w inner-w solid-h leg-h)
|
||||||
|
(send dc draw-path path))]))
|
||||||
|
|
||||||
|
;; closes path's current sub-path and draws the outline of an arch, clockwise
|
||||||
|
;; requires leg-h != 0
|
||||||
|
(define (dc-path-arch path X Y outer-w inner-w solid-h leg-h)
|
||||||
|
(let* ([xA X]
|
||||||
|
[xB (+ X outer-w)]
|
||||||
|
[xMid (/ (+ xA xB) 2.0)]
|
||||||
|
[ySolidEnd (+ Y solid-h)]
|
||||||
|
[yEnd (+ Y solid-h leg-h)]
|
||||||
|
[hdx (/ (- outer-w inner-w) 2.0)]
|
||||||
|
[xAi (+ xA hdx)]
|
||||||
|
[xBi (- xB hdx)]
|
||||||
|
[radius (+ (/ leg-h 2) (/ (sqr inner-w) 8 leg-h))]
|
||||||
|
[diameter (+ radius radius)]
|
||||||
|
[theta (asin (/ (- radius leg-h) radius))])
|
||||||
|
(send* path
|
||||||
|
(move-to xA Y)
|
||||||
|
(line-to xB Y)
|
||||||
|
(line-to xB ySolidEnd)
|
||||||
|
(line-to xB yEnd)
|
||||||
|
(line-to xBi yEnd)
|
||||||
|
(arc (- xMid radius) ySolidEnd
|
||||||
|
diameter diameter
|
||||||
|
theta
|
||||||
|
(- pi theta))
|
||||||
|
;; ends at *roughly* xAi yEnd
|
||||||
|
(line-to xAi yEnd)
|
||||||
|
(line-to xA yEnd)
|
||||||
|
(line-to xA ySolidEnd)
|
||||||
|
(line-to xA Y))))
|
||||||
|
|
||||||
|
;; ====
|
||||||
|
|
||||||
|
(define no-pen (make-object pen% "BLACK" 1 'transparent))
|
||||||
|
|
||||||
|
(define (brush/linear-gradient p stops)
|
||||||
|
(let* ([drawer (make-pict-drawer p)]
|
||||||
|
[w (pict-width p)]
|
||||||
|
[h (pict-height p)])
|
||||||
|
(dc (lambda (dc X Y)
|
||||||
|
(let* ([grad
|
||||||
|
(new linear-gradient%
|
||||||
|
;; Apparently gradient handles scaling,
|
||||||
|
;; rotation, etc automatically (???)
|
||||||
|
(x0 X) (y0 Y) (x1 (+ X w)) (y1 Y)
|
||||||
|
(stops stops))]
|
||||||
|
[new-brush (new brush% (gradient grad))]
|
||||||
|
[old-pen (send dc get-pen)]
|
||||||
|
[old-brush (send dc get-brush)])
|
||||||
|
(send* dc
|
||||||
|
(set-pen no-pen)
|
||||||
|
(set-brush new-brush))
|
||||||
|
(drawer dc X Y)
|
||||||
|
(send* dc
|
||||||
|
(set-pen old-pen)
|
||||||
|
(set-brush old-brush))))
|
||||||
|
w h)))
|
||||||
|
|
||||||
|
#|
|
||||||
|
;; FIXME:
|
||||||
|
;; (arch ....) by itself draws outline
|
||||||
|
;; (colorize (arch ....) "red") draws filled (no outline, or same color)
|
||||||
|
|
||||||
|
Problem: picts, colorize, etc not designed to inherit brush. See
|
||||||
|
texpict/utils: filled-rectangle, eg, makes new brush from pen color;
|
||||||
|
rectangle makes new transparent brush.
|
||||||
|
|
||||||
|
|#
|
||||||
|
|
@ -456,7 +456,7 @@ Blurs @racket[bitmap] using blur radii @racket[h-radius] and
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
@subsection{Tagged picts}
|
@subsection{Tagged Picts}
|
||||||
|
|
||||||
@defproc[(tag-pict [p pict?] [tag symbol?]) pict?]{
|
@defproc[(tag-pict [p pict?] [tag symbol?]) pict?]{
|
||||||
|
|
||||||
|
|
@ -495,7 +495,7 @@ the given tag-path.
|
||||||
(for*/fold ([p p])
|
(for*/fold ([p p])
|
||||||
([apath (in-list (find-tag* p 'a))]
|
([apath (in-list (find-tag* p 'a))]
|
||||||
[bpath (in-list (find-tag* p 'b))])
|
[bpath (in-list (find-tag* p 'b))])
|
||||||
(pin-arrow-line 10 p
|
(pin-arrow-line 4 p
|
||||||
apath rc-find
|
apath rc-find
|
||||||
bpath lc-find)))
|
bpath lc-find)))
|
||||||
]
|
]
|
||||||
|
|
@ -507,4 +507,55 @@ Returns @racket[#t] if @racket[x] is a symbol or a non-empty list of
|
||||||
symbols, @racket[#f] otherwise.
|
symbols, @racket[#f] otherwise.
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@section{Shadow Frames}
|
||||||
|
|
||||||
|
@defproc[(shadow-frame [pict pict?] ...
|
||||||
|
[#:sep separation real? 5]
|
||||||
|
[#:margin margin real? 20]
|
||||||
|
[#:background-color bg-color (or/c string? (is-a?/c color%)) "white"]
|
||||||
|
[#:frame-color frame-color (or/c string? (is-a?/c color%)) "gray"]
|
||||||
|
[#:frame-line-width frame-line-width (or/c real? #f) 0]
|
||||||
|
[#:shadow-side-length shadow-side-length real? 4]
|
||||||
|
[#:shadow-top-y-offset shadow-top-y-offset real? 10]
|
||||||
|
[#:shadow-bottom-y-offset shadow-bottom-y-offset real? 4]
|
||||||
|
[#:shadow-descent shadow-descent (and/c real? (not/c negative?)) 40]
|
||||||
|
[#:shadow-alpha-factor shadow-alpha-factor real? 3/4]
|
||||||
|
[#:blur blur-radius (and/c real? (not/c negative?)) 20])
|
||||||
|
pict?]{
|
||||||
|
|
||||||
|
Surrounds the @racket[pict]s with a rectangular frame that casts a
|
||||||
|
symmetric ``curled paper'' shadow.
|
||||||
|
|
||||||
|
The @racket[pict]s are vertically appended with @racket[separation]
|
||||||
|
space between them. They are placed on a rectangular background of
|
||||||
|
solid @racket[bg-color] with @racket[margin] space on all sides. A
|
||||||
|
frame of @racket[frame-color] and @racket[frame-line-width] is added
|
||||||
|
around the rectangle. The rectangle casts a shadow that extends
|
||||||
|
@racket[shadow-side-length] to the left and right, starts
|
||||||
|
@racket[shadow-top-y-offset] below the top of the rectangle and
|
||||||
|
extends to @racket[shadow-bottom-y-offset] below the bottom of the
|
||||||
|
rectangle in the center and an additional @racket[shadow-descent]
|
||||||
|
below that on the sides. The shadow is painted using a linear
|
||||||
|
gradient; @racket[shadow-alpha-factor] determines its density at the
|
||||||
|
center. Finally, the shadow is blurred by @racket[blur-radius]; all
|
||||||
|
previous measurements are pre-blur measurements.
|
||||||
|
|
||||||
|
@examples[#:eval the-eval
|
||||||
|
(scale (shadow-frame (text "text in a nifty frame" null 60)) 1/2)
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
|
@defproc[(arch [outer-width real?]
|
||||||
|
[inner-width real?]
|
||||||
|
[solid-height real?]
|
||||||
|
[leg-height real?])
|
||||||
|
pict?]{
|
||||||
|
|
||||||
|
Creates an arch.
|
||||||
|
|
||||||
|
@examples[#:eval the-eval
|
||||||
|
(colorize (arch 100 80 20 20) "red")
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
@(close-eval the-eval)
|
@(close-eval the-eval)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user