(module window mzscheme
(require (lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "class.ss")
(lib "etc.ss")
"model.ss")
(define-struct (exn:fail:fractal exn:fail) () #f)
(define fractal-window
(opt-lambda ([w 400] [h 300])
(define main-frame%
(class (frame:basic-mixin frame%)
(init label (parent #f) (width #f) (height #f))
(super-new (label label)
(parent parent)
(width width)
(height height))))
(define frame (new main-frame%
(label "Fractal")
(width w)
(height h)))
(define contents
(new vertical-pane%
(parent (send frame get-area-container))
(alignment '(center center))
(stretchable-height #t)))
(define fractal%
(class canvas%
(init (parent #f))
(inherit set-canvas-background get-dc get-width get-height refresh)
(define iteration 0)
(define segments null)
(define (compute-segments n width screen-width screen-height)
(let* ([segment-width (floor (/ width (expt 5 n)))]
[real-width (* segment-width (expt 5 n))]
[margin-width (floor (/ (- screen-width real-width) 2))])
(unless (> segment-width 0)
(raise (make-exn:fail:fractal "segment width too small" (current-continuation-marks))))
(fractal-iteration segment-width
(directions-for n 'E)
(cons margin-width (floor (/ screen-height 2))))))
(define (recompute iteration*)
(let* ([width (get-width)]
[height (get-height)]
[picture-width (max (- width 100) 0)]
[segments* (compute-segments iteration* picture-width width height)])
(set! iteration iteration*)
(set! segments segments*)
(let* ( [min-picture-width (expt 5 iteration*)]
[min-screen-width (+ min-picture-width 100)]
[min-screen-height (+ (* 2 (let f ([n iteration*])
(if (zero? n) 0 (+ (expt 5 (sub1 n))
(f (sub1 n))))))
15)]
[area (send frame get-area-container)])
(send area min-width min-screen-width)
(send area min-height min-screen-height))))
(define/public (set-iteration n)
(recompute n))
(define/public (increment-iteration)
(set-iteration (add1 iteration)))
(define (redraw)
(with-handlers ([exn:fail:fractal? void])
(recompute iteration)
(let ([dc (get-dc)])
(send dc set-pen "Black" 1 'solid)
(for-each (lambda (seg)
(send dc draw-line (caar seg) (cdar seg) (cadr seg) (cddr seg)))
segments))))
(define/override (on-event evt)
(when (send evt button-up?)
(with-handlers ([exn:fail:fractal? (lambda (exn)
(message-box "Error" "Fractal granularity too high to display." frame '(ok))
(void))])
(increment-iteration)
(refresh))))
(define/override (on-paint)
(redraw))
(super-new (parent parent)
(stretchable-width #t)
(stretchable-height #t)
(style '(border)))
(set-canvas-background (send the-color-database find-color "White"))))
(define fractal
(new fractal% (parent contents)))
(send frame show #t)
frame))
(provide fractal-window))