[plt-scheme] A Square Canvas

Hi All,

I'd like to create a square canvas - as big as possible.

The normal geometry management makes it easy to make an
rectangular canvas that uses as much space as possible.

At first I thought I could get the retangular size and then
shrink the canvas to use the minimum of the horizontal
and vertival sizes - but canvases have no resize method.

Is using a non-stretchable canvas my best option? Or is
there a trick I have overlooked?

A simplified version of my layout is found below.

/Jens Axel



#lang scheme/gui

(require framework)

(define-values (full-screen-width full-screen-height) (get-display-size #t))
(define-values (canvas-width canvas-height) (values 0 0))

(let* ([frame (new frame%
[label "Exercises"]
[width full-screen-width] [height full-screen-height]
[style '(no-resize-border no-caption hide-menu-bar no-system-menu)])]
[header-panel (new vertical-panel%
[parent frame] [alignment '(center center)] [stretchable-height #f])]
[header-msg (new message% [parent header-panel] [label "Problem Name"])]
; exercise + instructions
[main-panel (new horizontal-panel% [parent frame] [vert-margin 20] 
[horiz-margin 20])]
[left (new vertical-panel%
[parent main-panel] [vert-margin 20] [horiz-margin 20]
[min-width (- (* 2 (quotient full-screen-width 3)) 100)])]
[right (new vertical-panel%
[parent main-panel] [min-width (quotient full-screen-width 3)]
[alignment '(center center)])]
[statement (new message%
[parent left] [label "A problem statement"] [vert-margin 10])]
[instructions (new editor-canvas%
[parent right] [editor (new text%)] [style '(auto-vscroll no-hscroll)])]
; status message
[status-panel (new horizontal-panel% [parent frame] [stretchable-height 
#f])]
[status-msg (new message% [parent status-panel] [label "Status goes here"])]
[quit-button (new button% [parent right] [label "Quit"]
[callback (λ (but ev) (send frame show #f))])])
(define exercise-canvas%
(class canvas%
(define/public (get-canvas-size)
(set!-values (canvas-width canvas-height) (send this get-size)))
(define/override (on-event e)
(send this get-canvas-size))
(define (on-size e) (send this get-screen-size))
(define (on-move e) (send this get-screen-size))
(super-new)))
(letrec ([canvas (new exercise-canvas%
[parent left] [style '(border)]
[stretchable-width #t] [stretchable-height #t]
[paint-callback (λ (b dc) '...)])])
; move frame to top-left of screen
(let-values ([(dx dy) (send frame client->screen 0 0)])
(send frame move 0 (- dy)))
(send frame show #t)
(send (send instructions get-editor) insert "Solve the problem at the 
left.")))