#lang scheme/gui
;;; PLT Scheme Simulation Collection
;;; variable.ss
;;; Copyright (c) 2008 M. Douglas Williams
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA.
;;;
;;; Version  Date      Description
;;; 1.0.0    11/28/08  Initial release.  (Doug Williams)

(require "variable.ss")

(provide (all-defined-out))

;;; -----------------------------------------------------------------------------
;;;                               Variable Slider
;;; -----------------------------------------------------------------------------
;;; A variable slider is a slider that can automatically send its value to a
;;; simulation collection variable.  The class variable-slider% is a subclass of
;;; the MrEd slider% class and only works with integers in the range of -10000 to
;;; 10000.  The min and max values are set when the slider is created.

;;; variable-slider%
(define variable-slider%
  (class slider%
    ;; --------------------------------------------------------------------------
    ;;                            Initializations
    ;; --------------------------------------------------------------------------
    (init label)
    (init min-value)
    (init max-value)
    (init parent)
    (init ((variable-init variable) #f))
    (unless (or (variable? variable-init)
                (not variable-init))
      (error
       "initialization of variable-slider%: expected either a (simulation collection) variable or #f, given ~a"
       variable-init))
    ;; --------------------------------------------------------------------------
    ;;                          Inherited Methods
    ;; --------------------------------------------------------------------------
    (inherit get-value)
    ;; --------------------------------------------------------------------------
    ;;                          Private Variables
    ;; --------------------------------------------------------------------------
    (define variable #f)
    ;; --------------------------------------------------------------------------
    ;;                             Set Variable
    ;; --------------------------------------------------------------------------
    (define/public (set-variable v)
      (unless (or (not v)
                  (variable? v))
        (error 'set-variable
               "expect argument of either #f or type variable?, given ~a"
               v))
      (set! variable v)
      (when variable
        (set-variable-value! variable (get-value))))
    ;; --------------------------------------------------------------------------
    ;;                            Initialize Object
    ;; --------------------------------------------------------------------------
    (super-instantiate
        (label min-value max-value parent)
      ;; Callback will set the variable value
      (callback
       (lambda (slider event)
         (when variable
           (set-variable-value! variable (get-value))))))
    (set-variable variable-init)))

;;; -----------------------------------------------------------------------------
;;;                               Variable Gauge
;;; -----------------------------------------------------------------------------
;;; A variable gauge is a gauge that is automatically updated when the its assoc-
;;; iated variable, if any, is updated.
(define variable-gauge%
  (class gauge%
    ;; --------------------------------------------------------------------------
    ;;                            Initializations
    ;; --------------------------------------------------------------------------
    (init label)
    (init((range-init range)))
    (unless (or (and (integer? range-init)
                     (<= 1 range-init 10000))
                (and (variable? range-init)
                     (<= 1 (variable-value range-init) 10000)))
      (error
       "initialization of variable-gauge%: expected one of integer in the range 1 to 10000 or  a (simulation collection) variable whose value is an integer in the range 1 to 10000, given ~a"
       range-init))
    (init parent)
    (init ((variable-init variable) #f))
    (unless (or (variable? variable-init)
                (not variable-init))
      (error
       "initialization of variable-gauge%: expected either a (simulation collection) variable or #f, given ~a"
       variable-init))
    ;; --------------------------------------------------------------------------
    ;;                          Inherited Methods
    ;; --------------------------------------------------------------------------
    (inherit set-value)
    ;; --------------------------------------------------------------------------
    ;;                          Private Variables
    ;; --------------------------------------------------------------------------
    (define range
      (cond ((integer? range-init)
             range-init)
            ((variable? range-init)
             (variable-value range-init))))
    (define variable #f)
    (define range-monitor #f)
    (define value-monitor #f)
    ;; --------------------------------------------------------------------------
    ;;                              Set Range
    ;; --------------------------------------------------------------------------
    (define/override (set-range r)
      (unless (or (and (integer? r)
                       (<= 1 r 10000))
                  (and (variable? r)
                       (<= 1 (variable-value r) 10000)))
        (error 'set-variable
               "expected argument of one an integer in range 1 to 10000 or a (simulation collection) variable whose value is an integer in range 1 to 10000, given ~a"
               r))
      ;; Remove any existing range monitor
      (when range-monitor
        (variable-remove-set-monitor! range range-monitor)
        (set! range-monitor #f))
      ;; Set the local range variable
      (set! range r)
      ;; Set the parent range and set up the range variable monitor
      (cond ((integer? range)
             (super set-range range))
            ((variable? range)
             (super set-range (variable-value range))
             (set! range-monitor
                   (variable-add-set-monitor!
                    range 'after
                    (lambda (variable value)
                      (super set-range value)))))))
    ;; --------------------------------------------------------------------------
    ;;                             Set Variable
    ;; --------------------------------------------------------------------------
    (define/public (set-variable v)
      (unless (or (not v)
                  (variable? v))
        (error 'set-variable
               "expect argument of either #f or type variable?, given ~a"
               v))
      ;; Remove any existing value monitor
      (when value-monitor
        (variable-remove-set-monitor! variable value-monitor)
        (set! value-monitor #f))
      ;; Set the local variable variable
      (set! variable v)
      ;; Set the parent value and set up the value variable monitor
      (if variable
          (begin
            (if (variable-initialized? variable)
                (set-value (variable-value variable))
                (set-value 0))
            (set! value-monitor
                  (variable-add-set-monitor!
                   variable 'after
                   (lambda (variable value)
                     (if (variable-initialized? variable)
                         (set-value value)
                         (set-value 0))))))
          (set-value 0)))
    ;; --------------------------------------------------------------------------
    ;;                            Initialize Object
    ;; --------------------------------------------------------------------------
    (super-instantiate
        (label range parent))
    (set-range range-init)
    (set-variable variable-init)))

;;; -----------------------------------------------------------------------------
;;;                              Variable Message
;;; -----------------------------------------------------------------------------
(define variable-message%
  (class message%
    ;; --------------------------------------------------------------------------
    ;;                            Initializations
    ;; --------------------------------------------------------------------------
    (init label)
    (init parent)
    (init ((variable-init variable) #f))
    ;; --------------------------------------------------------------------------
    ;;                          Inherited Methods
    ;; --------------------------------------------------------------------------
    (inherit set-label)
    ;; --------------------------------------------------------------------------
    ;;                          Private Variables
    ;; --------------------------------------------------------------------------
    (define variable #f)
    (define value-monitor #f)
    ;; --------------------------------------------------------------------------
    ;;                             Set Variable
    ;; --------------------------------------------------------------------------
    (define/public (set-variable v)
      (when value-monitor
        (variable-remove-set-monitor! variable value-monitor)
        (set! value-monitor #f))
      (set! variable v)
      (when variable
        (set! value-monitor
              (variable-add-set-monitor!
               variable 'after
               (lambda (variable value)
                 (set-label (number->string value)))))))
    ;; --------------------------------------------------------------------------
    ;;                            Initialize Object
    ;; --------------------------------------------------------------------------
    (super-instantiate
        ((if (and (variable? variable-init)
                  (variable-initialized? variable-init))
             (number->string (variable-value variable-init))
             "")
         parent))
    (set-variable variable-init)))

(define variable-text-field%
  (class text-field%
    (init label)
    (init parent)
    (init ((variable-init variable) #f))
    (inherit set-value)
    (define variable #f)
    (define value-monitor #f)
    (define/public (set-variable v)
      (when value-monitor
        (variable-remove-set-monitor! variable value-monitor)
        (set! value-monitor #f))
      (set! variable v)
      (when variable
        (set! value-monitor
              (variable-add-set-monitor!
               variable 'after
               (lambda (variable value)
                 (set-value (number->string value)))))))
    (super-instantiate
        (label parent))
    (set-variable variable-init)))

(define variable-monitor%
  (class horizontal-panel%
    (init label)
    (init parent)
    (init ((variable-init variable) #f))
    (super-instantiate
     (parent))
    (define label-message
      (instantiate message%
        (label this)))
    (define value-message
      (instantiate message%
        ((if (and (variable? variable-init)
                  (variable-initialized? variable-init))
             (number->string (variable-value variable-init))
             "")
         this)
        (stretchable-width #t)))
    (define variable #f)
    (define value-monitor #f)
    (define/public (set-variable v)
      (when value-monitor
        (variable-remove-set-monitor! variable value-monitor)
        (set! value-monitor #f))
      (set! variable v)
      (when variable
        (set! value-monitor
              (variable-add-set-monitor!
               variable 'after
               (lambda (variable value)
                 (send value-message
                       set-label (number->string value)))))))
    (set-variable variable-init)))