A debugging tool that draws a pict of a mutable red black tree. Useful for debugging Rebellion's RB trees in mutable sorted collection implementations.

mutable-red-black-tree-pict.rkt

#lang racket/base


(require racket/contract/base)


(provide
 (contract-out
  [mutable-rb-tree-pict (-> mutable-rb-tree? pict?)]))


(require pict
         pict/tree-layout
         racket/port
         rebellion/collection/private/mutable-red-black-tree-base)


;@----------------------------------------------------------------------------------------------------


(define (mutable-rb-tree-pict tree)
  (binary-tidier (mutable-rb-node-layout (mutable-rb-tree-root-node tree))))


(define (nil-pict)
  (cc-superimpose (filled-rectangle 25 15 #:color "black") (colorize (text "NIL" '() 10) "white")))


(define (mutable-rb-node-layout node)
  (if (nil-leaf? node)
      (tree-layout #:pict (nil-pict) #false #false)
      (tree-layout
       #:pict (proper-mutable-rb-node-pict node)
       (mutable-rb-node-layout (mutable-rb-node-child node left))
       (mutable-rb-node-layout (mutable-rb-node-child node right)))))


(define (proper-mutable-rb-node-pict node)
  (define parent (mutable-rb-node-parent node))
  (define root-text (if (mutable-rb-root? parent) (colorize (text "ROOT") "white") (blank)))
  (define size-text (colorize (text (format "size: ~a" (mutable-rb-node-size node))) "white"))
  (define color (if (red-node? node) "red" "black"))
  (define contents (display-to-string (mutable-rb-node-key node)))
  (define node-pict
    (cc-superimpose (disk 25 #:border-width 2 #:color color) (colorize (text contents) "white")))
  (vc-append root-text size-text node-pict))


(define (display-to-string v)
  (with-output-to-string (λ () (display v))))