#lang racket
(require racket/gui/dynamic)
(define frame% (if (gui-available?) (gui-dynamic-require 'frame%) #f))
(define tab-panel% (if (gui-available?) (gui-dynamic-require 'tab-panel%) #f))
(define slider% (if (gui-available?) (gui-dynamic-require 'slider%) #f))
(define horizontal-pane% (if (gui-available?) (gui-dynamic-require 'horizontal-pane%) #f))
(define vertical-pane% (if (gui-available?) (gui-dynamic-require 'vertical-pane%) #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 (parameter? obj)
(and (cons? obj)
(string? (car obj))))
(require racket/trace)
(trace parameter?)
(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 (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-draw-fn fn sliders-fn)
(lambda ()
(begin (begin
(delete-all-shapes)
(let ((shape
(with-handlers ((exn:fail:contract:divide-by-zero? (lambda (exn) #f)))
(apply fn (map (lambda (slider) (send slider get-value)) (sliders-fn))))))
1 (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)
(let ((prev #f))
(λ (slider event)
(let ((new (send slider get-value)))
(unless (eqv? new prev)
(set! prev new)
(fn))))))
(define (make-widgets parent fn param)
(letrec ((draw-fn (make-draw-fn fn (λ () sliders)))
(sliders
(let loop ((param param) (parent parent) (curr vertical-pane%) (next horizontal-pane%))
(if (parameter? param)
(list (make-widget parent
(label<-parameter param)
(min-value<-parameter param)
(max-value<-parameter param)
(make-widget-callback draw-fn)))
(let ((parent (new curr [parent parent])))
(append* (map (λ (param) (loop param parent next curr))
param)))))))
(draw-fn)
(send parent show #t)))
(define (sliders label fn params)
(make-widgets (make-widgets-frame label) fn params #f))
(define (tabbed-sliders label fn params)
(make-widgets (make-widgets-frame label) fn params #t))
(sliders
"Foo1"
(lambda args (displayln args))
'("Bar" 1 10))
(sliders
"Foo2"
(lambda args (displayln args))
'(("Bar" 1 10)
("Baz" 1 100)))
(sliders
"Foo3"
(lambda args (displayln args))
'((("Bar" 1 10)
("Baz" 1 100))
(("Quux" 1 10)
("Yep" 1 100))))
(tabbed-sliders
"Foo4"
(lambda args (displayln args))
'(("Tab1"
("Bar1" 1 10))
("Tab2"
("Bar2" 1 10)
("Baz2" 1 100))))
(tabbed-sliders
"Foo4"
(lambda args (displayln args))
'(("Tab1"
(("Bar1" 1 10)
("Baz1" 1 100))
(("Quux1" 1 10)
("Yep1" 1 100)))
("Tab2"
(("Bar2" 1 10)
("Baz2" 1 100))
(("Quux2" 1 10)
("Yep2" 1 100)))))