From fa82d70cc646a2129f4f9ba6efa3096c979e4e58 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 23 Aug 2011 14:02:20 -0600 Subject: [PATCH] slideshow/pict: add `linestyle' and `#:style' argument to `pin-line' --- collects/scribblings/slideshow/picts.scrbl | 37 +++++++++++++++++++--- collects/slideshow/pict.rkt | 32 +++++++++++++------ collects/texpict/mrpict.rkt | 1 + collects/texpict/private/common-sig.rkt | 3 +- collects/texpict/private/common-unit.rkt | 1 + collects/texpict/private/mrpict-extra.rkt | 23 ++++++++++---- collects/texpict/private/mrpict-sig.rkt | 1 + collects/texpict/utils.rkt | 28 +++++++++++----- 8 files changed, 97 insertions(+), 29 deletions(-) diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index efe7f397ef..6ad76a4e60 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -294,6 +294,10 @@ argument for consistency with the other functions.} [#:end-pull end-pull real? 1/4] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a?/c color%)) #f] + [#:style style (one-of/c 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash)] [#:under? under? any/c #f]) pict?] [(pin-arrow-line [arrow-size real?] [pict pict?] @@ -307,6 +311,10 @@ argument for consistency with the other functions.} [#:end-pull end-pull real? 1/4] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a?/c color%)) #f] + [#:style style (one-of/c 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash)] [#:under? under? any/c #f] [#:solid? solid? any/c #t] [#:hide-arrowhead? any/c #f]) @@ -322,6 +330,10 @@ argument for consistency with the other functions.} [#:end-pull end-pull real? 1/4] [#:line-width line-width (or/c #f real?) #f] [#:color color (or/c #f string? (is-a?/c color%)) #f] + [#:style style (one-of/c 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash)] [#:under? under? any/c #f] [#:solid? solid? any/c #t] [#:hide-arrowhead? any/c #f]) @@ -337,7 +349,8 @@ the existing @racket[pict] drawing, instead of on top. If filled. The @racket[start-angle], @racket[end-angle], @racket[start-pull], and -@racket[end-pull] arguments control the curve of the line: +@racket[end-pull] arguments control the curve of the line (and the +defaults produce a straight line): @itemize[ @@ -352,11 +365,13 @@ The @racket[start-angle], @racket[end-angle], @racket[start-pull], and ] -When the @racket[hide-arrowhead?] argument is a true value, then -space for the arrowhead is left behind, but the arrowhead itself -is not drawn. +The @racket[line-width], @racket[color], and @racket[style] arguments +apply to the added line. + +When the @racket[hide-arrowhead?] argument is a true value, then space +for an arrowhead is kept around the line, but the arrowhead itself is +not drawn.} -The defaults produce a straight line.} @defthing[text-style/c contract?]{ @@ -520,6 +535,18 @@ for @racket[pict] that does not already use a specific pen width. A @racket[#f] value for @racket[w] makes the pen transparent (in contrast to a zero value, which means ``as thin as possible for the target device'').} + +@defproc[(linestyle [style (one-of/c 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash)] + [pict pict?]) + pict?]{ + +Selects a specific pen style for drawing, which applies to pen drawing +for @racket[pict] that does not already use a specific pen style.} + + @defproc[(colorize [pict pict?] [color (or/c string? (is-a?/c color%) (list (integer-in 0 255) diff --git a/collects/slideshow/pict.rkt b/collects/slideshow/pict.rkt index f307fa62ca..3a3ab89009 100644 --- a/collects/slideshow/pict.rkt +++ b/collects/slideshow/pict.rkt @@ -50,14 +50,17 @@ #:color [col #f] #:line-width [lw #f] #:under? [under? #f] - #:solid? [solid? #t]) + #:solid? [solid? #t] + #:style [style #f]) (if (not (or sa ea)) (finish-pin (launder (t:pin-line (ghost p) src src-find - dest dest-find)) + dest dest-find + #:style style)) p lw col under?) (pin-curve* #f #f p src src-find dest dest-find - sa ea sp ep 0 col lw under? #t))) + sa ea sp ep 0 col lw under? #t + style))) (define (pin-arrow-line sz p src src-find @@ -68,16 +71,19 @@ #:line-width [lw #f] #:under? [under? #f] #:solid? [solid? #t] + #:style [style #f] #: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?)) + #:hide-arrowhead? hide-arrowhead? + #:style style)) 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?))) + sa ea sp ep sz col lw under? solid? + style))) (define (pin-arrows-line sz p src src-find @@ -88,24 +94,28 @@ #:line-width [lw #f] #:under? [under? #f] #:solid? [solid? #t] + #:style [style #f] #:hide-arrowhead? [hide-arrowhead? #f]) (if (not (or sa ea)) (finish-pin (launder (t:pin-arrows-line sz (ghost p) src src-find dest dest-find #f #f #f solid? - #:hide-arrowhead? hide-arrowhead?)) + #:hide-arrowhead? hide-arrowhead? + #:style style)) p lw col under?) (pin-curve* (not hide-arrowhead?) (not hide-arrowhead?) p src src-find dest dest-find - sa ea sp ep sz col lw under? solid?))) + sa ea sp ep sz col lw under? solid? + style))) (define (pin-curve* start-arrow? end-arrow? p src src-find dest dest-find sa ea sp ep sz col lw - under? solid?) + under? solid? + style) (let-values ([(sx0 sy0) (src-find p src)] [(dx0 dy0) (dest-find p dest)]) (let* ([sa (or sa @@ -131,7 +141,8 @@ #:line-width lw #:color col #:under? under? - #:solid? solid?) + #:solid? solid? + #:style style) p))]) (send path move-to sx sy) (send path curve-to @@ -159,6 +170,9 @@ p)] [p (if lw (linewidth lw p) + p)] + [p (if style + (linestyle style p) p)]) p)) dx dy dx0 dy0) diff --git a/collects/texpict/mrpict.rkt b/collects/texpict/mrpict.rkt index 96619edb16..cb38d9016b 100644 --- a/collects/texpict/mrpict.rkt +++ b/collects/texpict/mrpict.rkt @@ -26,6 +26,7 @@ caps-text current-expected-text-scale dc linewidth + linestyle draw-pict make-pict-drawer) diff --git a/collects/texpict/private/common-sig.rkt b/collects/texpict/private/common-sig.rkt index ed1029b527..0788f36060 100644 --- a/collects/texpict/private/common-sig.rkt +++ b/collects/texpict/private/common-sig.rkt @@ -130,4 +130,5 @@ (define-signature texpict-internal^ (prepare-for-output pict->command-list - line-thickness))) + line-thickness + line-style))) diff --git a/collects/texpict/private/common-unit.rkt b/collects/texpict/private/common-unit.rkt index 98ec21d723..c6442500d7 100644 --- a/collects/texpict/private/common-unit.rkt +++ b/collects/texpict/private/common-unit.rkt @@ -317,6 +317,7 @@ (define (thick b) (thickness 'thicklines b)) (define (thin b) (thickness 'thinlines b)) (define (line-thickness n b) (thickness n b)) + (define (line-style n s) (thickness n s)) (define inset (case-lambda diff --git a/collects/texpict/private/mrpict-extra.rkt b/collects/texpict/private/mrpict-extra.rkt index a65e14d9f2..e89b218c65 100644 --- a/collects/texpict/private/mrpict-extra.rkt +++ b/collects/texpict/private/mrpict-extra.rkt @@ -301,6 +301,13 @@ (apply hbl-append 0 picts)))])) (define (linewidth n p) (line-thickness n p)) + (define (linestyle n p) + (unless (memq n '(transparent solid xor hilite + dot long-dash short-dash dot-dash + xor-dot xor-long-dash xor-short-dash + xor-dot-dash)) + (raise-type-error 'linestyle "style symbol" n)) + (line-style n p)) (define connect (case-lambda @@ -421,12 +428,16 @@ (set-pen (find-or-create-pen (send p get-color) (if (number? (cadr x)) (cadr x) - (if (eq? (cadr x) 'thicklines) - 1 - 0)) - (if (eq? (cadr x) #f) - 'transparent - 'solid))) + (case (cadr x) + [(thicklines) 1] + [(thinlines) 0] + [else (send p get-width)])) + (if (number? (cadr x)) + (send p get-style) + (case (cadr x) + [(#f) 'transparent] + [(thicklines thinlines) (send p get-style)] + [else (cadr x)])))) (loop dx dy (caddr x)) (set-pen p))] [(prog) diff --git a/collects/texpict/private/mrpict-sig.rkt b/collects/texpict/private/mrpict-sig.rkt index 7daa65d884..37e61fa579 100644 --- a/collects/texpict/private/mrpict-sig.rkt +++ b/collects/texpict/private/mrpict-sig.rkt @@ -9,6 +9,7 @@ text caps-text current-expected-text-scale dc linewidth + linestyle draw-pict make-pict-drawer))) diff --git a/collects/texpict/utils.rkt b/collects/texpict/utils.rkt index c0070e3c9f..a772ba43fd 100644 --- a/collects/texpict/utils.rkt +++ b/collects/texpict/utils.rkt @@ -76,7 +76,8 @@ pict-path? (-> pict? pict-path? (values number? number?))) ((or/c false/c number?) (or/c false/c string?) - boolean?) + boolean? + #:style (or/c false/c symbol?)) pict?)] [pin-arrow-line (->* (number? pict? @@ -86,6 +87,7 @@ (or/c false/c string?) boolean? boolean? + #:style (or/c false/c symbol?) #:hide-arrowhead? any/c) pict?)] [pin-arrows-line (->* (number? pict? @@ -95,6 +97,7 @@ (or/c false/c string?) boolean? boolean? + #:style (or/c false/c symbol?) #:hide-arrowhead? any/c) pict?)]) @@ -794,6 +797,7 @@ w h))) (define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head? + #:style [style #f] #:hide-arrowhead? [hide-arrowhead? #f]) (let-values ([(sx sy) (find-src base src)] [(dx dy) (find-dest base dest)]) @@ -832,9 +836,12 @@ solid-head?)]) `((place ,(+ sx xo) ,(+ sy yo) ,arrow))) null)))]) - (let ([p2 (if thickness - (linewidth thickness p) - p)]) + (let* ([p2 (if thickness + (linewidth thickness p) + p)] + [p2 (if style + (linestyle style p2) + p2)]) (if color (colorize p2 color) p2)))]) @@ -866,22 +873,27 @@ (values x (- (pict-height base) y))))) (define pin-line - (lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) + (lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f] #:style [style #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 + #:style style))) (define pin-arrow-line (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t] - #:hide-arrowhead? [hide-arrowhead? #f]) + #:hide-arrowhead? [hide-arrowhead? #f] + #:style [style #f]) (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest) thickness color arrow-size #f under? solid-head? + #:style style #: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] - #:hide-arrowhead? [hide-arrowhead? #f]) + #:hide-arrowhead? [hide-arrowhead? #f] + #:style [style #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? + #:style style #:hide-arrowhead? hide-arrowhead?))) (define black-color (make-object color% 0 0 0))