#lang racket/base

(require racket/class
         (prefix-in wx: "kernel.rkt")
         "lock.rkt"
         "const.rkt"
         "check.rkt"
         "helper.rkt"
         "wx.rkt"
         "wxpanel.rkt"
         "mrwindow.rkt"
         "mrcontainer.rkt")

(provide pane%
         vertical-pane%
         horizontal-pane%
         grow-box-spacer-pane%
         panel%
         vertical-panel%
         horizontal-panel%
         tab-panel%
         group-box-panel%)

(define-local-member-name get-initial-label)

(define pane%
  (class (make-subarea% (make-container% area%))
    (init parent
          [vert-margin no-val]
          [horiz-margin no-val]
          [border no-val]
          [spacing no-val]
          [alignment no-val]
          [min-width no-val]
          [min-height no-val]
          [stretchable-width no-val]
          [stretchable-height no-val])
    (init-rest)
    (define wx #f)
    (let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p
                 [(is-a? this vertical-pane%) 'vertical-pane]
                 [(is-a? this horizontal-pane%) 'horizontal-pane]
                 [(is-a? this grow-box-spacer-pane%) 'grow-box-spacer-pane]
                 [else 'pane])]
           [cwho `(constructor ,who)])
      (check-container-parent cwho parent)
      (as-entry
       (lambda ()
         (super-new
          [mk-wx
           (lambda ()
             (set! wx (make-object (case who
                                     [(vertical-pane) wx-vertical-pane%]
                                     [(horizontal-pane) wx-horizontal-pane%]
                                     [(grow-box-spacer-pane) wx-grow-box-pane%]
                                     [else wx-pane%])
                                   this this (mred->wx-container parent) null
                                   #f))
             wx)]
          [get-wx-pan (lambda () wx)]
          [get-outer-wx-pan (lambda () wx)]
          [mismatches
           (lambda ()
             (check-container-ready cwho parent))]
          [parent parent]
          [vert-margin vert-margin]
          [horiz-margin horiz-margin]
          [border border]
          [spacing spacing]
          [alignment alignment]
          [min-width min-width]
          [min-height min-height]
          [stretchable-width stretchable-width]
          [stretchable-height stretchable-height])
         (send (send wx area-parent) add-child wx)))
      (send parent after-new-child this))))

(define vertical-pane%
  (class pane%
    (init parent
          [vert-margin no-val]
          [horiz-margin no-val]
          [border no-val]
          [spacing no-val]
          [alignment no-val]
          [min-width no-val]
          [min-height no-val]
          [stretchable-width no-val]
          [stretchable-height no-val])
    (init-rest)
    (super-new [parent parent]
               [vert-margin vert-margin]
               [horiz-margin horiz-margin]
               [border border]
               [spacing spacing]
               [alignment alignment]
               [min-width min-width]
               [min-height min-height]
               [stretchable-width stretchable-width]
               [stretchable-height stretchable-height])))

(define horizontal-pane%
  (class pane%
    (init parent
          [vert-margin no-val]
          [horiz-margin no-val]
          [border no-val]
          [spacing no-val]
          [alignment no-val]
          [min-width no-val]
          [min-height no-val]
          [stretchable-width no-val]
          [stretchable-height no-val])
    (init-rest)
    (super-new [parent parent]
               [vert-margin vert-margin]
               [horiz-margin horiz-margin]
               [border border]
               [spacing spacing]
               [alignment alignment]
               [min-width min-width]
               [min-height min-height]
               [stretchable-width stretchable-width]
               [stretchable-height stretchable-height])))

(define grow-box-spacer-pane%
  (class pane%
    (init parent
          [vert-margin no-val]
          [horiz-margin no-val]
          [border no-val]
          [spacing no-val]
          [alignment no-val]
          [min-width no-val]
          [min-height no-val]
          [stretchable-width no-val]
          [stretchable-height no-val])
    (init-rest)
    (super-new [parent parent]
               [vert-margin vert-margin]
               [horiz-margin horiz-margin]
               [border border]
               [spacing spacing]
               [alignment alignment]
               [min-width min-width]
               [min-height min-height]
               [stretchable-width stretchable-width]
               [stretchable-height stretchable-height])))

(define panel%
  (class* (make-subwindow%
           (make-area-container-window%
            (make-window% #f (make-subarea% (make-container% area%)))))
    (subwindow<%>)
    (init parent [style null]
          ;; These additional init args are for the superclass
          ;; initializations and are needed to make sure the user can supply
          ;; these init args. They were originally handled by a class100 kw
          ;; macro. They're handed to super-instantiate below.
          [enabled #t]
          [vert-margin no-val]
          [horiz-margin no-val]
          [border no-val]
          [spacing no-val]
          [alignment no-val]
          [min-width no-val]
          [min-height no-val]
          [stretchable-width no-val]
          [stretchable-height no-val])
    (init-rest)
    (define wx #f)
    (public* [get-initial-label (lambda () #f)])
    (let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p
                 [(is-a? this tab-panel%) 'tab-panel]
                 [(is-a? this group-box-panel%) 'group-box-panel]
                 [(is-a? this vertical-panel%) 'vertical-panel]
                 [(is-a? this horizontal-panel%) 'horizontal-panel]
                 [else 'panel])]
           [cwho `(constructor ,who)]
           [can-canvas? (memq who '(vertical-panel
                                    horizontal-panel
                                    panel))]
           [as-canvas? (lambda () (or (memq 'vscroll style)
                                      (memq 'auto-vscroll style)
                                      (memq 'hide-vscroll style)
                                      (memq 'hscroll style)
                                      (memq 'auto-hscroll style)
                                      (memq 'hide-hscroll style)))])
      (check-container-parent cwho parent)
      (check-style cwho #f (append '(border deleted)
                                   (if can-canvas?
                                       '(hscroll vscroll
                                         auto-hscroll auto-vscroll 
                                         hide-hscroll hide-vscroll)
                                       null))
                   style)

      (define (add-scrolls style)
        (append
         (if (memq 'hide-vscroll style) 
             '(auto-vscroll)
             null)
         (if (memq 'hide-hscroll style) 
             '(auto-hscroll)
             null)
         style))

      (as-entry
       (lambda ()
         (super-instantiate
          ((lambda () (set! wx (make-object (case who
                                              [(vertical-panel)
                                               (if (as-canvas?)
                                                   wx-vertical-canvas-panel%
                                                   wx-vertical-panel%)]
                                              [(tab-panel) wx-vertical-tab-panel%]
                                              [(group-box-panel) wx-vertical-group-panel%]
                                              [(horizontal-panel)
                                               (if (as-canvas?)
                                                   wx-horizontal-canvas-panel%
                                                   wx-horizontal-panel%)]
                                              [else (if (as-canvas?)
                                                        wx-canvas-panel%
                                                        wx-panel%)])
                                            this this (mred->wx-container parent)
                                            (cons 'transparent (add-scrolls style))
                                            (get-initial-label)))
                   wx)
           (lambda () wx)
           (lambda () wx)
           (lambda () (check-container-ready cwho parent))
           #f parent #f)
          [enabled enabled]
          [vert-margin vert-margin]
          [horiz-margin horiz-margin]
          [border border]
          [spacing spacing]
          [alignment alignment]
          [min-width min-width]
          [min-height min-height]
          [stretchable-width stretchable-width]
          [stretchable-height stretchable-height])
         (unless (memq 'deleted style)
           (send (send wx area-parent) add-child wx))))
      (send parent after-new-child this))))

(define vertical-panel%
  (class panel%
    (init parent [style null] 
          [enabled #t]
          [vert-margin no-val]
          [horiz-margin no-val]
          [border no-val]
          [spacing no-val]
          [alignment no-val]
          [min-width no-val]
          [min-height no-val]
          [stretchable-width no-val]
          [stretchable-height no-val])
    (init-rest)
    (super-new [parent parent]
               [style style]
               [enabled enabled]
               [vert-margin vert-margin]
               [horiz-margin horiz-margin]
               [border border]
               [spacing spacing]
               [alignment alignment]
               [min-width min-width]
               [min-height min-height]
               [stretchable-width stretchable-width]
               [stretchable-height stretchable-height])
    (public* [set-orientation (λ (x) (send (mred->wx this) set-orientation x))]
             [get-orientation (λ () (send (mred->wx this) get-orientation))])))
(define horizontal-panel%
  (class panel%
    (init parent [style null] 
          [enabled #t]
          [vert-margin no-val]
          [horiz-margin no-val]
          [border no-val]
          [spacing no-val]
          [alignment no-val]
          [min-width no-val]
          [min-height no-val]
          [stretchable-width no-val]
          [stretchable-height no-val])
    (init-rest)
    (super-new [parent parent]
               [style style]
               [enabled enabled]
               [vert-margin vert-margin]
               [horiz-margin horiz-margin]
               [border border]
               [spacing spacing]
               [alignment alignment]
               [min-width min-width]
               [min-height min-height]
               [stretchable-width stretchable-width]
               [stretchable-height stretchable-height])
    (public* [set-orientation (λ (x) (send (mred->wx this) set-orientation x))]
             [get-orientation (λ () (send (mred->wx this) get-orientation))])))

(define list-append append)

(define tab-panel%
  (class vertical-panel%
    (init choices parent [callback (lambda (b e) (void))] [style null] [font no-val]
          ;; inherited inits
          [enabled #t]
          [vert-margin no-val]
          [horiz-margin no-val]
          [border no-val]
          [spacing no-val]
          [alignment no-val]
          [min-width no-val]
          [min-height no-val]
          [stretchable-width no-val]
          [stretchable-height no-val])
    (init-rest)
    (define save-choices choices)
    (override* [get-initial-label (lambda () save-choices)])

    (let ([cwho '(constructor tab-panel)])
      (unless (and (list? choices) (andmap label-string? choices))
        (raise-argument-error (who->name cwho) "label-string?" choices))
      (check-callback cwho callback)
      (check-container-parent cwho parent)
      (check-style cwho #f '(deleted no-border) style)
      (check-font cwho font))
    (super-new [parent parent]
               [style
                (if (memq 'no-border style)
                    (if (eq? (car style) 'no-border)
                        (cdr style)
                        (list (car style)))
                    (cons 'border style))]
               [enabled enabled]
               [vert-margin vert-margin]
               [horiz-margin horiz-margin]
               [border border]
               [spacing spacing]
               [alignment alignment]
               [min-width min-width]
               [min-height min-height]
               [stretchable-width stretchable-width]
               [stretchable-height stretchable-height])
    (send (mred->wx this) set-callback (lambda (wx e) (callback (wx->mred wx) e)))

    (public*
     [get-number (lambda () (length save-choices))]
     [append (entry-point
              (lambda (n)
                (check-label-string '(method tab-panel% append) n)
                (let ([n (string->immutable-string n)])
                  (set! save-choices (list-append save-choices (list n)))
                  (send (mred->wx this) append n))))]
     [get-selection (lambda () (and (pair? save-choices)
                                    (send (mred->wx this) get-selection)))]
     [set-selection (entry-point
                     (lambda (i)
                       (check-item 'set-selection i)
                       (send (mred->wx this) set-selection i)))]
     [delete (entry-point
              (lambda (i)
                (check-item 'delete i)
                (set! save-choices (let loop ([p 0][l save-choices])
                                     (if (= p i)
                                         (cdr l)
                                         (cons (car l) (loop (add1 p) (cdr l))))))
                (send (mred->wx this) delete i)))]
     [set-item-label (entry-point
                      (lambda (i s)
                        (check-item 'set-item-label i)
                        (check-label-string '(method tab-panel% set-item-label) s)
                        (let ([s (string->immutable-string s)])
                          (set! save-choices (let loop ([save-choices save-choices][i i])
                                               (if (zero? i)
                                                   (cons s (cdr save-choices))
                                                   (cons (car save-choices) (loop (cdr save-choices) (sub1 i))))))
                          (send (mred->wx this) set-label i s))))]
     [set
      (entry-point (lambda (l)
                     (unless (and (list? l) (andmap label-string? l))
                       (raise-argument-error (who->name '(method tab-panel% set))
                                             "(listof label-string?)" l))
                     (set! save-choices (map string->immutable-string l))
                     (send (mred->wx this) set l)))]
     [get-item-label (entry-point
                      (lambda (i)
                        (check-item 'get-item-label i)
                        (list-ref save-choices i)))])

    (private*
     [check-item
      (lambda (method n)
        (check-non-negative-integer `(method tab-panel% ,method) n)
        (let ([m (length save-choices)])
          (unless (< n m)
            (raise-range-error (who->name `(method tab-panel% ,method))
                               "panel" "tab "
                               n
                               this
                               0
                               (sub1 m)
                               #f))))])))

(define group-box-panel%
  (class vertical-panel%
    (init label parent [style null] [font no-val]
          ;; This is a vestige of the class100 keyword handling macro
          ;; that was used. Since `horiz-margin` and `vert-margin` are
          ;; used below, we have to supply it here (even though it's
          ;; handled by the subarea init args)
          [enabled #t]
          [vert-margin no-val]
          [horiz-margin no-val]
          [border no-val]
          [spacing no-val]
          [alignment no-val]
          [min-width no-val]
          [min-height no-val]
          [stretchable-width no-val]
          [stretchable-height no-val])
    (init-rest)
    (define lbl label)
    (override* [get-initial-label (lambda () lbl)])

    (let ([cwho '(constructor group-box-panel)])
      (check-label-string cwho label)
      (check-container-parent cwho parent)
      (check-style cwho #f '(deleted) style)
      (check-font cwho font))

    ;; Technically a bad way to change margin defaults, since it's
    ;;  implemented with an update after creation:
    (when (eq? horiz-margin no-val) (set! horiz-margin 2))
    (when (eq? vert-margin no-val) (set! vert-margin 2))

    (super-instantiate
     (parent
      (if (memq 'deleted style)
          '(deleted)
          null))
     [enabled enabled]
     [horiz-margin horiz-margin]
     [vert-margin vert-margin]
     [border border]
     [spacing spacing]
     [alignment alignment]
     [min-width min-width]
     [min-height min-height]
     [stretchable-width stretchable-width]
     [stretchable-height stretchable-height])

    (override*
     [set-label (entry-point
                 (lambda (s)
                   (check-label-string '(method group-box-panel% set-label) s)
                   (set! lbl (if (immutable? s)
                                 s
                                 (string->immutable-string s)))
                   (send (mred->wx this) set-label s)))]
     [get-label (lambda () lbl)])))