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

added some error checking

Browse Source
This commit is contained in:
Robby Findler 2010-10-05 14:57:18 -05:00
parent 7bcd107e7f
commit 4992e2ab27
1 changed files with 22 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/texpict/private/common-unit.rkt
View File

@ -1,8 +1,8 @@
#lang scheme/unit #lang scheme/unit
(require scheme/gui/base (require scheme/gui/base
scheme/class) scheme/class
racket/list)
(require "common-sig.ss") (require "common-sig.ss")
@ -613,8 +613,11 @@
ctl-superimpose ctl-superimpose
cbl-superimpose) cbl-superimpose)
(let ([make-superimpose (let ([make-superimpose
(lambda (get-h get-v get-th) (lambda (get-h get-v get-th name)
(lambda boxes (lambda boxes
(unless (andmap pict? boxes)
(error name "expected all picts as arguments, got ~a"
(apply string-append (add-between (map (λ (x) (format "~e" x)) boxes) " "))))
(let ([max-w (apply max (map pict-width boxes))] (let ([max-w (apply max (map pict-width boxes))]
[max-h (apply max (map pict-height boxes))] [max-h (apply max (map pict-height boxes))]
[max-a (apply max (map pict-ascent boxes))] [max-a (apply max (map pict-ascent boxes))]
@ -672,22 +675,22 @@
[tline (lambda (m v md d mac a) (- mac (- v a)))] [tline (lambda (m v md d mac a) (- mac (- v a)))]
[bline (lambda (m v md d mac a) (- md d))] [bline (lambda (m v md d mac a) (- md d))]
[c (lambda (m v . rest) (quotient* (- m v) 2))]) [c (lambda (m v . rest) (quotient* (- m v) 2))])
(values (values
(make-superimpose lb rt norm) (make-superimpose lb rt norm 'lt-superimpose)
(make-superimpose lb lb norm) (make-superimpose lb lb norm 'lb-superimpose)
(make-superimpose lb c norm) (make-superimpose lb c norm 'lc-superimpose)
(make-superimpose lb tline tbase) (make-superimpose lb tline tbase 'ltl-superimpose)
(make-superimpose lb bline bbase) (make-superimpose lb bline bbase 'lbl-superimpose)
(make-superimpose rt rt norm) (make-superimpose rt rt norm 'rt-superimpose)
(make-superimpose rt lb norm) (make-superimpose rt lb norm 'rb-superimpose)
(make-superimpose rt c norm) (make-superimpose rt c norm 'rc-superimpose)
(make-superimpose rt tline tbase) (make-superimpose rt tline tbase 'rtl-superimpose)
(make-superimpose rt bline bbase) (make-superimpose rt bline bbase 'rbl-superimpose)
(make-superimpose c rt norm) (make-superimpose c rt norm 'ct-superimpose)
(make-superimpose c lb norm) (make-superimpose c lb norm 'cb-superimpose)
(make-superimpose c c norm) (make-superimpose c c norm 'cc-superimpose)
(make-superimpose c tline tbase) (make-superimpose c tline tbase 'ctl-superimpose)
(make-superimpose c bline bbase)))) (make-superimpose c bline bbase 'cbl-superimpose))))
(define table (define table
(case-lambda (case-lambda