private/pict.ss
(module pict mzscheme
  (require (lib "mrpict.ss" "texpict")
           (lib "utils.ss" "texpict")
           (lib "etc.ss")
           (lib "list.ss")
           (lib "mred.ss" "mred")
           (lib "class.ss")
           (lib "kw.ss")
           "reduction-semantics.ss"
           "struct.ss"
           "loc-wrapper.ss"
           "matcher.ss"
           "arrow.ss")
  
  (provide language->pict
           language->ps
           reduction-relation->pict
           reduction-relation->ps
           metafunction->pict
           metafunction->ps
           set-rule-picts-style!
           default-font-size
           label-font-size
           set-literal-style!
           set-metafunction-style!
           current-label-extra-space
           compact-vertical-min-width)
  
  ;; for the test suite
  (provide build-lines setup-lines
           make-spacer-token 
           make-string-token
           make-pict-token
           make-align-token
           loc-wrapper->tree
           pict-token?
           token-column
           token-span) 
  
  (define STIX? #f) ;; waiting for the STIX fonts
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;   reduction to pict
  ;;
  
  (define reduction-relation->pict
    (lambda/kw (rr #:key [rules #f] [converters #hash()])
      (current-rule-picts->pict
       (map (rr-lws->trees (language-nts (reduction-relation-lang rr)) converters)
            (if rules
                (let ([ht (make-hash-table 'equal)])
                  (for-each (lambda (rp)
                              (hash-table-put! ht (rule-pict-label rp) rp))
                            (reduction-relation-lws rr))
                  (map (lambda (label)
                         (hash-table-get ht label
                                         (lambda ()
                                           (error 'reduction-relation->pict
                                                  "no rule found for label: ~e"
                                                  label))))
                       rules))
                (reduction-relation-lws rr))))))
  
  (define/kw (reduction-relation->ps rr filename #:key [rules #f] [converters #hash()])
    (save-as-ps (λ () (reduction-relation->pict rr #:rules rules #:converters converters))
                filename))
  
  (define ((rr-lws->trees nts converters) rp)
    (let ([tp (λ (x)
                (lines->pict 
                 (setup-lines 
                  (build-lines nts (list (loc-wrapper->tree x converters))))))])
      (make-rule-pict (rule-pict-arrow rp)
                      (tp (rule-pict-lhs rp))
                      (tp (rule-pict-rhs rp))
                      (rule-pict-label rp)
                      (map tp (rule-pict-side-conditions rp))
                      (map tp (rule-pict-fresh-vars rp))
                      (map (lambda (v)
                             (cons (tp (car v)) (tp (cdr v))))
                           (rule-pict-pattern-binds rp)))))
  
  #;
  (define (rule-picts->pict/horizontal rps)
    (let ([lhs-space (make-horiz-space (map rule-pict-lhs rps))]
          [rhs-space (make-horiz-space (map rule-pict-rhs rps))]
          [label-space (make-horiz-space (map rp->pict-label rps))]
          [side-condition-width
           (pict-width (apply rt-superimpose (map (lambda (rp) (rp->side-condition-pict rp +inf.0)) rps)))]
          [arrow-space 
           (inset (make-horiz-space (map arrow->pict (map rule-pict-arrow rps)))
                  2
                  0)])
      (apply
       vr-append
       (add-between
        (blank 0 4)
        (map (λ (rp)
               (vr-append (widen
                           side-condition-width
                           (htl-append 
                            (inset (rule-pict-lhs rp) 
                                   (- (pict-width lhs-space)
                                      (pict-width (rule-pict-lhs rp)))
                                   0 0 0)
                            (blank 2 0)
                            (let* ([ap (arrow->pict (rule-pict-arrow rp))]
                                   [extra-space
                                    (/ (- (pict-width arrow-space)
                                          (pict-width ap))
                                       2)])
                              (inset ap extra-space 0 extra-space 0))
                            (blank 2 0)
                            (inset (rule-pict-rhs rp) 
                                   0 0
                                   (- (pict-width rhs-space)
                                      (pict-width (rule-pict-rhs rp)))
                                   0)
                            (blank 2 0)
                            (inset (rp->pict-label rp)
                                   0 0
                                   (- (pict-width label-space)
                                      (pict-width (rp->pict-label rp)))
                                   0)))
                          (rp->side-condition-pict rp +inf.0)))
             rps)))))
  
  (define current-label-extra-space (make-parameter 0))
  
  (define (widen w pict)
    (cond
      [(< (pict-width pict) w)
       (htl-append (blank (- w (pict-width pict)) 0)
                   pict)]
      [else
       pict]))

  (define (rule-picts->pict/horizontal rps)
    (let ([sep 2])
      (let ([max-rhs (apply max
                            0
                            (map pict-width
                                 (map rule-pict-rhs rps)))]
            [max-w (apply max
                          0
                          (map (lambda (rp)
                                 (+ sep sep
                                    (pict-width (rule-pict-lhs rp))
                                    (pict-width (arrow->pict (rule-pict-arrow rp)))
                                    (pict-width (rule-pict-rhs rp))))
                               rps))])
        (table 4
               (apply
                append
                (map (lambda (rp)
                       (let ([arrow (arrow->pict (rule-pict-arrow rp))]
                             [lhs (rule-pict-lhs rp)]
                             [rhs (rule-pict-rhs rp)]
                             [spc (basic-text " " default-style)]
                             [label (rp->pict-label rp)]
                             [sep (blank 4)])
                         (list lhs arrow rhs label
                               (blank) (blank)
                               (let ([sc (rp->side-condition-pict rp max-w)])
                                 (inset sc (min 0 (- max-rhs (pict-width sc))) 0 0 0))
                               (blank)
                               sep (blank) (blank) (blank))))
                     rps))
               (list* rtl-superimpose ctl-superimpose ltl-superimpose)
               (list* rtl-superimpose ctl-superimpose ltl-superimpose)
               (list* sep sep (+ sep (current-label-extra-space))) 2))))
  
  (define ((make-vertical-style side-condition-combiner) rps)
    (let* ([mk-top-line-spacer
            (λ (rp)
              (hbl-append (rule-pict-lhs rp)
                          (basic-text " " default-style)
                          (arrow->pict (rule-pict-arrow rp))
                          (basic-text " " default-style)
                          (rp->pict-label rp)))]
           [mk-bot-line-spacer
            (λ (rp)
              (rt-superimpose
               (rule-pict-rhs rp)
               (rp->side-condition-pict rp +inf.0)))]
           [multi-line-spacer
            (ghost
             (launder
              (ctl-superimpose 
               (apply ctl-superimpose (map mk-top-line-spacer rps))
               (apply ctl-superimpose (map mk-bot-line-spacer rps)))))]
           [spacer (dc void 
                       (pict-width multi-line-spacer)
                       (pict-descent multi-line-spacer) ;; probably could be zero ...
                       0
                       (pict-descent multi-line-spacer))])
      (apply
       vl-append
       (add-between
        (blank 0 4)
        (map (λ (rp)
               (side-condition-combiner
                (vl-append
                 (ltl-superimpose 
                  (htl-append (rule-pict-lhs rp)
                              (basic-text " " default-style)
                              (arrow->pict (rule-pict-arrow rp)))
                  (rtl-superimpose 
                   spacer
                   (rp->pict-label rp)))
                 (rule-pict-rhs rp))
                (rp->side-condition-pict rp +inf.0)))
             rps)))))
  
  (define compact-vertical-min-width (make-parameter 0))
  
  (define rule-picts->pict/vertical 
    (make-vertical-style vr-append))
  
  (define rule-picts->pict/vertical-overlapping-side-conditions
    (make-vertical-style rbl-superimpose))
  
  (define (rule-picts->pict/compact-vertical rps)
    (let ([max-w (apply max
                        (compact-vertical-min-width)
                        (map pict-width
                             (append
                              (map rule-pict-lhs rps)
                              (map rule-pict-rhs rps))))])
      (table 3
             (apply
              append
              (map (lambda (rp)
                     (let ([arrow (arrow->pict (rule-pict-arrow rp))]
                           [lhs (rule-pict-lhs rp)]
                           [rhs (rule-pict-rhs rp)]
                           [spc (basic-text " " default-style)]
                           [label (rp->pict-label rp)]
                           [sep (blank (compact-vertical-min-width) 4)])
                       (if ((apply + (map pict-width (list lhs spc arrow spc rhs)))
                            . < .
                            max-w)
                           (list 
                            (blank) (hbl-append lhs spc arrow spc rhs) label
                            (blank) (rp->side-condition-pict rp max-w) (blank)
                            (blank) sep (blank))
                           (list (blank) lhs label
                                 arrow rhs (blank)
                                 (blank) (rp->side-condition-pict rp max-w) (blank)
                                 (blank) sep (blank)))))
                   rps))
             ltl-superimpose ltl-superimpose
             (list* 2 (+ 2 (current-label-extra-space))) 2)))

  (define (side-condition-pict fresh-vars side-conditions pattern-binds max-w)
    (let* ([frsh 
            (if (null? fresh-vars)
                null
                (list
                 (hbl-append
                  (apply 
                   hbl-append
                   (add-between
                    'comma
                    fresh-vars))
                  (basic-text " fresh" default-style))))]
           [binds (map (lambda (b)
                         (htl-append
                          (car b)
                          (make-=)
                          (cdr b)))
                       pattern-binds)]
           [lst (add-between
                 'comma
                 (append
                  binds
                  side-conditions
                  frsh))])
      (if (null? lst)
          (blank)
          (let ([where (basic-text " where " default-style)])
            (let ([max-w (- max-w (pict-width where))])
              (htl-append where
                          (let loop ([p (car lst)][lst (cdr lst)])
                            (cond
                              [(null? lst) p]
                              [(eq? (car lst) 'comma)
                               (loop (htl-append p (basic-text ", " default-style))
                                     (cdr lst))]
                              [((+ (pict-width p) (pict-width (car lst))) . > . max-w)
                               (vl-append p
                                          (loop (car lst) (cdr lst)))]
                              [else (loop (htl-append p (car lst)) (cdr lst))]))))))))
  
  (define (rp->side-condition-pict rp max-w)
    (side-condition-pict (rule-pict-fresh-vars rp)
                         (rule-pict-side-conditions rp)
                         (rule-pict-pattern-binds rp)
                         max-w))
  
  (define (rp->pict-label rp)
    (if (rule-pict-label rp)
        (let ([m (regexp-match #rx"^([^_]*)(?:_([^_]*)|)$" 
                               (format "~a" (rule-pict-label rp)))])
          (hbl-append
           (text " [" label-style (label-font-size))
           (text (cadr m) label-style (label-font-size))
           (if (caddr m)
               (text (caddr m) `(subscript . ,label-style) (label-font-size))
               (blank))
           (text "]" label-style (label-font-size))))
        (blank)))
  
  (define (add-between i l)
    (cond
      [(null? l) l]
      [else 
       (cons (car l)
             (apply append 
                    (map (λ (x) (list i x)) (cdr l))))]))
  
  (define (make-horiz-space picts) (blank (pict-width (apply cc-superimpose picts)) 0))
  
  (define current-rule-picts->pict rule-picts->pict/vertical)
  (define (set-rule-picts-style! s)
    (set! current-rule-picts->pict
          (case s
            [(vertical) rule-picts->pict/vertical]
            [(compact-vertical) rule-picts->pict/compact-vertical]
            [(vertical-overlapping-side-conditions)
             rule-picts->pict/vertical-overlapping-side-conditions]
            [else rule-picts->pict/horizontal])))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;  language to pict
  ;;
    
  (define/kw (language->ps lang non-terminals filename #:key [pict-wrap (lambda (p) p)])
    (save-as-ps (λ () (pict-wrap (language->pict lang non-terminals)))
                filename))
  
  (define (language->pict lang non-terminals)
    (let* ([all-non-terminals (hash-table-map (compiled-lang-ht lang) (λ (x y) x))]
           [non-terminals (or non-terminals all-non-terminals)])
      (make-grammar-pict (compiled-lang-pict-builder lang) 
                         non-terminals
                         all-non-terminals)))
 
  ;; lang-pict-builder : (-> pict) string -> void
  (define (save-as-ps mk-pict filename) 
    (let ([ps-dc (make-ps-dc filename)])
      (parameterize ([dc-for-text-size ps-dc])
        (send ps-dc start-doc "x")
        (send ps-dc start-page)
        (draw-pict (mk-pict) ps-dc 0 0)
        (send ps-dc end-page)
        (send ps-dc end-doc))))

  (define (make-ps-dc filename)
    (let ([ps-setup (make-object ps-setup%)])
      (send ps-setup copy-from (current-ps-setup))
      (send ps-setup set-file filename)
      (parameterize ([current-ps-setup ps-setup])
        (make-object post-script-dc% #f #f))))
  
  (define (make-grammar-pict raw-info nts all-nts)
    (let* ([info (filter (λ (x) (member (car x) nts))
                         raw-info)]
           [term-space 
            (launder
             (ghost
              (apply cc-superimpose (map (λ (x) (non-terminal (format "~a" (car x))))
                                         info))))])
      (apply vl-append
             (map (λ (line)
                    (htl-append 
                     (rc-superimpose term-space (non-terminal (format "~a" (car line))))
                     (lines->pict 
                      (setup-lines 
                       (build-lines
                        all-nts
                        (add-bars
                         (map (lambda (lw) (loc-wrapper->tree lw #hash())) (cdr line))))))))
                  info))))
  
  (define (make-::=) (basic-text " ::= " default-style))
  (define (make-bar) (basic-text " | " default-style))
  
  (define (add-bars lst)
    (cond
      [(null? lst) null]
      [else
       (cons
        (let ([fst (car lst)])
          (make-loc-wrapper
           (rc-superimpose (ghost (make-bar)) (make-::=))
           (loc-wrapper-line fst)
           (loc-wrapper-line-span fst)
           (loc-wrapper-column fst)
           0
           (loc-wrapper-column fst)))
        
        (let loop ([fst (car lst)]
                   [rst (cdr lst)])
          (cond
            [(null? rst) (list fst)]
            [else 
             (let* ([snd (car rst)]
                    [bar 
                     (cond
                       [(= (loc-wrapper-line snd)
                           (loc-wrapper-line fst))
                        (let* ([line (loc-wrapper-line snd)]
                               [line-span (loc-wrapper-line-span snd)]
                               [column (+ (loc-wrapper-column fst)
                                          (loc-wrapper-span fst))]
                               [span (- (loc-wrapper-column snd)
                                        (+ (loc-wrapper-column fst)
                                           (loc-wrapper-span fst)))]
                               [last-column (+ column span)])
                          (make-loc-wrapper (make-bar) line line-span column span last-column))]
                       [else
                        (make-loc-wrapper
                         (rc-superimpose (make-bar) (ghost (make-::=)))
                         (loc-wrapper-line snd)
                         (loc-wrapper-line-span snd)
                         (loc-wrapper-column snd)
                         0
                         (loc-wrapper-column snd))])])
               (list* fst
                      bar
                      (loop snd (cdr rst))))])))]))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;   metafunction to pict
  ;;
  
  (define (make-=) (basic-text " = " default-style))

  (define metafunction->pict
    (lambda/kw (mf #:key [converters #hash()] [linebreaks #f])
      (let ([all-nts (language-nts (metafunc-proc-lang (metafunction-proc mf)))]
            [sep 2])
        (let ([wrapper->pict
               (lambda (lw)
                 (lines->pict 
                  (setup-lines 
                   (build-lines all-nts (list (loc-wrapper->tree lw converters))))))])
          (table 3
                 (apply append
                        (let* ([eqns (metafunc-proc-pict-info (metafunction-proc mf))]
                               [lhss (map (lambda (eqn) (wrapper->pict (car eqn))) eqns)]
                               [scs (map (lambda (eqn)
                                           (if (and (null? (cadr eqn))
                                                    (null? (caddr eqn)))
                                               #f
                                               (side-condition-pict null 
                                                                    (map wrapper->pict (cadr eqn)) 
                                                                    (map (lambda (p)
                                                                           (cons (wrapper->pict (car p)) (wrapper->pict (cdr p))))
                                                                         (caddr eqn))
                                                                    +inf.0)))
                                         eqns)]
                               [rhss (map (lambda (eqn) (wrapper->pict (cadddr eqn))) eqns)]
                               [linebreaks (or linebreaks
                                               (map (lambda (x) #f) eqns))]
                               [=-pict (make-=)]
                               [max-lhs-w (apply max (map pict-width lhss))]
                               [max-line-w (apply
                                            max
                                            (map (lambda (lhs sc rhs linebreak?)
                                                   (max
                                                    (if sc (pict-width sc) 0)
                                                    (if linebreak?
                                                        (max (pict-width lhs)
                                                             (+ (pict-width rhs) (pict-width =-pict)))
                                                        (+ (pict-width lhs) (pict-width rhs) (pict-width =-pict)
                                                           (* 2 sep)))))
                                                 lhss scs rhss linebreaks))])
                          (map (lambda (lhs sc rhs linebreak?)
                                 (append
                                  (if linebreak?
                                      (list lhs (blank) (blank))
                                      (list lhs =-pict rhs))
                                  (if linebreak?
                                      (let ([p rhs])
                                        (list (hbl-append sep
                                                          =-pict
                                                          (inset p 0 0 (- 5 (pict-width p)) 0))
                                              (blank)
                                              ;; n case this line sets the max width, add suitable space in the right:
                                              (blank (max 0 (- (pict-width p) max-lhs-w sep))
                                                     0)))
                                      null)
                                  (if (not sc)
                                      null
                                      (list (inset sc 0 0 (- 5 (pict-width sc)) 0)
                                            (blank)
                                            ;; In case sc set the max width...
                                            (blank (max 0 (- (pict-width sc) max-lhs-w (pict-width =-pict) (* 2 sep)))
                                                   0)))))
                               lhss
                               scs
                               rhss
                               linebreaks)))
                 ltl-superimpose ltl-superimpose
                 sep sep)))))
  
  (define/kw (metafunction->ps mf filename #:key [converters #hash()] [linebreaks #f])
    (save-as-ps (λ () (metafunction->pict mf #:converters converters #:linebreaks linebreaks))
                filename))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;  pattern processing
  ;;
  
  ;; token = string-token | spacer-token | pict-token | align-token
  
  (define-struct token (column span) (make-inspector))
  
  ;; string : string
  ;; style : valid third argument to mrpict.ss's `text' function
  (define-struct (string-token token) (string style) (make-inspector))
  
  ;; width : number
  ;; pict : pict
  (define-struct (pict-token token) (pict) (make-inspector))
  
  ;; spacer : number
  (define-struct (spacer-token token) () (make-inspector))
  
  ;; pict : pict
  ;; this token always appears at the beginning of a line and its width
  ;; is the x-coordinate of the pict inside itself (which must appear on
  ;; an earlier line)
  (define-struct align-token (pict) (make-inspector))
  
  (define (loc-wrapper->tree p converters)
    (p #:hole-pict hole-pict
       #:rearrange-pict (rearrange-pict converters)))
  
  (define (hole-pict a1 a2 line line-span col span last-column)
    (if (and (not a1) (not a2))
        (basic-text "[]" default-style)
        (make-grouper 
         (list
          (make-loc-wrapper
           (blank)
           line
           0
           col
           (- (loc-wrapper-column a1) col)
           (loc-wrapper-column a1))
          a1 
          (make-loc-wrapper/space-between
           (basic-text "[" default-style)
           a1 a2)
          a2
          
          (cond
            [(and (= (loc-wrapper-line a2) line)
                  (= (loc-wrapper-line-span a2) 0))
             (make-loc-wrapper
              (basic-text "]" default-style)
              (+ (loc-wrapper-line a2)
                 (loc-wrapper-line-span a2))
              (- (+ line line-span)
                 (+ (loc-wrapper-line a2)
                    (loc-wrapper-line-span a2)))
              (+ (loc-wrapper-column a2)
                 (loc-wrapper-span a2))
              (- (+ col span)
                 (+ (loc-wrapper-column a2)
                    (loc-wrapper-span a2)))
              (+ col span))]
            [else
             (make-loc-wrapper
              (basic-text "]" default-style)
              (+ (loc-wrapper-line a2)
                 (loc-wrapper-line-span a2))
              0
              (loc-wrapper-last-column a2)
              0
              (loc-wrapper-last-column a2))])))))
  
  (define (rewrite-proc-apply who
                              args new
                              line line-span col span last-column)
    (if (null? args)
        ;; No args (a constant):
        (if (string? (car new))
            (basic-text (car new) default-style)
            (car new))
        ;; Non-empty args:
        (make-grouper
         (cons
          (make-loc-wrapper
           (if (loc-wrapper? (car new))
               (blank)
               (if (string? (car new))
                   (basic-text (car new) default-style)
                   (car new)))
           line
           0
           col
           (- (loc-wrapper-column (car args)) col)
           (loc-wrapper-column (car args)))
          (let loop ([new (if (loc-wrapper? (car new)) new (cdr new))]
                     [prev-arg (if (loc-wrapper? (car new)) (car args) #f)]
                     [args args])
            (cond
              [(or (null? new)
                   (and (not (loc-wrapper? (car new)))
                        (null? args)))
               (unless (null? args)
                 (error who "rewrite for pict didn't use arg: ~e" (car args)))
               (list (make-loc-wrapper
                      (if (null? new)
                          (blank)
                          (if (string? (car new))
                              (basic-text (car new) default-style)
                              (car new)))
                      (+ (loc-wrapper-line prev-arg)
                         (loc-wrapper-line-span prev-arg))
                      0
                      (loc-wrapper-column prev-arg)
                      (- last-column
                         (loc-wrapper-column prev-arg))
                      last-column))]
              [(not (loc-wrapper? (car new)))
               (cons (make-loc-wrapper/space-between
                      (if (string? (car new))
                          (basic-text (car new) default-style)
                          (car new))
                      prev-arg (car args))
                     (loop (cdr new) prev-arg args))]
              [else
               (unless (eq? (car new) (car args))
                 (error who "found in rewrite sequence: ~e; expected string or next original: ~e" 
                        (car new)
                        (car args)))
               (cons (car new)
                     (loop (cdr new) (car args) (cdr args)))]))))))
    
  (define ((rearrange-pict converters) content line line-span col span last-column)
    (if (and (list? content)
             (= 2 (length content))
             (loc-wrapper? (car content))
             (metafunction-id? (loc-wrapper-e (car content)))
             (loc-wrapper? (cadr content))
             (list? (loc-wrapper-e (cadr content))))
        (let ([args (loc-wrapper-e (cadr content))])
          (let ([conv (hash-table-get converters (metafunction-id-sym (loc-wrapper-e (car content))) #f)])
            (if conv
                (rewrite-proc-apply 'rearrange-pict
                                    args (conv args)
                                    line line-span col span last-column)
                ;; default metafunction conversion
                (make-grouper 
                 (list
                  (make-loc-wrapper
                   (blank)
                   line
                   0
                   col
                   0
                   col)
                  (car content)
                  (rewrite-proc-apply 'rearrange-pict
                                      args (list* #;"〚" "("
                                                  (car args)
                                                  (apply append
                                                         (append
                                                          (map (lambda (s) (list ", " s))
                                                               (cdr args))
                                                          (list (list #;"〛" ")")))))
                                      line line-span col span last-column))))))
        content))
    
  (define (make-loc-wrapper/space-between e before after)
    (cond
      [(= (loc-wrapper-line before) (loc-wrapper-line after))
       (let* ([line (+ (loc-wrapper-line before)
                       (loc-wrapper-line-span before))]
              [line-span
               (- (loc-wrapper-line after)
                  (+ (loc-wrapper-line before)
                     (loc-wrapper-line-span before)))]
              [column
               (+ (loc-wrapper-column before)
                  (loc-wrapper-span before))]
              [span
               (- (loc-wrapper-column after)
                  (+ (loc-wrapper-column before)
                     (loc-wrapper-span before)))]
              [last-column (+ column span)])
         (make-loc-wrapper e line line-span column span last-column))]
      [else
       (make-loc-wrapper
        e
        (+ (loc-wrapper-line before)
           (loc-wrapper-line-span before))
        0
        (+ (loc-wrapper-column before)
           (loc-wrapper-span before))
        0
        (+ (loc-wrapper-column before)
           (loc-wrapper-span before)))]))
  
  (define (build-lines all-nts lws)
    (define initial-column (loc-wrapper-column (car lws)))
    (define initial-line (loc-wrapper-line (car lws)))
    (define current-line (loc-wrapper-line (car lws)))
    (define current-column (loc-wrapper-column (car lws)))
    (define tokens '())
    (define lines '())
    (define (eject line col span atom raw-string?)
      (unless (= current-line line)
        ;; make new lines
        (for-each 
         (λ (x) 
           (set! lines (cons (reverse! tokens) lines))
           (set! tokens '()))
         (build-list (max 0 (- line current-line)) (λ (x) 'whatever)))
        
        (set! tokens (cons (make-spacer-token 0
                                              (- col initial-column))
                           tokens))
        
        (set! current-line line)
        (set! current-column col))
      (when (< current-column col)
        (let ([space-span (- col current-column)])
          (set! tokens (cons (make-string-token (- current-column initial-column)
                                                space-span
                                                (apply string (build-list space-span (λ (x) #\space)))
                                                default-style)
                             tokens))))
      (set! tokens (append 
                    (if raw-string?
                        (list
                         (make-string-token (- col initial-column) 
                                            span 
                                            atom
                                            default-style))
                        (reverse
                         (atom->tokens (- col initial-column) span atom all-nts)))
                    tokens))
      (set! current-column (+ col span)))
    
    (define (handle-loc-wrapped lw last-line last-column last-span)
      (cond
        [(loc-wrapper? lw)
         (handle-object (loc-wrapper-e lw)
                        (loc-wrapper-line lw)
                        (loc-wrapper-column lw)
                        (loc-wrapper-span lw))]
        [(pict? lw)
         (eject current-line current-column 0 lw #f)]
        [else
         (handle-object lw last-line last-column last-span)]))
    
    (define (handle-object obj line col span)
      (cond
        [(grouper? obj)
         (map (λ (x) (handle-loc-wrapped x line col span))
              (grouper-content obj))]
        [(null? obj)
         (eject line col span '() #f)]
        [(list? obj)
         (eject line col 1 "(" #t)
         (for-each (λ (x) (handle-loc-wrapped x line col span))
                   obj)
         (eject current-line 
                (if (= line current-line)
                    (+ col span -1) 
                    current-column)
                1 
                ")"
                #t)]
        [(pair? obj)
         ;; dotted list
         (eject line col 1 "(" #t)
         (let loop ([items obj])
           (cond
             [(pair? items) 
              (handle-loc-wrapped (car items) line col span)
              (loop (cdr items))]
             [else
              (eject current-line 
                     current-column
                     2
                     " ."
                     #t)
              (handle-loc-wrapped items line col span)]))
         (eject current-line 
                (if (= line current-line)
                    (+ col span -1) 
                    current-column)
                1
                ")"
                #t)]
        [(unq-pict? obj)
         (eject line col span 
                (handle-unq (unq-pict-arg obj))
                #f)]
        [else 
         (eject line col span obj #f)]))
    
    (define (handle-unq e)
      (side-condition->pict
       (let loop ([e e])
         (cond
           [(pair? e) (cons (loop (car e))
                            (loop (cdr e)))]
           [(term-pict? e)
            (lines->pict
             (setup-lines
              (build-lines all-nts
                           (list (term-pict-arg e)))))]
           [else e]))))
    
    (for-each (λ (lw) (handle-loc-wrapped lw 0 0 0))
              lws)
    (set! lines (cons (reverse! tokens) lines)) ;; handle last line ejection
    lines)
  
  ;; setup-lines : (listof (listof token)) -> (listof (listof token))
  ;; removes the spacer tokens from the beginning of lines, replacing them with align tokens
  ;; expects the lines to be in reverse order
  (define (setup-lines lines)
    (let loop ([lines lines])
      (cond
        [(null? lines) null]
        [else 
         (let ([line (car lines)]
               [rst (cdr lines)])
           (if (null? line)
               (cons line (loop (cdr lines)))
               (if (spacer-token? (car line))
                   (let* ([pict (blank)]
                          [rst (split-out (token-span (car line))
                                          pict
                                          rst)])
                     (cons (cons (make-align-token pict) (cdr line))
                           (loop rst)))
                   (cons line (loop (cdr lines))))))])))
  
  ;; split-out : number pict (listof (listof token)) -> (listof (listof token))
  (define (split-out col pict lines)
    (let ([new-token (make-pict-token col 0 pict)])
      (let loop ([lines lines])
        (cond
          [(null? lines)
           ;; this case can happen when the line in question is to the left of all other lines
           (error 'exchange-spacer "could not find matching line")]
          [else (let ([line (car lines)])
                  (if (null? line)
                      (cons line (loop (cdr lines)))
                      (let ([spacer (car line)])
                        (cond
                          [(not (spacer-token? spacer))
                           (cons (insert-new-token col new-token (token-column spacer) (car lines))
                                 (cdr lines))]
                          [(= (token-span spacer)
                              col)
                           (cons (list* spacer new-token (cdr line))
                                 (cdr lines))]
                          [(> (token-span spacer)
                              col)
                           (cons line (loop (cdr lines)))]
                          [(< (token-span spacer)
                              col)
                           (cons (insert-new-token col new-token (token-column spacer) (car lines))
                                 (cdr lines))]))))]))))
                  
  (define (insert-new-token column-to-insert new-token init-width line)
    (let loop ([line line])
      (cond
        [(null? line)
         (error 'insert-new-token "not yet finished (need to go to a previous line)")]
        [else
         (let ([tok (car line)])
           (unless (token? tok)
             (error 'insert-new-token "ack ~s" tok))
           (cond
             [(<= column-to-insert (token-column tok))
              (cons new-token line)]
             [(< (token-column tok)
                 column-to-insert
                 (+ (token-column tok) (token-span tok)))
              (append (split-token (- column-to-insert (token-column tok)) tok new-token)
                      (cdr line))]
             [(= column-to-insert (+ (token-column tok) (token-span tok)))
              (list* (car line) new-token (cdr line))]
             [else 
              (cons (car line)
                    (loop (cdr line)))]))])))
               
  (define (split-token offset tok new-token)
    (cond
      [(string-token? tok)
       (list (make-string-token (token-column tok)
                                offset
                                (substring (string-token-string tok)
                                           0 offset)
                                (string-token-style tok))
             new-token
             (make-string-token (+ (token-column tok) offset)
                                (- (token-span tok) offset)
                                (substring (string-token-string tok)
                                           offset 
                                           (string-length (string-token-string tok)))
                                (string-token-style tok)))]
      [(pict-token? tok)
       (list new-token)]))
  
  ;; lines->pict : (listof (listof token)) -> pict
  ;; expects the lines to be in order from bottom to top
  (define (lines->pict lines)
    (let loop ([lines lines])
      (cond
        [(null? lines) (blank)]
        [(null? (cdr lines))
         (handle-single-line (car lines) (blank))]
        [else
         (let ([rst (loop (cdr lines))])
           (vl-append rst (handle-single-line (car lines) rst)))])))
  
  (define (handle-single-line line rst)
    (cond
      [(null? line) 
       (let ([h (pict-height (token->pict (make-string-token 0 0 "x" default-style)))])
         (blank 0 h))]
      [else
       (if (align-token? (car line))
           (let-values ([(x y) (lt-find rst (align-token-pict (car line)))])
             (apply hbl-append 
                    (blank x 0)
                    (map token->pict (cdr line))))
           (apply hbl-append (map token->pict line)))]))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; font specs
  ;;
  
  (define (token->pict tok)
    (cond
      [(string-token? tok)
       (basic-text (string-token-string tok) (string-token-style tok))]
      [(pict-token? tok) (pict-token-pict tok)]
      [else (error 'token->pict "~s" tok)]))
  
  (define (atom->tokens col span atom all-nts)
    (cond
      [(pict? atom)
       (list (make-pict-token col span atom))]
      [(metafunction-id? atom)
       (list (make-string-token col span (format "~s" (metafunction-id-sym atom)) metafunction-style))]
      [(otherwise-pict? atom)
       (list (make-string-token col span "otherwise" `(italic . ,default-style)))]
      [(and (symbol? atom)
            (regexp-match #rx"^([^_]*)_(.*)$" (format "~a" atom)))
       =>
       (λ (m)
         (let* ([first-part (cadr m)]
                [second-part (caddr m)]
                [first-span (- span (string-length first-part))])
           (list 
            (make-string-token col
                               first-span
                               first-part
                               non-terminal-style)
            (make-string-token (+ col first-span) 
                               (- span first-span)
                               second-part
                               non-terminal-subscript-style))))]
      [(memq atom all-nts)
       (list (make-string-token col span (format "~s" atom) non-terminal-style))]
      [(eq? atom '...)
       (if STIX?
           (list (make-pict-token col span (basic-text "\u22ef" default-style)))
           (list (make-string-token col span "..." default-style)))]
      [else
       (list (make-string-token col span (format "~s" atom) literal-style))]))
  
  (define (il-memq sym s)
    (and (pair? s)
         (or (eq? sym (car s))
             (il-memq sym (cdr s)))))
  (define (il-remq sym s)
    (if (pair? s)
        (if (eq? sym (car s))
            (cdr s)
            (cons (car s) (il-remq sym (cdr s))))
        s))
  
  (define (basic-text str style) 
    (if (il-memq 'caps style)
        (caps-text str (il-remq 'caps style) (default-font-size))
        (text str style (default-font-size))))
  (define (non-terminal str) (text str non-terminal-style (default-font-size)))
  (define (unksc str) (pink-background (text str 'modern (default-font-size))))
  (define non-terminal-style '(italic . roman))
  (define non-terminal-subscript-style `(subscript . ,non-terminal-style))
  (define default-style 'roman)
  (define metafunction-style 'swiss)
  (define literal-style 'swiss)
  (define label-style 'swiss)
  (define default-font-size (make-parameter 14))
  (define label-font-size (make-parameter 14))
  
  (define (set-literal-style! s) (set! literal-style s))
  (define (set-metafunction-style! s) (set! metafunction-style s))
  
  (define (mk-arrow-pict sz curvy?)
    (make-arrow-pict sz curvy? default-style (default-font-size)))

  (define long-arrow-pict (mk-arrow-pict "xxx" #f))
  (define short-arrow-pict (mk-arrow-pict "m" #f))
  (define curvy-arrow-pict (mk-arrow-pict "xxx" #t))
  
  (define (arrow->pict arr)
    (case arr
      ;; we're waiting for the STIX fonts before using the commented out guys.
      [(--> -+>)
       (if STIX?
           (basic-text "\u27f5" default-style)
           (long-arrow-pict))]
      [(==>)
       (if STIX?
           (basic-text "\u27f9" default-style)
           (scale (basic-text "\u21D2" default-style) 2 1))]
      [(->) (if STIX?
                (basic-text "\u2192" default-style)
                (short-arrow-pict))]
      [(=>) (basic-text "\u21D2" default-style)]
      [(..>) (basic-text "\u21E2" default-style)]
      [(>->) (basic-text "\u21a3" default-style)]
      [(~> ~~>) (if STIX?
                    (basic-text "\u21DD" default-style)
                    (curvy-arrow-pict))]
      [(:->) (basic-text "\u21a6" default-style)]
      [(c->) (basic-text "\u21aa" default-style)]
      [(-->>) (basic-text "\u21a0" default-style)]
      [(>--) (basic-text "\u291a" default-style)]
      [(--<) (basic-text "\u2919" default-style)]
      [(>>--) (basic-text "\u291c" default-style)]
      [(--<<) (basic-text "\u291b" default-style)]
      [else (error 'arrow->pict "unknown arrow ~s" arr)]))
  

  (require (lib "match.ss"))
  (define (side-condition->pict sc)
    (let loop ([sc sc])
      (match sc
        [(? pict? sc) sc]
        [`(or ,s1 ,s2)
          (hbl-append
           (loop s1)
           (basic-text " or " 'roman)
           (loop s2))]
        [`(or ,s1 ,s2 ...)
          (apply hbl-append
                 (add-between (basic-text ", or " 'roman)
                              (map loop (cons s1 s2))))]
        [else 
         (fprintf (current-error-port) "unknown Scheme code: ~s\n" sc)
         (render-side-condition sc)])))
  
  (define (render-side-condition sc)
    (cond
      [(pict? sc) sc]
      [(null? sc) (unksc "()")]
      [(pair? sc)
       (hbl-append
        (unksc "(")
        (render-side-condition (car sc))
        (if (null? (cdr sc))
            (blank)
            (render-side-condition/list (cdr sc)))
        (unksc ")"))]
      [else
       (unksc (format "~s" sc))]))
  
  ;; render-side-condition : pair -> pict
  (define (render-side-condition/list sc)
    (cond
      [(null? (cdr sc))
       (hbl-append 
        (unksc " ")
        (render-side-condition (car sc)))]
      [(pair? (cdr sc))
       (hbl-append 
        (unksc " ")
        (render-side-condition (car sc))
        (render-side-condition/list (cdr sc)))]
      [else
       (hbl-append 
        (unksc " ")
        (render-side-condition (car sc))
        (unksc " . ")
        (render-side-condition (cdr sc)))]))
  
  
  (define (pink-background p)
    (refocus
     (cc-superimpose 
      (colorize (filled-rectangle (pict-width p)
                                  (pict-height p))
                "pink")
      p)
     p))
  
  )