From d5ee6c68139b1a40b8eb7ddfd10044006d4f3999 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 28 Feb 2009 15:44:41 +0000 Subject: [PATCH] added #:hide-arrowhead? flag svn: r13881 --- collects/scribblings/slideshow/picts.scrbl | 10 ++++- collects/slideshow/pict.ss | 47 ++++++++++++---------- collects/texpict/utils.ss | 43 +++++++++++++------- 3 files changed, 62 insertions(+), 38 deletions(-) diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index cae5e309f1..a9ac09f854 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -305,7 +305,8 @@ argument for consistency with the other functions.} [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f] - [#:solid? solid? any/c #t]) + [#:solid? solid? any/c #t] + [#:hide-arrowhead? any/c #f]) pict?] [(pin-arrows-line [arrow-size real?] [pict pict?] [src pict-path?] @@ -319,7 +320,8 @@ argument for consistency with the other functions.} [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a/c? color%)) #f] [#:under? under? any/c #f] - [#:solid? solid? any/c #t]) + [#:solid? solid? any/c #t] + [#:hide-arrowhead? any/c #f]) pict?])]{ Adds a line or line-with-arrows onto @scheme[pict], using one of the @@ -347,6 +349,10 @@ The @scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and ] +When the @scheme[hide-arrowhead?] argument is a true value, then +space for the arrowhead is left behind, but the arrowhead itself +is not drawn. + The defaults produce a straight line.} @defthing[text-style/c contract?]{ diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index adc304e0d8..7c2fb925be 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -59,24 +59,26 @@ (pin-curve* #f #f p src src-find dest dest-find sa ea sp ep sz col lw under? #t))) - (define (pin-arrow-line sz p - src src-find - dest dest-find - #:start-angle [sa #f] #:end-angle [ea #f] - #:start-pull [sp #f] #:end-pull [ep #f] - #:color [col #f] - #:line-width [lw #f] - #:under? [under? #f] - #:solid? [solid? #t]) - (if (not (or sa ea)) - (finish-pin (launder (t:pin-arrow-line sz (ghost p) - src src-find - dest dest-find - #f #f #f solid?)) - p lw col under?) - (pin-curve* #f #t p src src-find dest dest-find - sa ea sp ep sz col lw under? solid?))) - + (define (pin-arrow-line sz p + src src-find + dest dest-find + #:start-angle [sa #f] #:end-angle [ea #f] + #:start-pull [sp #f] #:end-pull [ep #f] + #:color [col #f] + #:line-width [lw #f] + #:under? [under? #f] + #:solid? [solid? #t] + #:hide-arrowhead? [hide-arrowhead? #f]) + (if (not (or sa ea)) + (finish-pin (launder (t:pin-arrow-line sz (ghost p) + src src-find + dest dest-find + #f #f #f solid? + #:hide-arrowhead? hide-arrowhead?)) + p lw col under?) + (pin-curve* #f (not hide-arrowhead?) p src src-find dest dest-find + sa ea sp ep sz col lw under? solid?))) + (define (pin-arrows-line sz p src src-find dest dest-find @@ -85,14 +87,17 @@ #:color [col #f] #:line-width [lw #f] #:under? [under? #f] - #:solid? [solid? #t]) + #:solid? [solid? #t] + #:hide-arrowhead? [hide-arrowhead? #f]) (if (not sa ea) (finish-pin (launder (t:pin-arrows-line sz (ghost p) src src-find dest dest-find - #f #f #f solid?)) + #f #f #f solid? + #:hide-arrowhead? hide-arrowhead?)) p lw col under?) - (pin-curve* #t #t p src src-find dest dest-find + (pin-curve* (not hide-arrowhead?) (not hide-arrowhead?) + p src src-find dest dest-find sa ea sp ep sz col lw under? solid?))) (define (pin-curve* start-arrow? end-arrow? p diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss index ff0305dadc..71fb2bc2d6 100644 --- a/collects/texpict/utils.ss +++ b/collects/texpict/utils.ss @@ -72,7 +72,8 @@ ((or/c false/c number?) (or/c false/c string?) boolean? - boolean?) + boolean? + #:hide-arrowhead? any/c) pict?)] [pin-arrows-line (->* (number? pict? pict? (-> pict? pict? (values number? number?)) @@ -80,7 +81,8 @@ ((or/c false/c number?) (or/c false/c string?) boolean? - boolean?) + boolean? + #:hide-arrowhead? any/c) pict?)]) @@ -774,7 +776,8 @@ (send dc set-brush old-brush))) w h))) - (define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head?) + (define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head? + #:hide-arrowhead? [hide-arrowhead? #f]) (let-values ([(sx sy) (find-src base src)] [(dx dy) (find-dest base dest)]) (let ([arrows @@ -790,7 +793,8 @@ [dsx (* (or arrow2-size 0) 0.5 (- cosa))] [dsy (* (or arrow2-size 0) 0.5 (- sina))]) `(connect ,(+ sx dsx) ,(+ sy dsy) ,(+ dx ddx) ,(+ dy ddy))) - ,@(if arrow-size + ,@(if (and arrow-size + (not hide-arrowhead?)) (let-values ([(arrow xo yo) (arrowhead/delta (or thickness 0) @@ -800,7 +804,8 @@ solid-head?)]) `((place ,(+ dx xo) ,(+ dy yo) ,arrow))) null) - ,@(if arrow2-size + ,@(if (and arrow2-size + (not hide-arrowhead?)) (let-values ([(arrow xo yo) (arrowhead/delta (or thickness 0) @@ -827,12 +832,16 @@ (-add-line base src find-src dest find-dest thickness color #f #f under? #t))) (define add-arrow-line - (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) - (-add-line base src find-src dest find-dest thickness color arrow-size #f under? #t))) + (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] + #:hide-arrowhead? [hide-arrowhead? #f]) + (-add-line base src find-src dest find-dest thickness color arrow-size #f under? #t + #:hide-arrowhead? hide-arrowhead?))) (define add-arrows-line - (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) - (-add-line base src find-src dest find-dest thickness color arrow-size arrow-size under? #t))) + (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] + #:hide-arrowhead? [hide-arrowhead? #f]) + (-add-line base src find-src dest find-dest thickness color arrow-size arrow-size under? #t + #:hide-arrowhead? hide-arrowhead?))) (define (flip-find-y find-) (lambda (base path) @@ -842,17 +851,21 @@ (define pin-line (lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest) - thickness color #f #f under? #t))) - + thickness color #f #f under? #t))) + (define pin-arrow-line - (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t]) + (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t] + #:hide-arrowhead? [hide-arrowhead? #f]) (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest) - thickness color arrow-size #f under? solid-head?))) + thickness color arrow-size #f under? solid-head? + #:hide-arrowhead? hide-arrowhead?))) (define pin-arrows-line - (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t]) + (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t] + #:hide-arrowhead? [hide-arrowhead? #f]) (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest) - thickness color arrow-size arrow-size under? solid-head?))) + thickness color arrow-size arrow-size under? solid-head? + #:hide-arrowhead? hide-arrowhead?))) (define black-color (make-object color% 0 0 0))