Visualize s-expression in Racket

The picture is the result of the code below. It's not entirely automatic, so change the xmax and ymax if you need to generate other diagrams.

#lang racket
(require parser-tools/lex
         parser-tools/yacc
         (prefix-in re: parser-tools/lex-sre)
         (only-in pict cc-superimpose disk filled-rectangle text)
         pict/tree-layout)


(provide parse draw)


(define-empty-tokens empty-tokens
  (PLUS MINUS MULT DIV
   LPAREN RPAREN COMMA
   IF THEN ELSE END
   FOR NEXT STEP TO
   DEFINE
   EQUALS SEP EOF
   GT LT
   NOT AND OR
   TRUE FALSE
   QUOTE SET))

(define-tokens value-tokens (INT ID))



(define basic-lexer
  (lexer
   (#\+                            (token-PLUS))
   (#\-                            (token-MINUS))
   (#\*                            (token-MULT))
   (#\/                            (token-DIV))
   (#\=                            (token-EQUALS))
   (#\>                            (token-GT))
   (#\<                            (token-LT))
   (#\(                            (token-LPAREN))
   (#\)                            (token-RPAREN))
   (#\,                            (token-COMMA))
   ("var"                          (token-DEFINE))
   ("if"                           (token-IF))
   ("then"                         (token-THEN))
   ("else"                         (token-ELSE))
   ("end"                          (token-END))
   ("for"                          (token-FOR))
   ("to"                           (token-TO))
   ("next"                         (token-NEXT))
   ("step"                         (token-STEP))
   ("not"                          (token-NOT))
   ("and"                          (token-AND))
   ("or"                           (token-OR))
   ("true"                         (token-TRUE))
   ("false"                        (token-FALSE))
   ("literal"                      (token-QUOTE))
   ("set"                          (token-SET))
   ((re:or #\tab #\space)          (basic-lexer input-port))
   (#\newline                      (token-SEP))
   ((re:seq #\return #\newline)    (token-SEP))
   ((re:+ numeric)                 (token-INT (string->number lexeme)))
   ((re:+ alphabetic)              (token-ID (string->symbol lexeme)))
   ((eof)                          (token-EOF))))


(define basic-parser
  (parser

   (start start)
   (end EOF)

   (tokens value-tokens empty-tokens)

   (error (lambda (ok? name value)
            (printf "Couldn't parse: ~a\n" name)))

   (grammar

    (start
     ((sep-opt expr-list sep-opt)        $2))

    (expr-list
     ((expr)                            (list 'begin $1))
     ((expr-list sep expr)              (append $1 (list $3))))

    (expr
     ((or-expr)                          $1)
     ((var-def)                          $1)
     ((proc-call)                        $1)
     ((if-expr)                          $1)
     ((for-expr)                         $1)
     ((quote-expr)                       $1)
     ((assign-expr)                      $1))

    (assign-expr
     ((SET ID EQUALS expr)              (list 'set! $2 $4)))

    (quote-expr
     ((QUOTE expr)                      (list 'quote $2)))

    (for-expr
     ((FOR ID EQUALS or-expr TO or-expr
           sep-opt expr-list
           sep-opt NEXT)                (list 'do (list (list $2 $4 (list '+ $2 1))) (list (list '> $2 $6)) $8)))

    (if-expr
     ((IF expr THEN sep-opt
          expr-list sep-opt END IF)     (list 'if $2 $5))
     ((IF expr THEN sep-opt
          expr-list sep-opt
          ELSE sep-opt
          expr-list sep-opt END IF)     (list 'if $2 $5 $9)))

    (proc-call
     ((ID LPAREN RPAREN)                (list $1))
     ((ID LPAREN arg-list RPAREN)       (cons $1 $3)))

    (arg-list
     ((expr)                            (list $1))
     ((arg-list COMMA expr)             (append $1 (list $3))))

    (var-def
     ((DEFINE ID EQUALS expr)           (list 'define $2 $4)))

    (or-expr
     ((or-expr OR and-expr)             (list 'or $1 $3))
     ((and-expr)                         $1))

    (and-expr
     ((and-expr AND not-expr)           (list 'and $1 $3))
     ((not-expr)                         $1))

    (not-expr
     ((NOT not-expr)                    (list 'not $2))
     ((compare-expr)                     $1))

    (compare-expr
     ((compare-expr EQUALS add-expr)    (list '= $1 $3))
     ((compare-expr GT add-expr)        (list '> $1 $3))
     ((compare-expr LT add-expr)        (list '< $1 $3))
     ((add-expr)                         $1))

    (add-expr
     ((add-expr PLUS mult-expr)         (list '+ $1 $3))
     ((add-expr MINUS mult-expr)        (list '- $1 $3))
     ((mult-expr)                        $1))

    (mult-expr
     ((mult-expr MULT value)            (list '* $1 $3))
     ((mult-expr DIV value)             (list '/ $1 $3))
     ((value)                            $1))

    (value
     ((INT)                              $1)
     ((ID)                               $1)
     ((TRUE)                             #t)
     ((FALSE)                            #f)
     ((LPAREN expr RPAREN )              $2))

    (sep-opt
     ((sep)                              null)
     (()                                 null))

    (sep
     ((sep SEP)                          null)
     ((SEP)                              null)))))


(define (parse str)
  (let ((port (open-input-string str)))
         (basic-parser
                  (lambda () (basic-lexer port)))))


;;; https://stackoverflow.com/questions/54621805/visualize-arbitrary-tree-in-racket-using-tree-layout

(define (draw tree)
  (define (viz tree)
    (cond
      ((null? tree) #f)
      ((not (pair? tree))
       (tree-layout #:pict (cc-superimpose
                            (filled-rectangle 44 22 #:color "white")
                            (text (token->string tree)))))
      ((not (pair? (car tree)))
       (apply tree-layout (map viz (cdr tree))
              #:pict (cc-superimpose
                      (filled-rectangle 44 22 #:color "white")
                      (text (token->string (car tree))))))))
  (if (null? tree)
      #f
      (naive-layered (viz tree))))


(define (token->string token)
  (cond ((symbol? token) (symbol->string token))
        ((number? token) (number->string token))
        ((boolean? token) (if token "#t" "#f"))
        ((void? token)           "void")
        (else "")))


(require (except-in metapict text blank)
         (prefix-in mp: metapict)
         compatibility/mlist)

;;; Box and Pointer Diagrams

; This shows how to draw classical box and pointer diagrams 
; in SICP style. The call (draw-box-and-pointer-diagram v)
; will draw the value v using boxes and pointers.
; The function works on both mutable and immutable cons cells.

; Note: Also check out http://docs.racket-lang.org/sdraw/

; As is the code doesn't compute the extent of the drawing,
; so you need to modify the x- and y-range if your 
; data structure gets too large:

(defv (xmin xmax ymin ymax) (values -20 10 -20 10))

; Patches that automatically compute the ranges are welcome.

; The size of the arrow heads:
(ahlength (px 8))
; NB: Due to a (temporary) bug in the drawing of arrow heads,
;     make sure the size of the x-range and the y-range
;     are of equal size (otherwise the arrows get distorted).

(define (depth v)
  (def seen-pairs (make-hasheq))
  (define (seen! p) (hash-set! seen-pairs p #t))
  (define (seen? p) (hash-ref  seen-pairs p #f))
  (define (recur v)
    (cond [(seen? v) 0]
          [else      (seen! v)
                     (match v
                       [(or (cons a d) (mcons a d)) (+ (recur a) (recur d))]
                       [(list) 1]
                       [_      2])]))
  (recur v))

(define (draw-null-box upper-left)
  ; null is drawn as a crossed over box
  (def ul upper-left)
  (draw (rectangle ul dr)
        (curve (pt+ ul down) -- (pt+ ul right))))

(define (embeddable-value? v)
  #f
  ; an embeddable value is drawn inside a car or cdr box
  #;(or (and (number? v) (<= (abs v) 100))
      (char? v)))

(define (draw-embeddable-value v cnt)
  ; small value centered on cnt
  (draw (label-cnt (~v v) cnt)))

(define (draw-value v)
  ; values are simply displayed with ~v
  (mp:text (~v v)))

(define (atomic-value? v)
  ; atomic values are drawn direcly below their cell,
  (or (number? v)
      (string? v)
      (symbol? v)
      (char? v)))


(def dr   (vec+ down right))
(def dr/2 (vec* 1/2 dr))

(define (draw-cdr upper-left d recur)  
  (def ul upper-left)
  (def dm (pt+ ul right dr/2)) ; middle of cdr box
  (match d
    ; if null, the value d (from a cdr) is drawn as a crossed over rectangle
    [(list) (draw-null-box (pt+ ul right))]
    ; draw embeddable values inside the box
    [(? embeddable-value? a) (draw-embeddable-value a dm)]
    ; otherwise  i) use recur to draw d placed 3 units to the right of the cons cell
    [_ (match (recur (pt+ ul (vec* 3 right)) d)
         ;      ii) connect the cdr part of the cons cell to the value d
         [(? pt? ul-d) (draw-arrow (curve dm right .. (pt+ ul-d (vec 1/2 0)) down))]
         [d-pict       (draw (draw-arrow (curve dm -- (pt+ dm (vec* 3/2 right))))
                             d-pict)])]))

(define (draw-car upper-left a depth-d recur)
  (def ul upper-left)
  (def am (pt+ ul dr/2))
  (match a
    [(list) (draw-null-box ul)]
    [(? embeddable-value? a) (draw-embeddable-value a am)]
    [_ (def offset (if (atomic-value? a) 1/2 (+ depth-d 0)))
       (match (recur (pt+ ul (vec* (+ offset 1) down)) a)
         [(? pt? ul-a) ; got upper-left corner of already drawn value
          ; draw arrow, but first is it upwards or downwards?
          (if (positive? (dot (pt- ul-a ul) up))
              (draw-arrow (curve am                      up ..
                                 (pt+ am   (vec 0  1/2)) up .. 
                                 (pt+ ul-a (vec 0 -1/2)) right))
              (draw-arrow (curve am                      down ..
                                 (pt+ am   (vec 0 -1/2)) down .. 
                                 (pt+ ul-a (vec 0 -1/2)) right)))]
         [a-pict       
          (draw (draw-arrow (curve am -- (pt+ am (vec* (+ offset 1/2) down))))
                a-pict)])]))

(define (draw-cons-cell upper-left v recur)
  (def ul upper-left)
  (match v
    [(or (cons a d) (mcons a d))
     (draw (rectangle ul             (pt+ ul dr))
           (rectangle (pt+ ul right) (pt+ ul right dr))
           (draw-cdr ul d recur)
           (draw-car ul a (depth d) recur))]))

(define (draw-label ul v labels)
  ; Labels is a hash table from that maps cons cells to be labelled into 
  ; strings, picts or one-argument procedures mapping a point (upper-left corner
  ; of the cons cell) into a label
  (match (hash-ref labels v #f)
    [(? string? l)    (label-top l ul)]
    [(? pict? l)      (label-top l ul)]
    [(? procedure? f) (f ul)]
    [#f               (mp:blank)]
    [_ (error 'draw-label (~a "expect label, pict or string, got: " v))]))

(define (draw-box-and-pointer-diagram 
         v #:upper-left [upper-left (pt+ (pt xmin ymax) right down)]
           #:labels     [labels (hash)])
  ; pairs already seen will not be drawn again
  (def seen-pairs (make-hasheq))
  (define (seen! p ul) (hash-set! seen-pairs p ul))
  (define (seen? p) (hash-ref  seen-pairs p #f))
  (define (recur ul v)
    ; draw the value v, the upper-left is at the position ul
    (cond
      [(seen? v) (hash-ref seen-pairs v)]
      [else  
       (unless (atomic-value? v) ; only share compound values (to avoid clutter)
         (seen! v ul))
       (draw (draw-label ul v labels)
             (match v
               [(list)                      (draw-null-box ul)]
               [(or (cons a d) (mcons a d)) (draw-cons-cell ul v recur)]
               [_ (label-cnt (~a v) (pt+ ul dr/2))]))]))
  (recur upper-left v))

(set-curve-pict-size 1200 1200)
(curve-pict-window (window xmin xmax ymin ymax))
(def gray-grid (color "gray" (grid (pt xmin ymin) (pt xmax ymax) (pt 0 0) #:step 1)))

(scale 0.5
       (text-scale 2
       (draw gray-grid
             (draw-box-and-pointer-diagram
              (parse "for i = 1 to 10
              display(i)
              next")))))