[plt-scheme] A Square Canvas

[Jens Axel Soegaard]

Jens Axel Soegaard wrote:
> Robby Findler wrote:
>> Is the goal to have a stretchable canvas, but one that always stays
>> square? 
> Yes.
>> For that you'd need to make your own geometry manager, I'm
>> afraid. This is the relevant part of the docs:
>>
>> http://docs.plt-scheme.org/gui/windowing-overview.html#(part._new-containers) 
>>
>>   
> I'll take a look.

Here is a solution meant for the archives.

I have made an alternative to horizontal-panel%. The square-panel% 
behaves as a
horizon-panel% when respect to borders, margin, and vertical alignment.
The children all become quadratic. The stretchable children will be 
stretched
with the same magnification factor.

In my use case, where I needed a stretchable, quadratic canvas, all I 
need to do
is to place a single canvas as the only child of a square-panel%.

-- 
Jens Axel Søgaard

-------------- next part --------------
#lang scheme/gui

(require "square-panel.ss")

(let* ([frame (new frame% [label "Test of Square Canvas"])]
       [square-panel (new square-panel% [parent frame] [border 50] [spacing 20] 
                          [alignment '(left center)])])
  (define (build-canvas stretch? size-x size-y pen-color brush-color)
    (letrec ([pen   (make-object pen% pen-color 1 'solid)]
             [brush (make-object brush% brush-color 'solid)]
             [canvas (new canvas% 
                          [parent square-panel] [style '()]
                          [min-width size-x] [min-height size-y]
                          [stretchable-width stretch?] [stretchable-height stretch?]
                          [paint-callback (λ (b dc) 
                                            (let-values ([(w h) (send canvas get-size)])
                                              (let ([dc (send canvas get-dc)])
                                                (send dc set-pen pen)
                                                (send dc set-brush brush)
                                                (send dc draw-rectangle 0 0 w h)
                                                (send dc draw-line 0 0 w h)
                                                (send dc draw-line 0 h w 0))))])])
      canvas))
  (build-canvas #t 100 50  "red" "white")
  (build-canvas #f 200 100 "green" "black")
  (build-canvas #t 50  100 "white" "red")
  (build-canvas #f 150 100 "yellow" "green")
  (send frame show #t))


-------------- next part --------------
A non-text attachment was scrubbed...
Name: example.png
Type: image/png
Size: 11622 bytes
Desc: not available
Url : http://list.cs.brown.edu/pipermail/plt-scheme/attachments/20080714/dcf7263c/example.png
-------------- next part --------------
#lang scheme/gui

(provide square-panel%)

; Horizontal panel where all children are quadratic.
; All children are magnified with the same factor.
; That is, stretchability is ignored.
; And so is margins.

(define square-panel%
  (let ()
    (define-syntax with-info
      (syntax-rules ()
        [(with-info (w h hs vs) i body ...)
         (let ([w  (list-ref i 0)]
               [h  (list-ref i 1)]
               [hs (list-ref i 2)]
               [vs (list-ref i 3)])
           body ...)]))
    (class panel%
      (define/override (container-size infos)
        (let* ([c (foldl (λ (i a) 
                           (with-info (w h hs vs) i
                             (let ([m (max w h)])
                               (match a [(list aw ah) (list (+ aw m) (max ah m))]))))
                         '(0 0)
                         infos)]
               [b (send this border)]
               [s (send this spacing)]
               [n (length infos)])
          (match c 
            [(list w h) 
             (values (+ w (* 2 b) (* s (max 0 (- n 1))))
                     (+ h (* 2 b)))])))
      (define/override (place-children infos width height)
        ; place the children within an width x height area
        (let* ([border (send this border)]
               [spacing (send this spacing)]
               [n (length infos)]
               [width (- width (* 2 border) (* spacing (max 0 (- n 1))))]
               [height (- height (* 2 border))]
               [total-horiz  (foldl (λ (i a) (with-info (w h hs vs) i (+ a (max w h)))) 0 infos)]
               [total-stretchable-horiz 
                (foldl (λ (i a) (with-info (w h hs vs) i (if (and hs vs) (+ a (max w h)) a))) 0 infos)]
               [non-stretchable-horiz (- total-horiz total-stretchable-horiz)]
               [total-vert   (foldl (λ (i a) (with-info (w h hs vs) i (max a w h))) 0 infos)]
               [total-stretchable-vert   
                (foldl (λ (i a) (with-info (w h hs vs) i (if (and hs vs) (max a w h) a))) 0 infos)]
               [vert-factor  (/ height total-stretchable-vert)]
               [horiz-factor (/ (- width non-stretchable-horiz) total-stretchable-horiz)]
               [factor       (min vert-factor horiz-factor)]
               [b border]
               [s spacing])
          (let-values ([(horiz-alignment vert-alignment) (send this get-alignment)])
            (define (mag s) (inexact->exact (floor (* factor s))))
            (reverse 
             (first 
              (foldl (λ (i a)
                       (match a
                         [(list specs x)
                          (with-info (w h hs vs) i
                            (let* ([m (max w h)]
                                   [m (if (and hs vs) (mag m) m)]
                                   [y (case vert-alignment
                                        [(top)    b]
                                        [(center) (+ b (- (quotient height 2)
                                                          (quotient m 2)))]
                                        [(bottom) (+ b (- height m))]
                                        [else (error 'unknown-alignment)])])
                              (list (cons (list x y m m) specs)
                                    (+ x m s))))]))
                     (list '() b)
                     infos))))))
        (super-new))))