;;; -*- Mode:LISP; Package:MIDI; Readtable:CL; Base:10 -*-
;;;
;;; Defs for MIDI I/O
;;;
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; MIDI Input
;;;

(defvar *midi-vcmem-quad-slot* #xf8)

(defun vcmem-setup ()
  (dolist (x '(0 0 0 #x18 #x01 #x18 #x03 #xc1 #x04 #xc4 #x05 #xea))
    (%nubus-write *midi-vcmem-quad-slot* (* #o15 4) x)))

(defsubst vcmem-char-available-p ()
  (ldb-test (byte 1 0) (%nubus-read *midi-vcmem-quad-slot* (* #o15 4))))

(defun vcmem-tyi ()
  (cond ((null (vcmem-char-available-p))
	 (process-wait "Midi-Tyi" 'vcmem-char-available-p)))
  (ldb (byte 8 0) (%nubus-read *midi-vcmem-quad-slot* (* #o14 4))))

(defun vcmem-tyi-busy-wait ()
  (do ()
      ((vcmem-char-available-p)))
  (ldb (byte 8 0) (%nubus-read *midi-vcmem-quad-slot* (* #o14 4))))

(defun read-array (8-bit-array &optional (start 0) (end (array-length 8-bit-array)))
  (send *terminal-io* :clear-input)
;  (process-sleep 10)
  (do ((count start (add1 count)))
      ((= count end))
    (without-interrupts
      (do ()
	  ((vcmem-char-available-p))
	(when (tv:kbd-hardware-char-available)
	  (return-from read-array :aborted)))
      (aset (ldb (byte 8 0) (%nubus-read *midi-vcmem-quad-slot* (* #o14 4)))
	    8-bit-array
	    count))))
	  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; MIDI output
;;;
;;;

(defsubst vcmem-output-buffer-empty-p ()
  (ldb-test (byte 1 2) (%nubus-read *midi-vcmem-quad-slot* (* #o15 4))))

(defun vcmem-tyo (c)
  (do ()
      ((vcmem-output-buffer-empty-p)))
  (%nubus-write *midi-vcmem-quad-slot* (* #o14 4) c))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Random stuff
;;;
;;;


(defun @note-off (note &optional (channel 0) (velocity 64.))
  (vcmem-tyo (dpb channel (byte 4 0) #b10000000))
  (vcmem-tyo note)
  (vcmem-tyo velocity))

(defun @note-on (note &optional (channel 0) (velocity 64.))
  (vcmem-tyo (dpb channel (byte 4 0) #b10010000))
  (vcmem-tyo note)
  (vcmem-tyo velocity))

;(defun @key-after-touch (note &optional (channel 0) (velocity 64.))
;  (midi-tyo (dpb channel (byte 4 0) #xa0) t)
;  (midi-tyo note)
;  (midi-tyo velocity))

;(defun @control-change (control-number &optional (channel 0) (value 0))
;  (midi-tyo (dpb channel (byte 4 0) #xb0) t)
;  (midi-tyo control-number)
;  (midi-tyo value))

;(defun @program-change (program-number &optional (channel 0))
;  (midi-tyo (dpb channel (byte 4 0) #xc0) t)
;  (midi-tyo program-number))

;(defun @channel-after-touch (value &optional (channel 0))
;  (midi-tyo (dpb channel (byte 4 0) #xd0) t)
;  (midi-tyo value))

;(defun @pitch-wheel (value &optional (channel 0))
;  (midi-tyo (dpb channel (byte 4 0) #xe0) t)
;  (midi-tyo (ldb (byte 7 0) value))
;  (midi-tyo (ldb (byte 7 7) value)))

;(defun set-controller-value (controller value &optional (channel 0))
;  (cond ((< controller 32.)
;	 (@control-change controller channel (ldb (byte 7 0) value)) ;LSB
;	 (@control-change (+ 32. controller) channel (ldb (byte 7 7) value)) ;MSB
;	 )
;	((< controller 122.)
;	 (@control-change controller channel value))
;	(t
;	 (ferror nil "reserved"))))

;(defun all-notes-off (&optional (channel 0))
;  (@control-change 123. channel 0))

;(defun omni-mode (on-p &optional (channel 0))
;  (if on-p
;      (@control-change 124. channel 0)
;    (@control-change 125. channel 0)))

;(defun poly-mode (on-p &optional (channel 0))
;  on-p
;  (@control-change 127. channel 0))

;(defun print-just-notes ()
;  (prog (state (i -1) char key vel)
;    next
;	(setq i (1+ i))
;	(setq char (aref midi-array i))
;	(cond ((null char)
;	       (return nil))
;	      ((zerop (ldb (byte 1 7) char))
;	       (cond ((eq state 'on-first)
;		      (setq key char)
;		      (setq state 'on-second)
;		      (go next))
;		     ((eq state 'on-second)
;		      (setq vel char)
;		      (format t "~&~d ~d" key vel)
;		      (setq state 'on-first)
;		      (go next))
;		     (t
;		      (go next))))
;	      ((= (ldb (byte 3 4) char) 7)
;	       (go next))
;	      ((= (ldb (byte 3 4) char) 1)
;	       (setq state 'on-first)
;	       (go next))
;	      (t
;	       (setq state nil)
;	       (go next)))))

;(defun return-just-notes ()
;  (prog (state (i -1) char key vel answer)
;    next
;	(setq i (1+ i))
;	(setq char (aref midi-array i))
;	(cond ((null char)
;	       (return (reverse answer)))
;	      ((zerop (ldb (byte 1 7) char))
;	       (cond ((eq state 'on-first)
;		      (setq key char)
;		      (setq state 'on-second)
;		      (go next))
;		     ((eq state 'on-second)
;		      (setq vel char)
;		      (if (not (= 0 vel))
;			  (push key answer))
;		      (setq state 'on-first)
;		      (go next))
;		     (t
;		      (go next))))
;	      ((= (ldb (byte 3 4) char) 7)
;	       (go next))
;	      ((= (ldb (byte 3 4) char) 1)
;	       (setq state 'on-first)
;	       (go next))
;	      (t
;	       (setq state nil)
;	       (go next)))))

;(defun get-string-from-midi (base-idx count)
;  (let ((ans (make-string count)))
;    (dotimes (c count)
;      (aset (aref midi-array (+ base-idx c))
;	    ans
;	    c))
;    ans))