suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added hollow heads to arrows

Browse Source 
svn: r1312
This commit is contained in:
Robby Findler 2005-11-14 17:30:59 +00:00
parent ae6c167690
commit 24c6d96c7d
2 changed files with 23 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/texpict/doc.txt
View File

@ -575,12 +575,12 @@ Other constructors:
> pin-arrow-line ; arrow-size pict > pin-arrow-line ; arrow-size pict
; src-pict (pict pict -> x y) ; src-pict (pict pict -> x y)
; dest-pict (pict pict -> x y) ; dest-pict (pict pict -> x y)
; [line-w [color-string [lines-under?]]] ; [line-w [color-string [lines-under? [solid-head?]]]]
; -> pict ; -> pict
> pin-arrows-line ; arrow-size pict > pin-arrows-line ; arrow-size pict
; src-pict (pict pict -> x y) ; src-pict (pict pict -> x y)
; dest-pict (pict pict -> x y) ; dest-pict (pict pict -> x y)
; [line-w [color-string [lines-under?]]] ; [line-w [color-string [lines-under? [solid-head?]]]]
; -> pict ; -> pict
Adds a line or line-with-arrows onto a pict, using Adds a line or line-with-arrows onto a pict, using

40
collects/texpict/utils.ss
View File

@ -42,7 +42,7 @@
pin-line pin-line
pin-arrow-line pin-arrow-line
pin-arrows-line pin-arrows-line
add-line add-line
add-arrow-line add-arrow-line
@ -166,8 +166,8 @@
'solid)) 'solid))
(send dc set-brush (send the-brush-list (send dc set-brush (send the-brush-list
find-or-create-brush find-or-create-brush
(send p get-color) (if solid? (send p get-color) "white")
(if solid? 'solid 'transparent))) 'solid))
(send dc draw-polygon (send dc draw-polygon
(map pt->xform-obj (map pt->xform-obj
(if stem? (if stem?
@ -195,13 +195,13 @@
(let-values ([(p dx dy) (arrow/delta size angle)]) (let-values ([(p dx dy) (arrow/delta size angle)])
p)) p))
(define (arrowhead/delta pen-thickness size angle) (define (arrowhead/delta pen-thickness size angle solid-head?)
(generic-arrow #f #t size angle pen-thickness)) (generic-arrow #f solid-head? size angle pen-thickness))
(define (arrowhead size angle) (define (arrowhead size angle)
(let-values ([(p dx dy) (arrowhead/delta 0 size angle)]) (let-values ([(p dx dy) (arrowhead/delta 0 size angle #t)])
p)) p))
(define (arrowhead/offset size angle) (define (arrowhead/offset size angle)
(arrowhead/delta 0 size angle)) (arrowhead/delta 0 size angle #t))
(define (pip-line dx dy size) (define (pip-line dx dy size)
(picture (picture
@ -209,7 +209,7 @@
`((connect 0 0 ,dx ,(- dy))))) `((connect 0 0 ,dx ,(- dy)))))
(define (arrow-line dx dy size) (define (arrow-line dx dy size)
(let-values ([(a adx ady) (arrowhead/delta 0 size (atan dy dx))]) (let-values ([(a adx ady) (arrowhead/delta 0 size (atan dy dx) #t)])
(picture (picture
0 0 0 0
`((connect 0 0 ,dx ,dy) `((connect 0 0 ,dx ,dy)
@ -714,7 +714,7 @@
(send dc set-brush old-brush))) (send dc set-brush old-brush)))
w h))) w h)))
(define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under?) (define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head?)
(let-values ([(sx sy) (find-src base src)] (let-values ([(sx sy) (find-src base src)]
[(dx dy) (find-dest base dest)]) [(dx dy) (find-dest base dest)])
(let ([arrows (let ([arrows
@ -736,7 +736,8 @@
(or thickness 0) (or thickness 0)
arrow-size arrow-size
(atan (- dy sy) (atan (- dy sy)
(- dx sx)))]) (- dx sx))
solid-head?)])
`((place ,(+ dx xo) ,(+ dy yo) ,arrow))) `((place ,(+ dx xo) ,(+ dy yo) ,arrow)))
null) null)
,@(if arrow2-size ,@(if arrow2-size
@ -745,7 +746,8 @@
(or thickness 0) (or thickness 0)
arrow-size arrow-size
(atan (- sy dy) (atan (- sy dy)
(- sx dx)))]) (- sx dx))
solid-head?)])
`((place ,(+ sx xo) ,(+ sy yo) ,arrow))) `((place ,(+ sx xo) ,(+ sy yo) ,arrow)))
null)))]) null)))])
(let ([p2 (if thickness (let ([p2 (if thickness
@ -760,15 +762,15 @@
(define add-line (define add-line
(opt-lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (opt-lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
(-add-line base src find-src dest find-dest thickness color #f #f under?))) (-add-line base src find-src dest find-dest thickness color #f #f under? #t)))
(define add-arrow-line (define add-arrow-line
(opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (opt-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?))) (-add-line base src find-src dest find-dest thickness color arrow-size #f under? #t)))
(define add-arrows-line (define add-arrows-line
(opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (opt-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?))) (-add-line base src find-src dest find-dest thickness color arrow-size arrow-size under? #t)))
(define (flip-find-y find-) (define (flip-find-y find-)
(lambda (base path) (lambda (base path)
@ -778,17 +780,17 @@
(define pin-line (define pin-line
(opt-lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (opt-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) (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color #f #f under?))) thickness color #f #f under? #t)))
(define pin-arrow-line (define pin-arrow-line
(opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t])
(-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest) (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color arrow-size #f under?))) thickness color arrow-size #f under? solid-head?)))
(define pin-arrows-line (define pin-arrows-line
(opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]) (opt-lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t])
(-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest) (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
thickness color arrow-size arrow-size under?))) thickness color arrow-size arrow-size under? solid-head?)))
(define black-color (make-object color% 0 0 0)) (define black-color (make-object color% 0 0 0))