;;;Transpose, call with Interactive #f and Interval "c ees" to transpose current note
;;;call with Interactive #f to transpose whole staff. FIXME
(if (not (defined? 'Transpose::Interactive))
    (define Transpose::Interactive #t))

(let (
					;functions
      (lily->pitch 0)
      (pitch::semitone-vec 0)
      (pitch::semitone 0)
      (pitch::transpose 0)	
      (get-delta 0)
      (split-input 0)
      (transposed 0)
      (transposed-diff 0)
      (apply-transposition 0)
      (this-proc 0)

					;oginal note
      (original-pitch '(0 0 0))

					;transposition amount
      (original-delta '(0 0 0))

      (transpose-origin '(0 0 0))
      (transpose-delta '(0 0 0))
      )
  (begin
    (set! lily->pitch
  	  (lambda (lilyname)
            (let ((accidental 0) (octave 0) (notename 0) (loop 0))
	      (begin
		(set! notename 
		      (lambda (char)
			(modulo (- (char->integer char) 99) 7)
			))
		(set! loop 
		      (lambda (x)
			(if (< x (string-length lilyname))
			    (begin
			      (if (= x 0) (set! notename (notename (string-ref lilyname x))))
			      (if (> x 0) 
				  (begin
				    (if (equal? #\i (string-ref lilyname x))
					(set! accidental (+ accidental 1)))
				    (if (equal? #\e (string-ref lilyname x))
					(set! accidental (- accidental 1)))
				    (if (equal? #\' (string-ref lilyname x))
					(set! octave (+ octave 1)))
				    (if (equal? #\, (string-ref lilyname x))
					(set! octave (- octave 1)))))
			      (loop (+ 1 x))
			      )
			    );end of if
			)
		      );end of loop
		(loop 0)
		)
	      `(,octave ,notename ,accidental)

	      );end of let
	    ))
	;;;;copied from chord-name.scm in lilypond-1.6.5

    (set! pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))

    (set! pitch::semitone 
	  (lambda (pitch)
	    (+ (* (car pitch) 12)
	       (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
	       (caddr pitch))))

    (set! pitch::transpose 
	  (lambda (pitch delta)
	    (let ((simple-octave (+ (car pitch) (car delta)))
		  (simple-notename (+ (cadr pitch) (cadr delta))))
	      (let ((octave (+ simple-octave (quotient simple-notename 7)))
		    (notename (modulo simple-notename 7)))
		(let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
				     (pitch::semitone `(,octave ,notename 0)))))
		  `(,octave ,notename ,accidental))))))

	;;;;end of ApplyToSelection derivitive

    (set! get-delta
	  (lambda ()
	    (begin
	      (set! original-delta (pitch::transpose transpose-origin transpose-delta))
	      (display "original-delta")
	      (display original-delta)
	      )))

    (set! split-input
	  (lambda (arguments)
	    (let ( 
		  (first (list-ref (string-split arguments #\space) 0))
		  (second (list-ref (string-split arguments #\space) 1))
		  )
	      (set! transpose-origin (lily->pitch first))
	      (set! transpose-delta (lily->pitch second))
	      )
	    ))

    (set! transposed (lambda ()
		       (begin
			 (pitch::transpose original-pitch 
					   original-delta ) )))

    (set! transposed-diff (lambda ()
			    (begin
			      (let
				  ((octave (- (list-ref (transposed) 0) (list-ref original-pitch 0)))
				   (notename (- (list-ref (transposed) 1) (list-ref original-pitch 1)))
				   (accidental (list-ref (transposed) 2))
				   )
				`(,octave ,notename ,accidental))
			      )))

    (set! apply-transposition (lambda ()
				(begin 
				  (set! original-pitch (lily->pitch (d-GetNotes)))
				  (d-DiatonicShift (number->string (* 7 (list-ref (transposed-diff) 0))))
				  (d-DiatonicShift (number->string (list-ref (transposed-diff) 1)))
				  (if (= (list-ref (transposed-diff) 2) 2) 
				      (begin
					(d-Sharpen) 
					(d-Sharpen)
					))
				  (if (= (list-ref (transposed-diff) 2) 1) (d-Sharpen))
				  (if (= (list-ref (transposed-diff) 2) -2) 
				      (begin 
					(d-Flatten)
					(d-Flatten)
					))
				  (if (= (list-ref (transposed-diff) 2) -1) (d-Flatten))
				  )))
    
    
    (set! this-proc (lambda ()
		      (if (d-NextNote)
			  (begin 
			    (apply-transposition) 
			    (this-proc)    
			    ))))
    (if Transpose::Interactive
	(begin
	  (split-input (d-GetUserInput "Transposition - Instructions" 
				       "Enter a note and then how you would 
				     like that note to appear separated 
				     by a space" "c d")) 
	  (get-delta)
	  (d-GoToBeginning)
	  (apply-transposition)
	  (this-proc));; interactive
	(begin
	  (split-input Transpose::Interval)
	  (get-delta)
	  (apply-transposition)));;not interactive
	) ;begin
    ) ;let