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

(in-package :cm)

(defun sco-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 optional key)
       `(progn (write-char ,delim ,filv) (write ,acc :stream ,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 make-sco-writer (objclassname objclassvar pars supers sdecl)
  sdecl
  supers
  (define-output-method objclassname objclassvar 'obj 'sco-stream
   '<sco-stream> 'io 'scoretime
   (list `(let ((fp (io-open io)))
            (princ (object-name obj) fp)
            ,@(mapcar (lambda (p)
                        (sco-par-print p 'obj 'fp 'scoretime))
                      pars)
            (terpri fp)
            (values)))))

(progn (defclass sco-stream (event-stream)
         ((header :initform nil :initarg :header :accessor
           sco-stream-header)
          (userargs :accessor sco-userargs :initform '()))
         #+metaclasses
         (:metaclass io-class))
       (defparameter <sco-stream> (find-class 'sco-stream))
       (finalize-class <sco-stream>)
       (setf (io-class-definer <sco-stream>) #'make-sco-writer)
       (setf (io-class-file-types <sco-stream>) '("*.sco"))
       (setf (io-class-mime-type <sco-stream>) "text/x-csound-score")
       (values))

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

(defmethod io-handler-args ((io sco-stream)) (sco-userargs io))

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

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

(defparameter *csound* "/usr/local/bin/csound")

(defun play-sco-file (file &key orchestra options output play?)
  (let ((cmd *csound*))
    (when options (setf cmd (concatenate 'string cmd " " options)))
    (when output (setf cmd (concatenate 'string cmd " -o" output)))
    (setf cmd (concatenate 'string cmd " " orchestra))
    (setf cmd (concatenate 'string cmd " " file))
    (shell cmd)
    (when (and play?
               (not (member output '("devaudio" "dac" "stdout"))))
      (shell (format nil "/usr/bin/play ~a" output)))))

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

(defmethod initialize-io ((io sco-stream))
  (format (io-open io)
          "; ~a output on ~a~%"
          (cm-version)
          (date-and-time))
  (let ((header (sco-stream-header io)))
    (cond ((consp header)
           (dolist (h header) (format (io-open io) "~a~%" h)))
          ((stringp header) (format (io-open io) "~a~%" header))
          ((not header) nil)
          (t (error "Bad .sco file header: ~s" header)))))

(defobject i (event) (ins dur) (:parameters time dur) (:writers))

(defmethod object-name ((obj i))
  (if (slot-boundp obj 'ins)
      (format nil "i~a" (slot-value obj 'ins))
      (let ((n (symbol-name (class-name (class-of obj)))))
        (if (char-lower-case? (elt n 0)) n (string-downcase n)))))

(defobject f (event) (num size gen) (:parameters time size gen)
 (:writers))

(defmethod object-name ((obj f))
  (if (slot-boundp obj 'num)
      (format nil "f~a" (slot-value obj 'num))
      (let ((n (symbol-name (class-name (class-of obj)))))
        (if (char-lower-case? (elt n 0)) n (string-downcase n)))))

(defun carry-pars (pars last)
  (let ((data pars) (head last) (pnum 1))
    (if (null last)
        (loop for p in data
              for i from 1
              collect (if (or (string= p ".")
                              (string= p "+")
                              (char= (elt p 0) #\^))
                          (error "No p~a value to carry in ~s"
                                 i
                                 pars)
                          (string-read p)))
              (do ()
                  ((or (null data) (null last))
                   (if (and (null data) (not (null last)))
                       (append pars last)
                       pars))
                (cond ((string= (car data) ".")
                       (rplaca data (car last)))
                      ((string= (car data) "+")
                       (unless (= pnum 2)
                         (error "Found p2 carry value ~s in p~d."
                                (car pars)
                                pnum))
                       (rplaca data (+ (cadr head) (caddr head))))
                      ((char= (elt (car data) 0) #\^)
                       (unless (= pnum 2)
                         (error "Found p2 carry value ~S in p~d."
                                (car pars)
                                pnum))
                       (let ((n (string-read (subseq (car data) 1))))
                         (rplaca data (+ (cadr head) n))))
                      (t
                       (rplaca data (string-read (car data)))
                       (unless (numberp (car data))
                         (format t
                                 "; warning: Importing non-numerical p~s value: ~s."
                                 pnum
                                 (car data)))
                       (rplaca last (car data))))
                (setf data (cdr data))
                (setf last (cdr last))
                (setf pnum (1+ pnum))))))

(defun parse-i-statement (line last)
  (let ((pars (list)))
    (setf pars (string-substrings line :start 1))
    (if (null pars)
        (setf pars
              (copy-list (if (null last)
                             (error "Dangling i_statement: ~a" line)
                             last)))
        (if (not (null last))
            (let ((p (car pars)))
              (when (or (digit-char-p (elt p 0))
                        (and (char= (elt p 0) #\-)
                             (digit-char-p (elt p 1))))
                (let ((n (string-read p)))
                  (unless (= (floor n) (floor (first last)))
                    (setf last (list)))))
              (if (not (null last))
                  (setf pars (carry-pars pars last))
                  (progn (setf pars (carry-pars pars (list)))
                         (setf last (copy-list pars)))))
            (progn (setf pars (carry-pars pars (list)))
                   (setf last (copy-list pars)))))
    (values pars last)))

(defmacro checkdefs (pars d)
  (let ((i (gensym)))
    `(let ((,i (floor (car ,pars))))
       (unless (assoc ,i ,d)
         (push (list ,i
                     (length ,pars)
                     (intern (format nil "i~a" ,i) :cm))
               ,d)))))

(defmethod import-events ((io sco-stream) &key (output))
  (let ((secs 0)
        (rate 60)
        (beat 0)
        (head (list))
        (list (list))
        (defs (list))
        (line nil)
        (next nil)
        (last (list))
        (pars (list))
        (sort nil)
        (keys (list))
        (statement nil)
        (in nil)
        (path nil)
        (name nil)
        (stop nil))
    rate
    keys
    path
    name
    (with-open-io (input io :input) (setf in (io-open input))
     (do ()
         (stop nil)
       (if next
           (setf line next)
           (let ((raw (file-line in)))
             (if (file-eof? raw)
                 (setf line raw)
                 (let ((pos (position #\; raw)))
                   (if pos (setf raw (subseq raw 0 pos)))
                   (setf line (string-trim '(#\Space #\Tab) raw))))))
       (cond ((file-eof? line) (setf stop t))
             ((string= line "") (setf next nil))
             ((member (elt line 0) '(#\i #\f #\a #\t #\s #\e))
              (if statement
                  (progn (case (elt statement 0)
                           (#\i
                            (multiple-value-setq (pars last)
                              (parse-i-statement statement last))
                            (push pars list)
                            (if (< (cadr pars) beat)
                                (setf sort t)
                                (setf beat (cadr pars)))
                            (checkdefs pars defs))
                           (#\f (push statement head)
                            (setf last nil))
                           (#\a
                            (format t
                                    "; Warning: a_statement not implemented: ~s"
                                    line)
                            (setf last nil))
                           (#\t
                            (setf rate
                                  (string-read (subseq statement 1)))
                            (setf last nil))
                           (#\s (setf secs (+ secs 1))
                            (when (> secs 1)
                              (format
                               t
                               "; Warning: Multiple 's' not implemented."))
                            (setf last nil))
                           (#\e (setf stop t) (setf last nil)))
                         (progn (setf statement nil)
                                (setf next line)))
                  (progn (setf statement line) (setf next nil)))
              (progn (if statement
                         (setf statement
                               (concatenate
                                'string
                                statement
                                " "
                                line))
                         (progn (format
                                 t
                                 "Skipping unimplemented statement:~% ~S"
                                 line)
                                (setf statement nil)))
                     (setf next nil)))))
     (if statement
         (if (char= (elt statement 0) #\i)
             (let ((pars (parse-i-statement statement last)))
               (push pars list)
               (if (< (cadr pars) beat)
                   (setf sort t)
                   (setf beat (cadr pars)))
               (checkdefs pars defs)))))
    (if (and (file-eof? line) list)
        (progn (if sort
                   (progn (format t "~%Sorting i statements...")
                          (setf list
                                (funcall
                                 sort
                                 list
                                 (lambda
                                  (a b)
                                  (< (cadr a) (cadr b)))))
                          (format t "done!"))
                   (setf list (nreverse list)))
               (sco-write-and-load io output defs list))
        nil)))

(defun sco-write-and-load (&rest args) args nil)
