#lang racket
;;; katy-sliders.rkt
(require 2htdp/universe 2htdp/image rsound)

(define-struct posn (x y))

; Uses katy-sliders from John Clements whose source is here.
; katy-sliders.rkt, Copyright 2012, John Clements (clements@brinckerhoff.org)
; Licensed under the Apache License, Version 2.0 (the "License");
; you may not use this file except in compliance with the License.
; You may obtain a copy of the License at
;  http://www.apache.org/licenses/LICENSE-2.0
; Unless required by applicable law or agreed to in writing, software
; distributed under the License is distributed on an "AS IS" BASIS,
; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
; See the License for the specific language governing permissions and
; limitations under the License.

;; TO SHOW TO STUDENTS:
;; - LOCAL
;; - LIST SYNTAX
;; - ERRORS

;; demo of some sliders. Modifying the code is your own risk !

;; DATA DEFINITIONS:

;; a world is  
;; (make-ws list-of-components maybe-component number number)
;; interp: 
;;  - cs: the list of components in the world,
;;  - live: the posn of the component currently being dragged,
;;  - W : the width of the scene, and
;;  - H : the height of the scene
(define-struct ws (cs live W H))

;; a list-of-components is either
;; - empty, or
;; - (cons component list-of-components)

;; a component is (make-component vslider posn)
;; interp:
;; - s : the slider (currently, only sliders are allowed)
;; - posn : the location of the upper-left corner of the component
;;          within the global scene.
(define-struct component (s posn))

;; NOTE: the 'posn' structure is already defined.

;; a maybe-component is either
;; - false, or
;; - a posn
;; interp. false -> no slider is live, 
;;  - posn, e.g. (make-posn 30 40) -> the component at 30,40 is live
;; NOTE: if two components have the same x and y, we're in big trouble.

;; a vslider is (make-vslider name number number fraction)
;; interp:
;; - Name : the name of the slider
;; - W : the width of the slider on the screen
;; - H : the height of the slider on the screen
;; - val : the fraction representing the position of
;;         the slider; 0 is at the bottom, 1 is at the top.
(define-struct vslider (Name W H val))

;; a fraction is a number between 0.0 and 1.0 inclusive

(define VSLIDER-HANDLE-H 40)
(define SLOT-OFFSET (/ VSLIDER-HANDLE-H 2))

;;;;;;;;;;;;
;;
;;  DRAWING
;;
;;;;;;;;;;;;

;; draw the world
;; world -> image
(define (katy-draw ws)
  (set-box! world-box ws)
  (place-components (ws-cs ws)
                    (empty-scene (ws-W ws) (ws-H ws))))

;; place-components : list-of-components scene -> scene
;; place all of the given components onto the scene
(define (place-components comps scene)
  (if (empty? comps)
      scene
      (place-components  (rest comps) (place-component (first comps) scene))))

;; place-component : component scene -> scene
;; place the image of the component onto the scene
;; (tested indirectly.)
(define (place-component c s)
  (place-image (draw-vslider (component-s c))
               (+ (posn-x (component-posn c)) (/ (component-width c) 2))
               (+ (posn-y (component-posn c)) (/ (component-height c) 2))
               s))


