From 550e07f78fa16312d6d53a1e5aee78c019acc288 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 13 Aug 2010 11:45:52 -0400 Subject: [PATCH] Added labeled lines and arrows to unstable from Scott Owens. --- collects/unstable/gui/slideshow.rkt | 117 +++++++++++++++++- .../unstable/scribblings/gui/slideshow.scrbl | 60 +++++++++ 2 files changed, 176 insertions(+), 1 deletion(-) diff --git a/collects/unstable/gui/slideshow.rkt b/collects/unstable/gui/slideshow.rkt index 90808ed911..557d9aa7e7 100644 --- a/collects/unstable/gui/slideshow.rkt +++ b/collects/unstable/gui/slideshow.rkt @@ -1,7 +1,8 @@ #lang racket (require slideshow/base slideshow/pict - racket/splicing racket/stxparam racket/gui/base racket/block + racket/splicing racket/stxparam racket/gui/base + racket/block racket/class unstable/define) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -347,3 +348,117 @@ (->* [real?] [#:color color/c #:border-color color/c #:border-width real?] pict?)]) + + +;; the following has been written by Scott Owens +;; and updated and added by stamourv + +(define (blank-line) + (blank 0 (current-font-size))) + +(define (label-line label pict src-pict src-coord-fn dest-pict dest-coord-fn + #:x-adjust (x-adjust 0) #:y-adjust (y-adjust 0)) + (let-values (((src-x src-y) (src-coord-fn pict src-pict)) + ((dest-x dest-y) (dest-coord-fn pict dest-pict))) + (let* ((src (make-rectangular src-x src-y)) + (dest (make-rectangular dest-x dest-y)) + (adjust (make-rectangular x-adjust y-adjust)) + (v (- dest src)) + (h2 (pict-height label))) + ;; Ensure that the src is left of dest + (when (< (real-part v) 0) + (set! v (- v)) + (set! src dest)) + (let ((p (+ src + ;; Move the label to sit atop the line. + (/ (* h2 -i v) (magnitude v) 2) + ;; Center the label in the line. + (/ (- v (make-rectangular (pict-width label) + (pict-height label))) + 2) + adjust))) + (pin-over + pict + (real-part p) + (imag-part p) + label))))) + +(define (pin-label-line label pict + src-pict src-coord-fn + dest-pict dest-coord-fn + #:start-angle (start-angle #f) + #:end-angle (end-angle #f) + #:start-pull (start-pull 1/4) + #:end-pull (end-pull 1/4) + #:line-width (line-width #f) + #:color (color #f) + #:under? (under? #f) + #:x-adjust (x-adjust 0) + #:y-adjust (y-adjust 0)) + (label-line + label + (pin-line + pict src-pict src-coord-fn dest-pict dest-coord-fn + #:start-angle start-angle #:end-angle end-angle + #:start-pull start-pull #:end-pull end-pull + #:line-width line-width #:color color #:under? under?) + src-pict src-coord-fn dest-pict dest-coord-fn + #:x-adjust x-adjust #:y-adjust y-adjust)) + +(define-values (pin-arrow-label-line + pin-arrows-label-line) + (let () + (define ((mk fn) + label arrow-size pict + src-pict src-coord-fn + dest-pict dest-coord-fn + #:start-angle (start-angle #f) + #:end-angle (end-angle #f) + #:start-pull (start-pull 1/4) + #:end-pull (end-pull 1/4) + #:line-width (line-width #f) + #:color (color #f) + #:under? (under? #f) + #:solid? (solid? #t) + #:hide-arrowhead? (hide-arrowhead? #f) + #:x-adjust (x-adjust 0) + #:y-adjust (y-adjust 0)) + (label-line + label + (fn + arrow-size pict src-pict src-coord-fn dest-pict dest-coord-fn + #:start-angle start-angle #:end-angle end-angle + #:start-pull start-pull #:end-pull end-pull + #:line-width line-width #:color color #:under? under? + #:hide-arrowhead? hide-arrowhead?) + src-pict src-coord-fn dest-pict dest-coord-fn + #:x-adjust x-adjust #:y-adjust y-adjust)) + (values (mk pin-arrow-line) + (mk pin-arrows-line)))) +(define pin-arrow-label-line-contract + (->* [pict? real? pict? + pict-path? (-> pict? pict-path? (values real? real?)) + pict-path? (-> pict? pict-path? (values real? real?))] + [#:start-angle (or/c real? #f) #:end-angle (or/c real? #f) + #:start-pull real? #:end-pull real? + #:line-width (or/c real? #f) + #:color (or/c #f string? (is-a?/c color%)) + #:under? any/c #:hide-arrowhead? any/c + #:x-adjust real? #:y-adjust real?] + pict?)) + +(provide/contract + [blank-line (-> pict?)] + [pin-label-line + (->* [pict? pict? + pict-path? (-> pict? pict-path? (values real? real?)) + pict-path? (-> pict? pict-path? (values real? real?))] + [#:start-angle (or/c real? #f) #:end-angle (or/c real? #f) + #:start-pull real? #:end-pull real? + #:line-width (or/c real? #f) + #:color (or/c #f string? (is-a?/c color%)) + #:under? any/c + #:x-adjust real? #:y-adjust real?] + pict?)] + [pin-arrow-label-line pin-arrow-label-line-contract] + [pin-arrows-label-line pin-arrow-label-line-contract]) diff --git a/collects/unstable/scribblings/gui/slideshow.scrbl b/collects/unstable/scribblings/gui/slideshow.scrbl index 0f2a84ad1b..41da278e25 100644 --- a/collects/unstable/scribblings/gui/slideshow.scrbl +++ b/collects/unstable/scribblings/gui/slideshow.scrbl @@ -338,3 +338,63 @@ Computes the width of one column out of @scheme[n] that takes up a ratio of )]{ These functions create shapes with border of the given color and width. } + +@addition{Scott Owens} + +@defproc[(blank-line) pict?]{ +Adds a blank line of the current font size's height. +} + +@deftogether[( +@defproc[(pin-label-line [label pict?] [pict pict?] + [src-pict pict-path?] + [src-coord-fn (-> pict-path? (values real? real?))] + [dest-pict pict-path?] + [dest-coord-fn (-> pict-path? (values real? real?))] + [#:start-angle start-angle (or/c real? #f)] + [#:end-angle end-angle (or/c real? #f)] + [#:start-pull start-pull real?] + [#:end-pull end-pull real?] + [#:line-width line-width (or/c real? #f)] + [#:color color (or/c #f string? (is-a?/c color%))] + [#:under? under? any/c] + [#:x-adjust x-adjust real?] + [#:y-adjust y-adjust real?]) + pict?] +@defproc[(pin-arrow-label-line [label pict?] [arrow-size real?] [pict pict?] + [src-pict pict-path?] + [src-coord-fn (-> pict-path? (values real? real?))] + [dest-pict pict-path?] + [dest-coord-fn (-> pict-path? (values real? real?))] + [#:start-angle start-angle (or/c real? #f)] + [#:end-angle end-angle (or/c real? #f)] + [#:start-pull start-pull real?] + [#:end-pull end-pull real?] + [#:line-width line-width (or/c real? #f)] + [#:color color (or/c #f string? (is-a?/c color%))] + [#:under? under? any/c] + [#:hide-arrowhead? hide-arrowhead? any/c] + [#:x-adjust x-adjust real?] + [#:y-adjust y-adjust real?]) + pict?] +@defproc[(pin-arrows-label-line [label pict?] [arrow-size real?] [pict pict?] + [src-pict pict-path?] + [src-coord-fn (-> pict-path? (values real? real?))] + [dest-pict pict-path?] + [dest-coord-fn (-> pict-path? (values real? real?))] + [#:start-angle start-angle (or/c real? #f)] + [#:end-angle end-angle (or/c real? #f)] + [#:start-pull start-pull real?] + [#:end-pull end-pull real?] + [#:line-width line-width (or/c real? #f)] + [#:color color (or/c #f string? (is-a?/c color%))] + [#:under? under? any/c] + [#:hide-arrowhead? hide-arrowhead? any/c] + [#:x-adjust x-adjust real?] + [#:y-adjust y-adjust real?]) + pict?] +)]{ +These functions behave like @racket[pin-line], @racket[pin-arrow-line] +and @racket[pin-arrows-line] with the addition of a label attached to +the line. +}