#lang racket


(require racket/gui/dynamic)

(define frame% (if (gui-available?) (gui-dynamic-require 'frame%) #f))
(define slider% (if (gui-available?) (gui-dynamic-require 'slider%) #f))
(define check-box% (if (gui-available?) (gui-dynamic-require 'check-box%) #f))
(define the-font-list (if (gui-available?) (gui-dynamic-require 'the-font-list) #f))

(when (gui-available?) (dynamic-require 'racket/gui/base 0))


(require (only-in "backends.rkt" delete-all-shapes realize refresh))

(provide sliders)


(define (argument<-slider param slider)
  (let ((s (send slider get-value)))
    (if (or (empty? (cdr param)) (empty? (cddr param)) (empty? (cdddr param)))
        s
        (* s (cadddr param)))))

(define (label<-parameter param)
  (car param))

(define (min-value<-parameter param)
  (if (empty? (cdr param))
      0
      (cadr param)))

(define (max-value<-parameter param)
  (if (or (empty? (cdr param)) (empty? (cddr param)))
      100
      (caddr param)))


(define (make-draw-fn fn params sliders-fn)
  (lambda ()
    (begin ;time
      (begin
        (delete-all-shapes)
        (let ((shape
               (with-handlers ((exn:fail:contract:divide-by-zero? (lambda (exn) #f)))
                 (apply fn (map argument<-slider params (sliders-fn))))))
          (realize shape)
          (refresh))))))

(define (make-widgets-frame label)
  (new frame% 
       [label label] 
       [alignment '(left center)]))

(define (make-widget parent label min-value max-value callback)
  (cond ((number? min-value)
         (new slider%
              [parent parent]
              #;[style '(horizontal vertical-label)]
              #;[font (send the-font-list
                          find-or-create-font 
                          12 'script 'italic 'bold #f 'smoothed)]
              [label label]
              [min-value min-value]
              [max-value max-value]
              [callback callback]))
        ((boolean? min-value)
         (new check-box%
              [parent parent]
              [label label]
              [callback callback]))
        (else
         (error "Unknown type of widget for value" min-value))))

(define (make-widget-callback fn params)
  (let ((prev #f))
    (λ (slider event)
      (let ((new (send slider get-value)))
        (unless (eqv? new prev)
          (set! prev new)
          ((fn)))))))

(define (make-widgets parent fn params)
  (letrec ((draw-fn (make-draw-fn fn params (λ () sliders)))
           (sliders
            (map
             (λ (param)
               (make-widget parent
                            (label<-parameter param)
                            (min-value<-parameter param)
                            (max-value<-parameter param)
                            (make-widget-callback (λ () draw-fn) params)))
             params)))
    (draw-fn)
    (send parent show #t)))

(define (sliders label fn params)
  (make-widgets (make-widgets-frame label) fn params))