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

Add edge-width option to tree-layout

Browse Source
This commit is contained in:
Asumu Takikawa 2014-08-26 18:57:50 -04:00
parent 82c10f79c6
commit 5d281f9cff
6 changed files with 70 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl
View File

@ -34,10 +34,26 @@ that render them as @racket[pict]s.
(or/c string?
(is-a?/c color%)
(list/c byte? byte? byte?))
"gray"])
"gray"]
[#:edge-width edge-width
(or/c 'unspecified real? #f)
'unspecified])
tree-edge?]{
This function specifies an edge from some parent to the given @racket[node].
It it intended to be used with @racket[tree-layout].
When @racket[edge-width] is @racket['unspecified], the line width will not be
set. This is intended to allow the line width to be set for the whole pict
via @racket[linewidth]. Otherwise, @racket[edge-width] is interpreted the
same way as the width argument for the @racket[linewidth] function.
@examples[#:eval
tree-layout-eval
(naive-layered (tree-layout
(tree-edge #:edge-width 3 (tree-layout))
(tree-edge #:edge-color "green" (tree-layout))))]
@history[#:changed "6.1.0.5" "Added an #:edge-width option"]
}
@defproc[(tree-layout? [v any/c]) boolean?]{

39
pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt
View File

@ -21,14 +21,14 @@ Computational Geometry, Theory and Applications 2 (1992)
(match t
[#f (blank)]
[(tree-layout pict (list left right))
(define-values (left-t left-color)
(define-values (left-t left-color left-width)
(match left
[#f (values #f #f)]
[(tree-edge child color) (values child color)]))
(define-values (right-t right-color)
[#f (values #f #f #f)]
[(tree-edge child color width) (values child color width)]))
(define-values (right-t right-color right-width)
(match right
[#f (values #f #f)]
[(tree-edge child color) (values child color)]))
[#f (values #f #f #f)]
[(tree-edge child color width) (values child color width)]))
(cond
[(and (not left-t) (not right-t))
(dot-ize pict)]
@ -44,7 +44,7 @@ Computational Geometry, Theory and Applications 2 (1992)
x-spacing y-spacing
left-p right-p))
(pin-over
(add-lines main left-color right-color left-p right-p)
(add-lines main left-color right-color left-width right-width left-p right-p)
(- (/ (pict-width pict) 2))
(- (/ (pict-height pict) 2))
pict)])]))
@ -77,18 +77,23 @@ Computational Geometry, Theory and Applications 2 (1992)
color
sub-tree-p))
(define (add-lines main left-color right-color t1 t2)
(add-a-line (add-a-line main left-color t1)
right-color t2))
(define (add-lines main left-color right-color left-width right-width t1 t2)
(add-a-line (add-a-line main left-color left-width t1)
right-color right-width t2))
(define (add-a-line main color sub)
(cc-superimpose
(launder
(define (add-a-line main color width sub)
(define colored
(colorize
(pin-line (ghost main)
main lt-find
sub lt-find)
color))
(pin-line (ghost main)
main lt-find
sub lt-find)
color))
(define with-linewidth
(if (eq? width 'unspecified)
colored
(linewidth width colored)))
(cc-superimpose
(launder with-linewidth)
main))
(module+ test

12
pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt
View File

@ -12,7 +12,7 @@
;; values of this struct leak outside, so it cannot be transparent
(struct tree-layout (pict children))
(struct tree-edge (child edge-color))
(struct tree-edge (child edge-color edge-width))
(define _tree-layout
(let ([constructor tree-layout])
@ -39,8 +39,10 @@
(define _tree-edge
(let ([constructor tree-edge])
(define (tree-edge child #:edge-color [edge-color "gray"])
(constructor child edge-color))
(define (tree-edge child
#:edge-color [edge-color "gray"]
#:edge-width [edge-width 'unspecified])
(constructor child edge-color edge-width))
tree-edge))
(define (binary-tree-layout? t)
@ -53,7 +55,7 @@
(define (binary-tree-edge? e)
(match e
[(tree-edge t _) (binary-tree-layout? t)]
[(tree-edge t _ _) (binary-tree-layout? t)]
[#f #t]))
(define (compute-spacing t given-x-spacing given-y-spacing)
@ -73,7 +75,7 @@
(for ([edge (in-list children)])
(match edge
[#f (void)]
[(tree-edge child edge-color)
[(tree-edge child edge-color _)
(loop child)]))]))
(values (or given-x-spacing x-spacing)

10
pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt
View File

@ -22,7 +22,7 @@
[#f
(define b (blank))
(cons b b)]
[(tree-edge child color)
[(tree-edge child color _)
(loop child)])))
(define this-root (launder (ghost pict)))
(define children-roots (map car children-pairs))
@ -43,14 +43,18 @@
(define this-tree-edge (car tree-edges))
(match this-tree-edge
[#f (loop main (cdr children-roots) (cdr tree-edges))]
[(tree-edge child edge-color)
(define w/line
[(tree-edge child edge-color edge-width)
(define *w/line
(colorize
(launder
(pin-line (ghost main)
this-root cc-find
child-root cc-find))
edge-color))
(define w/line
(if (eq? edge-width 'unspecified)
*w/line
(linewidth edge-width *w/line)))
(loop (cc-superimpose w/line main)
(cdr children-roots)
(cdr tree-edges))])]))])])))

26
pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt
View File

@ -46,23 +46,27 @@ Vol 7, #2, March 1981
(* x x-spacing)
(* y y-spacing)
node-pict))
(define (add-edge to color)
(set! main (cc-superimpose
(colorize (launder (pin-line (ghost main)
node-pict cc-find
to cc-find))
color)
main)))
(define (add-edge to color width)
(define colored
(colorize (launder (pin-line (ghost main)
node-pict cc-find
to cc-find))
color))
(define with-linewidth
(if (eq? width 'unspecified)
colored
(linewidth width colored)))
(set! main (cc-superimpose with-linewidth main)))
(match left-t
[#f (void)]
[(tree-edge left-t left-color)
[(tree-edge left-t left-color left-width)
(define left-pict (loop left-t left-xc (+ y 1)))
(add-edge left-pict left-color)])
(add-edge left-pict left-color left-width)])
(match right-t
[#f (void)]
[(tree-edge right-t right-color)
[(tree-edge right-t right-color right-width)
(define right-pict (loop right-t right-xc (+ y 1)))
(add-edge right-pict right-color)])
(add-edge right-pict right-color right-width)])
node-pict]))
main]

3
pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt
View File

@ -21,7 +21,8 @@
(->* (tree-layout?)
(#:edge-color (or/c string?
(is-a?/c color%)
(list/c byte? byte? byte?)))
(list/c byte? byte? byte?))
#:edge-width (or/c 'unspecified real? #f))
tree-edge?)]