From 5d281f9cff235e37d5d457ae27a7c4c03887551d Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 26 Aug 2014 18:57:50 -0400 Subject: [PATCH] Add edge-width option to tree-layout --- .../pict/scribblings/tree-layout.scrbl | 18 ++++++++- pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt | 39 +++++++++++-------- .../pict-lib/pict/private/layout.rkt | 12 +++--- .../pict-lib/pict/private/naive-layered.rkt | 10 +++-- .../pict-lib/pict/private/tidier.rkt | 26 +++++++------ pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt | 3 +- 6 files changed, 70 insertions(+), 38 deletions(-) diff --git a/pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl b/pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl index b4d87c5ea8..899d6ae2d7 100644 --- a/pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl +++ b/pkgs/pict-pkgs/pict-doc/pict/scribblings/tree-layout.scrbl @@ -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?]{ diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt index 046aab95a5..b0b6a9face 100644 --- a/pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt +++ b/pkgs/pict-pkgs/pict-lib/pict/private/hv.rkt @@ -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 diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt index b7807816e7..ae4579adc3 100644 --- a/pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt +++ b/pkgs/pict-pkgs/pict-lib/pict/private/layout.rkt @@ -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) diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt index 3ad38c6ed7..c28278e66a 100644 --- a/pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt +++ b/pkgs/pict-pkgs/pict-lib/pict/private/naive-layered.rkt @@ -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))])]))])]))) diff --git a/pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt b/pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt index e0fefa7647..50fabcb7e6 100644 --- a/pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt +++ b/pkgs/pict-pkgs/pict-lib/pict/private/tidier.rkt @@ -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] diff --git a/pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt b/pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt index 5ad625e4b9..e431cbd3b6 100644 --- a/pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt +++ b/pkgs/pict-pkgs/pict-lib/pict/tree-layout.rkt @@ -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?)]