suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added an error check to colorize and removed dependency on mzlib/etc

Browse Source 
svn: r14852
This commit is contained in:
Robby Findler 2009-05-18 00:48:55 +00:00
parent aba257c816
commit a6b38844ee
1 changed files with 55 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
collects/texpict/private/common-unit.ss
View File

@ -1,8 +1,9 @@
#lang scheme/unit
(require mzlib/etc)
(require scheme/gui/base
scheme/class)
(require "common-sig.ss")
(import texpict-common-setup^)
@ -445,48 +446,49 @@
(let ([make-append-boxes
(lambda (wcomb hcomb fxoffset fyoffset rxoffset ryoffset
combine-ascent combine-descent)
(rec *-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
(or (pict-last rest) rest)))])))))]
(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
(or (pict-last rest) 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)]
@ -895,14 +897,15 @@
(lambda (x)
(and x #t))))
(define colorize
(case-lambda
[(p color)
(if (black-and-white)
p
(extend-pict
p 0 0 0 0 0
`(color ,color ,(pict-draw p))))]))
(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])