;; draw a vertical slider
;; slider -> image
(define (draw-vslider vs)
  (local
    [(define w (vslider-W vs))
     (define h (vslider-H vs))
     (define slot-len (- h (* 2 SLOT-OFFSET)))
     (define slider-pixels (- (+ slot-len SLOT-OFFSET)
                              (* slot-len (vslider-val vs))))
     (define name (vslider-Name vs))
     (define rect
       (overlay (text (number->string (min 99 (inexact->exact (round (* (vslider-val vs) 100))))) 35 "red")
                (rectangle w VSLIDER-HANDLE-H "solid" (make-color #xE0 #xD0 #x90))))
     (define img-slider (place-image rect (/ w 2) slider-pixels
                                     (add-line (rectangle w h "solid" "white")
                                               (/ w 2) SLOT-OFFSET (/ w 2) (- h SLOT-OFFSET) 
                                               (make-pen "black" 7 "solid" "round" "round"))))]
    (above img-slider (text name 18 "blue"))))

;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  HANDLING MOUSE EVENTS
;;
;;;;;;;;;;;;;;;;;;;;;;;;;

(define (katy-mouse ws x y event)            ;; world x number x number x string -> world
  ;; BUTTON-DOWN EVENT:
  (cond [(string=? event "button-down")
         (local
           [(define chosen-component (xy->component (ws-cs ws) x y))]
           (if (equal? chosen-component #f)
               ws                        ;; missed all components, leave the world state alone !
               ;; hit one: turn it on:
               (make-ws (components-posn-update (ws-cs ws) chosen-component y)
                        chosen-component
                        (ws-W ws)
                        (ws-H ws))))]
        ;; BUTTON-UP EVENT:
        [(string=? event "button-up")
         ;; turn the live one off:
         (make-ws (ws-cs ws) #f (ws-W ws) (ws-H ws))]
        ;; OTHER EVENT:
        [(equal? (ws-live ws) #f) ws]
        [else  ;; one of them is already live
         (make-ws (components-posn-update (ws-cs ws) (ws-live ws) y)
                  (ws-live ws)
                  (ws-W ws)
                  (ws-H ws))]))

;; components-posn-update : list-of-components x posn x number -> list-of-components
;; return a list of components with the chosen component updated to the position of the mouse
(define (components-posn-update comps live y)
  (cond [(empty? comps) (error 'components-posn-update "no matching component")]
        [(equal? (component-posn (first comps)) live) ;; found it!
         (cons (component-posn-update (first comps) y) (rest comps))]
        [else ;; keep searching:
         (cons (first comps)
               (components-posn-update (rest comps) live y))]))

;; component-posn-update : component x number -> component
;; update the given component to reflect the y position of the mouse
;; (tested indirectly.)
(define (component-posn-update c y)
  (make-component (slider-posn-update (component-s c) (- y (posn-y (component-posn c))))
                  (component-posn c)))

;; slider-posn-update: slider x number -> slider
;; given a vertical slider and a Y mouse position relative to the 
;; slider, update the slider accordingly
(define (slider-posn-update vs ypos)
  (local
    [(define range (- (vslider-H vs) (* 2 SLOT-OFFSET)))
     (define capped (max SLOT-OFFSET (min (- (vslider-H vs) SLOT-OFFSET) ypos)))
     (define new-posn (- 1.0 (/ (- capped SLOT-OFFSET) range)))]
    (make-vslider (vslider-Name vs) (vslider-W vs) (vslider-H vs) new-posn)))

;; component-width : the width of the component
;; [tested indirectly]
(define (component-width c) (vslider-W (component-s c)))

;; component-height : the height of the component
;; [tested indirectly]
(define (component-height c) (vslider-H (component-s c)))

;; determine which component a mouse position is in, or #f :
;; xy->component : number x number -> maybe-component
(define (xy->component components x y)
  (if (empty? components)
      #f
      (local [(define fc (first components))]
        (if (in-bounding-box? fc x y)
            (component-posn fc)
            (xy->component (rest components) x y)))))

;; in-bounding-box? : component pixels pixels -> boolean
;; determine whether an x and a y are in the bounding box of a 
;; component.
(define (in-bounding-box? component x y)
  (local [(define p (component-posn component))]
    (and (<= (posn-x p) x (sub1 (+ (posn-x p) (component-width component))))
         (<= (posn-y p) y (sub1 (+ (posn-y p) (component-height component)))))))

;;; getting the value of sliders (n = 0, 1, 2, 3, 4)
(define (fetch-slider0) (vslider-val (component-s (first (ws-cs (unbox world-box))))))
(define (fetch-slider1) (vslider-val (component-s (second (ws-cs (unbox world-box))))))
(define (fetch-slider2) (vslider-val (component-s (third (ws-cs (unbox world-box))))))
(define (fetch-slider3) (vslider-val (component-s (fourth (ws-cs (unbox world-box))))))
(define (fetch-slider4) (vslider-val (component-s (fifth (ws-cs (unbox  world-box))))))

(define initial-world    ; the world is a panel of 5 sliders
  (make-ws (list 
            (make-component (make-vslider "FREQ" 50 400 0.2)         ; <----------------- configure
                            (make-posn 50 30))
            (make-component (make-vslider "LFO" 50 400 0.2)          ; <----------------- your 
                            (make-posn 105 30))
            (make-component (make-vslider "Vol" 50 400 0)            ; <----------------- sliders...
                            (make-posn 160 30))
            (make-component (make-vslider "" 50 400 0.2)             ; unused
                            (make-posn 215 30))
            (make-component (make-vslider "" 50 400 0.2)             ; unused
                            (make-posn 270 30)))
           #f
           375 460))

(define world-box (box initial-world))

(define (katy-run)
  (big-bang initial-world
            (on-mouse katy-mouse)
            (on-draw katy-draw)))

;;;;;;;;;;;;;;;;;;;;; end of katy-sliders ;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; User stuff : a frequency modulation example (PF2)

(define SIG
  (network ()
           (a <= sine-wave (* 880 (fetch-slider0)))         ; signal source between 0 and 880 Hz
           (lfo <= sine-wave (* 3 (fetch-slider1)))         ; lfo : Low Frequency Oscillator between 0 and 3 Hz
           (fm = (* a lfo))                                 ; Frequency Modulation !
           (vol = (fetch-slider2))                          ; amplitude
           (out = (* fm vol))))

(signal-play SIG)

(katy-run)