From a6b38844eea1ad6bd8c94110b4290b0ca0690421 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 18 May 2009 00:48:55 +0000 Subject: [PATCH] added an error check to colorize and removed dependency on mzlib/etc svn: r14852 --- collects/texpict/private/common-unit.ss | 107 ++++++++++++------------ 1 file changed, 55 insertions(+), 52 deletions(-) diff --git a/collects/texpict/private/common-unit.ss b/collects/texpict/private/common-unit.ss index f0ef465281..e17d620eee 100644 --- a/collects/texpict/private/common-unit.ss +++ b/collects/texpict/private/common-unit.ss @@ -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])