;;; examples of extensions to Snd's graphics

(provide 'snd-draw.scm)


(define (overlay-rms-env snd chn)
  (let* ((red (make-color 1 0 0))            ; rms env displayed in red
	 (left (left-sample snd chn))
	 (right (right-sample snd chn))
	 (rms-size 128)                      ; this could be a parameter -- not sure what the "right" size is
	 (sr (/ 1.0 (srate snd)))
	 (old-color (foreground-color snd chn))
	 (axinf (axis-info snd chn))
	 (old-axinf (channel-property 'rms-axis-info snd chn)))

    ;; these functions are an optimization to speed up calculating the rms env graph.
    ;; ideally we'd use something like:
    ;;
    ;;   (let* ((x1 (x->position (/ i (srate)) snd chn))
    ;;          (y1 (y->position (moving-rms rms (reader)) snd chn)))
    ;;     (draw-line x0 y0 x1 y1)
    ;;
    ;; in the do-loop below that runs through the samples, but I haven't added x|y->position or draw-line
    ;; to the optimizer ("run"), and each would be looking up the graph axis info on each call even if
    ;; available to the optimizer -- this seems wasteful.  So, the grf-it function below is using the
    ;; axis info in axinf to get the pixel location for the envelope line segment break point.
    ;; Also, draw-lines takes a vector for some reason, so we need to tell "run" that it is an
    ;; integer vector (and preload it with 0).  We save the vector in the channel property 'rms-lines,
    ;; and the associated axis info in 'rms-axis-info.  Since redisplay is common in Snd, it reduces
    ;; "flashing" a lot to have this data instantly available.

    (define (pack-x-info axinf)
      (vct (list-ref axinf 2) ;  x0
	   (list-ref axinf 4) ;  x1
	   (list-ref axinf 10) ; x_axis_x0
	   (list-ref axinf 12) ; x_axis_x1
	   (list-ref axinf 15) ; scale
	   (- (list-ref axinf 10) (* (list-ref axinf 2) (list-ref axinf 15))))) ; base

    (define (pack-y-info axinf)
      (vct (list-ref axinf 3) ;  y0
	   (list-ref axinf 5) ;  y1
	   (list-ref axinf 11) ; y_axis_y0
	   (list-ref axinf 13) ; y_axis_y1
	   (list-ref axinf 16) ; scale
	   (- (list-ref axinf 11) (* (list-ref axinf 3) (list-ref axinf 16))))) ; base

    (define (grf-it val v)
      (round
       (if (>= val (v 1))
	   (v 3)
	   (if (<= val (v 0))
	       (v 2)
	       (+ (v 5) (* val (v 4)))))))

    (define* (make-moving-rms (size 128))
      (make-moving-average size))

    (define (moving-rms gen y)
      (sqrt (moving-average gen (* y y))))

    (if (equal? axinf old-axinf)                    ; the previously calculated lines can be re-used
	(begin
	  (set! (foreground-color snd chn) red)
	  (draw-lines (channel-property 'rms-lines snd chn))
	  (set! (foreground-color snd chn) old-color))
	(let* ((xdata (pack-x-info axinf))
	       (ydata (pack-y-info axinf))
	       (start (max 0 (- left rms-size)))
	       (reader (make-sampler start snd chn))
	       (rms (make-moving-rms rms-size))
	       (x0 0)
	       (y0 0)
	       (line-ctr 2)
	       (lines (make-vector (* 2 (+ 1 (- (list-ref axinf 12) (list-ref axinf 10)))) 0)))
	  (dynamic-wind
	      (lambda ()
		(set! (foreground-color snd chn) red))
	      (lambda ()
		(run
		 (if (< start left)                ; check previous samples to get first rms value
		     (do ((i start (+ 1 i)))
			 ((= i left))
		       (moving-rms rms (reader))))
		 (let ((first-sample (next-sample reader)))
		   (set! x0 (grf-it (* left sr) xdata))
		   (set! y0 (grf-it first-sample ydata))
		   (set! (lines 0) x0)        ; first graph point
		   (set! (lines 1) y0))
		 (do ((i (+ left 1) (+ 1 i)))       ; loop through all samples calling moving-rms
		     ((= i right))
		   (let* ((x1 (grf-it (* i sr) xdata))
			  (y (moving-rms rms (next-sample reader))))
		     (if (> x1 x0)                 ; very often many samples are represented by one pixel
			 (let ((y1 (grf-it y ydata)))
			   (set! (lines line-ctr) x1)
			   (set! (lines (+ 1 line-ctr)) y1)
			   (set! line-ctr (+ line-ctr 2))
			   (set! x0 x1)
			   (set! y0 y1))))))      ; else should we do "max" here? or draw a vertical line from min to max?
		(if (< line-ctr (length lines))
		    (do ((j line-ctr (+ j 2)))       ; off-by-one in vector size calc -- need to pad so we don't get a bogus line to (0, 0)
			((>= j (length lines)))
		      (set! (lines j) x0)
		      (set! (lines (+ j 1)) y0)))
		(draw-lines lines snd chn)
		(set! (channel-property 'rms-lines snd chn) lines)  ; save current data for possible redisplay
		(set! (channel-property 'rms-axis-info snd chn) axinf))
	      (lambda ()
		(set! (foreground-color snd chn) old-color)))))))

;(add-hook! after-graph-hook overlay-rms-env)


(define* (display-colored-samples color beg dur snd chn)
  "(display-colored-samples color beg dur snd chn) displays samples from beg for dur in color 
whenever they're in the current view."
  (let ((left (left-sample snd chn))
	(right (right-sample snd chn))
	(end (+ beg dur))
	(old-color (foreground-color snd chn)))
    (if (and (< left end)
	     (> right beg))
	(let* ((data (make-graph-data snd chn)))
	  (if (vct? data)
	      (let* ((samps (- (min right end) (max left beg)))
		     (offset (max 0 (- beg left)))
		     (new-data (vct-subseq data offset (+ offset samps))))
		(set! (foreground-color snd chn) color)
		(graph-data new-data snd chn copy-context (max beg left) (min end right))
		(set! (foreground-color snd chn) old-color))
	      (let* ((low-data (car data))
		     (high-data (cadr data))
		     (size (length low-data))
		     (samps (- right left))
		     (left-offset (max 0 (- beg left)))
		     (left-bin (floor (/ (* size left-offset) samps)))
		     (right-offset (- (min end right) left))
		     (right-bin (floor (/ (* size right-offset) samps)))
		     (new-low-data (vct-subseq low-data left-bin right-bin))
		     (new-high-data (vct-subseq high-data left-bin right-bin)))
		(set! (foreground-color snd chn) color)
		(graph-data (list new-low-data new-high-data) snd chn copy-context left-bin right-bin)
		(set! (foreground-color snd chn) old-color)))))))

(define (display-samples-in-color snd chn)
  ;; intended as after-graph-hook member 
  ;; run through 'colored-samples lists passing each to display-colored-samples
  (let ((colors (channel-property 'colored-samples snd chn)))
    (if colors
	(for-each
	 (lambda (vals)
	   (apply display-colored-samples (append vals (list snd chn))))
	 colors))))

(define* (color-samples color ubeg udur usnd uchn)
  "(color-samples color beg dur snd chn) causes samples from beg to beg+dur to be displayed in color"
  (if (not (member display-samples-in-color (hook->list after-graph-hook)))
      (add-hook! after-graph-hook display-samples-in-color))
  (let* ((beg (or ubeg 0))
	 (snd (or usnd (selected-sound) (car (sounds))))
	 (chn (or uchn (selected-channel snd) 0))
	 (dur (or udur (- (frames snd chn) beg)))
	 (old-colors (or (channel-property 'colored-samples snd chn) '())))
    (set! (channel-property 'colored-samples snd chn) (cons (list color beg dur) old-colors))
    (update-time-graph snd chn)))

(define* (uncolor-samples usnd uchn)
  "(uncolor-samples snd chn) cancels sample coloring in the given channel"
  (let*	((snd (or usnd (selected-sound) (car (sounds))))
	 (chn (or uchn (selected-channel snd) 0)))
    (set! (channel-property 'colored-samples snd chn) '())
    (update-time-graph snd chn)))



(define (display-previous-edits snd chn)
  "(display-previous-edits snd chn) displays all edits of the current sound, with older versions gradually fading away"
  (let* ((edits (edit-position snd chn))
	 (old-color (foreground-color snd chn))
	 (clist (color->list old-color))
	 (r (car clist))
	 (g (cadr clist))
	 (b (caddr clist))
	 (rinc (/ (- 1.0 r) (+ edits 1)))
	 (ginc (/ (- 1.0 g) (+ edits 1)))
	 (binc (/ (- 1.0 b) (+ edits 1))))
    (if (> edits 0)
	(begin
	  (do ((pos 0 (+ 1 pos))
	       (re (- 1.0 rinc) (- re rinc))
	       (ge (- 1.0 ginc) (- ge ginc))
	       (be (- 1.0 binc) (- be binc)))
	      ((> pos edits))
	    (let ((data (make-graph-data snd chn pos)))
	      (set! (foreground-color snd chn) (make-color re ge be))
	      (graph-data data snd chn)))
	  (set! (foreground-color snd chn) old-color)))))


(define (overlay-sounds . args)
  "(overlay-sounds . args) overlays onto its first argument all subsequent arguments: (overlay-sounds 1 0 3)"
  (let ((base (car args)))
    (add-hook! after-graph-hook
	       (lambda (snd chn)
		 (if (and (sound? base)
			  (equal? snd base))
		     (for-each 
		      (lambda (snd)
			;; perhaps this should also set sync
			(if (and (sound? snd)
				 (> (channels snd) chn)
				 (> (channels base) chn))
			    (graph-data 
			     (make-graph-data snd chn) 
			     base chn copy-context 
			     #f #f graph-dots)))
		      (cdr args)))))))

(define (samples-via-colormap snd chn)
  "(samples-via-colormap snd chn) displays time domain graph using current colormap (just an example of colormap-ref)"
  (let* ((left (left-sample snd chn))
	 (right (right-sample snd chn))
	 (old-color (foreground-color snd chn))
	 (data (make-graph-data snd chn)))

    (define (samples-1 cur-data)
      (let* ((x0 (x->position (/ left (srate snd))))
	     (y0 (y->position (cur-data 0)))
	     (colors (make-vector (colormap-size) #f))
	     (len (length cur-data))
	     (incr (/ (+ 1 (- right left)) len)))
	(do ((i (+ left incr) (+ i incr))
	     (j 1 (+ 1 j)))
	    ((or (>= i right)
		 (>= j len)))
	  (let* ((x1 (x->position (/ i (srate snd))))
		 (y1 (y->position (cur-data j)))
		 (x (abs (cur-data j)))
		 (ref (floor (* (colormap-size) x)))
		 (color (or (colors ref)
			    (let ((new-color (apply make-color (colormap-ref (colormap) x))))
			      (set! (colors ref) new-color)
			      new-color))))
	    (set! (foreground-color snd chn) color)
	    (draw-line x0 y0 x1 y1)
	    (set! x0 x1)
	    (set! y0 y1)))
	(set! (foreground-color snd chn) old-color)))

    (if data
	(if (vct? data)
	    (samples-1 data)
	    (begin
	      (samples-1 (car data))
	      (samples-1 (cadr data)))))))



;;; -------- click-for-listener-help

(define click-for-listener-help
  (let ((help-moved #f)
	(last-click-time 0))
    (lambda (pos)
  
      (define (char-quit? ch)
	(or (char-whitespace? ch)
	    (char=? ch #\()
	    (char=? ch #\))
	    (char=? ch #\')
	    (char=? ch #\")))

      ;; find nearest name
      ;; scan back and forth for non-alphanumeric
      ;; call snd-help on name and post in help-dialog
      
      (let* ((time (get-internal-real-time)) ; look for double-click
	     (click-time (- time last-click-time)))
	(set! last-click-time time)
	(if (< click-time 25) ; .25 secs -- could use XtGetMultiClickTime if xm loaded
	    (let* ((text (widget-text (list-ref (main-widgets) 4)))
		   (len (and (string? text) (string-length text)))
		   (happy #f))
	      (if (and len (>= pos len)) (set! pos (- len 1))) ;click at very bottom of listener is beyond current string end
	      (if (and len (>= pos 1))                        ;not click in empty listener, etc
		  (begin
		    (if (char-quit? (string-ref text pos))
			(begin                      ;not currently in a name
			  ;; go looking for plausible name (look left first)
			  (do ((i (- pos 1) (- i 1)))
			      ((or happy (= i 0)))
			    (if (char-alphabetic? (string-ref text i))
				(begin
				  (set! pos i)
				  (set! happy #t))))
			  (if (not happy)           ;nothing to the left -- try to the right
			      (do ((i (+ 1 pos) (+ 1 i)))
				  ((or happy (= i len)))
				(if (char-alphabetic? (string-ref text i))
				    (begin
				      (set! pos i)
				      (set! happy #t))))))
			(set! happy #t))
		    (if happy
			;; found some portion of a name -- try to get the full thing
			(let ((start pos)
			      (end pos))
			  (set! happy #f)
			  (do ((i (- pos 1) (- i 1)))  ;look for start of name
			      ((or happy (= i 0)))
			    (if (char-quit? (string-ref text i))
				(begin
				  (set! start (+ i 1))
				  (set! happy #t))))
			  (set! happy #f)
			  (do ((i (+ 1 pos) (+ 1 i)))  ;look for end of name
			      ((or happy (and (= i len)
					      (let () 
						(set! end i) 
						(set! happy #t) 
						#t))))
			    (if (char-quit? (string-ref text i))
				(begin
				  (set! end i)
				  (set! happy #t))))
			  (if (and happy
				   (> end start))
			      ;; got a name -- look for snd-help, if any
			      (let* ((name (substring text start end))
				     (help (snd-help name #f)))
				(if (string=? name help)
				    (set! help (snd-help (string->symbol name))))
				(if (not (string=? name help))
				    (let ((dialog (help-dialog name help)))
				      (if (not help-moved)
					  ;; if this is the first call, try to position help dialog out of the way
					  ;;   this is clunky -- perhaps better would be a tooltip window at the bottom of the listener?
					  (let ((main-xy (widget-position (cadr (main-widgets))))
						(main-size (widget-size (cadr (main-widgets)))))
					    (set! (widget-position (list-ref (dialog-widgets) 14))
						  (list (+ (car main-xy) (car main-size))
							(cadr main-xy)))
					    (set! help-moved #t)))))))))))))))))
