#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 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))

(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))))))

(define (make-sliders-frame label)
  (new frame% [label label]))

(define (make-slider parent label min-value max-value callback)
  (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]))

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

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

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