;;; **********************************************************************
;;; Copyright (C) 2003 Heinrich Taube (taube@uiuc.edu) 
;;; This program is free software; you can redistribute it and
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; **********************************************************************

;;; generated by scheme->cltl from scales.scm on 23-Mar-2005 12:21:17

(in-package :cm)

(defparameter *chromatic-scale* ())

(defparameter *scale* ())

(defun rest? (f) (or (eq f 'r) (eq f -1) (equal f 0.0)))

(progn (defclass scale (container)
         ((octave :accessor scale-octave)
          (lowest :accessor scale-lowest :initform nil :initarg
           :lowest)
          (divisions :accessor scale-divisions)
          (into :accessor scale-into)
          (keynum-offset :initform 0 :accessor scale-keynum-offset
           :initarg :keynum-offset)))
       (defparameter <scale> (find-class 'scale))
       (finalize-class <scale>)
       (values))

(progn (defclass tuning (scale)
         ((steps :initform '() :accessor scale-steps :initarg :cents
           :initarg :ratios)
          (table :accessor scale-table :initform 10 :initarg
           :octaves)
          (defoct :initform 4 :initarg :default-octave :accessor
           scale-default-octave)
          (octave-offset :initform 0 :accessor scale-octave-offset)))
       (defparameter <tuning> (find-class 'tuning))
       (finalize-class <tuning>)
       (values))

(progn (defclass mode (scale)
         ((steps :initform '() :accessor scale-steps :initarg :steps
           :initarg :degrees :initarg :notes)
          (lowest :accessor scale-lowest :initform nil :initarg
           :tonic)
          (tuning :initform *chromatic-scale* :initarg :scale
           :accessor mode-tuning)))
       (defparameter <mode> (find-class 'mode))
       (finalize-class <mode>)
       (values))

(define-list-struct sd note keynum octave class name accidental)

(defmethod initialize-instance :after ((obj tuning) &rest args)
  args
  (let ((extern nil)
        (steps? t)
        (cents? t)
        (equal? nil)
        (nums nil)
        (syms nil)
        (data nil)
        (len nil)
        (octave nil))
    (dopairs (a v args)
     (case a
       ((:cents) (setf cents? t) (setf extern v))
       ((:ratios) (setf cents? nil) (setf extern v))))
    (unless extern
      (error "Tuning needs :ratios or :cents initialization."))
    (when (null extern)
      (setf extern (getf args ':ratios))
      (if (not extern)
          (error "Tuning needs :ratios or :cents initialization.")
          (setf cents? nil)))
    (cond ((consp (car extern))
           (setf nums
                 (loop for e in extern
                       collect (if
                                (and (consp e) (numberp (car e)))
                                (car e)
                                (if
                                 (numberp e)
                                 e
                                 (error
                                  "Bad degree: ~s in ~s."
                                  e
                                  extern)))))
                 (setf steps? (not (apply #'< nums)))
                 (when (and (not steps?)
                            (consp (end extern))
                            (scale-table obj))
                   (error "No ending octave size (cent or ratio): ~s "
                          extern))
                 (setf syms
                       (loop for e in extern
                             while (consp e)
                             collect (if
                                      (null (cdr e))
                                      (error
                                       "Degree spec missing notes: ~s."
                                       e)
                                      (cdr e)))))
                 ((numberp (car extern))
                  (setf nums extern)
                  (setf steps? (not (apply #'< nums)))
                  (setf syms nil))
                 (t (error "Bad degree spec ~s." extern)))
           (setf equal?
                 (if steps?
                     (apply #'= nums)
                     (let ((one
                            (if cents?
                                (- (second nums) (first nums))
                                (/ (second nums) (first nums)))))
                       (loop for tail on nums
                             while (not (null (cdr tail)))
                             always (let
                                     ((a (first tail))
                                      (b (second tail)))
                                     (=
                                      one
                                      (if
                                       cents?
                                       (- b a)
                                       (/ b a))))))))
                 (if equal?
                     (if steps?
                         (progn (setf
                                 data
                                 (if
                                  cents?
                                  (cents->scaler (first nums))
                                  (first nums)))
                                (setf
                                 octave
                                 (if
                                  cents?
                                  (cents->scaler (apply #'+ nums))
                                  (apply #'+ nums)))
                                (setf len (length nums)))
                         (progn (setf
                                 data
                                 (if
                                  cents?
                                  (cents->scaler (second nums))
                                  (second nums)))
                                (setf
                                 octave
                                 (if
                                  cents?
                                  (cents->scaler (end nums))
                                  (end nums)))
                                (setf len (1- (length nums)))))
                     (progn (if steps?
                                (setf
                                 data
                                 (do
                                  ((tail nums (cdr tail))
                                   (l (list (if cents? 0 1)))
                                   (k nil))
                                  ((null tail) l)
                                  (if
                                   (not k)
                                   (setf k (car tail))
                                   (setf
                                    k
                                    (if
                                     cents?
                                     (+ k (car tail))
                                     (* k (car tail)))))
                                  (push k l)))
                                (setf data (reverse nums)))
                            (setf octave
                                  (if
                                   cents?
                                   (cents->scaler (pop data))
                                   (pop data)))
                            (setf data
                                  (if
                                   cents?
                                   (mapcar
                                    #'cents->scaler
                                    (reverse data))
                                   (reverse data)))
                            (setf len (length data))
                            (setf (scale-into obj)
                                  (loop for s in data
                                   collect (log s octave)))))
                     (setf (scale-steps obj) data)
                     (setf (scale-divisions obj) len)
                     (if (not syms)
                         (setf (scale-table obj) nil)
                         (let ((octaves (scale-table obj))
                               (table
                                (make-hash-table
                                 :size
                                 103
                                 :test
                                 #'equal))
                               (degrees
                                (loop for deg in syms
                                 for i from 0
                                 collect (loop for d in deg
                                          unless (consp d)
                                          do (setf d (list d))
                                          collect (let
                                                   ((n (pop d)))
                                                   (make-sd
                                                    :note
                                                    n
                                                    :keynum
                                                    i
                                                    :octave
                                                    (getf d :octave)
                                                    :class
                                                    i
                                                    :name
                                                    n
                                                    :accidental
                                                    (getf
                                                     d
                                                     :accidental)))))))
                                (setf (scale-table obj) table)
                                (fill-tuning-table
                                 obj
                                 degrees
                                 octaves)))
                           (setf (scale-octave obj) octave)
                           (if (scale-lowest obj)
                               (unless
                                (numberp (scale-lowest obj))
                                (error
                                 "lowest not hertz value: ~s."
                                 (scale-lowest obj)))
                               (setf
                                (scale-lowest obj)
                                (* 6.875 (expt 2 1/4))))))

(defun fill-tuning-table (tuning degrees octaves)
  (let ((table (scale-table tuning))
        (rst (make-sd :note 'r :keynum -1)))
    (setf (gethash 'r table) (list rst))
    (setf (gethash -1 table) (list rst))
    (when octaves
      (dolist (deg degrees)
        (dolist (d deg)
          (setf (gethash (sd-note d) table)
                (cons d (remove d deg)))))))
  (let ((table (scale-table tuning))
        (divisions (scale-divisions tuning))
        (begoct nil)
        (endoct nil))
    (if (consp octaves)
        (progn (setf begoct (first octaves))
               (setf endoct (second octaves)))
        (if octaves
            (progn (setf begoct 0) (setf endoct (1- octaves)))
            (progn (setf begoct 0) (setf endoct 0))))
    (setf (scale-octave-offset tuning) begoct)
    (do ((num begoct (+ num 1)) (oct 0 (+ oct 1)))
        ((> num endoct) nil)
      (do ((lst degrees (cdr lst)) (i 0 (+ i 1)) (deg nil))
          ((null lst) nil)
        (setf deg (car lst))
        (let* ((k (+ (* oct divisions) i))
               (l
                (loop for d in deg
                      for n = (sd-note d)
                      for o = (+ num (or (sd-octave d) 0))
                      collect (make-sd
                               :note
                               (if
                                octaves
                                (intern (format nil "~A~A" n o) :cm)
                                (sd-note d))
                               :keynum
                               k
                               :octave
                               oct
                               :class
                               (sd-class d)
                               :name
                               n
                               :accidental
                               (sd-accidental d)))))
               (setf (gethash k table) l)
               (dolist (x l)
                 (setf (gethash (sd-note x) table)
                       (cons x (remove x l))))))))
    (when octaves
      (dolist (degs degrees)
        (dolist (d degs) (sd-octave-set! d nil)))))

(defun scale-ref (table ref)
  (or (gethash ref table)
      (if (and ref (symbolp ref))
          (gethash (intern (symbol-name ref) :cm) table)
          nil)))

(defun equal-tuning? (tuning)
  (let ((steps (scale-steps tuning))) (if (consp steps) nil steps)))

(defmethod mode-tuning ((obj scale)) nil)

(defmethod scale-default-octave ((obj mode))
  (scale-default-octave (mode-tuning obj)))

(defmethod scale-table ((obj mode)) (scale-table (mode-tuning obj)))

(defun octave-equivalent (note &optional (octave 0)
                          (scale *chromatic-scale*))
  (let* ((table (scale-table scale))
         (entries (scale-ref table note))
         (entry (and entries (first entries))))
    (if entry
        (loop for e in
                  (scale-ref table
                   (+ (sd-class entry)
                      (* octave (scale-divisions scale))))
              when (eq (sd-name e) (sd-name entry))
                return e)
                (error "~s is not a note in the standard chromatic scale."
                       note))))

(defun ascending-mode-order (notes tuning)
  (setf notes
        (if (let ((t3 (car notes))) (and t3 (symbolp t3)))
            (mapcar (lambda (n)
                      (or (note-name n tuning)
                          (error "Note '~s' not defined in ~s."
                                 n
                                 tuning)))
                    notes)
            (mapcar (lambda (k) (pitch-class k tuning)) notes)))
  (let* ((old (car notes))
         (pc? (numberp old))
         (oct 0)
         (oth nil)
         (res '()))
    (dolist (n notes)
      (if (scale< n old tuning) (setf oct (+ oct 1)))
      (setf oth (octave-equivalent n oct tuning))
      (push (if pc? (cadr oth) (car oth)) res)
      (setf old n))
    (nreverse res)))

(defmethod initialize-instance :after ((obj mode) &rest args)
  args
  (let* ((spec nil)
         (owner (mode-tuning obj))
         (low (scale-lowest obj))
         (steps nil)
         (type nil)
         (len nil)
         (octave nil))
    (dopairs (a v args)
     (case a
       ((:steps)
        (if (let ((t4 (car v))) (and t4 (symbolp t4)))
            (progn (warn "Bad :step value ~s, use :degrees to pass notes to a mode."
                         v)
                   (setf spec v)
                   (setf type ':degrees))
            (progn (setf spec v) (setf type a))))
       ((:degrees :notes)
        (when spec
          (error "Found duplicate keywords ~s and ~s." type a))
        (setf spec v) (setf type a))
       (t nil)))
    (if (member type '(:degrees :notes))
        (progn (setf spec (ascending-mode-order spec owner))
               (unless low
                 (setf low
                       (if (let ((t5 (car spec)))
                             (and t5 (symbolp t5)))
                           (sd-name
                            (octave-equivalent (first spec) 0 owner))
                           (sd-keynum
                            (octave-equivalent (first spec) 0
                             owner)))))
               (if (eq type ':notes)
                   (progn (unless (let
                                   ((t6 (car spec)))
                                   (and t6 (symbolp t6)))
                            (error "mode :notes spec not note names: ~s."
                                   spec))
                          (unless (eq owner *chromatic-scale*)
                            (error "mode :notes but not chromatic scale: ~s."
                                   owner))
                          (setf steps
                                (do
                                 ((l (list (interval 0 0)))
                                  (x (cdr spec) (cdr x)))
                                 ((null x) l)
                                 (push
                                  (interval (car spec) (car x))
                                  l))))
                   (progn (when (let
                                 ((t7 (car spec)))
                                 (and t7 (symbolp t7)))
                            (setf spec (keynum spec :in owner)))
                          (setf steps
                                (do
                                 ((x spec (cdr x))
                                  (l '())
                                  (n (car spec)))
                                 ((null x) l)
                                 (push (- (car x) n) l))))))
        (progn (unless low (setf low 0))
               (when (consp (car spec))
                 (setf spec (mapcar #'interval spec)))
               (if (%interval-encoded? (car spec))
                   (setf steps
                         (do ((l '())
                              (s (encode-interval 'p 1))
                              (k spec (cdr k)))
                             ((null k) (cons s l))
                           (push s l)
                           (setf s (transpose s (car k)))))
                   (setf steps
                         (do ((l '()) (s 0) (k spec (cdr k)))
                             ((null k) (cons s l))
                           (push s l)
                           (incf s (car k)))))))
    (setf octave (pop steps))
    (setf steps (reverse steps))
    (setf len (length steps))
    (setf (scale-steps obj) steps)
    (setf (scale-divisions obj) len)
    (setf (scale-octave obj) octave)
    (let ((into
           (make-list (interval-semitones octave)
                      :initial-element
                      nil)))
      (loop for step in steps
            for degree from 0
            do (setf (elt into (interval-semitones step)) degree))
            (setf (scale-into obj) into))
      (transpose obj low owner)))

(defmethod print-object ((obj mode) stream)
  (let* ((name (object-name obj))
         (low (scale-lowest obj))
         (pos
          (if (= 0 (sd-octave low))
              (or (sd-name low) (sd-keynum low))
              (or (sd-note low) (sd-keynum low))))
         (str
          (string-downcase
            (symbol-name (class-name (class-of obj))))))
    (if name
        (format stream "#<~a: ~s (on ~a)>" str name pos)
        (format stream "#<~a (on ~a)>" str pos))))

(defmethod tuning->mode ((mode mode) keynum force?)
  (let ((div (interval-semitones (scale-octave mode)))
        (num (- keynum (scale-keynum-offset mode)))
        (into (scale-into mode))
        (deg nil))
    (multiple-value-bind (oct int)
        (floor (round num) div)
      (setf deg
            (or (elt into int)
                (if force?
                    (loop for i from int downto 0
                          for j = (elt into i)
                          when j return j) nil)))
                (if deg (+ (* oct (scale-divisions mode)) deg) nil))))

(defmethod mode->tuning ((mode mode) keynum return)
  (let ((scale (mode-tuning mode))
        (div (scale-divisions mode))
        (int nil))
    (multiple-value-bind (oct rem)
        (floor (round keynum) div)
      (setf int (elt (scale-steps mode) rem))
      (if (and (eq return ':note) (%interval-encoded? int))
          (do ((low (car (scale-lowest mode))) (num 0 (+ num 1)))
              ((= num oct) (transpose low int scale))
            (setf low (transpose low (scale-octave mode) scale)))
          (let ((num
                 (+ (* oct (interval-semitones (scale-octave mode)))
                    (scale-keynum-offset mode)
                    (interval-semitones int))))
            (if (eq return ':note)
                (tuning-keynum->note scale num nil t)
                (if (eq return ':hertz)
                    (tuning-keynum->hertz scale num)
                    num)))))))

(defmethod tuning-hertz->keynum ((obj tuning) hz)
  (let ((low (scale-lowest obj))
        (oct (scale-octave obj))
        (int (equal-tuning? obj))
        (div (scale-divisions obj))
        (off (scale-keynum-offset obj)))
    (if int
        (- (* (- (log hz oct) (log low oct)) div) off)
        (let* ((into (scale-into obj))
               (val (log (/ hz low) oct))
               (octnum (floor val))
               (octrem (- val octnum))
               (y (car into))
               (int nil))
          (setf into (cdr into))
          (do ((i 0 (+ i 1)) (x y y))
              (int
               (if (and (= int (- div 1))
                        (< (- 1 octrem) (- octrem x)))
                   (- (* div (1+ octnum)) off)
                   (- (+ (* div octnum) int) off)))
            (setf y (car into))
            (if (<= x octrem y)
                (if (< (- y octrem) (- octrem x))
                    (setf int (+ 1 i))
                    (setf int i))
                (if (null (cdr into))
                    (setf int (+ 1 i))
                    (setf into (cdr into)))))))))

(defmethod tuning-hertz->note ((scale tuning) hz acci err?)
  (tuning-keynum->note scale (tuning-hertz->keynum scale hz) acci
   err?))

(defmethod tuning-keynum->hertz ((obj tuning) knum)
  (let ((low (scale-lowest obj))
        (off (scale-keynum-offset obj))
        (div (scale-divisions obj))
        (octsiz (scale-octave obj)))
    (if (equal-tuning? obj)
        (* low (expt octsiz (/ (+ knum off) div)))
        (multiple-value-bind (oct step)
            (floor knum div)
          (* low
             (expt octsiz oct)
             (elt (scale-steps obj) (floor step)))))))

(defmethod tuning-keynum->note ((obj tuning) knum acci err?)
  (let* ((table (scale-table obj))
         (entries (and table (scale-ref table (round knum)))))
    (if entries
        (let ((it
               (if acci
                   (if (consp acci)
                       (loop for a in acci
                             for x =
                                 (find
                                  a
                                  entries
                                  :key
                                  #'sd-accidental)
                             when x
                               return x)
                               (find
                                acci
                                entries
                                :key
                                #'sd-accidental))
                             (first entries))))
               (if it
                   (sd-note it)
                   (if err?
                       (error "No note with accidental ~s for keynum ~s in ~s."
                              acci
                              (round knum)
                              obj)
                       nil)))
              (if err?
                  (if table
                      (error "No note for keynum ~s in ~s." knum obj)
                      (error "No note table defined in ~s." obj))
                  nil))))

(defparameter %oct ())

(defmethod tuning-note->hertz ((obj tuning) note err?)
  (let* ((table (scale-table obj))
         (entries (and table (scale-ref table note)))
         (entry (and entries (first entries))))
    (if entry
        (if (sd-octave entry)
            (progn (if %oct (setf %oct (sd-octave entry)))
                   (tuning-keynum->hertz obj (sd-keynum entry)))
            (let ((k
                   (+ (* (or %oct (scale-default-octave obj))
                         (scale-divisions obj))
                      (sd-class entry))))
              (tuning-keynum->hertz obj k)))
        (if err?
            (if table
                (error "~s is not a note in ~s." note obj)
                (error "No note table defined in ~s." obj))
            nil))))

(defmethod tuning-note->keynum ((obj tuning) note err?)
  (let* ((table (scale-table obj))
         (entries (and table (scale-ref table note)))
         (entry (and entries (first entries))))
    (if entry
        (if (eq note 'r)
            (sd-keynum entry)
            (if (sd-octave entry)
                (progn (if %oct (setf %oct (sd-octave entry)))
                       (sd-keynum entry))
                (+ (* (or %oct (scale-default-octave obj))
                      (scale-divisions obj))
                   (sd-class entry))))
        (if err?
            (if table
                (error "No note for ~s in ~s." note obj)
                (error "No note table defined in ~s." obj))
            nil))))

(defmethod tuning-note->note ((obj tuning) note acci err?)
  (if acci
      (tuning-keynum->note obj (tuning-note->keynum obj note err?)
       acci err?)
      (let* ((table (scale-table obj))
             (entries (and table (scale-ref table note))))
        (if entries
            (tuning-keynum->note obj
             (tuning-note->keynum obj note err?)
             (sd-accidental (car entries)) err?)
            (if err?
                (if table
                    (error "No note ~s in ~s." note obj)
                    (error "No note table defined in ~s." obj))
                nil)))))

(defparameter %hertz (quote (:hertz hertz :hz hz)))

(defun mode? (x) (typep x <mode>))

(defun tuning? (x) (typep x <tuning>))

(defmacro with-default-octave (scale &body body)
  (let ((v (gensym "v")))
    `(let ((,v nil))
       (unwind-protect
           (progn (setf %oct (or %oct (scale-default-octave ,scale)))
                  (setf ,v ,@body))
         (setf %oct nil))
       ,v)))

(defun hertz (freq &rest args)
  (let ((hz? nil) (scale nil) (mode nil) (tuning nil) (oper nil))
    (unless freq
      (error "~s is not a note name, key number, Hertz value or list."
             false))
    (when (and (consp args)
               (member (first args) %hertz)
               (oddp (length args)))
      (warn "Found :HZ tag, use the :HZ keyword parameter instead: ~s"
            (list* 'note ':hz true (rest args)))
      (setf args (list* ':hz true (rest args))))
    (dopairs (sym val args)
     (case sym
       ((:hz) (setf hz? val))
       ((:in :through)
        (when oper
          (error "Found more than one of :in or :through in ~s."
                 (cons 'note args)))
        (setf oper sym) (setf scale val))
       (t (error "~s not a valid keyword: :hz :in :through" sym))))
    (unless scale (setf scale *scale*))
    (if (typep scale <mode>)
        (progn (if (eq oper ':in)
                   (error "Not a tuning: ~s ~s." oper scale))
               (setf tuning (mode-tuning scale))
               (setf mode scale))
        (progn (setf tuning scale)))
    (if (consp freq)
        (with-default-octave tuning
         (loop for f in freq collect (apply #'hertz f args)))
         (if (and (not mode) hz?)
             freq
             (let ((key
                    (if hz?
                        (tuning-hertz->keynum tuning freq)
                        (if (and freq (symbolp freq))
                            (tuning-note->keynum tuning freq t)
                            freq))))
               (if mode
                   (mode->tuning mode (tuning->mode mode key t)
                    ':hertz)
                   (tuning-keynum->hertz tuning
                    (if (eq oper ':through) (round key) key))))))))

(defun keynum (freq &rest args)
  (let ((hz? nil)
        (scale nil)
        (mode nil)
        (tuning nil)
        (oper nil)
        (test? nil))
    (unless freq
      (error "~s is not a note name, key number, Hertz value or list."
             false))
    (when (and (consp args)
               (member (first args) %hertz)
               (oddp (length args)))
      (setf args (list* ':hz true (rest args))))
    (dopairs (sym val args)
     (case sym
       ((:hz) (setf hz? val))
       ((:in :in? :through :to)
        (when oper
          (error "More than one of: :in, :in? or :through in ~s."
                 (cons 'note args)))
        (if (eq sym ':in?) (setf test? t)) (setf oper sym)
        (setf scale val))
       (t
        (error "~s not a valid keyword: :hz :in :in? :through"
               sym))))
    (unless scale (setf scale *scale*))
    (if (typep scale <mode>)
        (progn (if (eq oper ':in) (setf oper ':from))
               (setf tuning (mode-tuning scale))
               (setf mode scale))
        (progn (setf tuning scale)))
    (if (consp freq)
        (with-default-octave tuning
         (loop for f in freq collect (apply #'keynum f args)))
         (let ((key
                (if hz?
                    (tuning-hertz->keynum tuning freq)
                    (if (and freq (symbolp freq))
                        (tuning-note->keynum tuning freq (not test?))
                        freq))))
           (if mode
               (let ((in
                      (if (eq oper ':from)
                          key
                          (tuning->mode mode key
                           (not (eq oper ':in?))))))
                 (if (not in)
                     nil
                     (if (eq oper ':to)
                         in
                         (mode->tuning mode in ':keynum))))
               (if (eq oper ':through) (values (round key)) key))))))

(defun note (freq &rest args)
  (let ((oper nil)
        (hz? nil)
        (scale nil)
        (test? nil)
        (tuning nil)
        (mode nil)
        (acci nil))
    (unless freq
      (error "~s is not a note name, key number, Hertz value or list."
             false))
    (when (and (consp args)
               (member (first args) %hertz)
               (oddp (length args)))
      (warn "Found :hz tag, use the :hz keyword parameter instead: ~s"
            (list* 'note ':hz true (rest args)))
      (setf args (list* ':hz true (rest args))))
    (dopairs (sym val args)
     (case sym
       ((:hz) (setf hz? val))
       ((:in :in? :through)
        (when oper
          (error "Found more than one of :in, :in? or :through in ~s."
                 (cons 'note args)))
        (if (eq sym ':in?) (setf test? t)) (setf oper sym)
        (setf scale val))
       ((:accidental) (setf acci val))
       (t
        (error "~s not a valid keyword: :hz :in :in? :through"
               sym))))
    (unless scale (setf scale *scale*))
    (if (typep scale <mode>)
        (progn (if (eq oper ':in) (setf oper ':from))
               (setf tuning (mode-tuning scale))
               (setf mode scale))
        (progn (if (eq oper ':through)
                   (error "Not a mode: ~s ~s." oper scale))
               (setf tuning scale)))
    (when (and (eq oper ':from) (or hz? (and freq (symbolp freq))))
      (error ":from conversion: ~s is not a key number in ~s."
             freq
             mode))
    (cond ((consp freq)
           (with-default-octave tuning
            (loop for f in freq collect (apply #'note f args))))
           ((and freq (symbolp freq))
            (let ((ref
                   (tuning-note->note tuning freq acci (not test?))))
              (if (not mode)
                  ref
                  (if (not ref)
                      nil
                      (let* ((key (tuning-note->keynum tuning ref t))
                             (out
                              (mode->tuning
                               mode
                               (tuning->mode mode key t)
                               ':note)))
                        (if test? (if (eq out ref) ref nil) out))))))
           (t
            (let ((keyn
                   (if hz? (tuning-hertz->keynum tuning freq) freq)))
              (if (not mode)
                  (tuning-keynum->note tuning keyn acci (not test?))
                  (let* ((in
                          (if (eq oper ':from)
                              keyn
                              (tuning->mode mode keyn (not test?))))
                         (out
                          (and in (mode->tuning mode in ':note))))
                    (if test?
                        out
                        (or out
                            (error "No note for keynum ~s in mode ~s."
                                   keyn
                                   mode))))))))))

(defun pitch-class (note &optional (scale *scale*))
  (let* ((table (scale-table scale))
         (entry (and table (scale-ref table note))))
    (if entry (sd-class (first entry)) nil)))

(defun octave-number (note &optional (scale *scale*) real?)
  (let* ((table (scale-table scale))
         (entry (and table (scale-ref table note))))
    (if entry
        (if (sd-octave (first entry))
            (if real?
                (sd-octave (first entry))
                (+ (sd-octave (first entry))
                   (scale-octave-offset scale)))
            nil)
        nil)))

(defun note-name (note &optional (scale *scale*))
  (let* ((table (scale-table scale))
         (entry (and table (scale-ref table note))))
    (if entry (sd-name (first entry)) nil)))

(defun note-accidental (note &optional (scale *scale*))
  (let* ((table (scale-table scale))
         (entry (and table (scale-ref table note))))
    (if entry (sd-accidental (first entry)) nil)))

(defun scale< (a b &optional (scale *scale*))
  (< (if (numberp a) a (tuning-note->keynum scale a t))
     (if (numberp b) b (tuning-note->keynum scale b t))))

(defun scale<= (a b &optional (scale *scale*))
  (<= (if (numberp a) a (tuning-note->keynum scale a t))
      (if (numberp b) b (tuning-note->keynum scale b t))))

(defun scale= (a b &optional (scale *scale*))
  (= (if (numberp a) a (tuning-note->keynum scale a t))
     (if (numberp b) b (tuning-note->keynum scale b t))))

(defun scale>= (a b &optional (scale *scale*))
  (>= (if (numberp a) a (tuning-note->keynum scale a t))
      (if (numberp b) b (tuning-note->keynum scale b t))))

(defun scale> (a b &optional (scale *scale*))
  (> (if (numberp a) a (tuning-note->keynum scale a t))
     (if (numberp b) b (tuning-note->keynum scale b t))))

(defun scale-min (a b &optional (scale *scale*))
  (if (< (if (numberp b) b (tuning-note->keynum scale b t))
         (if (numberp a) a (tuning-note->keynum scale a t)))
      b
      a))

(defun scale-max (a b &optional (scale *scale*))
  (if (> (if (numberp b) b (tuning-note->keynum scale b t))
         (if (numberp a) a (tuning-note->keynum scale a t)))
      b
      a))

(defmethod scale-mod ((freq number) modulus &key (offset t)
                      (in *scale*) accidental)
  accidental
  (let* ((div (scale-divisions in))
         (val
          (if (and offset (symbolp offset))
              (if (eq offset t)
                  (* (floor (/ (max freq 0) div)) div)
                  (keynum offset :in in))
              offset)))
    (+ val (mod (- freq val) modulus))))

(defmethod scale-mod ((freq symbol) modulus &key (offset t)
                      (in *scale*) accidental)
  (tuning-keynum->note in
   (scale-mod (keynum freq) modulus :offset offset :in in) accidental
   t))

(defmethod scale-mod ((freq cons) modulus &key (offset t)
                      (in *scale*) accidental)
  (if (eq offset t) (setf offset (first freq)))
  (loop for f in freq
        collect (scale-mod f modulus :in in :offset offset
                 :accidental accidental)))

(defmethod note-in-scale? (note (scale scale))
  (let ((table (scale-table scale)))
    (and table (scale-ref table note) note)))

(defun scale-order (lis &optional (order ':up) unique?)
  (if unique?
      (setf lis (remove-duplicates lis))
      (setf lis (copy-list lis)))
  (cond ((or (eq order t) (eq order ':up)) (sort lis #'scale<))
        ((eq order ':down) (sort lis #'scale>))
        ((eq order ':random) (shuffle lis))
        ((not order) lis)
        (t (sort lis order))))

(defmethod transpose ((note cons) int &optional (scale *scale*))
  (with-default-octave scale
   (loop for n in note collect (transpose n int scale))))

(defmethod transpose ((note symbol) int &optional (scale *scale*))
  (if (eq note 'r)
      note
      (if (numberp int)
          (let* ((table (scale-table scale))
                 (entries (and table (scale-ref table note)))
                 (entry (and entries (first entries))))
            (if entry
                (if (sd-octave entry)
                    (if %oct (setf %oct (sd-octave entry)))
                    (setf entry
                          (octave-equivalent note
                           (or %oct (scale-default-octave scale))
                           scale)))
                (error "~s is not a note in ~s." note scale))
            (if (and (eq scale *chromatic-scale*)
                     (integerp int)
                     (%interval-encoded? int))
                (let* ((names
                        '((cff cf c cn cs css) (dff df d dn ds dss)
                          (eff ef e en es ess) (fff ff f fn fs fss)
                          (gff gf g gn gs gss) (aff af a an as ass)
                          (bff bf b bn bs bss)))
                       (trans
                        (elt names
                             (mod
                              (+
                               (position
                                (sd-name entry)
                                names
                                :test
                                #'member)
                               (*
                                (%interval-letters int)
                                (%interval-sign int)))
                              7)))
                       (keyn
                        (+ (sd-keynum entry)
                           (interval-semitones int)))
                       (entries
                        (scale-ref table
                         (if (sd-octave entry) keyn (mod keyn 12))))
                       (newnote
                        (or (loop for n in trans
                                  for e
                                  =
                                  (find n entries :key #'sd-name)
                                  when e
                                  return e)
                                  (error
                                   "Can't transpose ~a by ~a."
                                   note
                                   (decode-interval int)))))
                        (if (sd-octave entry)
                            (sd-note newnote)
                            (sd-name newnote)))
                       (tuning-keynum->note scale
                        (+ (sd-keynum entry) int) nil t)))
                (error "Don't know how to transpose ~s by ~s."
                       note
                       int))))

(defmethod transpose ((note number) int &optional (scale *scale*))
  (if (numberp int)
      (if (and (integerp note) (%interval-encoded? note))
          (if (and (integerp int) (%interval-encoded? int))
              (let* ((sign1 (%interval-sign note))
                     (sign2 (%interval-sign int))
                     (width
                      (+ (* (%interval-letters note) sign1)
                         (* (%interval-letters int) sign2)))
                     (steps
                      (+ (* (%interval-semitones note) sign1)
                         (* (%interval-semitones int) sign2)))
                     (perfs '(0 1 3 5 6))
                     (imperfs '(0 1 2 4 5 6))
                     (offset nil)
                     (types nil)
                     (type nil))
                (case (mod width 7)
                  ((0) (setf offset -2) (setf types perfs))
                  ((1) (setf offset -1) (setf types imperfs))
                  ((2) (setf offset 1) (setf types imperfs))
                  ((3) (setf offset 3) (setf types perfs))
                  ((4) (setf offset 5) (setf types perfs))
                  ((5) (setf offset 6) (setf types imperfs))
                  ((6) (setf offset 8) (setf types imperfs)))
                (setf type (elt types (mod (- steps offset) 12)))
                (encode-interval (first (elt interval-names type))
                 (+ width 1)))
              (+ (interval-semitones note) int))
          (+ note
             (if (and (integerp int) (%interval-encoded? int))
                 (interval-semitones int)
                 int)))
      (if (and int (symbolp int))
          (transpose int note scale)
          (error "Don't know how to transpose ~s by ~s." note int))))

(defmethod transpose ((obj mode) note &optional (scale *scale*))
  (setf scale (mode-tuning obj))
  (unless (note-in-scale? note scale)
    (error "~s is not defined in mode's tuning" note))
  (if (eq (note-name note scale) note)
      (progn (setf (scale-lowest obj)
                   (octave-equivalent note 0 scale))
             (setf (scale-keynum-offset obj)
                   (sd-class (scale-lowest obj))))
      (let* ((oct (octave-number note scale t))
             (ref (octave-equivalent note oct scale)))
        (setf (scale-lowest obj) ref)
        (setf (scale-keynum-offset obj) (sd-keynum ref))))
  obj)

(defmethod invert ((lst cons) &optional pc?)
  (let* ((n (car lst)) (k (keynum n)))
    (loop for x in lst
          for d = (- k (keynum x))
          collect (transpose n (if pc? (mod d 12) d)))))

(defmethod interval ((ref cons) &optional ref2)
  ref2
  (interval (first ref) (second ref)))

(defmethod interval ((ref integer) &optional ref2)
  (if (null ref2)
      ref
      (let* ((steps ref)
             (width (+ 1 (mod (abs ref2) 7)))
             (perfs '(0 1 3 5 6))
             (imperfs '(0 1 2 4 5 6))
             (offset nil)
             (types nil)
             (type nil)
             (int nil))
        (case width
          ((1) (setf offset -2) (setf types perfs))
          ((2) (setf offset -1) (setf types imperfs))
          ((3) (setf offset 1) (setf types imperfs))
          ((4) (setf offset 3) (setf types perfs))
          ((5) (setf offset 5) (setf types perfs))
          ((6) (setf offset 6) (setf types imperfs))
          ((7) (setf offset 8) (setf types imperfs)))
        (setf type (elt types (mod (- (abs steps) offset) 12)))
        (setf int (+ (* (floor (/ (abs steps) 12)) 7) width))
        (encode-interval (first (elt interval-names type))
         (if (< steps 0) (- int) int)))))

(defmethod interval ((ref symbol) &optional ref2)
  (cond ((note-in-scale? ref *chromatic-scale*)
         (let* ((table (scale-table *chromatic-scale*))
                (entries1 (and table (scale-ref table ref)))
                (entry1 (and entries1 (first entries1)))
                (entries2 (and table (scale-ref table ref2)))
                (entry2 (and entries2 (first entries2)))
                (names
                 '((cff cf c cn cs css) (dff df d dn ds dss)
                   (eff ef e en es ess) (fff ff f fn fs fss)
                   (gff gf g gn gs gss) (aff af a an as ass)
                   (bff bf b bn bs bss)))
                (letters nil)
                (semitones nil))
           (rotatef entry1 entry2)
           (if (not entry1)
               (error "~s not in standard chromatic scale." ref2))
           (setf letters
                 (mod (- (position (sd-name entry1)
                                   names
                                   :test
                                   #'member)
                         (position (sd-name entry2)
                                   names
                                   :test
                                   #'member))
                      7))
           (setf semitones (- (sd-keynum entry1) (sd-keynum entry2)))
           (when (and (not (sd-octave entry1)) (< semitones 0))
             (setf semitones (+ semitones 12)))
           (if (< semitones 0)
               (interval semitones (- (- 7 letters)))
               (interval semitones letters))))
        ((null ref2)
         (let* ((str (symbol-name ref))
                (beg 0)
                (end (length str))
                (pos (- end 1))
                (sign 1)
                (size nil))
           (if (digit-char-p (elt str pos))
               (loop while (and (> (- pos 1) 0)
                                (digit-char-p (elt str (- pos 1))))
                     do (setf pos (- pos 1))
                     finally (setf
                              size
                              (read-from-string
                               (subseq str pos end))))
                     (error "~s is not an interval." ref))
               (if (char= (elt str 0) #\-)
                   (progn (setf sign -1) (incf beg))
                   (if (char= (elt str 0) #\+) (progn (incf beg))))
               (encode-interval (subseq str beg pos) (* size sign))))
         (t (encode-interval ref ref2))))

(setf *chromatic-scale*
      (make-instance
        <tuning>
        :name
        "chromatic-scale"
        :octaves
        '(-1 10)
        :lowest
        6.875
        :keynum-offset
        3
        :default-octave
        5
        :cents
        '((100 (c) (cn :accidental n) (bs :accidental s :octave -1)
           (dff :accidental ff))
          (100 (cs :accidental s) (df :accidental f)
           (bss :accidental ss :octave -1))
          (100 (d) (dn :accidental n) (css :accidental ss)
           (eff :accidental ff))
          (100 (ef :accidental f) (ds :letter d :accidental s)
           (fff :letter f :accidental ff))
          (100 (e) (en :accidental n) (ff :accidental f)
           (dss :accidental ss))
          (100 (f) (fn :accidental n) (es :accidental s)
           (gff :accidental ff))
          (100 (fs :accidental s) (gf :accidental f)
           (ess :accidental ss))
          (100 (g) (gn :accidental n) (fss :accidental ss)
           (aff :accidental ff))
          (100 (af :accidental f) (gs :accidental s))
          (100 (a) (an :accidental n) (gss :accidental ss)
           (bff :accidental ff))
          (100 (bf :accidental f) (as :accidental s)
           (cff :accidental ff :octave 1))
          (100 (b) (bn :accidental n) (cf :accidental f :octave 1)
           (ass :accidental ss)))))

(setf *scale* *chromatic-scale*)
