From 6442a2777b98fd2bb01a20dd2dedd7f15525c909 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 30 Jul 2011 18:13:38 -0500 Subject: [PATCH] unstable/gui/pict: added shadow-frame and arch --- collects/unstable/gui/pict.rkt | 28 ++++ collects/unstable/gui/private/shframe.rkt | 145 +++++++++++++++++++ collects/unstable/scribblings/gui/pict.scrbl | 55 ++++++- 3 files changed, 226 insertions(+), 2 deletions(-) create mode 100644 collects/unstable/gui/private/shframe.rkt diff --git a/collects/unstable/gui/pict.rkt b/collects/unstable/gui/pict.rkt index cb42ca2a86..577a9dfd13 100644 --- a/collects/unstable/gui/pict.rkt +++ b/collects/unstable/gui/pict.rkt @@ -403,3 +403,31 @@ [find-tag* (-> pict? tag-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?)]) diff --git a/collects/unstable/gui/private/shframe.rkt b/collects/unstable/gui/private/shframe.rkt new file mode 100644 index 0000000000..fb9f5ce3bf --- /dev/null +++ b/collects/unstable/gui/private/shframe.rkt @@ -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. + +|# diff --git a/collects/unstable/scribblings/gui/pict.scrbl b/collects/unstable/scribblings/gui/pict.scrbl index 9c8ac1947b..e6a8f9583b 100644 --- a/collects/unstable/scribblings/gui/pict.scrbl +++ b/collects/unstable/scribblings/gui/pict.scrbl @@ -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?]{ @@ -495,7 +495,7 @@ the given tag-path. (for*/fold ([p p]) ([apath (in-list (find-tag* p 'a))] [bpath (in-list (find-tag* p 'b))]) - (pin-arrow-line 10 p + (pin-arrow-line 4 p apath rc-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. } +@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)