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

(in-package :cm)

(defun clm-print-par-value (v s)
  (when (consp v) (write-char #\' s))
  (write v :stream s))

(defun clm-par-print (par objv filv timv)
  (let* ((raw
          (if (parameter-time? par)
              timv
              (slot-getter-form objv (parameter-slot par))))
         (acc
          (if (parameter-decimals par)
              `(decimals ,raw ,(parameter-decimals par))
              raw))
         (delim #\Space))
    (case (parameter-type par)
      ((required)
       `(progn (write-char ,delim ,filv)
               (clm-print-par-value ,acc ,filv)))
      ((optional)
       (let ((form `(clm-print-par-value ,acc ,filv)))
         `(if (slot-boundp ,objv ',(parameter-slot par))
              (progn (write-char ,delim ,filv) ,form))))
      ((key)
       `(if (slot-boundp ,objv ',(parameter-slot par))
            (progn (write-char ,delim ,filv)
                   (write ',(parameter-prefix par) :stream ,filv)
                   (write-char ,delim ,filv)
                   (clm-print-par-value ,acc ,filv))))
      ((rest)
       (let ((v (gensym)))
         `(if (slot-boundp ,objv ',(parameter-slot par))
              (do ((,v ,(slot-getter-form objv (parameter-slot par))
                    (cdr ,v)))
                  ((null ,v) nil)
                (write-char ,delim ,filv)
                (write (car ,v) :stream ,filv))))))))

(defun clm-writer (objclassname objclassvar pars supers sdecl)
  supers
  sdecl
  (define-output-method objclassname objclassvar 'obj 'clm-stream
   '<clm-stream> 'io 'scoretime
   (list `(let ((fp (io-open io)))
            (write-char #\( fp)
            (princ (object-name obj) fp)
            ,@(mapcar (lambda (p)
                        (clm-par-print p 'obj 'fp 'scoretime))
                      pars)
            (write-char #\) fp)
            (terpri fp)
            (values)))))

(progn (defclass clm-stream (event-stream)
         ((clmargs :initform '() :accessor clm-args))
         #+metaclasses
         (:metaclass io-class))
       (defparameter <clm-stream> (find-class 'clm-stream))
       (finalize-class <clm-stream>)
       (setf (io-class-definer <clm-stream>) #'clm-writer)
       (setf (io-class-mime-type <clm-stream>) "text/x-clm-score")
       (setf (io-class-file-types <clm-stream>) '("*.clm"))
       (values))

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

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

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

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

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

(defmethod initialize-io ((io clm-stream))
  (when (eq (io-direction io) ':output)
    (format (io-open io)
            ";;; ~a output on ~a~%"
            (cm-version)
            (date-and-time))))

(defun play-clm-file (file &rest args)
  (apply #'clm-load file :play t args))

(defun snd-writer (objclassname objclassvar pars supers sdecl)
  supers
  sdecl
  (flet ((parf (par objv argsv timv)
           (let* ((raw
                   (if (parameter-time? par)
                       timv
                       (slot-getter-form objv (parameter-slot par))))
                  (acc
                   (if (parameter-decimals par)
                       `(decimals ,raw ,(parameter-decimals par))
                       raw)))
             (case (parameter-type par)
               ((required)
                `(progn (rplacd ,argsv (list ,acc))
                        (setf ,argsv (cdr ,argsv))))
               ((optional)
                `(if (slot-boundp ,objv ',(parameter-slot par))
                     (progn (rplacd ,argsv (list ,acc))
                            (setf ,argsv (cdr ,argsv)))))
               ((key)
                `(if (slot-boundp ,objv ',(parameter-slot par))
                     (progn (rplacd ,argsv
                                    (list ',(parameter-prefix par)))
                            (setf ,argsv (cdr ,argsv))
                            (rplacd ,argsv (list ,acc))
                            (setf ,argsv (cdr ,argsv)))))
               ((rest)
                `(if (slot-boundp ,objv ',(parameter-slot par))
                     (progn (rplacd ,argsv ,acc)
                            (setf ,argsv (cdr ,argsv)))))))))
    (define-output-method objclassname objclassvar 'obj
     'clm-audio-stream '<clm-audio-stream> 'io 'scoretime
     (list `(let* ((args (list nil)) (tail args))
              (if (eq (slot-value io 'output-trace) t)
                  (format t
                          "~a ~s..."
                          (object-name obj)
                          (decimals scoretime 3)))
              ,@(mapcar (lambda (p) (parf p 'obj 'tail 'scoretime))
                        pars)
              (apply (symbol-function (object-name obj)) (cdr args))
              (values))))))

(progn (defclass clm-audio-stream (event-stream)
         ((clmargs :initform '() :accessor clm-args)
          (output-trace :initform :info :initarg :trace-output
           :accessor audio-file-output-trace))
         #+metaclasses
         (:metaclass io-class))
       (defparameter <clm-audio-stream> (find-class
                                         'clm-audio-stream))
       (finalize-class <clm-audio-stream>)
       (setf (io-class-definer <clm-audio-stream>) #'snd-writer)
       (setf (io-class-mime-type <clm-audio-stream>)
             "audio/x-clm-audio")
       (setf (io-class-file-types <clm-audio-stream>)
             '("*.snd" "*.aiff" "*.wav"))
       (values))

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

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

(defmethod io-handler-args? ((io clm-audio-stream)) io t)

(defmethod io-handler-args ((io clm-audio-stream)) (clm-args io))

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

(defun formals->defobject (form &optional tpar)
  (let* ((&keys '(&optional &rest &key &aux &allow-other-keys))
         (name (pop form))
         (pars
          (mapcar (lambda (x)
                    (case x
                      ((:optional) '&optional)
                      ((:rest) '&rest)
                      ((:key) '&key)
                      ((:aux) '&aux)
                      ((:allow-other-keys) '&allow-other-keys)
                      (t (if (consp x) (car x) x))))
                  form))
         (slots '()))
    (do ((tail pars (cdr tail)))
        ((null tail) (setf slots (reverse slots)))
      (unless (member (car tail) &keys)
        (if (or (and tpar (equal (car tail) tpar))
                (member (car tail) *time-slots*))
            (push (list (car tail) :accessor 'object-time) slots)
            (push (car tail) slots))))
    `(defobject ,name () ,slots (:parameters ,@pars))))

(defparameter *clm-imports* (list))

(defparameter *clm-import-translations* (quote
                                         ((let import-let)
                                          (let* import-let)
                                          (progn import-progn)
                                          (clm:with-sound
                                           import-with-sound)
                                          (defun import-defun))))

(defun import-form (form translate exclude include &optional
                    toplevel?)
  (let ((sym (car form)))
    (if (or (not (and sym (symbolp sym)))
            (and toplevel? (member sym exclude)))
        nil
        (let* ((obj (find-class sym nil))
               (pars (and obj (class-parameters obj))))
          (if pars
              (import-object pars form)
              (let ((trans (assoc sym translate)))
                (if trans
                    (funcall (cadr trans)
                             form
                             translate
                             exclude
                             include)
                    (if (or (fboundp sym) (special-operator-p sym))
                        form
                        (if (and include
                                 (or
                                  (eq include t)
                                  (member sym include)))
                            form
                            (progn (format
                                    t
                                    "~%Skipping undefined function: ~s."
                                    sym)
                                   nil))))))))))

(defun import-let (form translate exclude include)
  (let ((body
         (loop for f in (cddr form)
               for r = (import-form f translate exclude include)
               when r collect r)))
         (if body (list* (car form) (cadr form) body) nil)))

(defun import-progn (form translate exclude include)
  (let ((body
         (loop for f in (cdr form)
               for r = (import-form f translate exclude include t)
               when r collect r)))
         (if body `(progn ,@body) nil)))

(defun import-with-sound (form translate exclude include)
  (values (loop for f in (cddr form)
                for r = (import-form f translate exclude include t)
                when r collect r) t))

(defun import-defun (form trans excl inc)
  (list* 'defun
         (cadr form)
         (caddr form)
         (loop for f in (cdddr form)
               collect (import-form f trans excl inc))))

(defun import-object (pars forms)
  (let ((save forms)
        (name (pop forms))
        (reqs nil)
        (opts nil)
        (rest nil)
        (keys nil))
    (setf reqs
          (loop with par
                while (and (not (null forms))
                           (eq (parameter-type (car pars))
                               'required))
                do (setf par (pop pars))
                collect (parameter-slot par)
                collect (pop forms)))
          (setf opts
                (loop with par
                      while (and (not (null forms))
                                 (eq
                                  (parameter-type (car pars))
                                  'optional))
                      do (setf par (pop pars))
                      collect (parameter-slot par)
                      collect (pop forms)))
                (when (and (not (null forms))
                           (eq (parameter-type (car pars)) 'rest))
                  (setf rest forms)
                  (pop pars))
                (setf keys
                      (loop with par
                            while (not (null forms))
                            do (setf
                                par
                                (find
                                 (car forms)
                                 pars
                                 :key
                                 #'parameter-prefix))
                               (or
                                par
                                (error
                                 "No slot for ~s in ~s."
                                 (car forms)
                                 save))
                            collect (parameter-slot par)
                            collect (cadr forms)
                            do (setf forms (cddr forms))))
                      `(push (new ,name ,@reqs ,@opts ,@rest ,@keys)
                             *clm-imports*)))

(defmethod import-events ((io clm-stream) &key (output nil)
                          (translations *clm-import-translations*)
                          (include nil) (exclude nil) (seq t))
  (flet ((fprint (f s) (format s "~S~%" f)))
    (let* ((clmname (io-filename io))
           (seqname (format nil "from-~a" (filename-name clmname)))
           (*print-case* ':downcase)
           (outfil nil))
      (unless output
        (setf output
              (concatenate 'string
                           (filename-directory clmname)
                           (filename-name clmname)
                           ".cm")))
      (unless (or (eq include t) (listp include))
        (error ":include value not ~s or list: ~s" t include))
      (unless (listp exclude)
        (error ":exclude value not list: ~s." exclude))
      (setf outfil (open-file output :output))
      (with-open-io (infil io :input) (setf infil (io-open io))
       (format outfil
               ";;; Imported from ~s on ~a~%"
               clmname
               (date-and-time))
       (fprint `(setf *clm-imports* (list)) outfil)
       (loop with trans
             and flag
             for form = (file-form infil)
             until (file-eof? form)
             when (and (consp form)
                       (let ((t9 (car form))) (and t9 (symbolp t9))))
               do (unless (eq include t)
                    (when (member (car form)
                                  '(defun defmacro define))
                      (unless (member (cadr form) exclude)
                        (unless (member (cadr form) include)
                          (push (cadr form) include)))))
                  (multiple-value-setq (trans flag)
                    (import-form form translations exclude include
                     t))
                  (when trans
                    (if flag
                        (dolist (x trans) (fprint x outfil))
                        (fprint trans outfil))))
               (if seq
                   (fprint
                    `(setf *clm-imports*
                           (new seq :name
                            ,(if (eq seq t) seqname `',seq)
                            :subobjects (nreverse *clm-imports*)))
                    outfil)
                   (fprint
                    `(setf *clm-imports* (nreverse *clm-imports*))
                    outfil)))
             (close-file outfil ':output)
             (setf *clm-imports* (list))
             (load output)
             *clm-imports*)))
