1046 lines
34 KiB
Scheme
1046 lines
34 KiB
Scheme
|
|
#lang scheme/unit
|
|
|
|
(require scheme/gui/base
|
|
scheme/class)
|
|
|
|
(require "common-sig.ss")
|
|
|
|
(import texpict-common-setup^)
|
|
(export texpict-common^ texpict-internal^)
|
|
|
|
(define default-seg 5)
|
|
(define recordseplinespace 4)
|
|
|
|
(define-struct pict (draw ; drawing instructions
|
|
width ; total width
|
|
height ; total height >= ascent + desecnt
|
|
ascent ; portion of height above top baseline
|
|
descent ; portion of height below bottom baseline
|
|
children ; list of child records
|
|
panbox ; panorama box, computed on demand
|
|
last) ; a descendent for the bottom-right
|
|
#:mutable)
|
|
(define-struct child (pict dx dy sx sy))
|
|
(define-struct bbox (x1 y1 x2 y2 ay dy))
|
|
|
|
(define (quotient* a b)
|
|
(if (integer? a)
|
|
(quotient a b)
|
|
(/ a b)))
|
|
|
|
(define blank
|
|
(case-lambda
|
|
[() (blank 0 0 0)]
|
|
[(s) (blank s s)]
|
|
[(w h) (blank w h 0)]
|
|
[(w a d) (make-pict `(picture ,w ,(+ a d)) w (+ a d) a d null #f #f)]
|
|
[(w h a d) (make-pict `(picture ,w ,h) w h a d null #f #f)]))
|
|
|
|
(define (extend-pict box dx dy dw da dd draw)
|
|
(let ([w (pict-width box)]
|
|
[h (pict-height box)]
|
|
[d (pict-descent box)]
|
|
[a (pict-ascent box)])
|
|
(make-pict (if draw draw (pict-draw box))
|
|
(+ w dw) (+ h da dd)
|
|
(max 0 (+ a da)) (max 0 (+ d dd))
|
|
(list (make-child box dx dy 1 1))
|
|
#f
|
|
(pict-last box))))
|
|
|
|
(define (single-pict-offset pict subbox)
|
|
(let floop ([box pict]
|
|
[found values]
|
|
[not-found (lambda () (error 'find-XX
|
|
"sub-pict: ~a not found in: ~a"
|
|
subbox pict))])
|
|
(if (eq? box subbox)
|
|
(found 0 0 1 1)
|
|
(let loop ([c (pict-children box)])
|
|
(if (null? c)
|
|
(not-found)
|
|
(floop (child-pict (car c))
|
|
(lambda (dx dy sx sy)
|
|
(let ([tsx (child-sx (car c))]
|
|
[tsy (child-sy (car c))])
|
|
(found (+ (* tsx dx)
|
|
(child-dx (car c)))
|
|
(+ (* tsy dy)
|
|
(child-dy (car c)))
|
|
(* sx tsx)
|
|
(* sy tsy))))
|
|
(lambda ()
|
|
(loop (cdr c)))))))))
|
|
|
|
(define (find-lbx pict subbox-path)
|
|
(if (pict? subbox-path)
|
|
(single-pict-offset pict subbox-path)
|
|
(let loop ([p pict][l subbox-path][dx 0][dy 0][sx 1][sy 1])
|
|
(if (null? l)
|
|
(values dx dy sx sy)
|
|
(let-values ([(x y tsx tsy) (find-lbx p (car l))])
|
|
(loop (car l) (cdr l)
|
|
(+ (* sx x) dx) (+ (* sy y) dy)
|
|
(* sx tsx) (* sy tsy)))))))
|
|
|
|
(define-values (find-lt
|
|
find-lc
|
|
find-lb
|
|
find-ltl
|
|
find-lbl
|
|
find-ct
|
|
find-cc
|
|
find-cb
|
|
find-ctl
|
|
find-cbl
|
|
find-rt
|
|
find-rc
|
|
find-rb
|
|
find-rtl
|
|
find-rbl)
|
|
(let ([lb (lambda (x sx w d a) x)]
|
|
[c (lambda (x sx w d a) (+ x (* sx (quotient* w 2))))]
|
|
[rt (lambda (x sx w d a) (+ x (* sx w)))]
|
|
[tline (lambda (x sx w d a) (+ x (* sx (- w a))))]
|
|
[bline (lambda (x sx w d a) (+ x (* sx d)))]
|
|
[find (lambda (get-x get-y)
|
|
(lambda (pict pict-path)
|
|
(let-values ([(dx dy sx sy) (find-lbx pict pict-path)])
|
|
(let ([p (let loop ([path pict-path])
|
|
(cond
|
|
[(pict? path) path]
|
|
[(null? (cdr path)) (loop (car path))]
|
|
[else (loop (cdr path))]))])
|
|
(values (get-x dx sx (pict-width p) 0 0)
|
|
(get-y dy sy (pict-height p) (pict-descent p) (pict-ascent p)))))))])
|
|
(values (find lb rt)
|
|
(find lb c)
|
|
(find lb lb)
|
|
(find lb tline)
|
|
(find lb bline)
|
|
(find c rt)
|
|
(find c c)
|
|
(find c lb)
|
|
(find c tline)
|
|
(find c bline)
|
|
(find rt rt)
|
|
(find rt c)
|
|
(find rt lb)
|
|
(find rt tline)
|
|
(find rt bline))))
|
|
|
|
(define-values (lt-find
|
|
lc-find
|
|
lb-find
|
|
ltl-find
|
|
lbl-find
|
|
ct-find
|
|
cc-find
|
|
cb-find
|
|
ctl-find
|
|
cbl-find
|
|
rt-find
|
|
rc-find
|
|
rb-find
|
|
rtl-find
|
|
rbl-find)
|
|
(let ([flip (lambda (orig)
|
|
(lambda (pict pict-path)
|
|
(let-values ([(x y) (orig pict pict-path)])
|
|
(values x (- (pict-height pict) y)))))])
|
|
(values (flip find-lt)
|
|
(flip find-lc)
|
|
(flip find-lb)
|
|
(flip find-ltl)
|
|
(flip find-lbl)
|
|
(flip find-ct)
|
|
(flip find-cc)
|
|
(flip find-cb)
|
|
(flip find-ctl)
|
|
(flip find-cbl)
|
|
(flip find-rt)
|
|
(flip find-rc)
|
|
(flip find-rb)
|
|
(flip find-rtl)
|
|
(flip find-rbl))))
|
|
|
|
(define (launder box)
|
|
(unless (pict-panbox box)
|
|
(panorama-box! box))
|
|
(let ([b (extend-pict box 0 0 0 0 0 #f)])
|
|
(set-pict-children! b null)
|
|
(set-pict-panbox! b (pict-panbox box))
|
|
;; After laundering, we can't find the last-pos box.
|
|
;; So create a new last-position box to preserve the
|
|
;; original shape:
|
|
(let ([l (pict-last box)])
|
|
(set-pict-last! box #f) ; preserve invariants
|
|
(cond
|
|
[(not l) b]
|
|
[else
|
|
(let-values ([(x y) (lt-find box l)]
|
|
[(l) (let loop ([l l])
|
|
(if (pair? l)
|
|
(if (null? (cdr l))
|
|
(car l)
|
|
(loop (cdr l)))
|
|
l))])
|
|
(let ([b2 (blank (pict-width l) (pict-height l)
|
|
(pict-ascent l) (pict-descent l))])
|
|
(use-last/unchecked
|
|
(pin-over b x y b2)
|
|
b2)))]))))
|
|
|
|
(define (lift p n)
|
|
(let* ([dh (- (max 0 (- n (pict-descent p))))]
|
|
[do-a? (= (pict-height p)
|
|
(+ (pict-ascent p) (pict-descent p)))]
|
|
[h2 (+ dh (pict-height p))]
|
|
[d2 (max 0 (- (pict-descent p) n))])
|
|
(make-pict (pict-draw p)
|
|
(pict-width p) h2
|
|
(if do-a?
|
|
(- h2 d2)
|
|
(pict-ascent p))
|
|
d2
|
|
(map (lambda (c)
|
|
(make-child
|
|
(child-pict c)
|
|
(child-dx c)
|
|
(+ dh (child-dy c))
|
|
1 1))
|
|
(pict-children p))
|
|
#f
|
|
(pict-last p))))
|
|
|
|
(define (drop p n)
|
|
(let* ([dh (- (max 0 (- n (pict-ascent p))))]
|
|
[do-d? (= (pict-height p)
|
|
(+ (pict-ascent p) (pict-descent p)))]
|
|
[h2 (+ dh (pict-height p))]
|
|
[a2 (max 0 (- (pict-ascent p) n))])
|
|
(make-pict (pict-draw p)
|
|
(pict-width p) h2
|
|
a2
|
|
(if do-d?
|
|
(- h2 a2)
|
|
(pict-descent p))
|
|
(pict-children p)
|
|
#f
|
|
(pict-last p))))
|
|
|
|
(define (baseless p)
|
|
(let ([p (lift p (pict-descent p))])
|
|
(drop p (- (pict-ascent p) (pict-height p)))))
|
|
|
|
(define (refocus p c)
|
|
(let-values ([(x y) (find-lt p c)])
|
|
(let ([p (inset p
|
|
(- x) (- y (pict-height p))
|
|
(- (- (pict-width p) x (pict-width c)))
|
|
(- (pict-height c) y))])
|
|
(make-pict (pict-draw p)
|
|
(pict-width c) (pict-height c)
|
|
(pict-ascent c) (pict-descent c)
|
|
(pict-children p)
|
|
#f
|
|
(last* c)))))
|
|
|
|
(define (panorama-box! p)
|
|
(let ([bb (pict-panbox p)])
|
|
(if bb
|
|
(values (bbox-x1 bb) (bbox-y1 bb) (bbox-x2 bb) (bbox-y2 bb)
|
|
(bbox-ay bb) (bbox-dy bb))
|
|
(let loop ([x1 0][y1 0][x2 (pict-width p)][y2 (pict-height p)]
|
|
[ay (- (pict-height p) (pict-ascent p))][dy (pict-descent p)]
|
|
[l (pict-children p)])
|
|
(if (null? l)
|
|
(begin
|
|
(set-pict-panbox! p (make-bbox x1 y1 x2 y2 ay dy))
|
|
(values x1 y1 x2 y2 ay dy))
|
|
(let ([c (car l)])
|
|
(let-values ([(cx1 cy1 cx2 cy2 cay cdy) (panorama-box! (child-pict c))])
|
|
(loop (min x1 (* (+ cx1 (child-dx c)) (child-sx c)))
|
|
(min y1 (* (+ cy1 (child-dy c)) (child-sy c)))
|
|
(max x2 (* (+ cx2 (child-dx c)) (child-sx c)))
|
|
(max y2 (* (+ cy2 (child-dy c)) (child-sy c)))
|
|
(max ay (* (+ cay (child-dy c)) (child-sy c)))
|
|
(min dy (* (+ cdy (child-dy c)) (child-sy c)))
|
|
(cdr l)))))))))
|
|
|
|
(define (panorama p)
|
|
(let-values ([(x1 y1 x2 y2 ay dy) (panorama-box! p)])
|
|
(let ([h (- y2 y1)])
|
|
(place-over (blank (- x2 x1) h (- h ay) dy)
|
|
(- x1) (- y2 (pict-height p))
|
|
p))))
|
|
|
|
(define (clip-descent b)
|
|
(let* ([w (pict-width b)]
|
|
[h (pict-height b)]
|
|
[d (pict-descent b)])
|
|
(extend-pict
|
|
b 0 (- d)
|
|
0 0 (- d)
|
|
`(picture ,w ,(- h d)
|
|
(put 0 ,(- d) ,(pict-draw b))))))
|
|
|
|
(define (clip-ascent b)
|
|
(let* ([w (pict-width b)]
|
|
[h (pict-height b)]
|
|
[a (pict-descent b)])
|
|
(extend-pict
|
|
b 0 a
|
|
0 (- a) 0
|
|
`(picture ,w ,(- h a)
|
|
(put 0 0 ,(pict-draw b))))))
|
|
|
|
(define (thickness mode b)
|
|
(let* ([w (pict-width b)]
|
|
[h (pict-height b)])
|
|
(extend-pict
|
|
b 0 0 0 0 0
|
|
`(picture ,w ,h
|
|
(thickness ,mode ,(pict-draw b))))))
|
|
|
|
(define (thick b) (thickness 'thicklines b))
|
|
(define (thin b) (thickness 'thinlines b))
|
|
(define (line-thickness n b) (thickness n b))
|
|
|
|
(define inset
|
|
(case-lambda
|
|
[(box a) (inset box a a a a)]
|
|
[(box h v) (inset box h v h v)]
|
|
[(box l t r b)
|
|
(let ([w (+ l r (pict-width box))]
|
|
[h (+ t b (pict-height box))])
|
|
(extend-pict
|
|
box l b
|
|
(+ l r) t b
|
|
`(picture
|
|
,w ,h
|
|
(put ,l ,b ,(pict-draw box)))))]))
|
|
|
|
(define (use-last* p sub-p)
|
|
(use-last p (last* sub-p)))
|
|
|
|
(define (last* sub-p)
|
|
;; Either use `sub-p' for last or create a path though `sub-p'
|
|
;; to the last of `sub-p' (in case the last of `sub-p' is also
|
|
;; in other places within `p')
|
|
(let ([l (pict-last sub-p)])
|
|
(cond
|
|
[(not l) sub-p]
|
|
[(eq? l sub-p) sub-p]
|
|
[(pair? l) (if (eq? (car l) sub-p)
|
|
l
|
|
(cons sub-p l))]
|
|
[else (list sub-p l)])))
|
|
|
|
(define (use-last p sub-p)
|
|
(if (let floop ([p p] [sub-p sub-p])
|
|
(or (eq? p sub-p)
|
|
(and (pair? sub-p)
|
|
(eq? p (car sub-p))
|
|
(or (null? (cdr sub-p))
|
|
(floop p (cdr sub-p))))
|
|
(ormap (lambda (c) (floop (child-pict c) sub-p))
|
|
(pict-children p))))
|
|
(use-last/unchecked p sub-p)
|
|
(error 'use-last
|
|
"given new last-pict path: ~e not in the base pict: ~e"
|
|
sub-p
|
|
p)))
|
|
|
|
(define (use-last/unchecked p sub-p)
|
|
(make-pict (pict-draw p)
|
|
(pict-width p) (pict-height p)
|
|
(pict-ascent p) (pict-descent p)
|
|
(list (make-child p 0 0 1 1))
|
|
#f
|
|
sub-p))
|
|
|
|
(define dash-frame
|
|
(case-lambda
|
|
[(box) (dash-frame box default-seg)]
|
|
[(box seg)
|
|
(let ([w (pict-width box)]
|
|
[h (pict-height box)])
|
|
(extend-pict
|
|
box 0 0 0 0 0
|
|
`(picture
|
|
,w ,h
|
|
(put 0 0 ,(pict-draw box))
|
|
(put 0 0 ,(pict-draw (dash-hline w 0 seg)))
|
|
(put 0 ,h ,(pict-draw (dash-hline w 0 seg)))
|
|
(put 0 0 ,(pict-draw (dash-vline 0 h seg)))
|
|
(put ,w 0 ,(pict-draw (dash-vline 0 h seg))))))]))
|
|
|
|
(define (frame box)
|
|
(dash-frame box (max (pict-width box) (pict-height box))))
|
|
|
|
(define (dash-line width height rotate seg)
|
|
(let ([vpos (quotient* height 2)])
|
|
(make-pict
|
|
`(picture
|
|
,@(rotate width height)
|
|
,@(if (>= seg width)
|
|
`((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,width)))
|
|
(let* ([remain (+ (- width (floor width))
|
|
(remainder (floor width) (* 2 seg)))]
|
|
[count (inexact->exact (floor (quotient* width (* 2 seg))))]
|
|
[lremain (quotient* remain 2)]
|
|
[rremain (- remain lremain)])
|
|
`((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,lremain))
|
|
,@(let loop ([count count][pos lremain])
|
|
(if (zero? count)
|
|
null
|
|
(cons `(put ,@(rotate (+ pos seg) vpos)
|
|
(line ,@(rotate 1 0) ,seg))
|
|
(loop (sub1 count) (+ pos seg seg)))))
|
|
(put ,@(rotate (- width rremain) vpos)
|
|
(line ,@(rotate 1 0) ,rremain))))))
|
|
(car (rotate width height))
|
|
(cadr (rotate width height))
|
|
(cadr (rotate 0 height)) 0
|
|
null
|
|
#f
|
|
#f)))
|
|
|
|
(define (rlist b a) (list a b))
|
|
|
|
(define (hline width height)
|
|
(dash-line width height list width))
|
|
|
|
(define (vline width height)
|
|
(dash-line height width rlist height))
|
|
|
|
(define dash-hline
|
|
(case-lambda
|
|
[(width height) (dash-hline width height default-seg)]
|
|
[(width height seg) (dash-line width height list seg)]))
|
|
|
|
(define dash-vline
|
|
(case-lambda
|
|
[(width height) (dash-vline width height default-seg)]
|
|
[(width height seg) (dash-line height width rlist seg)]))
|
|
|
|
(define (oval box)
|
|
(let ([w (pict-width box)]
|
|
[h (pict-height box)])
|
|
(extend-pict
|
|
box 0 0 0 0 0
|
|
`(picture
|
|
,w ,h
|
|
(put 0 0 ,(pict-draw box))
|
|
(put ,(quotient* w 2) ,(quotient* h 2) (oval "" ,w ,h))))))
|
|
|
|
(define (oval/radius box r)
|
|
(let* ([w (pict-width box)]
|
|
[h (pict-height box)]
|
|
[rr (* 2 r)]
|
|
[lw (- w rr)]
|
|
[lh (- h rr)])
|
|
(extend-pict
|
|
box 0 0 0 0 0
|
|
`(picture
|
|
,w ,h
|
|
(put 0 0 ,(pict-draw box))
|
|
(put ,r ,r (oval "[bl]" ,rr ,rr))
|
|
(put ,r 0 (line 1 0 ,lw))
|
|
(put ,(- w r) ,r (oval "[br]" ,rr ,rr))
|
|
(put ,w ,r (line 0 1 ,lh))
|
|
(put ,r ,(- h r) (oval "[tl]" ,rr ,rr))
|
|
(put ,r ,h (line 1 0 ,lw))
|
|
(put ,(- w r) ,(- h r) (oval "[tr]" ,rr ,rr))
|
|
(put ,0 ,r (line 0 1 ,lh))))))
|
|
|
|
(define (big-circle d)
|
|
(let ([r (quotient* d 2)])
|
|
(picture
|
|
d d
|
|
`((curve 0 ,r ,r 0 0 0)
|
|
(curve ,r 0 ,d ,r ,d 0)
|
|
(curve ,d ,r ,r ,d ,d ,d)
|
|
(curve ,r ,d 0 ,r 0 ,d)))))
|
|
|
|
(define (ghost box)
|
|
(let ([w (pict-width box)]
|
|
[h (pict-height box)])
|
|
(extend-pict
|
|
box 0 0 0 0 0
|
|
`(picture
|
|
,w ,h))))
|
|
|
|
(define-values (vl-append
|
|
vc-append
|
|
vr-append
|
|
ht-append
|
|
hc-append
|
|
hb-append
|
|
htl-append
|
|
hbl-append)
|
|
(let ([make-append-boxes
|
|
(lambda (wcomb hcomb fxoffset fyoffset rxoffset ryoffset
|
|
combine-ascent combine-descent)
|
|
(letrec ([*-append
|
|
(lambda (sep . args)
|
|
(unless (number? sep)
|
|
(set! args (cons sep args))
|
|
(set! sep 0))
|
|
(let append-boxes ([args args])
|
|
(cond
|
|
[(null? args) (blank)]
|
|
[(null? (cdr args)) (car args)]
|
|
[else
|
|
(let* ([first (car args)]
|
|
[rest (append-boxes (cdr args))]
|
|
[w (wcomb (pict-width first) (pict-width rest) sep first rest)]
|
|
[h (hcomb (pict-height first) (pict-height rest) sep first rest)]
|
|
[fw (pict-width first)]
|
|
[fh (pict-height first)]
|
|
[rw (pict-width rest)]
|
|
[rh (pict-height rest)]
|
|
[fd1 (pict-ascent first)]
|
|
[fd2 (pict-descent first)]
|
|
[rd1 (pict-ascent rest)]
|
|
[rd2 (pict-descent rest)]
|
|
[dx1 (fxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)]
|
|
[dy1 (fyoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)]
|
|
[dx2 (rxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)]
|
|
[dy2 (ryoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)])
|
|
(make-pict
|
|
`(picture
|
|
,w ,h
|
|
(put ,dx1
|
|
,dy1
|
|
,(pict-draw first))
|
|
(put ,dx2
|
|
,dy2
|
|
,(pict-draw rest)))
|
|
w h
|
|
(combine-ascent fd1 rd1 fd2 rd2 fh rh h (+ dy1 fh) (+ dy2 rh))
|
|
(combine-descent fd2 rd2 fd1 rd1 fh rh h (- h dy1) (- h dy2))
|
|
(list (make-child first dx1 dy1 1 1)
|
|
(make-child rest dx2 dy2 1 1))
|
|
#f
|
|
(last* rest)))])))])
|
|
*-append))]
|
|
[2max (lambda (a b c . rest) (max a b))]
|
|
[zero (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 . args) 0)]
|
|
[fv (lambda (a b . args) a)]
|
|
[sv (lambda (a b . args) b)]
|
|
[min2 (lambda (a b . args) (min a b))]
|
|
[max2 (lambda (a b . args) (max a b))]
|
|
[3+ (lambda (a b c . args) (+ a b c))]
|
|
[a-max (lambda (a b c first rest)
|
|
(+ (max (pict-ascent first) (pict-ascent rest))
|
|
(max (- (pict-height first) (pict-ascent first))
|
|
(- (pict-height rest) (pict-ascent rest)))))]
|
|
[d-max (lambda (a b c first rest)
|
|
(+ (max (pict-descent first) (pict-descent rest))
|
|
(max (- (pict-height first) (pict-descent first))
|
|
(- (pict-height rest) (pict-descent rest)))))]
|
|
[min-ad (lambda (a b oa ob ah bh h da db)
|
|
(- h (max oa ob) (max (- ah oa a)
|
|
(- bh ob b))))]
|
|
[xmin-ad (lambda (a b oa ob ah bh h da db)
|
|
(min (+ (- h da) a) (+ (- h db) b)))])
|
|
(values
|
|
(make-append-boxes 2max 3+
|
|
zero (lambda (fw fh rw rh sep . a) (+ sep rh))
|
|
zero zero
|
|
fv sv)
|
|
(make-append-boxes 2max 3+
|
|
(lambda (fw fh rw rh sep . a) (quotient* (- (max fw rw) fw) 2))
|
|
(lambda (fw fh rw rh sep . a) (+ sep rh))
|
|
(lambda (fw fh rw rh sep . a) (quotient* (- (max fw rw) rw) 2))
|
|
zero
|
|
fv sv)
|
|
(make-append-boxes 2max 3+
|
|
(lambda (fw fh rw rh sep . a) (- (max fw rw) fw))
|
|
(lambda (fw fh rw rh sep . a) (+ sep rh))
|
|
(lambda (fw fh rw rh sep . a) (- (max fw rw) rw))
|
|
zero
|
|
fv sv)
|
|
(make-append-boxes 3+ 2max
|
|
zero
|
|
(lambda (fw fh rw rh sep . a) (- (max fh rh) fh))
|
|
(lambda (fw fh rw rh sep . a) (+ sep fw))
|
|
(lambda (fw fh rw rh sep . a) (- (max fh rh) rh))
|
|
xmin-ad xmin-ad)
|
|
(make-append-boxes 3+ 2max
|
|
zero
|
|
(lambda (fw fh rw rh sep . a) (quotient* (- (max fh rh) fh) 2))
|
|
(lambda (fw fh rw rh sep . a) (+ sep fw))
|
|
(lambda (fw fh rw rh sep . a) (quotient* (- (max fh rh) rh) 2))
|
|
xmin-ad xmin-ad)
|
|
(make-append-boxes 3+ 2max
|
|
zero zero
|
|
(lambda (fw fh rw rh sep . a) (+ sep fw)) zero
|
|
xmin-ad xmin-ad)
|
|
(make-append-boxes 3+ a-max
|
|
zero
|
|
(lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h)
|
|
(- h fh (- (max fd1 rd1) fd1)))
|
|
(lambda (fw fh rw rh sep . a) (+ sep fw))
|
|
(lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h)
|
|
(- h rh (- (max fd1 rd1) rd1)))
|
|
max2 min-ad)
|
|
(make-append-boxes 3+ d-max
|
|
zero
|
|
(lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h)
|
|
(- (max fd2 rd2) fd2))
|
|
(lambda (fw fh rw rh sep . a) (+ sep fw))
|
|
(lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h)
|
|
(- (max fd2 rd2) rd2))
|
|
min-ad max2))))
|
|
|
|
(define-values (lt-superimpose
|
|
lb-superimpose
|
|
lc-superimpose
|
|
ltl-superimpose
|
|
lbl-superimpose
|
|
rt-superimpose
|
|
rb-superimpose
|
|
rc-superimpose
|
|
rtl-superimpose
|
|
rbl-superimpose
|
|
ct-superimpose
|
|
cb-superimpose
|
|
cc-superimpose
|
|
ctl-superimpose
|
|
cbl-superimpose)
|
|
(let ([make-superimpose
|
|
(lambda (get-h get-v get-th)
|
|
(lambda boxes
|
|
(let ([max-w (apply max (map pict-width boxes))]
|
|
[max-h (apply max (map pict-height boxes))]
|
|
[max-a (apply max (map pict-ascent boxes))]
|
|
[max-a-complement (apply max (map (lambda (b) (- (pict-height b) (pict-ascent b)))
|
|
boxes))]
|
|
[max-d (apply max (map pict-descent boxes))]
|
|
[max-d-complement (apply max (map (lambda (b) (- (pict-height b) (pict-descent b)))
|
|
boxes))])
|
|
(let ([p (picture max-w (get-th max-h max-a max-d max-a-complement max-d-complement)
|
|
(map (lambda (box)
|
|
`(place ,(get-h max-w (pict-width box))
|
|
,(get-v max-h (pict-height box)
|
|
max-d (pict-descent box)
|
|
max-a-complement (pict-ascent box))
|
|
,box))
|
|
boxes))])
|
|
;; Figure out top and bottom baselines by finding the picts again, etc:
|
|
(let ([ys (map (lambda (box)
|
|
(let-values ([(x y) (find-lt p box)])
|
|
y))
|
|
boxes)])
|
|
(let ([min-a (apply min (map (lambda (box y)
|
|
(+ (- (pict-height p) y) (pict-ascent box)))
|
|
boxes ys))]
|
|
[min-d (apply min (map (lambda (box y)
|
|
(+ (- y (pict-height box)) (pict-descent box)))
|
|
boxes ys))])
|
|
(make-pict (pict-draw p)
|
|
(pict-width p) (pict-height p)
|
|
min-a min-d
|
|
(pict-children p)
|
|
#f
|
|
;; Find bottomost, rightmost of old last picts to be the
|
|
;; new last pict.
|
|
(let ([subs (map (lambda (box)
|
|
(let ([last (last* box)])
|
|
(let-values ([(x y) (rb-find p last)])
|
|
(list last x y))))
|
|
boxes)])
|
|
(if (null? subs)
|
|
#f
|
|
(caar (sort subs
|
|
(lambda (a b)
|
|
(let ([ay (caddr a)]
|
|
[by (caddr b)])
|
|
(cond
|
|
[(ay . > . by) #t]
|
|
[(= ay by) ((cadr a) . > . (cadr b))]
|
|
[else #f]))))))))))))))]
|
|
[norm (lambda (h a d ac dc) h)]
|
|
[tbase (lambda (h a d ac dc) (+ a ac))]
|
|
[bbase (lambda (h a d ac dc) (+ d dc))]
|
|
[lb (lambda (m v . rest) 0)]
|
|
[rt (lambda (m v . rest) (- m v))]
|
|
[tline (lambda (m v md d mac a) (- mac (- v a)))]
|
|
[bline (lambda (m v md d mac a) (- md d))]
|
|
[c (lambda (m v . rest) (quotient* (- m v) 2))])
|
|
(values
|
|
(make-superimpose lb rt norm)
|
|
(make-superimpose lb lb norm)
|
|
(make-superimpose lb c norm)
|
|
(make-superimpose lb tline tbase)
|
|
(make-superimpose lb bline bbase)
|
|
(make-superimpose rt rt norm)
|
|
(make-superimpose rt lb norm)
|
|
(make-superimpose rt c norm)
|
|
(make-superimpose rt tline tbase)
|
|
(make-superimpose rt bline bbase)
|
|
(make-superimpose c rt norm)
|
|
(make-superimpose c lb norm)
|
|
(make-superimpose c c norm)
|
|
(make-superimpose c tline tbase)
|
|
(make-superimpose c bline bbase))))
|
|
|
|
(define table
|
|
(case-lambda
|
|
[(ncol cells col-aligns row-aligns col-seps row-seps)
|
|
(unless (positive? ncol)
|
|
(raise-type-error 'table "positive column count" ncol))
|
|
(let ([count (length cells)])
|
|
(unless (zero? (remainder count ncol))
|
|
(error 'table "cell count isn't divisble by the provided column count"))
|
|
(let* ([w ncol]
|
|
[h (/ count w)]
|
|
[cells (let rloop ([r h][cells cells][r-acc null])
|
|
(if (zero? r)
|
|
(list->vector (reverse r-acc))
|
|
(let loop ([c w][cells cells][one-acc null])
|
|
(if (zero? c)
|
|
(rloop (sub1 r) cells (cons (list->vector (reverse one-acc)) r-acc))
|
|
(loop (sub1 c) (cdr cells) (cons (car cells) one-acc))))))]
|
|
[imp-list->vector (lambda (l n)
|
|
(let ([v (make-vector n)])
|
|
(let loop ([l l][p 0])
|
|
(unless (= n p)
|
|
(vector-set! v
|
|
p
|
|
(if (pair? l)
|
|
(car l)
|
|
l))
|
|
(loop (if (pair? l) (cdr l) l) (add1 p))))
|
|
v))]
|
|
[ralign (imp-list->vector row-aligns h)]
|
|
[calign (imp-list->vector col-aligns w)]
|
|
[rsep (imp-list->vector row-seps h)]
|
|
[csep (imp-list->vector col-seps w)]
|
|
[get-cell (lambda (c r) (vector-ref (vector-ref cells r) c))]
|
|
[nmap (lambda (f w)
|
|
(let loop ([n w][acc null])
|
|
(if (zero? n)
|
|
acc
|
|
(loop (sub1 n) (cons (f (sub1 n)) acc)))))]
|
|
[rowmap (lambda (f) (nmap f h))]
|
|
[colmap (lambda (f) (nmap f w))]
|
|
[superimposed-rows (list->vector
|
|
(rowmap (lambda (r)
|
|
(apply
|
|
(vector-ref ralign r)
|
|
(colmap (lambda (c) (get-cell c r)))))))]
|
|
[superimposed-cols (list->vector
|
|
(colmap (lambda (c)
|
|
(apply
|
|
(vector-ref calign c)
|
|
(rowmap (lambda (r) (get-cell c r)))))))])
|
|
; No space after the last row/col
|
|
(vector-set! rsep (sub1 h) 0)
|
|
(vector-set! csep (sub1 w) 0)
|
|
|
|
(apply
|
|
vl-append
|
|
0
|
|
(rowmap
|
|
(lambda (r)
|
|
(vl-append
|
|
0
|
|
(apply
|
|
ht-append
|
|
0
|
|
(colmap (lambda (c)
|
|
(ht-append
|
|
0
|
|
(let* ([cell (get-cell c r)]
|
|
[sc (vector-ref superimposed-cols c)]
|
|
[sr (vector-ref superimposed-rows r)]
|
|
[w (pict-width sc)]
|
|
[h (pict-height sr)])
|
|
(let-values ([(x __) (find-lb sc cell)]
|
|
[(_ y) (find-lb sr cell)])
|
|
(picture
|
|
w h
|
|
`((place ,x ,y ,cell)))))
|
|
(blank (vector-ref csep c) 0)))))
|
|
(blank 0 (vector-ref rsep r))))))))]))
|
|
|
|
(define (record title . fields)
|
|
(let* ([totalwidth (apply max (pict-width title) (map pict-width fields))]
|
|
[linespace (if (null? fields) 0 recordseplinespace)]
|
|
[totalheight (+ (pict-height title) (apply + (map pict-height fields))
|
|
linespace)]
|
|
[title-y (- totalheight (pict-height title))]
|
|
[field-ys (let loop ([pos (- totalheight (pict-height title) linespace)]
|
|
[fields fields])
|
|
(if (null? fields)
|
|
null
|
|
(let* ([p (- pos (pict-height (car fields)))])
|
|
(cons p
|
|
(loop p (cdr fields))))))])
|
|
(make-pict
|
|
`(picture
|
|
,totalwidth ,totalheight
|
|
(put 0 0 (line 1 0 ,totalwidth))
|
|
(put 0 ,totalheight (line 1 0 ,totalwidth))
|
|
(put 0 0 (line 0 1 ,totalheight))
|
|
(put ,totalwidth 0 (line 0 1 ,totalheight))
|
|
(put 0 ,title-y ,(pict-draw title))
|
|
,@(if (null? fields)
|
|
'()
|
|
`((put 0 ,(- totalheight (pict-height title) (quotient* linespace 2))
|
|
(line 1 0 ,totalwidth))))
|
|
,@(map (lambda (f p) `(put 0 ,p ,(pict-draw f)))
|
|
fields field-ys))
|
|
totalwidth totalheight
|
|
totalheight 0
|
|
(cons
|
|
(make-child title 0 title-y 1 1)
|
|
(map (lambda (child child-y) (make-child child 0 child-y 1 1)) fields field-ys))
|
|
#f
|
|
#f)))
|
|
|
|
(define (picture* w h a d commands)
|
|
(let loop ([commands commands][translated null][children null])
|
|
(if (null? commands)
|
|
(make-pict
|
|
`(picture ,w ,h
|
|
,@(reverse translated))
|
|
w h a d
|
|
children
|
|
#f
|
|
#f)
|
|
(let ([c (car commands)]
|
|
[rest (cdr commands)])
|
|
(unless (and (pair? c) (symbol? (car c)))
|
|
(error 'picture "bad command: ~a" c))
|
|
(case (car c)
|
|
[(connect) (loop rest
|
|
(append (apply connect (cdr c))
|
|
translated)
|
|
children)]
|
|
[(dconnect) (loop rest
|
|
(let ([x (cadr c)]
|
|
[y (caddr c)]
|
|
[dx (cadddr c)]
|
|
[dy (list-ref c 4)])
|
|
(append (connect x y (+ x dx) (+ y dy)
|
|
(if (null? (list-tail c 5))
|
|
#t
|
|
(list-ref c 5)))
|
|
translated))
|
|
children)]
|
|
[(connect~y) (loop rest
|
|
(append (apply ~connect 'x (cdr c))
|
|
translated)
|
|
children)]
|
|
[(connect~x) (loop rest
|
|
(append (apply ~connect 'y (cdr c))
|
|
translated)
|
|
children)]
|
|
[(connect~xy) (loop rest
|
|
(append (apply ~connect 'r (cdr c))
|
|
translated)
|
|
children)]
|
|
[(curve) (loop rest
|
|
(let ([x1 (cadr c)]
|
|
[y1 (caddr c)]
|
|
[x2 (cadddr c)]
|
|
[y2 (list-ref c 4)]
|
|
[xm (list-ref c 5)]
|
|
[ym (list-ref c 6)]
|
|
[d (if (null? (list-tail c 7))
|
|
1.0
|
|
(list-ref c 7))])
|
|
(let ([p (if (and d (>= d 0))
|
|
(inexact->exact (floor (* d (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2))))))
|
|
#f)])
|
|
(if (and (= x1 x2) (= y1 y2))
|
|
translated
|
|
(cons `(qbezier ,p ,x1 ,y1 ,xm ,ym ,x2 ,y2)
|
|
translated))))
|
|
children)]
|
|
[(place) (let ([x (cadr c)]
|
|
[y (caddr c)]
|
|
[p (cadddr c)])
|
|
(loop rest
|
|
(cons
|
|
`(put ,x ,y ,(pict-draw p))
|
|
translated)
|
|
(cons
|
|
(make-child p x y 1 1)
|
|
children)))]
|
|
[else (loop rest (cons c translated) children)])))))
|
|
|
|
(define (picture w h commands)
|
|
(picture* w h h 0 commands))
|
|
|
|
(define (cons-picture p commands)
|
|
(picture
|
|
(pict-width p) (pict-height p)
|
|
(cons
|
|
`(place 0 0 ,p)
|
|
commands)))
|
|
|
|
(define (cons-picture* p commands)
|
|
(picture*
|
|
(pict-width p) (pict-height p)
|
|
(pict-ascent p) (pict-descent p)
|
|
(cons
|
|
`(place 0 0 ,p)
|
|
commands)))
|
|
|
|
(define (place-it who flip? base dx dy target)
|
|
(let-values ([(dx dy)
|
|
(cond
|
|
[(and (number? dx) (number? dy))
|
|
(values dx (- (pict-height base) dy))]
|
|
[(and (or (pict? dx)
|
|
(and (list? dx) (andmap pict? dx)))
|
|
(procedure? dy)
|
|
(procedure-arity-includes? dy 2))
|
|
(if flip?
|
|
(let-values ([(dx dy) (dy base dx)])
|
|
(values dx (- (pict-height base) dy)))
|
|
(dy base dx))]
|
|
[else
|
|
(error who
|
|
"expects two numbers or a sub-pict and a find procedure")])])
|
|
(use-last/unchecked (cons-picture*
|
|
base
|
|
`((place ,dx ,(- dy (pict-height target)) ,target)))
|
|
(last* base))))
|
|
|
|
(define (place-over base dx dy target)
|
|
(place-it 'place-over #f base dx dy target))
|
|
(define (place-under base dx dy target)
|
|
(cc-superimpose
|
|
(place-it 'place-under #f (ghost base) dx dy target)
|
|
base))
|
|
|
|
(define (pin-over base dx dy target)
|
|
(place-it 'pin-over #t base dx dy target))
|
|
(define (pin-under base dx dy target)
|
|
(cc-superimpose
|
|
(place-it 'pin-under #t (ghost base) dx dy target)
|
|
(launder base)))
|
|
|
|
(define black-and-white
|
|
(make-parameter #f
|
|
(lambda (x)
|
|
(and x #t))))
|
|
|
|
(define (colorize p color)
|
|
(unless (or (string? color)
|
|
(is-a? color color%))
|
|
(error 'colorize "expected a color, given ~e" color))
|
|
(if (black-and-white)
|
|
p
|
|
(extend-pict
|
|
p 0 0 0 0 0
|
|
`(color ,color ,(pict-draw p)))))
|
|
|
|
(define (optimize s)
|
|
(let o-loop ([s s][dx 0][dy 0])
|
|
(if (string? s)
|
|
s
|
|
(let ([tag (car s)])
|
|
(case tag
|
|
[(picture)
|
|
(list* 'picture (cadr s) (caddr s)
|
|
(map optimize (cdddr s)))]
|
|
[(color)
|
|
(let ([next (caddr s)])
|
|
(if (and (pair? next) (eq? (car next) 'color))
|
|
(optimize next)
|
|
(list* 'color (cadr s)
|
|
(list 'put dx dy (optimize next)))))]
|
|
[(thickness)
|
|
(let ([t (cadr s)]
|
|
[p (caddr s)])
|
|
(list 'put dx dy
|
|
(list 'thickness t
|
|
(optimize p))))]
|
|
[(put)
|
|
(let ([x (cadr s)]
|
|
[y (caddr s)]
|
|
[next (cadddr s)])
|
|
(if (and (pair? next) (eq? (car next) 'picture))
|
|
; optmize put-picture to just contents ...
|
|
(cons 'begin (map (lambda (s) (o-loop s (+ x dx) (+ y dy))) (cdddr next)))
|
|
; normal
|
|
(list 'put (+ x dx) (+ y dy) (optimize next))))]
|
|
[(qbezier)
|
|
(let ([x1 (list-ref s 2)]
|
|
[y1 (list-ref s 3)]
|
|
[xm (list-ref s 4)]
|
|
[ym (list-ref s 5)]
|
|
[x2 (list-ref s 6)]
|
|
[y2 (list-ref s 7)]
|
|
[p (list-ref s 1)])
|
|
(list 'qbezier p
|
|
(+ x1 dx) (+ y1 dy)
|
|
(+ xm dx) (+ ym dy)
|
|
(+ x2 dx) (+ y2 dy)))]
|
|
[(frame)
|
|
(list 'frame (optimize (cadr s)))]
|
|
[(colorbox)
|
|
(list 'colorbox (cadr s) (optimize (caddr s)))]
|
|
[(line vector dirline dirvector circle circle* make-box oval prog) s]
|
|
[else (error 'optimize "bad tag: ~s" tag)])))))
|
|
|
|
(define (fixup-top s)
|
|
(cond
|
|
[(and (pair? s) (eq? (car s) 'color))
|
|
;; Drop initial put
|
|
(list* 'color (cadr s) (caddr (cdddr s)))]
|
|
[(and (pair? s) (eq? (car s) 'put))
|
|
;; Wrap initial put (from thickness) in a pair of braces
|
|
`(local ,(cadddr s))]
|
|
[else
|
|
;; Do nothing
|
|
s]))
|
|
|
|
(define (prepare-for-output s)
|
|
(fixup-top (optimize (pict-draw s))))
|
|
|
|
(define (pict->command-list s)
|
|
(let output ([s (prepare-for-output s)])
|
|
(if (string? s)
|
|
(list s)
|
|
(let ([tag (car s)])
|
|
(case tag
|
|
[(local)
|
|
(output (cadr s))]
|
|
[(begin)
|
|
(apply append (map output (cdr s)))]
|
|
[(picture)
|
|
(apply append (map output (cdddr s)))]
|
|
[(color)
|
|
`((with-color ,(cadr s) ,(output (cddr s))))]
|
|
[(thickness)
|
|
`((with-thickness ,(cadr s) ,(output (caddr s))))]
|
|
[(put)
|
|
`((offset ,(cadr s) ,(caddr s) ,(output (cadddr s))))]
|
|
[(qbezier)
|
|
`((bezier ,@(cddr s)))]
|
|
[(line vector)
|
|
`((,tag ,(cadr s) ,(caddr s) ,(cadddr s)))]
|
|
[(circle circle*)
|
|
`((,tag ,(cadr s)))]
|
|
[(frame)
|
|
`((frame ,(output (cadr s))))]
|
|
[(colorbox)
|
|
`((colorbox ,(cadr s) ,(output (caddr s))))]
|
|
[(oval)
|
|
`((oval ,(caddr s) ,(cadddr s) ,(cadr s)))]
|
|
[(make-box)
|
|
`((make-box ,(cadr s) ,(caddr s) ,(cadddr s) ,(car (cddddr s))))]
|
|
[(prog)
|
|
`((prog ,(cadr s) ,(caddr s)))]
|
|
[else (error 'pict->commands "bad tag: ~s" tag)])))))
|