;;; Obtained from: http://cf.hum.uva.nl/mmm/code/2%20GTF.lisp

;;; THE VIBRATO PROBLEM: COMPARING TWO SOLUTIONS, CMJ 19(3)
;;; APPENDIX C: GTF MICROWORLD

;;; **********************************************************
;;; **********************************************************
;;; GTF microworld
;;; Micro-version of Generalized Time Functions
;;; (with naming and order of arguments adjusted
;;; to match top-level syntax of ACF microworld)
;;; In Common Lisp ©1993, Desain & Honing
;;; Stripped version by Henkjan Honing

;;; Adapted to the Timing-functions framework (TFF)
;;; by Bas de Haas <bas.dehaas@phil.uu.nl>
;;; 2006



#|(defpackage :gtf
   (:use :cl)
   (:export :delay :force :note :pause :seq :sim 
    :stretch :time-funcall :ramp :oscillator :attach-gtf 
    :output :loop-pattern :attach-gtif :calc-score-end))

(in-package :gtf)
|#

;;; **********************************************************
;;; delayed evaluation utilities

(defmacro delay ((start factor env) &body form)
  "Return a musical object generator"
  `#'(lambda (,start ,factor, env) ,@form))

(defun force (generator start factor env)
  "Return an explicit musical object"
  (funcall generator start factor env))

;;; **********************************************************
;;; basic musical objects

(defun make-event (data end-time)
  "Return event data structure"
  (list data end-time))

(defun note (pitch duration amplitude &optional (gtif nil))
  "Return a musical object generator of a note"
  (delay (start factor env)
    (let ((stretched-duration (* duration factor)))
      (make-event (list
                   (list :start start
                         :duration stretched-duration
                         :performance-start (or gtif start)
                         :performance-end (or gtif (+ start stretched-duration))
                         :pitch pitch
                         :amplitude amplitude
                         :environment env))
                  (+ start stretched-duration)))))

(defun pause (duration)
  "Return a musical object generator of a pause"
  (delay (start factor env)
    (declare (ignore env))
    (make-event nil (+ start (* duration factor)))))

;;; **********************************************************
;;; compound musical objects (time structuring)

(defun seq (&rest elements)
  "Return musical object generator of a sequential object"
  (delay (start factor env)
    (loop for element in elements
          as next-start = start then end
          as (events end) = (force element
                                   next-start factor env)
          append events into result
          finally (return (make-event result end)))))

(defun sim (&rest elements)
  "Return a musical object generator of a parallel object"
  (delay (start factor env)
    (loop for element in elements
        as (events end) = (force element start factor env)
        append events into result
        maximize end into end-time
        finally (return (make-event result end-time)))))

;;; **********************************************************
;;; time transformation

(defun stretch (amount object)
  "Return musical object generator of a stretched object"
  (delay (start factor env)
    (force object start (* amount factor) env)))

;;; **********************************************************
;;; time function utilities (abstraction and application)

(defmacro anonymous-gtf ((start duration time) &body form)
  "Return a generalized time function (GTF)"
  `#'(lambda (,start ,duration ,time) ,@form))

(defun time-funcall (gtf-or-constant start duration time)
  "Return result of applying GTF to its arguments"
  (if (functionp gtf-or-constant) ;functionp returns true if gtf-or-constant is a function
    (funcall gtf-or-constant start duration time)
    gtf-or-constant))

(defun time-fun-compose (operator &rest gtfs)
  "Return a GTF composed of operator applied to GTF's"
  (anonymous-gtf (start duration time)
    (apply operator
           (mapcar #'(lambda (gtf)
                       (time-funcall gtf
                                     start duration time))
                   gtfs))))

