(module fred (lib "frtime.ss" "frtime")
  (require "mixin-macros.ss"
           "aux-mixin-macros.ss"
           (lib "class.ss")
           (lib "string.ss")
           (all-except (lib "mred.ss" "mred") send-event)
           (lib "framework.ss" "framework"))
  
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Helpers
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (define (in-string itm)
    (if (undefined? itm)
        ""
        (if (string? itm)
            itm
            (expr->string itm))))
  
  
  ;; adding assumed methods
  (define (add-void-set-value super-class)
    (class super-class
      (define/public (set-value v) (void))
      (super-new)))
  
  (define (callback->pub-meth super-class)
    (class super-class
      (define/public (callback-method w e) (void))
      (super-new (callback (lambda (w e) (callback-method w e))))))
  
  (define (add-shown super-class)
    (class super-class
      (init (shown #f))
      (define shown-val shown)
      (super-new)
      (inherit show)
      (show shown-val)))
      
  
  
  ;; *-event-processor init-argument values
  (define event-is-val
    (lambda (es)
      (map-e car es)))
  
  ; (send x get-mouse-events) returns a split procedure over the event-type
  (define split-mouse-events/type
    (lambda (evt-src)
      (split (map-e cadr evt-src) (lambda (evt) (send evt get-event-type)))))
  
  ; (send x get-key-events) returns a split procedure over the key code
  (define split-key-events/type
    (lambda (evt-src)
      (split (map-e cadr evt-src) (lambda (evt) (send evt get-key-code)))))
  
  
  (define (send-for-value w e)
    (send w get-value))
  
  (define (send-for-selection w e)
    (send w get-selection))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; make state available as eventstreams
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (define (add-mouse-access super-class)
    ((callbacks->args-evts mouse-events ; Name of event stream
                          on-subwindow-event ; proc overriding
                          )
     split-mouse-events/type
     super-class))
  
  
  (define (add-focus-access super-class)
    ((callbacks->args-evts focus-events on-focus)
     event-is-val
     super-class))
  
  (define (add-keypress-split super-class)
    ((callbacks->args-evts key-events on-subwindow-char)
     split-key-events/type
     super-class))
  
  
  (define (add-size-access super-class)
    ((callbacks->args-evts size-events on-size)
     (lambda (x) x)
     super-class))
  
  (define (add-size-b super-class)
    ((mixin-hold size-b init-size-b get-size-events)
     '(0 0)
     (add-size-access super-class)))
  
  (define (add-position-access super-class)
    ((callbacks->args-evts position-events on-move)
     (lambda (x) x)
     super-class))
  
  (define (add-position-b super-class)
    ((mixin-hold position-b init-position-b get-position-events)
     '(0 0)
     (add-position-access super-class)))
  
  
  
  (define (monitor-set-value super-class)
    ((callbacks->args-evts set-value-events set-value)
     event-is-val
     super-class))
  
  (define (monitor-callback-method super-class)
    ((callbacks->args-evts callback-events callback-method)
     (lambda (x) x)
     super-class))
  
  
  (define (add-callback-access val-ext super-class)
    ((mixin-merge-e
      value-e
      get-set-value-events 
      get-callback-events)
     (class (monitor-set-value
             (monitor-callback-method
              (callback->pub-meth super-class)))
       (super-new (callback-events-event-processor 
                   (lambda (es) (map-e (lambda (e) (apply val-ext e)) es)))))))

  
  (define add-value-b (mixin-hold value-b initial-value get-value-e))
                       
            
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; using events to drive object interaction
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (define (add-callback-access/loop val-ext super-class)
    ((events->callbacks value-set set-value)
     (add-callback-access val-ext super-class)))
  
  
  (define (add-focus-on-event super-class)
    (class ((events->callbacks focus-when carries-args-for focus)
            super-class)
      (init (focus-when (event-receiver)))
      (define focus-map (map-e (lambda (_) '()) focus-when))
      (super-new (focus-when focus-map))))
  
  
  
 

  
    ;; Standard mixin combinations
  (define (standard-lift widget)
    (add-size-b
     (add-position-b
      (add-keypress-split
       (add-focus-on-event
        (add-mouse-access
         (add-focus-access
          (add-signal-controls 
           widget
           (label set-label "") 
           (enabled enable #t)
           (min-width min-width 0)
           (min-height min-height 0)
           (stretchable-width stretchable-width #f)
           (stretchable-height stretchable-height #f)
           ))))))))
  
  (define (standard-input-lift accessor default val-ext)
    (lambda (super-class)
      (add-value-b
       default
       (accessor val-ext super-class))))
  
  
  
  (define ft-frame%
    ((behavior->callbacks shown show)
     #f
     (add-shown
      (standard-lift frame%))))
      
  (define ft-message% 
    (standard-lift message%))
  
  (define ft-button%
    (add-callback-access (lambda (w e) e) (add-void-set-value (standard-lift button%))))
  
  (define ft-check-box%
    ((standard-input-lift add-callback-access/loop #f send-for-value)
     (standard-lift check-box%)))
  
  (define ft-slider%
    ((standard-input-lift add-callback-access/loop 0 send-for-value)
     (standard-lift slider%))) ;ideally the default should be the minimum value
  
  (define ft-text-field%
    ((standard-input-lift add-callback-access/loop "" send-for-value)
     (standard-lift text-field%)))

  (define ft-radio-box%
    ((standard-input-lift add-callback-access 0 send-for-selection)
     (add-void-set-value (standard-lift radio-box%))))
  
  (define ft-choice%
    ((standard-input-lift add-callback-access 0 send-for-selection)
     (add-void-set-value (standard-lift choice%))))
  
  (define ft-list-box%
    ((standard-input-lift add-callback-access 0 send-for-selection)
     (add-void-set-value (standard-lift list-box%))))
  
  
 
  
  ;; Special case widgets

  
  (define specialized-gauge%
    (add-signal-controls
     (class gauge%
       (init value)  
       (super-new)
       (send this set-value value))
     (value set-value 0)
     (range set-range 1)))
  
  
  (define ft-gauge%
    (standard-lift specialized-gauge%))
  
  
  (define ft-menu-item%
    (add-callback-access
     list
     (add-void-set-value
      menu-item%)))  
  
  
  (provide (all-defined)
           (all-from (lib "class.ss"))
           (all-from "mixin-macros.ss")
           (all-from "aux-mixin-macros.ss"))) 



