From 87c01f5700bdc14c192bf674dd1aadba304345b3 Mon Sep 17 00:00:00 2001 From: Mike MacHenry Date: Sun, 10 Nov 2002 05:22:54 +0000 Subject: [PATCH] ... original commit: 40ef5d1c81f2d5afc478e060a7fe8f0cb589417d --- .../private/aligned-pasteboard/alignment.ss | 148 ++++++++++++++++++ 1 file changed, 148 insertions(+) create mode 100644 collects/mrlib/private/aligned-pasteboard/alignment.ss diff --git a/collects/mrlib/private/aligned-pasteboard/alignment.ss b/collects/mrlib/private/aligned-pasteboard/alignment.ss new file mode 100644 index 00000000..0c09bc92 --- /dev/null +++ b/collects/mrlib/private/aligned-pasteboard/alignment.ss @@ -0,0 +1,148 @@ +;;note: This code computes the sizees for the rectangles in the space using the on dimention +;; off dimention method of referencing sizes. This means for example instead of saying +;; width we say off dimention for vertical alignment. Inorder to consume and return +;; the values in terms of width and height manipulation had to be done. I chose to create +;; a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect +;; stucts on to them. This code is a bit long but more readable than the other two options +;; I came up with. +;; 1) define all functions to be letrec bound functions inside align. align then take +;; accessors for the rect struct. The caller of align swaps the order of ondimention +;; and off dimention accessors for vertical or horizontal code. This method does not +;; allow the use of the readable, sort, consis pattern matching code. As some of the +;; matching code is easily removed this may be a good option but a large letrec +;; is harder to write tests for. +;; 2) define a pattern matcher syntax that will match the struct rect but swap the fields +;; based on wich on is the on or off dimention. This would have been shorter but much +;; more confusing. +;; The current implementation requires align to map over the rects and allocate new stucts +;; for each one on both passing into and returning from stretch-to-fit; This is not a bottle +;; neck and it is the most readable solution. + +(module alignment mzscheme + + (require + (lib "match.ss") + (lib "contracts.ss") + (lib "etc.ss") + (lib "list.ss")) + + (define-struct rect (x y)) + (define-struct abs-rect (ondim offdim)) + (define-struct dim (pos size stretchable?)) + ;; make-rect (dim? dim? . -> . rect?) + ;; make-abs-rect (dim? dim? . -> . rect?) + ;; make-dim (nonnegative? nonnegative? boolean? . -> . dim?) + + (provide + (struct rect (x y)) + (struct dim (pos size stretchable?))) + + (provide/contract + (align ((symbols 'horizontal 'vertical) + positive? positive? (listof rect?) + . -> . (listof rect?)))) + + ;; align the rectangles within the given space + (define (align type width height rects) + (cond + [(symbol=? type 'horizontal) + (map abs->horiz (stretch-to-fit width height (map horiz->abs rects)))] + [(symbol=? type 'vertical) + (map abs->vert (stretch-to-fit height width (map vert->abs rects)))])) + + ;; abs->horiz (abs-rect? . -> . rect?) + ;; convert an abstract rect to a horizontal rect + (define abs->horiz + (match-lambda + [($ abs-rect ondim offdim) + (make-rect ondim offdim)])) + + ;; abs->vert (abs-rect? . -> . rect?) + ;; convert an abstract rect to a vertical rect + (define abs->vert + (match-lambda + [($ abs-rect ondim offdim) + (make-rect offdim ondim)])) + + ;; horiz->abs (rect? . -> . abs-rect?) + ;; convert a horizontal rect to an abstract rect + (define horiz->abs + (match-lambda + [($ rect x y) + (make-abs-rect x y)])) + + ;; vert->abs (rect? . -> . abs-rect?) + ;; convert a vertical rect to an abstract rect + (define vert->abs + (match-lambda + [($ rect x y) + (make-abs-rect y x)])) + + ;; stretch-to-fit (positive? positive? (listof abs-rect?) . -> (listof abs-rect?)) + ;; stretch the rectangles to fit with the given space + (define (stretch-to-fit onsize offsize rects) + (let-values ([(total-unstretchable-size stretchable-sizes) + (get-onsizes rects)]) + (let-values ([(extra-div extra-mod) + (get-extra/rect + (- onsize total-unstretchable-size) + (quicksort stretchable-sizes >))]) + (allocate-evenly/position extra-div extra-mod offsize rects)))) + + ;; get-onsizes (((listof rect?)) . ->* . (nonnegative? (listof nonnegative?))) + ;; gets the unstretchable total size and a list of the stretchable sizes + (define (get-onsizes init-rects) + (let loop ([extra 0] + [stretchables empty] + [rects init-rects]) + (match rects + [() (values extra stretchables)] + [(($ abs-rect ($ dim _ onsize #f) _) rest-rects ...) + (loop (+ onsize extra) stretchables rest-rects)] + [(($ abs-rect ($ dim _ onsize #t) _) rest-rects ...) + (loop extra (cons onsize stretchables) rest-rects)]))) + + ;; get-extra/rect ((nonnegative? (listof nonnegative?)) . ->* . (nonnegative? nonnegative?)) + ;; get the space that each stretchable snip will have + (define (get-extra/rect init-extra init-sizes) + (let loop ([sizes init-sizes] + [extra init-extra] + [count (length init-sizes)]) + (cond + [(empty? sizes) (values 0 0)] + [else + (let ([extra/rect (quotient extra count)] + [onsize (first sizes)]) + (if (> onsize extra/rect) + (loop (rest sizes) (- extra onsize) (sub1 count)) + (values extra/rect (modulo extra count))))]))) + + ;; allocate-evenly/position ((cons/p nonnegative? nonnegative?) positive? (listof abs-rect?) . -> . + ;; (listof abs->rect?)) + ;; allocate the extra per rectangle to the stretchable rects and move them to their positions + (define (allocate-evenly/position extra-div extra-mod offsize init-rects) + (let ([mod (waner extra-mod)]) + (let loop ([rects init-rects] + [onpos 0]) + (match rects + [() empty] + [(($ abs-rect ($ dim _ min-onsize onstretch?) + ($ dim _ min-offsize offstretch?)) rest-rects ...) + (let ([onsize (if (and onstretch? + (< min-onsize extra-div)) + (+ extra-div (mod)) min-onsize)] + [offsize (if offstretch? offsize min-offsize)]) + (cons (make-abs-rect (make-dim onpos onsize onstretch?) + (make-dim 0 offsize offstretch?)) + (loop rest-rects (+ onpos onsize))))])))) + + ;; waner (nonnegative? . -> . (-> (union 1 0))) + ;; makes a thunk that returns 1 for it's first n applications, zero otherwise + (define (waner n) + (lambda () + (if (zero? n) + 0 + (begin + (set! n (sub1 n)) + 1)))) + ) \ No newline at end of file