diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl index 9201c4bc19..ba0b5b66e6 100644 --- a/collects/scribblings/reference/regexps.scrbl +++ b/collects/scribblings/reference/regexps.scrbl @@ -12,8 +12,6 @@ @guideintro["regexp"]{regular expressions} -@local-table-of-contents[] - @deftech{Regular expressions} are specified as strings or byte strings, using the same pattern language as the Unix utility @exec{egrep} or Perl. A string-specified pattern produces a character diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index f7c2be7001..49290ba55e 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -319,6 +319,66 @@ the existing @scheme[pict] drawing, instead of on top. If @scheme[solid?] is false, then the arrowheads are hollow instead of filled.} +@defproc*[([(pin-curve [pict pict?] + [src pict-path?] + [find-src (pict? pict-path? . -> . (values real? real?))] + [dest pict-path?] + [find-dest (pict? pict-path? . -> . (values real? real?))] + [#:start-angle start-angle (or/c real? #f) #f] + [#:end-angle end-angle (or/c real? #f) #f] + [#:start-pull start-pull (or/c real? #f) #f] + [#:end-pull end-pull (or/c real? #f) #f] + [#:arrow-size arrow-size real? 12] + [#: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]) + pict?] + [(pin-arrow-curve [pict pict?] + [src pict-path?] + [find-src (pict? pict-path? . -> . (values real? real?))] + [dest pict-path?] + [find-dest (pict? pict-path? . -> . (values real? real?))] + [#:start-angle start-angle (or/c real? #f) #f] + [#:end-angle end-angle (or/c real? #f) #f] + [#:start-pull start-pull (or/c real? #f) #f] + [#:end-pull end-pull (or/c real? #f) #f] + [#:arrow-size arrow-size real? 12] + [#: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]) + pict?] + [(pin-arrows-curve [pict pict?] + [src pict-path?] + [find-src (pict? pict-path? . -> . (values real? real?))] + [dest pict-path?] + [find-dest (pict? pict-path? . -> . (values real? real?))] + [#:start-angle start-angle (or/c real? #f) #f] + [#:end-angle end-angle (or/c real? #f) #f] + [#:start-pull start-pull (or/c real? #f) #f] + [#:end-pull end-pull (or/c real? #f) #f] + [#:arrow-size arrow-size real? 12] + [#: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]) + pict?])]{ + +Like @scheme[pin-arrow-line], etc., but draws a Bezier curve based on +@scheme[start-angle], @scheme[end-angle], @scheme[start-pull], and +@scheme[end-pull]. + +The @scheme[start-angle] and @scheme[end-angle] arguments specify the +direction of curve at its start and end positions; if either is +@scheme[#f], it defaults to the angle of a straight line from the +start position to end position. + +The @scheme[start-pull] and @scheme[end-pull] arguments specify a kind +of momentum for the starting and ending angles; larger values preserve +the angle longer. If @scheme[start-pull] or @scheme[end-pull] is +@scheme[#f], then it is replaced with one-fourth of the distance +between the start and end points.} + @defthing[text-style/c contract?]{ A contract that matches the second argument of @scheme[text].} diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index 3a8e3c7250..df56955529 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -6,7 +6,9 @@ (rename-in texpict/utils [pin-line t:pin-line] [pin-arrow-line t:pin-arrow-line] - [pin-arrows-line t:pin-arrows-line])) + [pin-arrows-line t:pin-arrows-line]) + (only-in scheme/gui/base dc-path%) + (only-in scheme/class new send)) (define (hline w h #:segment [seg #f]) (if seg @@ -71,6 +73,110 @@ #f #f #f solid?)) p lw col under?)) + (define (pin-curve p + src src-find + dest dest-find + #:start-angle [sa #f] #:end-angle [ea #f] + #:start-pull [sp #f] #:end-pull [ep #f] + #:arrow-size [sz 12] + #:color [col #f] + #:line-width [lw #f] + #:under? [under? #f] + #:solid? [solid? #t]) + (pin-curve* #f #f p src src-find dest dest-find + sa ea sp ep sz col lw under? #t)) + + (define (pin-arrow-curve p + src src-find + dest dest-find + #:start-angle [sa #f] #:end-angle [ea #f] + #:start-pull [sp #f] #:end-pull [ep #f] + #:arrow-size [sz 12] + #:color [col #f] + #:line-width [lw #f] + #:under? [under? #f] + #:solid? [solid? #t]) + (pin-curve* #f #t p src src-find dest dest-find + sa ea sp ep sz col lw under? solid?)) + + (define (pin-arrows-curve p + src src-find + dest dest-find + #:start-angle [sa #f] #:end-angle [ea #f] + #:start-pull [sp #f] #:end-pull [ep #f] + #:arrow-size [sz 12] + #:color [col #f] + #:line-width [lw #f] + #:under? [under? #f] + #:solid? [solid? #t]) + (pin-curve* #t #t p src src-find dest dest-find + sa ea sp ep sz col lw under? solid?)) + + (define (pin-curve* start-arrow? end-arrow? p + src src-find + dest dest-find + sa ea sp ep + sz col lw + under? solid?) + (let-values ([(sx0 sy0) (src-find p src)] + [(dx0 dy0) (dest-find p dest)]) + (let* ([sa (or sa + (atan (- sy0 dy0) (- dx0 sx0)))] + [ea (or ea + (atan (- sy0 dy0) (- dx0 sx0)))] + [d (sqrt (+ (* (- dy0 sy0) (- dy0 sy0)) (* (- dx0 sx0) (- dx0 sx0))))] + [sp (or sp (* 1/4 d))] + [ep (or ep (* 1/4 d))]) + (let ([dx (if end-arrow? (- dx0 (* sz (cos ea))) dx0)] + [dy (if end-arrow? (+ dy0 (* sz (sin ea))) dy0)] + [sx (if start-arrow? (+ sx0 (* sz (cos sa))) sx0)] + [sy (if start-arrow? (- sy0 (* sz (sin sa))) sy0)] + [path (new dc-path%)] + [maybe-pin-line + (lambda (arrow? p sx sy dx dy) + (if arrow? + (pin-arrow-line + sz + p + p (lambda (a b) (values sx sy)) + p (lambda (a b) (values dx dy)) + #:line-width lw + #:color col + #:under? under? + #:solid? solid?) + p))]) + (send path move-to sx sy) + (send path curve-to + (+ sx (* sp (cos sa))) + (- sy (* sp (sin sa))) + (- dx (* ep (cos ea))) + (+ dy (* ep (sin ea))) + dx + dy) + (maybe-pin-line + start-arrow? + (maybe-pin-line + end-arrow? + ((if under? pin-under pin-over) + p + 0 0 + (let* ([p (dc (lambda (dc x y) + (let ([b (send dc get-brush)]) + (send dc set-brush "white" 'transparent) + (send dc draw-path path x y) + (send dc set-brush b))) + 0 0)] + [p (if col + (colorize p col) + p)] + [p (if lw + (linewidth lw p) + p)]) + p)) + dx dy dx0 dy0) + sx sy sx0 sy0))))) + + (define (finish-pin l p lw col under?) (let* ([l (if lw (linewidth lw l) @@ -96,6 +202,7 @@ frame pict-path? pin-line pin-arrow-line pin-arrows-line + pin-curve pin-arrow-curve pin-arrows-curve (except-out (all-from-out texpict/mrpict) dash-hline dash-vline