scales.lisp

;;;; scales.lisp - "music theory" functionality; notes, tunings, scales, chords, and the relevant classes/functions to generate and query each.

;;; NOTES:
;; - 'key' is a scale including the root note. i.e. "g major" or the like.
;; - http://harmoniccycle.com/hc/music-08-chord-calc.htm
;; - https://www.reddit.com/r/musictheory/comments/8kycvx/online_music_theory_calculator/
;; - https://www.reddit.com/r/musictheory/comments/17v5pp/does_anyone_know_of_a_keyscale_calculator_that/
;; - http://harmoniccycle.com/hc/music-08-chord-calc.htm
;; - http://openmusictheory.com/scales.html
;; - https://atactionpark.github.io/
;; - https://www.solfej.io/chords/c-major - scale and chord finder site

;;; FIX: only signal `redefining-melodic-alias' when the new definition actually differs from the existing

(in-package #:cl-patterns)

(define-condition redefining-melodic-alias (warning)
  ((alias :initarg :alias :reader redefining-melodic-alias-alias)
   (existing-definition :initarg :existing-definition :reader redefining-melodic-alias-existing-definition)
   (new-definition :initarg :new-definition :reader redefining-melodic-alias-new-definition))
  (:report (lambda (condition stream)
             (format stream "Redefining alias ~S (for ~S) to point to ~S" (redefining-melodic-alias-alias condition) (redefining-melodic-alias-existing-definition condition) (redefining-melodic-alias-new-definition condition))))
  (:documentation "Condition for when changing an alias for a `tuning', `scale', or `chord'."))

(defun redefining-melodic-alias (alias existing new)
  "Signal a warning when changing an alias for a `tuning', `scale', or `chord'."
  (warn 'redefining-melodic-alias :alias alias
                                  :existing-definition existing
                                  :new-definition new))

;;; utilities

(defparameter *abbreviations*
  (list (list "MAJOR" "MAJ")
        (list "MINOR" "MIN")
        (list "AUGMENTED" "AUG")
        (list "DOMINANT" "DOM")
        (list "DIMINISHED" "DIM")
        (list "SUSPENDED" "SUS")
        (list "TRIAD" "TRI")
        (list "OTONALITY" "O")
        (list "UTONALITY" "U")
        (list "PENTATONIC" "PENT")
        (list "HARMONIC" "HARM"))
  "List of abbreviations that should be used by `generate-aliases' to auto-generate aliases for `tuning's, `scale's, `chord's, etc.")

