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

Draw :-> and :--> ourselves, similar to --> and friends.

Browse Source 
svn: r13698
This commit is contained in:
Stevie Strickland 2009-02-17 16:14:12 +00:00
parent e21ecbe074
commit 560836a804
2 changed files with 22 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/redex/private/arrow.ss
View File

@ -7,7 +7,7 @@
(provide/contract
[make-arrow-pict
(-> string?
(symbols 'curvy 'straight 'straight-double)
(symbols 'curvy 'straight 'straight-double 'map)
symbol?
number?
(-> pict?))])
@ -71,6 +71,17 @@
(case style
[(curvy)
(send dc draw-path path dx dy)]
[(map)
(send dc draw-line
dx
(- (+ dy line-pos) (/ head-height 2))
dx
(+ (+ dy line-pos) (/ head-height 2)))
(send dc draw-line
dx
(+ dy line-pos)
(+ dx w)
(+ dy line-pos))]
[(straight)
(send dc draw-line
dx

12
collects/redex/private/pict.ss
View File

@ -344,6 +344,8 @@
(define short-curvy-arrow-pict (mk-arrow-pict "m" 'curvy))
(define double-arrow-pict (mk-arrow-pict "xxx" 'straight-double))
(define short-double-arrow-pict (mk-arrow-pict "m" 'straight-double))
(define map-arrow-pict (mk-arrow-pict "m" 'map))
(define long-map-arrow-pict (mk-arrow-pict "xxx" 'map))
(define user-arrow-table (make-hasheq))
(define (set-arrow-pict! arr thunk)
@ -362,8 +364,14 @@
[(>->) (basic-text "\u21a3" (default-style))]
[(~~>) (curvy-arrow-pict)]
[(~>) (short-curvy-arrow-pict)]
[(:->) (basic-text "\u21a6" (default-style))]
[(:-->) (basic-text "\u27fc" (default-style))]
[(:->)
(if STIX?
(basic-text "\u21a6" (default-style))
(map-arrow-pict))]
[(:-->)
(if STIX?
(basic-text "\u27fc" (default-style))
(long-map-arrow-pict))]
[(c->) (basic-text "\u21aa" (default-style))]
[(-->>) (basic-text "\u21a0" (default-style))]
[(>--) (basic-text "\u291a" (default-style))]