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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;l
;;;
;;; Midi macros
;;;

;;; example of defmidi
;(defmidi foo (note &key (channel 0)) "bar"
;  (dpb note (byte 7 0) 0)
;  channel)

(defmacro defmidi (name arglist documentation &body slots)
  (let ((slot-length (length slots))
	(slot-list ())
	(slot-count 0)
	(check-type-forms ()))
    (dolist (type (process-arglist-for-type-checking arglist))
      (push `(check-type ,type ,(intern (string-append type "-TYPE"))) check-type-forms))
    (dolist (slot slots)
      (setq slot-list
	    (nconc slot-list `((aset ,slot string ,slot-count))))
      (incf slot-count))
    `(progn (defun (:property ,name :midi-string-generator)
		   ,(nconc arglist `(&aux (string (make-string ,slot-length))))
	      ,documentation
	      ,@check-type-forms
	      ,@slot-list
	      string)
	    (defun ,name (&rest args)
	      (declare (arglist . ,arglist))
	      (midi-string-out (lexpr-funcall (get ',name :midi-string-generator) args)
			       :delay 0)))))

(defun process-arglist-for-type-checking (arglist &rest return-value)
  (dolist (thing arglist (reverse return-value))
    (etypecase thing
      (list (pushnew (car thing) return-value))
      (symbol (unless (char-equal (aref (string thing) 0) #\&)
		(pushnew thing return-value))))))

;;; Type specifiers for integer values

(deftype channel-type () '(mod 16))
(deftype velocity-type () '(mod 128))
(deftype note-type () '(mod 128))
(deftype control-type () '(mod 128))
(deftype control-value-type () '(mod 128))
(deftype control-number-type () '(mod 128))
(deftype control-value-type  () '(mod 128))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; I/O primitives
;;;

(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)
  (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))))

(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) (ldb (byte 8 0) c)))


(deff midi-tyi 'vcmem-tyi)
(deff midi-tyo 'vcmem-tyo)

(defun midi-string-out (string &key (delay 1))
  (dotimes (c (length string))
    (midi-tyo (aref string c))
    (process-sleep delay)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Midi functions
;;;
;;;


;;; Channel voice message

(defmidi note-off (note &key (channel 0))
	 "Turn off NOTE on CHANNEL."
  (dpb channel (byte 4 0) #b10000000)
  note
  0)  ;ignored

(defmidi note-on (note &key (channel 0) (velocity 64.))
	 "Turn on NOTE with VELOCITY on CHANNEL."
  (dpb channel (byte 4 0) #b10010000)
  note
  velocity)

(defmidi control-change (control-number control-value &key (channel 0))
	 "Issue a control change."
  (dpb channel (byte 4 0) #b10110000)
  control-number
  control-value)

(defmidi program-change (program-number &key (channel 0))
	 "Issue a program change."
  (dpb channel (byte 4 0) #b11000000)
  program-number)

(defmidi channel-after-touch (pressure &key (channel 0))
	 "After touch."
  (dpb channel (byte 4 0) #b11010000)
  pressure)

(defmidi pitch-bend (pitch-bend &key (channel 0))
	 "Pitch bend"
  (dpb channel (byte 4 0) #b11100000)
  (ldb (byte 7 0) pitch-bend)
  (ldb (byte 7 8) pitch-bend))


;;; Channel mode message


(defmidi channel-mode (channel-mode channel-mode-value &key (channel 0))
	 "Channel mode message"
  (dpb channel (byte 4 0) #b11010000)
  channel-mode
  channel-mode-value)


;;; System real time message


(defmidi system-real-time ()
	 "System real time message."
  #b11111110)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Midi command string generation (real kludgy)
;;;
;;;

(defconst *midi-command-strings* ())

(defun remove-midi-command-macro (symbol)
  (delq symbol *midi-command-strings*))

(defun get-midi-command-macro-string (symbol)
  (get symbol :midi-command-string))

(defmacro define-midi-command-macro (name &body forms)
  (let ((strings))
    (dolist (form forms)
      (push (typecase form
	      (list (lexpr-funcall (get (car form) :midi-string-generator)
				   (cdr form)))
	      (symbol (get form :midi-command-string))
	      (string form))
	    strings))
    `(progn
       (setf (get ',name :midi-command-string)
	     ',(lexpr-funcall 'string-append strings))
       (pushnew ',name *midi-command-strings*))))

(defun send-midi-command-string (thing &key (interval 10))
  (let ((string (typecase thing
		  (string thing)
		  (symbol (get thing :midi-command-string))
		  (list (apply (car thing) (cdr thing))))))
    (dotimes (c (length string))
      (midi-tyo (aref string c))
      (process-sleep interval))
    (process-sleep (* 2 interval))))

;(define-midi-command-macro middle-c-scale-chromatic-1
;  #.(let ((strings))
;      (dotimes (c 13)
;	(push `(note-on (+ ,c 60)) strings)
;	(push `(note-off (+ ,c 60)) strings))
;      (apply 'string-append (reverse strings))))

;(define-midi-command-macro middle-c-scale-chromatic-down-1
;  #.(let ((strings))
;      (dotimes (c 13)
;	(push (note-on (- 73 c)) strings)
;	(push (note-off (- 73 c)) strings))
;      (apply 'string-append (reverse strings))))
			  
;(define-midi-command-macro middle-c-scale-chromatic-up-and-down-1
;  middle-c-scale-chromatic-1
;  middle-c-scale-chromatic-down-1)

(defun limit (min max value)
  (min max (max min value)))

(defun channel-generator (function)
  (let ((old-value (random 128)))
    #'(lambda ()
	(setq old-value (funcall function old-value)))))

(defun inc-or-dec (delta min max)
  #'(lambda (value)
      (fix (limit min max (+ value (funcall (if (= (random 2) 0) #'+ #'-) (random delta)))))))

(defun null-generator ()
  #'(lambda () (values nil 0 1000)))

(defun base-line-generator ()
  (let ((gen (channel-generator (inc-or-dec 4 20 60))))
    #'(lambda ()
	(values (funcall gen) (random 2) 10))))

(defun play-randomly-jrm (generators)
  (let ((notes-on           (vector '() '() '() '()))
	(consideration-time (vector   0   0   0   0)))
    (do-forever
      (when (listen)
	(all-off)
	(return nil))
      (dotimes (i 4)
	(if (not (zerop (elt consideration-time i)))
	    (decf (elt consideration-time i))
	  (multiple-value-bind
	    (note-to-add number-to-flush new-time)
	      (funcall (elt generators i))
	    (let ((note-list (elt notes-on i)))
	      (setf (elt consideration-time i) new-time)
	      (dotimes (flush-count number-to-flush)
		(if note-list
		    (let ((note (elt note-list (random (length note-list)))))
		      (note-off note :channel i))))
	      (if note-to-add
		  (note-on note-to-add :channel i)
		(setf (elt notes-on i) (push note-to-add note-list)))))))
      (process-sleep 4.))))

(defun play-randomly (&key
		      (number-of-channels 4)
		      (sleep-time 20))
  (do ((altered t)
       (decay-check (time:get-universal-time))
       (notes-on (make-array number-of-channels))
       (on-chance 2)
       (off-chance 2)
       (window tv:selected-window)
       (progression-interval 4)
       (spread-interval 10)
       (velocity (+ 20 (random 60))))
      (())
    ;;; Listen for command
    (when (listen)
      (setq altered t)
      (case (read-char)
	(#\end (sleep 2)
	       (all-off)
	       (return-from play-randomly nil))
	(#\c-= (incf sleep-time))
	(#\c-- (decf sleep-time))))
    ;;; notes off
    (when (> (- (time:get-universal-time) decay-check) 90)
      (setq decay-check (time:get-universal-time))
      (dotimes (c number-of-channels)
	(dolist (notes (aref notes-on c))
	  (when (>= (- decay-check (car notes)) 90)
	    (dolist (note (cdr notes))
	      (note-off note :channel c))
	    (setf (aref notes-on c)
		  (delq notes (aref notes-on c)))))))
    (when (= (random off-chance) 0)
      (let ((number (let ((num 0))
		       (dotimes (c number-of-channels num)
			 (incf num (length (aref notes-on c)))))))
	(unless (zerop number)
	  (setq altered t)
	  (let* ((channel (do* ((count 0 (add1 count))
				(length (length (aref notes-on count))
					(length (aref notes-on count))))
			       ((<= number length) count)
			    (decf number length)))
		 (note-list (aref notes-on channel))
		 (notes (nth (random (length note-list)) note-list)))
	    (when notes
	      (aset (delq notes note-list) notes-on channel)
	      (dolist (note (cdr notes))
		(note-off note :channel channel)))))))
    ;;; New notes on
    (when (= (random on-chance) 0)
      (setq altered t)
      (let* ((channel (random number-of-channels))
	     (note-list (aref notes-on channel))
	     (new-notes (select-random-progression
			  note-list
			  (randomly-signed progression-interval)
			  spread-interval)))
	(when new-notes
	  (push (cons (time:get-universal-time) new-notes) (aref notes-on channel))
	  (dolist (new-note new-notes)
	    (note-on new-note :channel channel :velocity velocity)))))
    ;;; Sleep time, on-chance and off-chance change
    (when (cond-every
	    ((= (random 2) 0)
	     (setq sleep-time (max 2 (min 40 (+ sleep-time (random-margin -10 10))))))
	    ((= (random 4) 0)
	     (setq on-chance (max 2 (min 4 (+ on-chance (random-margin -1 1))))))
	    ((= (random 4) 0)
	     (setq off-chance (max 3 (min 5 (+ off-chance (random-margin -1 1))))))
	    ((= (random 2) 0)
	     (setq spread-interval (max 5 (min 80 (+ spread-interval (random-margin -5 5))))))
	    ((= (random 2) 0)
	     (setq progression-interval (max 1 (min 20 (+ progression-interval (random-margin -20 20))))))
	    ((= (random 4) 0)
	     (setq velocity (if (= (random 4) 0)
				(+ 20 (random 60))
			      (mod (+ velocity (random-margin -5 5)) 128)))))
      (setq altered t))
    ;;; Print
    (when altered
      (setq altered nil)
      (send window :clear-screen)
      (format t "Sleep: ~D; On: ~D; Off: ~D; Progression: ~D; Spread: ~D; Velocity: ~D"
	      sleep-time on-chance off-chance progression-interval spread-interval velocity)
      (dotimes (c number-of-channels)
	(format t "~&C: ~D; #: ~D~%"
		c (length (aref notes-on c)))))
    (when (zerop (random 2)) (process-sleep sleep-time))))

(defun select-random-progression (notes-on progression-interval spread-interval)
  (if (null notes-on)
      (do ((list)
	   (count (random 20) (decf count)))
	  ((zerop count) list)
	(push (random 128) list))
    (let* ((last-notes (cdar notes-on))
	   (center (note-group-center last-notes))
	   (new-center (mod (+ center progression-interval) 128))
	   (spread (note-spread last-notes))
	   (new-spread (+ spread spread-interval))
	   (new-number-abs-margin (round (* (length last-notes)
					    .25)))
	   (new-number-of-notes (mod (+ (length last-notes)
					(random-margin (- new-number-abs-margin)
						       new-number-abs-margin))
				     10))
	   (base-note (mod (- new-center (quotient spread-interval 2)) 128))
	   new-notes)
      (push base-note new-notes)
      (dotimes (c (- new-number-of-notes 2))
	(push (mod (+ base-note
		      (* c new-spread)
		      (random-margin -1 1))
		   128)
	      new-notes))
      (push (mod (+ base-note spread-interval) 128) new-notes)
      new-notes)))

(defun random-margin (min max)
  (+ (random (add1 (- max min))) min))

(defun note-group-center (note-list)
  (round (/ (apply '+ note-list) (length note-list))))

(defun note-spread (note-list)
  (let ((min 128)
	(max 0))
    (dolist (note note-list)
      (cond ((> note max)
	     (setq max note))
	    ((< note min)
	     (setq min note))))
    (- max min)))

(defun randomly-signed (number)
  (if (zerop (random 2)) number (- number)))