;;; -*- Mode:LISP; Package:TF1; Base:10; Readtable:CL -*-
;;;
;;; Interface to the Yamaha TF-1
;;;
;;; -dg 10/20/85
;;;

(defconst *operator-parameter-symbols*
	  (list :egr-1
		:egr-2
		:egr-3
		:egr-4
		:egl-1
		:egl-2
		:egl-3
		:egl-4
		:kls-break-point
		:kls-left-depth
		:kls-right-depth
		:kls-left-curve
		:kls-right-curve
		:keyboard-rate-scaling
		:am-sensitivity
		:key-velocity-sensitivity
		:operator-output-level
		:oscillator-mode
		:oscillator-frequency-coarse
		:oscillator-frequency-fine
		:oscillator-detune))

(defconst *voice-parameter-symbols*
	  (list :peg-rate-1
		:peg-rate-2
		:peg-rate-3
		:peg-rate-4
		:peg-level-1
		:peg-level-2
		:peg-level-3
		:peg-level-4
		:algorithm-select
		:feedback
		:oscillator-key-sync
		:lfo-speed
		:lfo-delay
		:lfo-pitch-modulation-depth
		:lfo-amplitude-modulation-depth
		:lfo-key-sync
		:lfo-wave
		:lfo-pitch-modulation-sensitivity
		:transpose
		:name-1
		:name-2
		:name-3
		:name-4
		:name-5
		:name-6
		:name-7
		:name-8
		:name-9
		:name-10
		:operator-switch
		:operator-select
		))

