window.ss
(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)]
                   ;; give 50 pixels of room on either side
                   [picture-width (max (- width 100) 0)]
                   [segments* (compute-segments iteration* picture-width width height)])
              (set! iteration iteration*)
              (set! segments segments*)
              (let* (;; width(n) = 5^n
                     [min-picture-width (expt 5 iteration*)]
                     ;; give 50 pixels of room on either side
                     [min-screen-width (+ min-picture-width 100)]
                     ;; height(0) = 0, height(n) = 2 * (5^(n-1) + height(n-1))
                     [min-screen-height (+ (* 2 (let f ([n iteration*])
                                                  (if (zero? n) 0 (+ (expt 5 (sub1 n))
                                                                     (f (sub1 n))))))
                                           ;; give a little extra buffer room just in case
                                           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))