(defun generate-aliases (name)
  "Generate a list of aliases for NAME by mapping various combinations of `*abbreviations*'.

See also: `*abbreviations*'"
  (when (symbolp name)
    (return-from generate-aliases
      (generate-aliases (symbol-name name))))
  (remove-duplicates
   (mapcar #'friendly-symbol
           (let* (res
                  (name (string-upcase name))
                  (abbrs-found (remove-if-not
                                (lambda (a)
                                  (search (car a) name))
                                *abbreviations*)))
             (dotimes (n (1+ (length abbrs-found)) res)
               (map-combinations
                (lambda (combination)
                  (let ((cur-name name))
                    (dolist (c combination)
                      (setf cur-name (string-replace cur-name (car c) (cadr c))))
                    (push cur-name res)
                    (push (remove #\space cur-name) res)))
                abbrs-found
                :length n))))))

;;; notes

(defun sharp-or-flat (string)
  "Given STRING, return a number representing how many semitones above or below its number it represents, by counting sharps (#) and flats (b).

Example:

;; (sharp-or-flat \"#\") ;=> 1
;; (sharp-or-flat \"##\") ;=> 2
;; (sharp-or-flat \"b\") ;=> -1

See also: `note-name-and-octave', `index-and-offset'"
  (+ (* -1 (count #\b string :test #'string-equal))
     (count #\# string :test #'string-equal)))

(defun index-and-offset (num)
  "Get a cons cell consisting of the input number and the offset its sharps/flats represent."
  (etypecase num
    (number (cons num 0))
    (symbol (index-and-offset (string num)))
    (string (cons (parse-integer num :junk-allowed t)
                  (sharp-or-flat num)))))

;;; additional music theory functions

(defun tone-matrix (tones &optional transformation)
  "Generate a tone matrix from TONES. Supports symbols t and e for 10 and 11, respectively, but only returns numbers. TRANSFORMATION can be :inversion, :retrograde, or :retrograde-inversion (or a 3-letter abbreviation of any of the above)."
  (let* ((tones (mapcar (lambda (elem)
                          (etypecase elem
                            (integer elem)
                            (symbol (cond ((string= t elem)
                                           10)
                                          ((string= :e elem)
                                           11)))))
                        tones))
         (length (length tones))
         (diffs (loop :repeat (1- length)
                      :for (one two) :on tones
                      :collect (- one two))))
    (labels ((row-head (row-number last-row)
               (mod (+ (first last-row)
                       (nth row-number diffs))
                    length))
             (generate-row (row-number last-row)
               (when (nth row-number diffs)
                 (let* ((num (row-head row-number last-row))
                        (row (cons num (loop :for diff :in diffs
                                             :do (setf num (mod (- num diff) length))
                                             :collect num))))
                   (cons row (generate-row (1+ row-number) row))))))
      (let ((res (cons tones (generate-row 0 tones))))
        (case (make-keyword transformation)
          ((:nil :prime :pri)
           res)
          ((:inversion :inv)
           (flop res))
          ((:retrograde :ret)
           (mapcar #'reverse res))
          ((:retrograde-inversion :ret-inv :inv-ret :rin :rei :retinv :invret)
           (flop (mapcar #'reverse res))))))))

;;; tunings

(defgeneric tuning-name (tuning)
  (:documentation "The full name of the tuning."))

(defgeneric tuning-pitches (tuning)
  (:documentation "The actual semitone values of the tuning."))

(defgeneric tuning-steps-per-octave (tuning)
  (:documentation "The number of pitches per octave in the tuning."))

(defgeneric tuning-octave-ratio (tuning)
  (:documentation "The octave ratio of the tuning (i.e. what to multiply a pitch by to increase its octave by 1)."))

(defclass tuning (standard-object #+#.(cl:if (cl:find-package "SEQUENCE") '(:and) '(:or)) sequence)
  ((name :initarg :name :accessor tuning-name :documentation "The full name of the tuning.")
   (pitches :initarg :pitches :accessor tuning-pitches :documentation "The actual semitone values of the tuning.")
   (octave-ratio :initarg :octave-ratio :accessor tuning-octave-ratio :documentation "The octave ratio of the tuning (i.e. what to multiply a pitch by to increase its octave by 1)."))
  (:documentation "Tuning definition."))

(defmethod print-object ((tuning tuning) stream)
  (format stream "(~S ~S)" 'tuning (tuning-name tuning)))

(defvar *tunings* (make-hash-table)
  "Hash table mapping names and aliases to tuning definition objects.")

(defun define-tuning (name pitches octave-ratio &optional aliases)
  "Define a musical tuning.

See also: `tuning', `define-scale', `define-chord'"
  (let ((key (friendly-symbol name))
        (tuning (make-instance 'tuning :name name
                                       :pitches pitches
                                       :octave-ratio octave-ratio)))
    (setf (gethash key *tunings*) tuning)
    (dolist (alias (remove-duplicates (append (generate-aliases key) aliases)))
      (if-let ((existing (gethash alias *tunings*)))
        (if (symbolp existing)
            (progn
              (redefining-melodic-alias alias existing tuning)
              (setf (gethash alias *tunings*) key))
            (unless (eq existing tuning)
              (warn "Ignoring alias ~S that points to ~S (while trying to add it as an alias for ~S)." alias existing tuning)))
        (setf (gethash alias *tunings*) key)))))

(defun all-tunings ()
  "Get a list of all defined tunings."
  (remove-if-not (lambda (value)
                   (typep value 'tuning))
                 (hash-table-values *tunings*)))

(defgeneric tuning (object)
  (:documentation "Get a tuning by name."))

(defmethod tuning ((symbol symbol))
  (when-let ((tuning (gethash symbol *tunings*)))
    (if (symbolp tuning)
        (tuning tuning)
        tuning)))

(defmethod tuning ((string string))
  (tuning (friendly-symbol string)))

(defmethod tuning ((tuning tuning))
  tuning)

(defmethod tuning-name ((symbol symbol))
  (when symbol
    (tuning-name (tuning symbol))))

(defmethod tuning-pitches ((symbol symbol))
  (when symbol
    (tuning-pitches (tuning symbol))))

(defmethod tuning-steps-per-octave ((tuning tuning))
  (length (tuning-pitches tuning)))

(defmethod tuning-steps-per-octave ((symbol symbol))
  (when symbol
    (tuning-steps-per-octave (tuning symbol))))

(defmethod tuning-octave-ratio ((symbol symbol))
  (when symbol
    (tuning-octave-ratio (tuning symbol))))

;;; Scala (.scl) scale file support
;; http://www.huygens-fokker.org/scala/scl_format.html

(defun load-scala-scale (file &optional aliases)
  "Load a Scala (.scl) scale file and define a tuning and scale from it.

Note that Scala refers to these as \"scales\" but in cl-patterns they are known as tunings."
  (with-open-file (stream file :direction :input :if-does-not-exist :error)
    (let* ((lines (loop :for line = (read-line stream nil 'eof)
                        :if (eql line 'eof)
                          :do (loop-finish)
                        :unless (char= #\! (elt line 0))
                          :collect (string-left-trim '(#\space) line)))
           (name (car lines))
           (count (parse-integer (cadr lines)))
           (pitches (append (list 0)
                            (mapcar (lambda (line)
                                      (let ((line (subseq line
                                                          (position-if (lambda (char) (char/= #\space char)) line)
                                                          (position #\space line :test #'char=))))
                                        (if (position #\. line :test #'char=) ; if it has a . it's a cents value
                                            (/ (read-from-string line) 100) ; cents
                                            (ratio-midi (read-from-string line)))))
                                    (cddr lines))))
           (octave-ratio (car (last pitches)))
           (pitches (butlast pitches))
           (aliases (append (list (file-namestring (subseq file 0 (search ".scl" file :from-end t)))) aliases)))
      (when (/= (length pitches) count)
        (warn "There are ~A pitches listed in ~A but the file says there should be ~A pitches." (length pitches) file count))
      (unless (loop :for i :in (all-tunings)
                    :if (equal (tuning-pitches i) pitches)
                      :return (progn
                                ;; (warn "~&Tuning already exists as ~A; adding aliases: ~A" (tuning-name i) aliases)
                                ;; (apply #'define-tuning-aliases (tuning-name i) aliases)
                                ;; FIX: should we just remove the already-defined tuning and re-add with all the aliases, or was there a reason we were doing define-tuning-aliases separately?
                                ;; FIX: define scale aliases too
                                t))
        (define-tuning name pitches octave-ratio aliases)
        (define-scale name (iota (length pitches)) name aliases)))))

;;; scales

(defgeneric scale-name (scale)
  (:documentation "The full name of the scale."))

(defgeneric scale-notes (scale)
  (:documentation "The degrees of the scale."))

(defgeneric scale-tuning (scale)
  (:documentation "The scale's `tuning'."))

(defgeneric scale-steps-per-octave (scale)
  (:documentation "The number of pitches per octave in the scale's `tuning'."))

(defclass scale (standard-object #+#.(cl:if (cl:find-package "SEQUENCE") '(:and) '(:or)) sequence)
  ((name :initarg :name :accessor scale-name :documentation "The full name of the scale.")
   (notes :initarg :notes :accessor scale-notes :documentation "The notes of the scale.")
   (tuning :initarg :tuning :writer (setf scale-tuning) :documentation "The scale's `tuning'."))
  (:documentation "Scale definition."))

(defmethod print-object ((scale scale) stream)
  (format stream "(~S ~S)" 'scale (scale-name scale)))

(defvar *scales* (make-hash-table)
  "Hash table mapping names and aliases to scale definition objects.")

(defun define-scale (name notes &optional (tuning :et12) aliases)
  "Define a musical scale.

See also: `scale', `define-tuning', `define-chord'"
  (let ((key (friendly-symbol name))
        (scale (make-instance 'scale :name name
                                     :notes notes
                                     :tuning tuning)))
    (unless (tuning tuning)
      (warn "Tuning ~S does not exist." tuning))
    (setf (gethash key *scales*) scale)
    (dolist (alias (remove-duplicates (append (generate-aliases key) aliases)))
      (if-let ((existing (gethash alias *scales*)))
        (if (symbolp existing)
            (progn
              (redefining-melodic-alias alias existing scale)
              (setf (gethash alias *scales*) key))
            (unless (eq existing scale)
              (warn "Ignoring alias ~S that points to ~S (while trying to add it as an alias for ~S)." alias existing scale)))
        (setf (gethash alias *scales*) key)))))

(defun all-scales ()
  "Get a list of all defined scales."
  (remove-if-not (lambda (value)
                   (typep value 'scale))
                 (hash-table-values *scales*)))

(defgeneric scale (object)
  (:documentation "Get either a musical scale object by its name, or get the name of the scale of an event."))

(defmethod scale ((symbol symbol))
  (when-let ((scale (gethash symbol *scales*)))
    (if (symbolp scale)
        (scale scale)
        scale)))

(defmethod scale ((string string))
  (scale (friendly-symbol string)))

(defmethod scale ((scale scale))
  scale)

(defmethod scale-name ((symbol symbol))
  (when symbol
    (scale-name (scale symbol))))

(defmethod scale-notes ((symbol symbol))
  (when symbol
    (scale-notes (scale symbol))))

(defmethod scale-tuning ((scale scale))
  (tuning (slot-value scale 'tuning)))

(defmethod scale-tuning ((symbol symbol))
  (when symbol
    (scale-tuning (scale symbol))))

(defmethod scale-steps-per-octave ((scale scale))
  (tuning-steps-per-octave (slot-value scale 'tuning)))

(defmethod scale-steps-per-octave ((symbol symbol))
  (when symbol
    (scale-steps-per-octave (scale symbol))))

(defun scale-midinotes (scale &key (root :c) (octave 4))
  "Given a scale, return its midi note numbers. OCTAVE can be a number, a 2-element list denoting an octave range, or :all, for the full octave range (0-9)."
  (check-type octave (or number list (eql :all)))
  (when (eql octave :all)
    (return-from scale-midinotes (scale-midinotes scale :root root :octave (list 0 9))))
  (etypecase octave
    (integer
     (let ((scale-notes (scale-notes scale))
           (root-note-number (note-chromatic-index root)))
       (mapcar (lambda (note)
                 (+ note root-note-number (* octave 12)))
               scale-notes)))
    (cons
     (loop :for octave :from (first octave) :upto (second octave)
           :append (scale-midinotes scale :root root :octave octave)))))

;;; chords

(defgeneric chord-name (chord)
  (:documentation "The octave ratio of the chord (i.e. what to multiply a pitch by to increase its octave by 1)."))

(defgeneric chord-indexes (chord)
  (:documentation "The indexes of the notes from the scale that the chord is made up of."))

(defgeneric chord-scale (chord)
  (:documentation "The scale that the chord is derived from."))

(defclass chord (standard-object #+#.(cl:if (cl:find-package "SEQUENCE") '(:and) '(:or)) sequence)
  ((name :initarg :name :accessor chord-name :documentation "The full name of the chord.")
   (indexes :initarg :indexes :accessor chord-indexes :documentation "The indexes of the notes from the scale that the chord is made up of.")
   (scale :initarg :scale :accessor chord-scale :documentation "The scale that the chord is derived from."))
  (:documentation "Chord definition."))

(defmethod print-object ((chord chord) stream)
  (format stream "(~S ~S)" 'chord (chord-name chord)))

(defvar *chords* (make-hash-table)
  "Hash table mapping names and aliases to chord definition objects.")

(defun define-chord (name indexes scale &optional aliases)
  "Define a musical chord.

See also: `scale', `define-tuning', `define-scale'"
  (let ((key (friendly-symbol name))
        (chord (make-instance 'chord :name name
                                     :scale scale
                                     :indexes indexes)))
    (unless (scale scale)
      (warn "Scale ~S does not exist." scale))
    (setf (gethash key *chords*) chord)
    (dolist (alias (remove-duplicates (append (generate-aliases key) aliases)))
      (if-let ((existing (gethash alias *chords*)))
        (if (symbolp existing)
            (progn
              (redefining-melodic-alias alias existing chord)
              (setf (gethash alias *chords*) key))
            (unless (eq existing chord)
              (warn "Ignoring alias ~S that points to ~S (while trying to add it as an alias for ~S)." alias existing chord)))
        (setf (gethash alias *chords*) key)))))

(defun all-chords ()
  "Get a list of all defined chords."
  (remove-if-not (lambda (value)
                   (typep value 'chord))
                 (hash-table-values *chords*)))

(defgeneric chord (object)
  (:documentation "Get a chord by name."))

(defmethod chord ((list list))
  ;; FIX: allow for stuff like '(:c :major) etc
  )

(defmethod chord ((symbol symbol))
  (when-let ((chord (gethash symbol *chords*)))
    (if (symbolp chord)
        (chord chord)
        chord)))

(defmethod chord ((string string))
  (chord (friendly-symbol string)))

(defmethod chord ((chord chord))
  chord)

(defmethod chord-name ((symbol symbol))
  (when symbol
    (chord-name (chord symbol))))

(defmethod chord-scale ((symbol symbol))
  (when symbol
    (chord-scale (chord symbol))))

(defmethod chord-indexes ((symbol symbol))
  (when symbol
    (chord-indexes (chord symbol))))

(defmethod describe-object ((chord chord) stream)
  (with-slots (name scale) chord
    (format stream "~&~S is a chord named ~A,~%with possible abbreviations ~A.~%It takes notes from the ~A scale, which has notes ~S.~%Therefore, this chord contains the notes ~S,~%which are also known as ~A.~%"
            chord
            name
            (loop :for i :in (keys *chords*)
                  :if (eql (getf *chords* i) (friendly-symbol (chord-name chord)))
                    :collect i)
            scale
            (scale-notes (scale scale))
            (chord-notes chord)
            (mapcar #'chromatic-index-note (chord-notes chord)))))

(defun chord-notes (chord)
  "Return a list consisting of the note numbers for CHORD."
  (mapcar (lambda (idx)
            (let ((io (index-and-offset idx)))
              (+ (nth (car io) (scale-notes (scale (chord-scale chord))))
                 (cdr io))))
          (chord-indexes chord)))

(defun chord-midinotes (chord &optional (root 0) (octave 5))
  "Get a list of the midi note numbers in the specified chord."
  (mapcar #'+
          (circular-list (note-midinote root :octave octave))
          (chord-notes (chord chord))))

;;; base set of tunings and scales (copied from SuperCollider)

(dolist (tuning
         (flet ((mul-iota (mul num)
                  (mapcar (lambda (n)
                            (* n mul))
                          (iota num))))
           `(;; twelve-tone tunings
             ("Equal Temperament 12" ,(iota 12) 2 (:et12))

             ("Pythagorean" (t 1 256/243 9/8 32/27 81/64 4/3 729/512 3/2 128/81 27/16 16/9 243/128) 2 (:pyth))
             ("5-Limit Just Intonation" (t 1 16/15 9/8 6/5 5/4 4/3 45/32 3/2 8/5 5/3 9/5 15/8) 2 (:just))
             ("Septimal Tritone Just Intonation" (t 1 16/15 9/8 6/5 5/4 4/3 7/5 3/2 8/5 5/3 9/5 15/8) 2 (:sept1))
             ("7-Limit Just Intonation" (t 1 16/15 9/8 6/5 5/4 4/3 7/5 3/2 8/5 5/3 7/4 15/8) 2 (:sept2))
             ("Meantone, 1/4 Syntonic Comma" (0 0.755 1.93 3.105 3.86 5.035 5.79 6.965 7.72 8.895 10.07 10.82) 2 (:mean4))
             ("Meantone, 1/5 Pythagorean Comma" (0 0.804 1.944 3.084 3.888 5.028 5.832 6.972 7.776 8.916 10.056 10.86) 2 (:mean5))
             ("Meantone, 1/6 Pythagorean Comma" (0 0.86 1.96 3.06 3.92 5.02 5.88 6.98 7.84 8.94 10.04 10.9) 2 (:mean6))
             ("Kirnberger III" (t 1 256/243 ,(/ (sqrt 5) 2) 32/27 5/4 4/3 45/32 ,(expt 5 0.25) 128/81 ,(/ (expt 5 0.75) 2) 16/9 15/8) 2 (:kirnberger))
             ("Werckmeister III" (0 0.92 1.93 2.94 3.915 4.98 5.9 6.965 7.93 8.895 9.96 10.935) 2 (:werckmeister))
             ("Vallotti" (0 0.94135 1.9609 2.98045 3.92180 5.01955 5.9218 6.98045 7.9609 8.94135 10 10.90225) 2)
             ("Young" (0 0.9 1.96 2.94 3.92 4.98 5.88 6.98 7.92 8.94 9.96 10.9) 2)
             ("Mayumi Reinhard" (t 1 14/13 13/12 16/13 13/10 18/13 13/9 20/13 13/8 22/13 13/7 208/105) 2 (:reinhard))
             ("Wendy Carlos Harmonic" (t 1 17/16 9/8 19/16 5/4 21/16 11/8 3/2 13/8 27/16 7/4 15/8) 2 (:wcHarm))
             ("Wendy Carlos Super Just" (t 1 17/16 9/8 6/5 5/4 4/3 11/8 3/2 13/8 5/3 7/4 15/8) 2 (:wcSJ))
             ("Chinese Shi-er-lu scale" (t 1 2187/2048 9/8 19683/16384 81/64 177147/131072 729/612 3/2 6561/4096 27/16 59049/32768 243/128) 2 (:lu))

             ;; more than twelve-tone equal temperament
             ("Equal Temperament 19" ,(mul-iota 12/19 19) 2 (:et19))
             ("Equal Temperament 22" ,(mul-iota 6/11 22) 2 (:et22))
             ("Equal Temperament 24" ,(mul-iota 1/2 24) 2 (:et24))
             ("Equal Temperament 31" ,(mul-iota 12/31 31) 2 (:et31))
             ("Equal Temperament 41" ,(mul-iota 12/41 41) 2 (:et41))
             ("Equal Temperament 53" ,(mul-iota 12/53 53) 2 (:et53))

             ;; non-twelve-tone just intonation
             ("Ben Johnston" (t 1 25/24 135/128 16/15 10/9 9/8 75/64 6/5 5/4 81/64 32/25 4/3 27/20 45/32 36/25 3/2 25/16 8/5 5/3 27/16 225/128 16/9 9/5 15/8 48/25) 2 (:johnston))
             ("Harry Partch" (t 1 81/80 33/32 21/20 16/15 12/11 11/10 10/9 9/8 8/7 7/6 32/27 6/5 11/9 5/4 14/11 9/7 21/16 4/3 27/20 11/8 7/5 10/7 16/11 40/27 3/2 32/21 14/9 11/7 8/5 18/11 5/3 27/16 12/7 7/4 16/9 9/5 20/11 11/6 15/8 40/21 64/33 160/81) 2 (:partch))
             ("Jon Catler" (t 1 33/32 16/15 9/8 8/7 7/6 6/5 128/105 16/13 5/4 21/16 4/3 11/8 45/32 16/11 3/2 8/5 13/8 5/3 27/16 7/4 16/9 24/13 15/8) 2 (:catler))
             ("John Chalmers" (t 1 21/20 16/15 9/8 7/6 6/5 5/4 21/16 4/3 7/5 35/24 3/2 63/40 8/5 5/3 7/4 9/5 28/15 63/32) 2 (:chalmers))
             ("Lou Harrison" (t 1 16/15 10/9 8/7 7/6 6/5 5/4 4/3 17/12 3/2 8/5 5/3 12/7 7/4 9/5 15/8) 2 (:harrison))
             ("Sruti" (t 1 256/243 16/15 10/9 9/8 32/27 6/5 5/4 81/64 4/3 27/20 45/32 729/512 3/2 128/81 8/5 5/3 27/16 16/9 9/5 15/8 243/128) 2 (:sruti))
             ("Wilfrid Perret" (t 1 21/20 35/32 9/8 7/6 6/5 5/4 21/16 4/3 7/5 35/24 3/2 63/40 8/5 5/3 7/4 9/5 15/8 63/32) 2 (:perret))
             ("Michael Harrison 24 tone 7-limit" (t 1 28/27 135/128 16/15 243/224 9/8 8/7 7/6 32/27 6/5 135/112 5/4 81/64 9/7 21/16 4/3 112/81 45/32 64/45 81/56 3/2 32/21 14/9 128/81 8/5 224/135 5/3 27/16 12/7 7/4 16/9 15/8 243/128 27/14) 2 (:michaelharrison))

             ;; harmonic series -- length arbitary
             ("Harmonic Series 24" (t ,@(iota 24 :start 1)) 2 (:harmonic))

             ;; stretched/shrunk octave
             ("Bohlen-Pierce" ,(mul-iota (/ (ratio-midi 3) 13) 12) 3 (:bp))

             ("Wendy Carlos Alpha" ,(mul-iota 0.78 14) ,(midi-ratio (* 15 0.78)) (:wcAlpha))
             ("Wendy Carlos Beta" ,(mul-iota 0.638 18) ,(midi-ratio (* 19 0.638)) (:wcBeta))
             ("Wendy Carlos Gamma" ,(mul-iota 0.351 33) ,(midi-ratio (* 34 0.351)) (:wcGamma)))))
  (let ((t-tuning (cadr tuning)))
    (apply #'define-tuning
           (car tuning)
           (if (eql t (car t-tuning)) ; tunings lists that start with t need to be ratio-midi'd.
               (mapcar #'ratio-midi (cdr t-tuning))
               t-tuning)
           (cddr tuning))))

(dolist (scale
         '(;; twelve tones per octave

           ;; 5 note scales
           ("Minor Pentatonic" (0 3 5 7 10) :et12 (:pentatonic))
           ("Major Pentatonic" (0 2 4 7 9) :et12)

           ;; other modes of major pentatonic
           ("Ritusen" (0 2 5 7 9) :et12)
           ("Egyptian" (0 2 5 7 10) :et12)

           ("Kumoi" (0 2 3 7 9) :et12)
           ("Hirajoshi" (0 2 3 7 8) :et12)
           ("Iwato" (0 1 5 6 10) :et12)
           ("Chinese" (0 4 6 7 11) :et12)
           ("Indian" (0 4 5 7 10) :et12)
           ("Pelog" (0 1 3 7 8) :et12)

           ("Prometheus" (0 2 4 6 11) :et12)
           ("Scriabin" (0 1 4 7 9) :et12)

           ;; han chinese pentatonic scales
           ("Gong" (0 2 4 7 9) :et12)
           ("Shang" (0 2 5 7 10) :et12)
           ("Jiao" (0 3 5 8 10) :et12)
           ("Zhi" (0 2 5 7 9) :et12)
           ("Yu" (0 3 5 7 10) :et12)

           ;; 6 note scales
           ("Whole Tone" (0 2 4 6 8 10) :et12 (:whole))
           ("Augmented" (0 3 4 7 8 11) :et12)
           ("Augmented 2" (0 1 4 5 8 9) :et12)

           ;; partch's otonalities and utonalities
           ("Partch Otonality 1" (0 8 14 20 25 34) :partch (:partcho1))
           ("Partch Otonality 2" (0 7 13 18 27 35) :partch (:partcho2))
           ("Partch Otonality 3" (0 6 12 21 29 36) :partch (:partcho3))
           ("Partch Otonality 4" (0 5 15 23 30 37) :partch (:partcho4))
           ("Partch Otonality 5" (0 10 18 25 31 38) :partch (:partcho5))
           ("Partch Otonality 6" (0 9 16 22 28 33) :partch (:partcho6))
           ("Partch Utonality 1" (0 9 18 23 29 35) :partch (:partchu1))
           ("Partch Utonality 2" (0 8 16 25 30 36) :partch (:partchu2))
           ("Partch Utonality 3" (0 7 14 22 31 37) :partch (:partchu3))
           ("Partch Utonality 4" (0 6 13 20 28 38) :partch (:partchu4))
           ("Partch Utonality 5" (0 5 12 18 25 33) :partch (:partchu5))
           ("Partch Utonality 6" (0 10 15 21 27 34) :partch (:partchu6))

           ;; hexatonic modes with no tritone
           ("Hex Major 7" (0 2 4 7 9 11) :et12)
           ("Hex Dorian" (0 2 3 5 7 10) :et12)
           ("Hex Phrygian" (0 1 3 5 8 10) :et12)
           ("Hex Sus" (0 2 5 7 9 10) :et12)
           ("Hex Major 6" (0 2 4 5 7 9) :et12)
           ("Hex Aeolian" (0 3 5 7 8 10) :et12)

           ;; 7 note scales
           ("Major" (0 2 4 5 7 9 11) :et12)
           ("Ionian" (0 2 4 5 7 9 11) :et12)
           ("Dorian" (0 2 3 5 7 9 10) :et12)
           ("Phrygian" (0 1 3 5 7 8 10) :et12)
           ("Lydian" (0 2 4 6 7 9 11) :et12)
           ("Mixolydian" (0 2 4 5 7 9 10) :et12)
           ("Aeolian" (0 2 3 5 7 8 10) :et12)
           ("Natural Minor" (0 2 3 5 7 8 10) :et12 (:minor))
           ("Locrian" (0 1 3 5 6 8 10) :et12)

           ("Harmonic Minor" (0 2 3 5 7 8 11) :et12)
           ("Harmonic Major" (0 2 4 5 7 8 11) :et12)

           ("Melodic Minor" (0 2 3 5 7 9 11) :et12)
           ("Melodic Minor Descending" (0 2 3 5 7 8 10) :et12 (:melodicminordesc))
           ("Melodic Major" (0 2 4 5 7 8 10) :et12)

           ("Bartok" (0 2 4 5 7 8 10) :et12)
           ("Hindu" (0 2 4 5 7 8 10) :et12)

           ;; raga modes
           ("Todi" (0 1 3 6 7 8 11) :et12)
           ("Purvi" (0 1 4 6 7 8 11) :et12)
           ("Marva" (0 1 4 6 7 9 11) :et12)
           ("Bhairav" (0 1 4 5 7 8 11) :et12)
           ("Ahirbhairav" (0 1 4 5 7 9 10) :et12)

           ("Super Locrian" (0 1 3 4 6 8 10) :et12)
           ("Romanian Minor" (0 2 3 6 7 9 10) :et12)
           ("Hungarian Minor" (0 2 3 6 7 8 11) :et12)
           ("Neapolitan Minor" (0 1 3 5 7 8 11) :et12)
           ("Enigmatic" (0 1 4 6 8 10 11) :et12)
           ("Spanish" (0 1 4 5 7 8 10) :et12)

           ;; modes of whole tones with added note
           ("Leading Whole Tone" (0 2 4 6 8 10 11) :et12 (:leadingwhole))
           ("Lydian Minor" (0 2 4 6 7 8 10) :et12)
           ("Neapolitan Major" (0 1 3 5 7 9 11) :et12)
           ("Locrian Major" (0 2 4 5 6 8 10) :et12)

           ;; 8 note scales
           ("Diminished" (0 1 3 4 6 7 9 10) :et12)
           ("Diminished 2" (0 2 3 5 6 8 9 11) :et12)

           ;; 12 note scales
           ("Chromatic" (0 1 2 3 4 5 6 7 8 9 10 11) :et12)

           ;; 24 tones per octave

           ("Chromatic 24" (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23) :et24)

           ;; maqam ajam
           ("Ajam" (0 4 8 10 14 18 22) :et24)
           ("Jiharkah" (0 4 8 10 14 18 21) :et24)
           ("Shawq Afza" (0 4 8 10 14 16 22) :et24)

           ;; maqam sikah
           ("Sikah" (0 3 7 11 14 17 21) :et24)
           ("Sikah Descending" (0 3 7 11 13 17 21) :et24 (:sikahdesc))
           ("Huzam" (0 3 7 9 15 17 21) :et24)
           ("Iraq" (0 3 7 10 13 17 21) :et24)
           ("Bastanikar" (0 3 7 10 13 15 21) :et24)
           ("Mustar" (0 5 7 11 13 17 21) :et24)

           ;; maqam bayati
           ("Bayati" (0 3 6 10 14 16 20) :et24)
           ("Karjighar" (0 3 6 10 12 18 20) :et24)
           ("Husseini" (0 3 6 10 14 17 21) :et24)

           ;; maqam nahawand
           ("Nahawand" (0 4 6 10 14 16 22) :et24)
           ("Nahawand Descending" (0 4 6 10 14 16 20) :et24 (:nahawanddesc))
           ("Farahfaza" (0 4 6 10 14 16 20) :et24)
           ("Murassah" (0 4 6 10 12 18 20) :et24)
           ("Ushaq Mashri" (0 4 6 10 14 17 21) :et24)

           ;; maqam rast
           ("Rast" (0 4 7 10 14 18 21) :et24)
           ("Rast Descending" (0 4 7 10 14 18 20) :et24 (:rastdesc))
           ("Suznak" (0 4 7 10 14 16 22) :et24)
           ("Nairuz" (0 4 7 10 14 17 20) :et24)
           ("Yakah" (0 4 7 10 14 18 21) :et24)
           ("Yakah Descending" (0 4 7 10 14 18 20) :et24 (:yakahdesc))
           ("Mahur" (0 4 7 10 14 18 22) :et24)

           ;; maqam hijaz
           ("Hijaz" (0 2 8 10 14 17 20) :et24)
           ("Hijaz Descending" (0 2 8 10 14 16 20) :et24 (:hijazdesc))
           ("Zanjaran" (0 2 8 10 14 18 20) :et24)

           ;; maqam hijazkar
           ("hijazKar" (0 2 8 10 14 16 22) :et24)

           ;; maqam saba
           ("Saba" (0 3 6 8 12 16 20) :et24)
           ("Zamzam" (0 2 6 8 14 16 20) :et24)

           ;; maqam kurd
           ("Kurd" (0 2 6 10 14 16 20) :et24)
           ("Kijaz Kar Kurd" (0 2 8 10 14 16 22) :et24)

           ;; maqam nawa athar
           ("Nawa Athar" (0 4 6 12 14 16 22) :et24)
           ("Nikriz" (0 4 6 12 14 18 20) :et24)
           ("Athar Kurd" (0 2 6 12 14 16 22) :et24)))
  (apply #'define-scale scale))

(dolist (chord
         `(("Augmented Triad" (0 2 4#) :major (:augtri))
           ("Diminished Triad" (0 2b 4b) :major (:dimtri))
           ("Major Triad" (0 2 4) :major (:major :maj :majtri))
           ("Minor Triad" (0 2b 4) :major (:minor :min :mintri))
           ("Suspended 2nd Triad" (0 1 4) :major (:sus2tri))
           ("Suspended 4th Triad" (0 3 4) :major (:sus4tri))
           ("Major 6th" (0 2 4 5) :major (:maj6))
           ("Minor 6th" (0 2b 4 5) :major (:min6))
           ("Augmented 7th" (0 2 4# 6b) :major (:aug7))
           ("Augmented Major 7th" (0 2 4# 6) :major (:augmaj7))
           ("Half Diminished 7th" (0 2b 4b 6b) :major (:halfdim7))
           ("Diminished 7th" (0 2b 4b 6bb) :major (:dim7))
           ("Dominant 7th" (0 2 4 6b) :major (:dom7))
           ("Dominant 7th Suspended 4th" (0 3 4 6b) :major (:dom7sus4))
           ("Major 7th" (0 2 4 6) :major (:maj7))
           ("Major 7th Suspended 2nd" (0 1 4 6) :major (:maj7sus2))
           ("Major 7th Suspended 4th" (0 3 4 6) :major (:maj7sus4))
           ("Minor 7th" (0 2b 4 6b) :major (:min7))
           ("Minor Major 7th" (0 2b 4 6) :major (:minmaj7))))
  (apply #'define-chord chord))