[plt-scheme] Layout and grids with MrEd?

Danny Yoo wrote:
> Hi everyone,

> 
> I'm starting to write a tutorial on MrEd.  (My motivating way to learn 
> something new is to try to explain it).
> 
> But I'm running into some awkward code that I want to fix before posting 
> this to the Schematics Cookbook.  It involves writing a grid% class to 
> practice with simple geometry management:

I can't figure out whether you can use the rearrangement code from
this little game of fifteen or not - but nevetheless here it is:

;;;
;;; The game of FIFTEEN
;;;

;; Remember to choose a language including MrEd.

;;
;; HELPERS
;;

; interval: integer integer -> list-of-integers
;   produces a list of the integers in the interval from m to n
(define (interval m n)
   (if (> m n)
       (list)
       (cons m (interval (+ m 1) n))))

; id: alpha -> alpha
(define id (lambda x x))

;;;
;;; MODEL
;;;

; The 16 fields of the board holds the numbers from 1 to 15 and a blank.
(define board (vector 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 'blank))

; contents : integer -> integer or symbol
;   returns the number on the field
(define (contents field)
   (vector-ref board field))

; contents! : integer -> void
;   changes the contents of a field to new-contents
(define (contents! field new-contents)
   (vector-set! board field new-contents))

; swap : integer integer -> void
;   swap the contents of two fields
(define (swap field1 field2)
   (let ([contents1 (vector-ref board field1)])
     (contents! field1 (contents field2))
     (contents! field2 contents1)))

(define (distance field1 field2)
   (let ([x (lambda (field) (remainder field 4))]
         [y (lambda (field) (quotient field 4))])
     (+ (abs (- (x field1) (x field2)))
        (abs (- (y field1) (y field2))))))

(define (legal? field1 field2)
   (= (distance field1 field2) 1))

(define (push field1 field2)
   (if (legal? field1 field2)
       (swap field1 field2)))

; field-of-blank : void -> number
;   return the number of the blank field
(define (field-of-blank)
   (letrec ([loop (lambda (n l)
                    (if (equal? (car l) 'blank)
                        n
                        (loop (+ n 1) (cdr l))))])
     (loop 0 (vector->list board))))

(define (scramble n)
   (if (> n 0)
       (let ([f1 (random 16)]
             [f2 (random 16)])
         (if #t ; TODO: is the permutation even?
             (swap f1 f2))
         (scramble (sub1 n)))))

(scramble 100)

;;;
;;; VIEW
;;;

; A GUI consists of a frame.
; A frame can hold controls.
; Buttons and messages are controls.

;; a frame is created and shown
(define frame (make-object frame% "Femtenspillet"))
(send frame show #t)

; header
(define (make-explanation text)
   (make-object message% text frame))

(make-explanation "Your job is to arrange the numbers")
(make-explanation "as 1, 2, 3, ...")
(make-explanation "")
(make-explanation "Swap the numbers until they are ordered.")
(make-explanation "")

; we want to make a grid of buttons each representing a field

;   b1  b2  b3  b4
;   b5  b6  b7  bf8
;   b9  b10 b11 b12
;   b13 b14 b15 bblank

; and at all time we need to know where the blank one is
(define blank-button #f)


(define (make-button number panel)
   (let ([button (make-object button%
                              (number->string
                                (if (symbol? (contents number))
                                    -1 (contents number)) )
                   panel
                   ; on-click callback-procedure
                   (lambda (button event)
                     (let ([prev-number-of-blank (field-of-blank)])
                       ; update the model
                       (push prev-number-of-blank number)
                       ; update the view
                       (if (legal? prev-number-of-blank number)
                           (begin
                             (update-field button number)
                             (update-field blank-button
                                           prev-number-of-blank)
                             ; remember the blank one
                             (set! blank-button   button)
                             (send frame refresh))))))])
     (if (equal? (contents number) 'blank)
         (begin
           (send button show #f)
           (set! blank-button button)))
     button))

(define (update-field button number)
   (let ([contents (contents number)])
     (if (equal? contents 'blank)
         (begin
           (send button show #f))
         (begin
           (send button set-label (number->string contents))
           (send button show #t)))))

; the buttons of the board are put in a panel

(define board-panel (make-object vertical-panel% frame ))
(send board-panel set-alignment 'center 'center)
(send board-panel stretchable-width #f)
(send board-panel stretchable-height #f)


; each row of buttons are put in a horizontal panel
(define (make-horizontal-panel far)
   (let ([panel (make-object horizontal-panel% far )])
     (send panel set-alignment 'center 'center)
     (send panel stretchable-width #f)
     (send panel stretchable-height #f)
     panel))

(define panel1 (make-horizontal-panel board-panel))
(define panel2 (make-horizontal-panel board-panel))
(define panel3 (make-horizontal-panel board-panel))
(define panel4 (make-horizontal-panel board-panel))

; now we make the buttons

(make-button 0 panel1)
(make-button 1 panel1)
(make-button 2 panel1)
(make-button 3 panel1)

(make-button 4 panel2)
(make-button 5 panel2)
(make-button 6 panel2)
(make-button 7 panel2)

(make-button 8  panel3)
(make-button 9  panel3)
(make-button 10 panel3)
(make-button 11 panel3)

(make-button 12 panel4)
(make-button 13 panel4)
(make-button 14 panel4)
(make-button 15 panel4)


; from now we need to adjust the alignment and sizing
; of the buttons

(define (align-center sub-areas)
   (map (lambda (sub-area)
          (send sub-area set-alignment 'center 'center)
          sub-area)
        sub-areas))

(define (traverse container combine process)
   (let* ([result 0]
          [filter (lambda (sub-areas)
                    (set! result (apply combine (map process sub-areas)))
                    sub-areas)])
     (send container change-children filter)
     result))

(define (max-width-of-children container)
   (traverse container max (lambda (c)
                             (send c get-width))))

(max-width-of-children board-panel)

(define (max-height-of-children container)
   (traverse container max (lambda (c)
                             (send c get-height))))

(define (map-grid container f)
   (traverse container list (lambda (c)
                              (traverse c list f))))


(define (squarify container)
   (let* ([max-width  (traverse container max max-width-of-children)]
          [max-height (traverse container max max-height-of-children)]
          [size       (max max-width max-height)])
     (map-grid container (lambda (c)
                           (send c min-width size)
                           (send c min-height size)))))

; comment this line out to see what happens with no alignment
; and resizing
(squarify board-panel)


-- 
Jens Axel Søgaard