(defun time-fun-+ (&rest time-funs)
  "Return added time-functions"
  (apply #'time-fun-compose #'+ time-funs))

(defun global-to-local-gtf (gtf start duration)
  "Return a global GTF that can be referenced locally"
  (anonymous-gtf (local-start local-duration time)
    (declare (ignore local-start local-duration))
    (time-funcall gtf start duration time)))

;;; **********************************************************
;;; time function constructors

(defun ramp (from to)
  "Return a linear interpolating ramp time function"
  (anonymous-gtf (start duration time)
    (let ((progress (/ (- time start) duration)))
      (+ from (* progress (- to from))))))

(defun oscillator (offset frequency depth)
  "Return a sine wave time function"
  (anonymous-gtf (start duration time)
    (declare (ignore duration))
    (+ offset
       (* depth
          (sin (* 2 pi (- time start) frequency))))))

;;; **********************************************************
;;; attaching GTF's to musical objects

(defmacro attach-gtf (gtf start duration)
  "Return a GTF, with its start and duration fixed"
  (let ((local-start (gensym "local-start"))
        (local-duration (gensym "local-duration"))
        (time (gensym "time")))
    `(anonymous-gtf (,local-start ,local-duration ,time)
       (time-funcall
        (global-to-local-gtf ,gtf ,start ,duration)
        ,local-start ,local-duration ,time))))

(defmacro with-attached-gtfs (bindings expression)
  "Make bindings from GTF's to embedded musical object"
  (let ((duration (gensym "duration"))
        (start (gensym "start"))
        (factor (gensym "factor"))
        (env (gensym "environment")))
    `(delay (,start ,factor ,env)
       (let* ((,duration nil)
              ,@(loop for (var fun) in bindings
                      collect (list var
                                    `(attach-gtf ,fun
                                                 ,start
                                                 ,duration))))
         (destructuring-bind (events end)
                             (force ,expression
                                    ,start ,factor ,env)
           (setf ,duration (- end ,start))
           (make-event events end))))))

;;; **********************************************************
;;; attribute transformation constructor

(defun attribute-transform (keyword gtf operator generator)
  "Return musical object generator of a transformed object"
  (delay (start factor env)
    (let ((duration nil))
      (destructuring-bind (events end)
         (force generator
                start
                factor
                (modify-env env
                            keyword
                            (attach-gtf gtf
                                        start
                                        duration)
                            operator))
        (setf duration (- end start))
        (make-event events end)))))

(defun modify-env (env attribute gtf operator)
  "Return a modified environment for attribute"
  (let ((env-fun (getf env attribute)))
    (list* attribute
           (if env-fun
             #'(lambda (val object)
                 (funcall env-fun
                          (time-fun-compose operator
                                            gtf
                                            val)
                          object))
             #'(lambda (val object)
                 (declare (ignore object))
                 (time-fun-compose operator gtf val)))
           env)))

(defun get-event-attribute (event key)
  "Return fully transformed attribute time function"
  (let ((original (getf event key))
        (transform (getf (getf event :environment) key)))
    (if transform
      (funcall transform original event)
      original)))

;;; **********************************************************
;;; attribute transformations

(defun trans (pitch-gtf object)
  "Return a pitch-transformed musical object"
  (attribute-transform :pitch pitch-gtf #'+ object))

(defun loud (amplitude-gtf object)
  "Return an amplitude-transformed musical object"
  (attribute-transform :amplitude amplitude-gtf #'+ object))

;;; **********************************************************
;;; output

(defun output (musical-object)
  "Print musical object"
  (loop for event in (first (force musical-object 0 1 nil))
        do (setf (getf event :pitch)
                 (get-event-attribute  event :pitch))
        do (setf (getf event :amplitude)
                 (get-event-attribute  event :amplitude))
        do (apply #'output-note event)))

(defun output-note (&key start duration pitch amplitude performance-start performance-end environment)
  "Print a note with sampled attributes"
  (declare (ignore environment performance-start performance-end))
  (format t "~%[NOTE ~{~S ~}]"
     (list :start start :duration duration
           :pitch (sample pitch start duration)
           :amplitude (sample amplitude start duration))))

(defun sample (gtf start duration
                   &optional (resolution 1/4))
  "Return list of sampled values or constant"
  (if (functionp gtf)
    (loop for count from 0.0
          to (floor (/ duration resolution))
          as time = (+ start (* count resolution))
          collect (time-funcall gtf start duration time))
    gtf))


;;; **********************************************************
;;; Some helper functions

(defun loop-pattern (number-of-times pattern)
  "returns a GTF representation of a GTF pattern that is looped number-of-times times"
  (loop repeat (1- number-of-times) with result = pattern
        do(setf result (seq pattern result))
        finally (return result)))



;;; **********************************************************
;;; GTF & Timing Functions (GTIF)

;;; TO DO: put a GTIF in the environment

(defmacro attach-gtif (musical-object gtif)
  "returns a musical obect with an gtif attached to it, or repaces an
old gtif with a new one"
  (let ((duration (gensym "duration"))
        (start (gensym "start"))
        (factor (gensym "factor"))
        (env (gensym "environment")))
    `(delay (,start ,factor ,env)
       (let* ((,duration nil)
              (forced-musical-object (force ,musical-object ,start ,factor ,env)))
         (destructuring-bind (events end)
             (loop for event in (first forced-musical-object)
                   do (setf (getf event :performance-start) ,gtif)
                      (setf (getf event :performance-end) ,gtif)
                   finally return forced-musical-object)
           (setf ,duration (- end ,start))
       (make-event events end))))))


(defun calc-score-end (pattern &key (score-start 0))
  "calculates the final score-time from a GTF musical object"
  (let* ((forced-object (loop for event in (first (force pattern score-start 1 nil))
                              collect event))     ;force the pattern, because then the score length can become clear 
         (last-note (first (last forced-object))) ;the pattern's last note
         (start-last-note (getf last-note :start))
         (duration-last-note (getf last-note :duration)))
    (+ start-last-note duration-last-note)))



;;; **********************************************************
;;; examples of use 

#|
;; forces two notes with swing timing with some
;; explanatory notes.
;; **Vraag**: is het handig om met de force functie
;; een eventuele timing functies ook al uit te rekenen.
;; de score tijd is immers bekend? Dit gebeurt nu in 
;; force-MIDI-output.
(force (attach-gtif (seq (note 62 1 127)
                         (note 63 1 127))
                    (swing 0 2 2)) 0 1 1)
=>
(((:START    0 ; note nr. 1
   :DURATION   1
   :PERFORMANCE-START
   (:TIME-SHIFT
    #<Closure 2 subfunction of ANONYMOUS-GTIF>
    :TEMPO-CHANGE
    #<Closure 1 subfunction of ANONYMOUS-GTIF>
    :START-SCORE-TIME 0 ; start score time of the piece, remains zero because 
    :END-SCORE-TIME 2   ; the piece started at score-time 0, same holds for the end-score
    :PERFORMANCE-START-TIME  0
    :PERFORMANCE-END-TIME  2)
   :PERFORMANCE-END
   (:TIME-SHIFT
    #<Closure 2 subfunction of ANONYMOUS-GTIF>
    :TEMPO-CHANGE
    #<Closure 1 subfunction of ANONYMOUS-GTIF>
    :START-SCORE-TIME 0
    :END-SCORE-TIME  2
    :PERFORMANCE-START-TIME  0
    :PERFORMANCE-END-TIME  2)
   :PITCH  62
   :AMPLITUDE  127
   :ENVIRONMENT  1)
  (:START  1 ; note nr. 2
   :DURATION  1
   :PERFORMANCE-START
   (:TIME-SHIFT
    #<Closure 2 subfunction of ANONYMOUS-GTIF>
    :TEMPO-CHANGE
    #<Closure 1 subfunction of ANONYMOUS-GTIF>
    :START-SCORE-TIME  0
    :END-SCORE-TIME  2
    :PERFORMANCE-START-TIME  0
    :PERFORMANCE-END-TIME  2)
   :PERFORMANCE-END  
   (:TIME-SHIFT
    #<Closure 2 subfunction of ANONYMOUS-GTIF>
    :TEMPO-CHANGE
    #<Closure 1 subfunction of ANONYMOUS-GTIF>
    :START-SCORE-TIME 0
    :END-SCORE-TIME  2
    :PERFORMANCE-START-TIME 0
    :PERFORMANCE-END-TIME 2)
   :PITCH  63
   :AMPLITUDE  127
   :ENVIRONMENT 1))
 2) ; final score-time 


;; *** GTF-portmidi.lisp must be loaded ***
;; send two notes with swing timing (classical 1:2 ratio) to portmidi
(send-MIDI-output (attach-gtif (seq (note 62 1 127)
                                    (note 63 1 127))
                               (swing 0 2 2)) :print t)
=> ;; you should here these notes! :-)
[NOTE :PERFORMANCE-START 659952 :PERFORMANCE-END 659953 :DURATION 1 :PITCH 62 :VELOCITY 127 ]
[NOTE :PERFORMANCE-START 659954 :PERFORMANCE-END 659955 :DURATION 1 :PITCH 63 :VELOCITY 127 ]
0 

;; *** requires the Friberg&Sundsrom.lisp file for the swing gtif and TIF.lisp for
;; the use of gtif's ***
;; testing attach-gtif:
(setf *print-pretty* t) ;pretty macro expansion
(macroexpand (attach-gtif (note 62 1 127) (swing 0 2 2)))
=>
#.#'(LAMBDA (#:|start8404| #:|factor8405| #:|environment8406|)
      (LET* ((#:|duration8403| NIL)
             (FORCED-MUSICAL-OBJECT (FORCE (NOTE 62 1 127) #:|start8404| #:|factor8405| #:|environment8406|)))
        (DESTRUCTURING-BIND (EVENTS END)
                            (LOOP FOR EVENT IN (FIRST FORCED-MUSICAL-OBJECT)
                                  DO (SETF (GETF EVENT :PERFORMANCE-START) (SWING 0 2 2))
                                     (SETF (GETF EVENT :PERFORMANCE-END) (SWING 0 2 2))
                                  FINALLY RETURN FORCED-MUSICAL-OBJECT)
          (SETF #:|duration8403| (- END #:|start8404|))
          (MAKE-EVENT EVENTS END)))) 


;; for comparison puposes, attach-gtf is based on the structure of with-attached-gfs:
(macroexpand (with-attached-gtfs ((vibrato (oscillator 62 1 .5)))
                     (seq (note vibrato 1 1)
                          (pause .5)
                          (note vibrato 1.5 1))))
=>
#.#'(LAMBDA (#:|start798| #:|factor799| #:|environment800|)
      (LET* ((#:|duration797| NIL) (VIBRATO (ATTACH-GTF (OSCILLATOR 62 1 0.5) #:|start798| #:|duration797|)))
        (DESTRUCTURING-BIND (EVENTS END)
                            (FORCE (SEQ (NOTE VIBRATO 1 1) (PAUSE 0.5) (NOTE VIBRATO 1.5 1))
                                   #:|start798|
                                   #:|factor799|
                                   #:|environment800|)
          (SETF #:|duration797| (- END #:|start798|))
          (MAKE-EVENT EVENTS END))))

;; simple output:
(output
 (seq (note (ramp 64 62) 1 1)
      (pause .5)
      (note (ramp 64 62) 1.5 1)))
=>
[NOTE :START 0 :DURATION 1
      :PITCH (64.0 63.0 62.0) :AMPLITUDE 1 ]
[NOTE :START 1.5 :DURATION 1.5
      :PITCH (64.0 63.4 62.6 62.0) :AMPLITUDE 1 ]
NIL

;; a note with a vibrato
(output
 (note (oscillator 62 .5 .5) 3 1))
=>
[NOTE :START 0 :DURATION 3 
      :PITCH (62.0 62.5 62.0 61.5 62.0 62.5 62.0) :AMPLITUDE 1 ]
NIL

;; example page 20 figure 15
(output
 (with-attached-gtfs ((vibrato (oscillator 62 1 .5)))
                     (seq (note vibrato 1 1)
                          (pause .5)
                          (note vibrato 1.5 1))))
=>
[NOTE :START 0 :DURATION 1 
      :PITCH (62.0 62.0 62.0) :AMPLITUDE 1 ]
[NOTE :START 1.5 :DURATION 1.5 
      :PITCH (62.0 62.0 62.0 62.0) :AMPLITUDE 1 ]
NIL

;; example page 21 figure 16
(output
 (stretch 2 
          (trans (ramp 1 0) 
                 (note 63 1 1))))
=>
[NOTE :START 0 :DURATION 2 
      :PITCH (64.0 63.75 63.5 63.25 63.0) :AMPLITUDE 1 ]
NIL 

;; composition if a oscillator and a ramp (vibrato and glisando, unplayable but fun)
;; sample resolution (1/4)
(output 
 (note (time-fun-+ (ramp 43 34) (oscillator 0 .5 .5)) 
       1 1))
=>
[NOTE :START 0 :DURATION 1 :PITCH (43.0 41.10355339059328 39.0 36.60355339059328 34.0) :AMPLITUDE 1 ]

;; destructuring-bind testing:
(destructuring-bind ((a) b c) 
    `((1) 2 3))
  (list a c b))
=>nil

(destructuring-bind (a b c)
    '(1 2 3) 
  (print b))
=>2 
|#