(defmacro define-parameter-properties (parameter &body properties)
  (let ((symbol '#:symbol))
    `(progn
       (let ((,symbol (intern (string-upcase ',parameter) 'tf1)))
	 (setplist ,symbol ',properties)))))

(define-parameter-properties :egr-1
  :type (integer 0 99)
  :documentation "Envelope Generator Rate 1")

(define-parameter-properties :egr-2
  :type (integer 0 99)
  :documentation "Envelope Generator Rate 2")

(define-parameter-properties :egr-3
  :type (integer 0 99)
  :documentation "Envelope Generator Rate 3")

(define-parameter-properties :egr-4
  :type (integer 0 99)
  :documentation "Envelope Generator Rate 4")

(define-parameter-properties :egl-1
  :type (integer 0 99)
  :documentation "Envelope Generator Level 1")

(define-parameter-properties :egl-2
  :type (integer 0 99)
  :documentation "Envelope Generator Level 2")

(define-parameter-properties :egl-3
  :type (integer 0 99)
  :documentation "Envelope Generator Level 3")

(define-parameter-properties :egl-4
  :type (integer 0 99)
  :documentation "Envelope Generator Level 4")

(define-parameter-properties :kls-break-point
  :type (integer 0 99)
  :documentation "Keybload Level Scaling Break Point" )

(define-parameter-properties :kls-left-depth
  :type (integer 0 99)
  :documentation "Keyboard Level Scaling Left Depth")

(define-parameter-properties :kls-right-depth
  :type (integer 0 99)
  :documentation "Keyboard Level Scaling Right Depth")

(define-parameter-properties :kls-left-curve
  :type (integer 0 3)
  :documentation "Keybaord Level Scaling Left Curve"
  :value-map ((0 . :-lin)
	      (1 . :-exp)
	      (2 . :+exp)
	      (3 . :+lin)))

(define-parameter-properties :kls-right-curve
  :type (integer 0 3)
  :documentation "Keyboard Level Scaling Right Curve"
  :value-map ((0 . :-lin)
	      (1 . :-exp)
	      (2 . :+exp)
	      (3 . :+lin)))

(define-parameter-properties :keyboard-rate-scaling
  :type (integer 0 7)
  :documentation "Keyboard Rate Scaling")

(define-parameter-properties :am-sensitivity
  :type (integer 0 3)
  :documentation "Amplitude Modulation Sensitivity")

(define-parameter-properties :key-velocity-sensitivity
  :type (integer 0 7)
  :documentation "Key Velocity Sensitivity")

(define-parameter-properties :operator-output-level
  :type (integer 0 99)
  :documentation "Operator Output Level")

(define-parameter-properties :oscillator-mode
  :type (integer 0 1)
  :documentation "Oscillator Mode"
  :value-map ((0 . :frequency-ratio)
	      (1 . :fixed-frequency)))

(define-parameter-properties :oscillator-frequency-coarse
  :type (integer 0 31)
  :documentation "Oscillator Frequency Coarse")

(define-parameter-properties :oscillator-frequency-fine
  :type (integer 0 99)
  :documentation "Oscillator Frequency Fine")

(define-parameter-properties :oscillator-detune
  :type (integer 0 14)
  :documentation "Oscillator Detune")

;;; Other stuff

(define-parameter-properties :peg-rate-1
  :type (integer 0 99)
  :documentation "Pitch Envelope Generator Rate 1")

(define-parameter-properties :peg-rate-2
  :type (integer 0 99)
  :documentation "Pitch Envelope Generator Rate 2")

(define-parameter-properties :peg-rate-3
  :type (integer 0 99)
  :documentation "Pitch Envelope Generator Rate 3")

(define-parameter-properties :peg-rate-4
  :type (integer 0 99)
  :documentation "Pitch Envelope Generator Rate 4")

(define-parameter-properties :peg-level-1
  :type (integer 0 99)
  :documentation "Pitch Envelope Generator Level 1")

(define-parameter-properties :peg-level-2
  :type (integer 0 99)
  :documentation "Pitch Envelope Generator Level 2")

(define-parameter-properties :peg-level-3
  :type (integer 0 99)
  :documentation "Pitch Envelope Generator Level 3")

(define-parameter-properties :peg-level-4
  :type (integer 0 99)
  :documentation "Pitch Envelope Generator Level 4")

(define-parameter-properties :algorithm-select
  :type (integer 0 31)
  :documentation "Algorithm select")

(define-parameter-properties :feedback
  :type (integer 0 7)
  :documentation "Feedback")

(define-parameter-properties :oscillator-key-sync
  :type (integer 0 1)
  :documentation "Oscillator Key Sync")

(define-parameter-properties :lfo-speed
  :type (integer 0 99)
  :documentation "Low Frequency Oscillator Speed")

(define-parameter-properties :lfo-delay
  :type (integer 0 99)
  :documentation "Low Frequency Oscillator Delay")

(define-parameter-properties :lfo-pitch-modulation-depth
  :type (integer 0 99)
  :documentation "Low Frequency Oscillator Pitch Modulation Depth")

(define-parameter-properties :lfo-amplitude-modulation-depth
  :type (integer 0 99)
  :documentation "Low Frequency Oscillator Amplitude Modulation Depth")

(define-parameter-properties :lfo-key-sync
  :type (integer 0 1)
  :documentation "Low Frequency Oscillator Key Sync")

(define-parameter-properties :lfo-wave
  :type (integer 0 5)
  :documentation "Low Frequency Oscillator Wave")

(define-parameter-properties :lfo-pitch-modulation-sensitivity
  :type (integer 0 7)
  :documentation "Low Frequency Oscillator Pitch Modulation Sensitivity")

(define-parameter-properties :transpose
  :type (integer 0 48)
  :documentation "Transpose")

(define-parameter-properties :name-1
  :type :ascii
  :documentation "Voice Name 1")

(define-parameter-properties :name-2
  :type :ascii
  :documentation "Voice Name 2")

(define-parameter-properties :name-3
  :type :ascii
  :documentation "Voice Name 3")

(define-parameter-properties :name-4
  :type :ascii
  :documentation "Voice Name 4")

(define-parameter-properties :name-5
  :type :ascii
  :documentation "Voice Name 5")

(define-parameter-properties :name-6
  :type :ascii
  :documentation "Voice Name 6")

(define-parameter-properties :name-7
  :type :ascii
  :documentation "Voice Name 7")

(define-parameter-properties :name-8
  :type :ascii
  :documentation "Voice Name 8")

(define-parameter-properties :name-9
  :type :ascii
  :documentation "Voice Name 9")

(define-parameter-properties :name-10
  :type :ascii
  :documentation "Voice Name 10")

(define-parameter-properties :operator-switch
  :type (integer)
  :documentation "Operator On/Off Switch")

(define-parameter-properties :operator-select
  :type (integer 0 5)
  :documentation "Operator Select")

(eval-when (eval load)
  (setq *voice-parameter-symbols* (reverse *voice-parameter-symbols*)
	*operator-parameter-symbols* (reverse *operator-parameter-symbols*)))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Data Structures
;;;

(defun print-structure (object stream ignore)
  (format stream "#<~A ~D>" (type-of object) (%pointer object)))

(defstruct (operator-parameter-data
	     (:subtype art-8b)
	     (:constructor nil)
	     (:conc-name "OP-")
  	     (:print-function print-structure))
  egr-1
  egr-2
  egr-3
  egr-4
  egl-1
  egl-2
  egl-3
  egl-4
  kls-break-point
  kls-left-depth
  kls-right-depth
  ((kls-left-curve (byte 2 0))
   (kls-right-curve (byte 2 2)))
  ((keyboard-rate-scaling (byte 3 0))
   (oscillator-detune (byte 4 3)))
  ((am-sensitivity (byte 2 0))
   (key-velocity-sensitivity (byte 3 2)))
  operator-output-level
  ((oscillator-mode (byte 1 0))
   (oscillator-frequency-coarse (byte 5 1)))
  oscillator-frequency-fine)


(defstruct (voice-parameter-data
	     (:subtype art-8b)
	     (:constructor nil)
	     (:conc-name "VOICE-")
	     (:print-function print-structure))
  peg-rate-1
  peg-rate-2
  peg-rate-3
  peg-rate-4
  peg-level-1
  peg-level-2
  peg-level-3
  peg-level-4
  ((algorithm-select (byte 5 0)))
  ((feedback (byte 3 0))
   (oscillator-key-sync (byte 1 3)))
  lfo-speed
  lfo-delay
  lfo-pitch-modulation-depth
  lfo-amplitude-modulation-depth
  ((lfo-key-sync (byte 1 0))
   (lfo-wave (byte 3 1))
   (lfo-pitch-modulation-sensitivity (byte 3 4)))
  transpose
  name-1
  name-2
  name-3
  name-4
  name-5
  name-6
  name-7
  name-8
  name-9
  name-10)

(defflavor voice-object (op1
			 op2
			 op3
			 op4
			 op5
			 op6
			 voice
			 raw-array)
	   ()
  :gettable-instance-variables
  :inittable-instance-variables
  (:required-init-keywords :op1 :op2 :op3 :op4 :op5 :op6 :voice :raw-array))

(defun make-voice-parameter-object (&optional array offset)
  (when array
    (check-type array array)
    (check-type offset (integer 0)))
  (let* ((whole-array (if array
			  (make-array 128 :type 'art-8b
				      :displaced-to array
				      :displaced-index-offset offset)
			(make-array 128
				    :type 'art-8b)))
	 (op1 (make-array 17 :type 'art-8b
			  :displaced-to whole-array
			  :named-structure-symbol 'operator-parameter-data))
	 (op2 (make-array 17 :type 'art-8b
			  :displaced-to whole-array
			  :displaced-index-offset 17
			  :named-structure-symbol 'operator-parameter-data))
	 (op3 (make-array 17 :type 'art-8b
			  :displaced-to whole-array
			  :displaced-index-offset (* 17 2)
			  :named-structure-symbol 'operator-parameter-data))
	 (op4 (make-array 17 :type 'art-8b
			  :displaced-to whole-array
			  :displaced-index-offset (* 17 3)
			  :named-structure-symbol 'operator-parameter-data))
	 (op5 (make-array 17 :type 'art-8b
			  :displaced-to whole-array
			  :displaced-index-offset (* 17 4)
			  :named-structure-symbol 'operator-parameter-data))
	 (op6 (make-array 17 :type 'art-8b
			  :displaced-to whole-array
			  :displaced-index-offset (* 17 5)
			  :named-structure-symbol 'operator-parameter-data))
	 (voice (make-array 26 :type 'art-8b
			    :displaced-to whole-array
			    :displaced-index-offset (* 17 6)
			    :named-structure-symbol 'voice-parameter-data)))
    (make-instance 'voice-object
		   :op1 op1
		   :op2 op2
		   :op3 op3
		   :op4 op4
		   :op5 op5
		   :op6 op6
		   :voice voice
		   :raw-array whole-array)))

(defun make-32-voice-list (&optional array)
  (when array
    (check-arg array (eq (array-type array) 'art-1b) "an 'ART-8B array"))
  (let ((big-array (or array (make-array (* 32 128) :type 'art-8b)))
	voice-list)
    (dotimes (count 32 (cons big-array (reverse voice-list)))
      (push (make-voice-parameter-object big-array (* count 128)) voice-list))))