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

(in-package :cm)

(defparameter *mp* ())

(defparameter *midi-connections* (quote ("MidiShare" "MidiShare")))

(progn (defclass midishare-stream (midi-stream)
         ((connections :initform *midi-connections* :initarg
           :connections :accessor midishare-stream-connections)
          (elt-type :initform :byte))
         #+metaclasses
         (:metaclass io-class))
       (defparameter <midishare-stream> (find-class
                                         'midishare-stream))
       (finalize-class <midishare-stream>)
       (setf (io-class-mime-type <midishare-stream>)
             "audio/x-midishare")
       (setf (io-class-file-types <midishare-stream>) '("*.ms"))
       (values))

(progn (defclass midi-port (midishare-stream)
         nil
         #+metaclasses
         (:metaclass io-class))
       (defparameter <midi-port> (find-class 'midi-port))
       (finalize-class <midi-port>)
       (setf (io-class-mime-type <midi-port>) "audio/x-midishare")
       (setf (io-class-file-types <midi-port>) '("midi.port"))
       (values))

(defmethod midishare-stream-refnum ((obj midishare-stream))
  (let ((ref (event-stream-stream obj)))
    (if (consp ref) (car ref) nil)))

(defmethod open-midishare-client ((obj midishare-stream) name)
  (midishare:midiopen name))

(defmethod close-midishare-client ((obj midishare-stream))
  (midishare:midiclose (midishare-stream-refnum obj)))

(defmethod open-io ((obj midishare-stream) dir &rest args)
  dir
  args
  (let ((res (midishare:midishare)))
    (unless (equal res 1)
      (error "Can't open MidiShare connection: MidiShare not loaded.")))
  (let ((name (object-name obj)))
    (unless (event-stream-stream obj)
      (let* ((client
              (if (or (not name) (string-equal name "midi.port"))
                  "Common Music"
                  (filename-name name)))
             (applid (midishare:midigetnamedappl client))
             (refnum
              (if (= applid -4)
                  (open-midishare-client obj client)
                  applid)))
        (when (= refnum -4)
          (error "Cannot open Midishare client ~S." client))
        (setf (event-stream-stream obj)
              (midishare-set-connections obj refnum))
        (setf (io-open obj) (event-stream-stream obj))))
    obj))

(defun midishare-set-connections (obj client)
  (flet ((conn? (x y) (= 1 (midishare:midiisconnected x y)))
         (getref (x)
           (cond ((stringp x)
                  (if (string= x "")
                      nil
                      (let ((a (midishare:midigetnamedappl x)))
                        (if (= a -4)
                            (error "Not a Midishare client: ~s." x)
                            a))))
                 ((integerp x)
                  (let ((a nil))
                    (dotimes (i (midishare:midicountappls))
                      (if (= x (midishare:midigetindappl (+ i 1)))
                          (setf a x)))
                    (or a
                        (error "Not a Midishare client refnum: ~S."
                               x))))
                 ((eq x t) 0)
                 ((not x) nil)
                 (t (error "Not a MidiShare client: ~s." x)))))
    (let ((conn (midishare-stream-connections obj))
          (inref nil)
          (outref nil))
      (cond ((consp conn)
             (setf inref (getref (first conn)))
             (when inref
               (unless (conn? inref client)
                 (midishare:midiconnect inref client -1)
                 (unless (conn? inref client)
                   (error "Input connection from ~S to ~S failed."
                          (midishare:midigetname inref)
                          (midishare:midigetname client)))))
             (when (consp (cdr conn))
               (setf outref (getref (second conn)))
               (when outref
                 (unless (conn? client outref)
                   (midishare:midiconnect client outref -1)
                   (unless (conn? client outref)
                     (error "Output connection from ~S to ~S failed."
                            (midishare:midigetname client)
                            (midishare:midigetname outref)))))))
            (t
             (setf outref (getref conn))
             (when outref
               (unless (conn? client outref)
                 (midishare:midiconnect client outref -1)
                 (unless (conn? client outref)
                   (error "Output connection from ~S to ~S failed."
                          (midishare:midigetname client)
                          (midishare:midigetname outref)))))))
      (list client inref outref nil))))

(defmethod close-io ((obj midishare-stream) &rest mode)
  (if (eq (car mode) ':force)
      (progn (close-midishare-client obj)
             (setf (event-stream-stream obj) nil)
             (setf (io-open obj) nil)))
  (values))

(defmethod open-io ((obj midi-port) dir &rest args)
  dir
  args
  (when (not (io-open obj))
    (call-next-method)
    (setf *mp* (midishare-stream-refnum obj)))
  obj)

(defmethod close-io ((obj midi-port) &rest mode)
  (when (eq (car mode) ':force)
    (if (receive?) (receive))
    (call-next-method)
    (setf *mp* nil))
  (values))

(defun midi-open (&rest args) (apply #'open-io "midi.port" t args))

(defun midi-open? ()
  (let ((p (find-object "midi.port"))) (and p (io-open p) p)))

(defun midi-close ()
  (if (midi-open?)
      (progn (close-io (find-object "midi.port") ':force))
      nil)
  (values))

(defmethod initialize-io ((obj midishare-stream))
  (setf (object-time obj) (midishare:midigettime))
  (channel-tuning-init obj))

(defmethod deinitialize-io ((obj midishare-stream))
  (setf (object-time obj) 0))

(defun midishare:new (type &key (date 0) (port 0) (chan 0) (pitch 60)
                      (vel 64) (dur 500) (pressure 0) (controller 0)
                      (change 0) (bend 0) (program 0) (numerator 4)
                      (denominator 4) (clocks 24) (32nds 8) (sign 0)
                      (mode 0) (tempo 120) (number 0) (prefix 0)
                      (text "") (position 0) (song 0) (data '())
                      (offset '()))
  (let ((ev (midishare:midinewev type)))
    (midishare:date ev date)
    (midishare:port ev port)
    (midishare:chan ev chan)
    (cond ((<= typenote type typekeyoff)
           (midishare:field ev 0 pitch)
           (midishare:field ev 1 vel)
           (when (eq type typenote) (midishare:field ev 2 dur)))
          ((= type typekeypress)
           (midishare:field ev 0 pitch)
           (midishare:field ev 1 pressure))
          ((= type typectrlchange)
           (midishare:field ev 0 controller)
           (midishare:field ev 1 change))
          ((= type typeprogchange) (midishare:field ev 0 program))
          ((= type typechanpress) (midishare:field ev 0 pressure))
          ((= type typepitchbend)
           (midishare:bend ev
                           (if (<= -8192 bend 8191)
                               bend
                               (error
                                ":bend value ~s not between -8192 8191."
                                bend))))
          ((= type typesongpos)
           (let ((num (/ position 6)))
             (multiple-value-bind (msb lsb)
                 (floor num 128)
               (midishare:field ev 0 msb)
               (midishare:field ev 1 lsb))))
          ((= type typesongsel) (midishare:field ev 0 song))
          ((<= typeclock type typereset) nil)
          ((= type typesysex)
           (do ((l data (cdr l)))
               ((null l) nil)
             (midishare:midiaddfield ev (car l))))
          ((= type typeseqnum) (midishare:field ev 0 number))
          ((<= typetextual type typecuepoint)
           (midishare:text ev text))
          ((= type typechanprefix) (midishare:field ev 0 prefix))
          ((= type typeendtrack) nil)
          ((= type typetempo)
           (midishare:field ev 0 (floor (/ 60000000 tempo))))
          ((= type typesmpteoffset)
           (unless (= (length offset) 5)
             (error ":offset value ~s not list (hr min sec frame subframe)"
                    offset))
           (midishare:field ev
                            0
                            (+ (* (elt offset 0) 3600)
                               (* (elt offset 1) 60)
                               (elt offset 2)))
           (midishare:field ev
                            1
                            (+ (* (elt offset 3) 100)
                               (elt offset 4))))
          ((= type typetimesign)
           (midishare:field ev 0 numerator)
           (midishare:field ev 1 denominator)
           (midishare:field ev 2 clocks)
           (midishare:field ev 3 32nds))
          ((= type typekeysign)
           (midishare:field ev
                            0
                            (if (<= -7 sign 7)
                                (if (< sign 0) (+ sign 256) sign)
                                (error
                                 ":sign value ~s is not between -7 and 7."
                                 sign)))
           (midishare:field ev 1 mode))
          (t
           (error "Unimplemented MidiShare event type opcode: ~s."
                  type)))
    ev))

(defparameter midievnames #("Note" "KeyOn" "KeyOff" "KeyPress"
                            "CtrlChange" "ProgChange" "ChanPress"
                            "PitchBend" "SongPos" "SongSel" "Clock"
                            "Start" "Continue" "Stop" "Tune"
                            "ActiveSens" "Reset" "SysEx" "SeqNum"
                            "Text" "Copyright" "SeqName" "InstrName"
                            "Lyric" "Marker" "CuePoint" "ChanPrefix"
                            "EndTrack" "Tempo" "SMPTEOffset"
                            "TimeSign" "KeySign"))

(defun midishare:midiprintev (ev &rest stream)
  (let ((to (if (null stream) t (car stream)))
        (ty (midishare:evtype ev))
        (cl nil))
    (cond ((<= typenote ty typesysex) (setf cl (elt midievnames ty)))
          ((<= typeseqnum ty typekeysign)
           (set cl
                (elt midievnames (+ (- ty typeseqnum) typesysex 1))))
          (t nil))
    (if (not cl)
        (format to "~s" ev)
        (let ((ch (midishare:chan ev))
              (po (midishare:port ev))
              (da (midishare:date ev)))
          (format to "#<MidiEv ~a [~s/~s ~sms]" cl po ch da)
          (cond ((<= typenote ty typekeyon)
                 (format to
                         " ~s ~s"
                         (midishare:field ev 0)
                         (midishare:field ev 1))
                 (if (= ty typenote)
                     (format to " ~sms" (midishare:field ev 3))))
                ((= ty typepitchbend)
                 (format to
                         " ~s ~s"
                         (midishare:field ev 0)
                         (midishare:field ev 1)))
                ((= ty typeprogchange)
                 (format to " ~s" (midishare:field ev 0)))
                ((= ty typectrlchange)
                 (format to
                         " ~s ~s"
                         (midishare:field ev 0)
                         (midishare:field ev 1)))
                ((= ty typesongpos)
                 (format to
                         " ~s ~s"
                         (midishare:field ev 0)
                         (midishare:field ev 1)))
                ((= ty typesongsel)
                 (format to " ~s" (midishare:field ev 0)))
                ((= ty typesysex) nil)
                ((= ty typeseqnum)
                 (format to " ~s" (midishare:field ev 0)))
                ((<= typetextual ty typecuepoint) nil)
                ((= ty typechanprefix)
                 (format to " ~s" (midishare:field ev 0)))
                ((= ty typeendtrack) nil)
                ((= ty typetempo)
                 (format to " ~susec" (midishare:field ev 0)))
                ((= ty typesmpteoffset)
                 (format to
                         " ~s ~s"
                         (midishare:field ev 0)
                         (midishare:field ev 1)))
                ((= ty typetimesign)
                 (format to
                         " ~s ~s ~s ~s"
                         (midishare:field ev 0)
                         (midishare:field ev 1)
                         (midishare:field ev 2)
                         (midishare:field ev 3)))
                ((= ty typekeysign)
                 (format to
                         " ~s ~s"
                         (midishare:field ev 0)
                         (midishare:field ev 1)))
                (t nil))
          (format to ">")))))

(defmethod write-event ((obj midi) (stream midishare-stream)
                        scoretime)
  (let* ((beg (+ (object-time stream) (floor (* scoretime 1000))))
         (dur (floor (* (midi-duration obj) 1000)))
         (key (midi-keynum obj))
         (amp (midi-amplitude obj))
         (loc
          (logical-channel (midi-channel obj)
           (midi-stream-channel-map stream)))
         (prt (car loc))
         (chn (cadr loc))
         (evt nil))
    (cond ((and (integerp amp) (<= 0 amp 127)) nil)
          ((and (floatp amp) (<= 0.0 amp 1.0))
           (setf amp (floor (* amp 127))))
          (t
           (error "Can't convert amplitude ~s to midi velocity."
                  amp)))
    (ensure-microtuning key chn stream)
    (setf evt
          (midishare:new typenote :port prt :chan chn :pitch key :vel
           amp :dur dur))
    (midishare:midisendat (midishare-stream-refnum stream) evt beg)
    (values)))

(defparameter opcodes-evtypes (list
                               (list
                                (list +ml-note-on-opcode+ 1)
                                (list +ml-note-off-opcode+ 2)
                                (list +ml-key-pressure-opcode+ 3)
                                (list +ml-control-change-opcode+ 4)
                                (list +ml-program-change-opcode+ 5)
                                (list +ml-channel-pressure-opcode+ 6)
                                (list +ml-pitch-bend-opcode+ 7))))

(defun midi-op->evtype (op set)
  (let ((e (assoc op (elt opcodes-evtypes set))))
    (if e
        (or (cadr e)
            (error "No MidiShare evType for event opcode ~s." op))
        (error "No MidiShare evType for event opcode ~s." op))))

(defmethod write-event ((obj midi-channel-event)
                        (stream midishare-stream) scoretime)
  (let* ((opr (slot-value obj 'opcode))
         (typ (midi-op->evtype opr 0))
         (beg (+ (object-time stream) (floor (* scoretime 1000))))
         (loc
          (logical-channel (midi-event-channel obj)
           (midi-stream-channel-map stream)))
         (dat (midi-event-data2 obj))
         (evt (midishare:midinewev typ)))
    (midishare:port evt (car loc))
    (midishare:chan evt (cadr loc))
    (midishare:date evt beg)
    (midishare:field evt 0 (midi-event-data1 obj))
    (if (= typ typepitchbend)
        (bend evt (midi-pitch-bend-bend obj))
        (if dat (midishare:field evt 1 dat)))
    (midishare:midisendat (midishare-stream-refnum stream) evt beg)
    evt))

(defun make-proctable (num) (reset-proctable (make-array num)))

(defun reset-proctable (tbl)
  (do ((num (length tbl)) (pos 0 (+ pos 1)))
      ((= pos num) (setf (elt tbl (- num 1)) nil) tbl)
    (setf (elt tbl pos) (+ pos 1))))

(defparameter *proctable* (make-proctable 64))

(defun add-proc (proc)
  (let ((free (elt *proctable* 0)))
    (if free
        (progn (setf (elt *proctable* 0) (elt *proctable* free))
               (setf (elt *proctable* free) proc)
               free)
        nil)))

(defun rem-proc (index)
  (setf (elt *proctable* index) (elt *proctable* 0))
  (setf (elt *proctable* 0) index)
  (values))

(defun rt-sprout (obj &optional ahead)
  (let ((id (add-proc obj)))
    (if id
        (midishare:miditask run-proc
                            (+ (midishare:midigettime) (or ahead 0))
                            *mp*
                            id
                            0
                            0)
        (warn "Can't sprout, no room left in process table!")))
  (values))

(defun rt-output (ev &optional ahead)
  (if ahead
      (midishare:midisendat *mp*
                            ev
                            (+ ahead (midishare:midigettime)))
      (midishare:midisendim *mp* ev))
  (values))

(defun rt-now () (midishare:midigettime))

(defparameter *receive-hook* ())

(defun receive? () (and *receive-hook* t))

(defun receive (&optional hook)
  (if (midi-open?)
      (if hook
          (if *receive-hook*
              (format t
                      "Already receiving MIDI, type (ms:receive) to stop.~%")
              (progn (setf *receive-hook* hook)
                     (midishare:midisetrcvalarm
                       *mp*
                       midi-receive-hook)))
          (if (not *receive-hook*)
              (format t "Not currently receiving MIDI.~%")
              (progn (setf *receive-hook* nil)
                     (midishare:midisetrcvalarm
                       *mp*
                       (midishare:nullptr)))))
      (format t "MIDI not open!"))
  (values))
