(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)
(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)
(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) 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])))
(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)))
(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))))])))]))
(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)
(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)
(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))
(define-struct token (column span) (make-inspector))
(define-struct (string-token token) (string style) (make-inspector))
(define-struct (pict-token token) (pict) (make-inspector))
(define-struct (spacer-token token) () (make-inspector))
(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)
(if (string? (car new))
(basic-text (car new) default-style)
(car new))
(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)
(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)
(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)
(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)) lines)
(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))))))])))
(define (split-out col pict lines)
(let ([new-token (make-pict-token col 0 pict)])
(let loop ([lines lines])
(cond
[(null? 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)]))
(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)))]))
(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
[(--> -+>)
(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))]))
(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))
)