;;; **********************************************************************
;;; 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 cmn.scm on 23-Mar-2005 12:21:29

(in-package :cm)

(progn (defclass cmn-stream (event-stream)
         ((cmnargs :initform '() :accessor cmn-args)
          (exact :initform nil :initarg :exact-rhythms)
          (staffing :initform '() :accessor cmn-staffing :initarg
           :staffing))
         #+metaclasses
         (:metaclass io-class))
       (defparameter <cmn-stream> (find-class 'cmn-stream))
       (finalize-class <cmn-stream>)
       (setf (io-class-file-types <cmn-stream>) '("*.cmn" "*.eps"))
       (values))

(defun set-cmn-output-hook! (fn)
  (unless (or (not fn) (functionp fn))
    (error "Not a cmn output hook: ~s" fn))
  (setf (io-class-output-hook <cmn-stream>) fn)
  (values))

(defun set-cmn-stream-versions! (val)
  (setf (io-class-file-versions <cmn-stream>) val)
  (values))

(defmethod io-handler-args? ((io cmn-stream)) io t)

(defmethod io-handler-args ((io cmn-stream)) (cmn-args io))

(defmethod set-io-handler-args! ((io cmn-stream) args)
  (setf (cmn-args io) args)
  (values))

(defparameter *cmn-staves* (make-hash-table :size 31 :test #'equal))

(defun make-staffing (id &key name clef meter)
  (list id nil (or name (format nil "staff-~a" id)) clef meter))

(defmethod close-io ((io cmn-stream) &rest mode)
  mode
  (setf (io-open io) nil))

(defmethod open-io ((io cmn-stream) dir &rest args)
  args
  (when (eq dir ':output)
    (setf (io-open io)
          (init-clm-input
           (apply #'make-instance
                  (find-class 'score)
                  :output-file
                  (file-output-filename io)
                  (cmn-args io))))
    (setf *exact-rhythms* (slot-value io 'exact)))
  io)

(defmethod initialize-io ((io cmn-stream))
  (let ((score (io-open io)))
    (clrhash *cmn-staves*)
    (loop for s in (cmn-staffing io)
          for c = (apply #'make-staffing s)
          do (rplaca (cdr c) (add-staff score (third c) '()))
             (setf (gethash (first c) *cmn-staves*) c))
          (values)))

(defun set-one-staff-meter (staff meter)
  (let ((stfd (find staff staff-descriptors :key #'stfdat-staff)))
    (setf (staff-data (stfdat-staff stfd))
          (append (staff-data (stfdat-staff stfd))
                  (list (cmn-eval meter))))))

(defmethod deinitialize-io ((io cmn-stream))
  (flet ((get-active-staff-actions (score)
           score
           (let ((ids
                  (sort (hash-fold (lambda (k v p) v (cons k p)) '()
                         *cmn-staves*)
                        #'<))
                 (data '()))
             (dolist (id ids)
               (let* ((desc (gethash id *cmn-staves*))
                      (staff (second desc))
                      (label (third desc))
                      (clefs (fourth desc))
                      (meter (elt desc 4))
                      (count nil))
                 (when (staff-data staff)
                   (if (not (listp clefs)) (setf clefs (list clefs)))
                   (setf meter (elt desc 4))
                   (setf count (if (member ':both clefs) 2 1))
                   (push (list 'set-staff-number label count) data)
                   (when clefs
                     (push (list* 'set-staff-clef label clefs) data))
                   (when meter
                     (if (consp meter)
                         (unless (eq (first meter) 'meter)
                           (push 'meter meter))
                         (error "meter should be list like: (meter 3 4)"))
                     (push (list 'set-one-staff-meter label meter)
                           data)))))
             (nreverse data))))
    (let* ((score (io-open io))
           (path (file-output-filename io))
           (type (if (string= (filename-type path) "cmn") :cmn nil))
           (args '()))
      (unless (eq type ':cmn)
        (format t "~%Manuscripting ~a..." path))
      (setf args (get-active-staff-actions score))
      (apply #'finish-clm-input score type nil args))))

(defun cmn-eval (form)
  (flet ((cmnfun (sym)
           (let ((fun (find-symbol (symbol-name sym) :cmn)))
             (unless (and fun (fboundp fun))
               (error "~S is not a cmn function!" sym))
             fun))
         (cmnvar (sym)
           (let ((var (find-symbol (symbol-name sym) :cmn)))
             (unless (and var (boundp var))
               (error "~S is not a cmn variable." sym))
             (symbol-value var))))
    (cond ((consp form)
           (apply (cmnfun (car form))
                  (mapcar #'cmn-eval (cdr form))))
          ((constantp form) form)
          (form (cmnvar form))
          (t nil))))

(defun add-default-staff (id score)
  (let* ((entry (make-staffing id))
         (sname (third entry))
         (staff
          (or (find-staff score sname) (add-staff score sname '()))))
    (rplaca (cdr entry) staff)
    entry))

(defmethod write-event ((obj standard-object) (io cmn-stream)
                        scoretime)
  (let ((score (io-open io))
        (data (object->cmn obj))
        (entry nil)
        (staff nil))
    (unless (consp data)
      (error "object->cmn did not return a list: ~s.:" data))
    (setf entry (gethash (first data) *cmn-staves*))
    (unless entry
      (setf entry (add-default-staff (first data) score)))
    (setf staff (second entry))
    (if (= (length data) 2)
        (add-data-1 score staff (cmn-eval (second data)))
        (let ((dur (second data))
              (note (third data))
              (args
               (loop for i in (cdddr data) collect (cmn-eval i))))
              (unless (rest? note)
                (apply #'add-note-to-staff
                       score
                       staff
                       scoretime
                       dur
                       (cmn-eval note)
                       args))))))

(defobject cmn (event)
 ((staff :initform 0) (expr :initform nil :initarg :note)
  (duration :initform nil) (data :initform 'nil)))

(defmethod initialize-instance :after ((obj cmn) &rest args)
  args
  (do ((a args (cddr a)))
      ((null a) nil)
    (case (car a)
      ((:note) (setf (cmn-expr obj) (cadr a)))
      ((:expr) (setf (cmn-expr obj) (cadr a))))))

(defmethod object->cmn ((obj cmn))
  (let ((d (cmn-duration obj)))
    (if d
        (let ((n
               (or (note (cmn-expr obj) :in? *chromatic-scale*)
                   (error "cmn: '~s' is not a note for duration ~s."
                          (cmn-expr obj)
                          d))))
          (list* (cmn-staff obj)
                 d
                 n
                 (let ((x (cmn-data obj)))
                   (unless (listp x)
                     (error "cmn data '~s' is not a list." x))
                   x)))
        (list (cmn-staff obj)
              (let ((e (cmn-expr obj)) (x (cmn-data obj)))
                (if e
                    (if x
                        (progn (unless
                                (listp x)
                                (error
                                 "cmn data '~s' is not a list."
                                 x))
                               `(engorge (list ,e ,@x)))
                        e)
                    (if x
                        `(engorge (list ,@x))
                        (error "cmn: missing :expr, :note or :data"))))))))

(defmethod object->midi ((obj cmn))
  (let ((e (cmn-expr obj))
        (b (object-time obj))
        (d (cmn-duration obj)))
    (if d
        (make-instance
          <midi>
          :time
          b
          :duration
          d
          :channel
          (cmn-staff obj)
          :keynum
          e)
        (if (consp e)
            (case (car e)
              ((mm)
               (make-instance
                 <midi-tempo-change>
                 :time
                 b
                 :usecs
                 (floor (* (/ 60 (cadr e)) 1000000))))
              ((meter)
               (make-instance
                 <midi-time-signature>
                 :time
                 b
                 :numerator
                 (cadr e)
                 :denominator
                 (caddr e)))
              (t nil))
            (let* ((l
                    '((cf-major af-minor) (gf-major ef-minor)
                      (df-major bf-minor) (af-major f-minor)
                      (ef-major c-minor) (bf-major g-minor)
                      (f-major d-minor) (c-major a-minor)
                      (g-major e-minor) (d-major b-minor)
                      (a-major fs-minor) (e-major cs-minor)
                      (b-major gs-minor) (fs-major ds-minor)
                      (cs-major as-minor)))
                   (p (position e l :test #'member)))
              (if p
                  (make-instance
                    <midi-key-signature>
                    :time
                    b
                    :key
                    (- p 7)
                    :mode
                    (position e (elt l p)))
                  nil))))))

(defmethod object->cmn ((obj midi))
  (list (midi-channel obj)
        (midi-duration obj)
        (note (midi-keynum obj))))
