;; port -> int -> ()
(define write-i16
  (lambda (p n)
    (put-bytevector p (encode-i16 n))))

;; port -> int -> ()
(define write-i32
  (lambda (p n)
    (put-bytevector p (encode-i32 n))))

;; port -> int -> ()
(define write-variable-length-integer
  (lambda (p z)
    (letrec
	((make-result
	  (lambda (result input)
	    (if (> input 0)
		(let* ((a (fxarithmetic-shift-left result 8))
		       (b (fxxor a #x80))
		       (c (+ b (fxand input #x7f))))
		  (make-result c (fxarithmetic-shift-right input 7)))
		result)))
	 (write-result
	  (lambda (result)
	    (put-u8 p (fxand result #xff))
	    (if (not (= (fxand result #x80) 0))
		(write-result (fxarithmetic-shift-right result 8))
		#f))))
      (write-result 
       (make-result 
	(fxand z #x7f) 
	(fxarithmetic-shift-right z 7))))))

;; port -> [int] -> ()
(define write-header
  (lambda (p header-data)
    (put-bytevector p (string->utf8 "MThd"))
    (write-i32 p 6)
    (for-each 
     (lambda (x) 
       (write-i16 p x))
     header-data)))

;; port -> [int, event] -> ()
(define write-track
  (lambda (p event-list)
    (put-bytevector p (string->utf8 "MTrk"))
    (let ((data 
	   (call-with-bytevector-output-port 
	    (lambda (p)
	      (for-each 
	       (lambda (x)
		 (let* ((delta-time (list-ref x 0))
			(event (list-ref x 1))
			(status-byte (event-status event))
			(data-bytes (event-data event)))
		   (write-variable-length-integer p delta-time)
		   (case status-byte
		     ((#xff)
		      (put-u8 p status-byte)
		      (put-u8 p (head data-bytes))
		      (write-variable-length-integer p (length (tail data-bytes)) )
		      (for-each 
		       (lambda (byte)
			 (put-u8 p byte))
		       (tail data-bytes)))
		     ((#xf0 #xf7)
		      (put-u8 p status-byte)
		      (write-variable-length-integer p (length data-bytes))
		      (for-each 
		       (lambda (byte)
			 (put-u8 p byte))
		       data-bytes))
		     (else
		      (for-each 
		       (lambda (byte)
			 (put-u8 p byte))
		       event-data)))))
	       event-list)))))
      (write-i32 p (bytevector-length data))
      (put-bytevector p data))))

;; port -> tree int -> ()
(define midi-file-write
  (lambda (p m)
    (write-header p (midi-file-header m))
    (for-each 
     (lambda (track)
       (write-track p track))
     (tail m))))

;; tree int -> string -> ()
(define midi-file-write-file
  (lambda (m file-name)
    (let ((p (open-file-output-port file-name)))
      (midi-file-write p m)
      (close-port p))))