#lang racket/base
(require (rename-in racket/contract (-> -->)))
(require scheme/foreign)
(unsafe!)
(define _os-status _sint32)
(define _item-count _ulong)
(define _byte-count _ulong)
(define _midi-ts _uint64)
(define (check-retval where errno result)
(if (not (= errno 0))
(error where "Nonzero retval.")
result))
(define coremidi
(ffi-lib "/System/Library/Frameworks/CoreMIDI.framework/Versions/Current/CoreMIDI"))
(define corefoundation
(ffi-lib "/System/Library/Frameworks/CoreFoundation.framework/Versions/Current/CoreFoundation"))
(define (ffi-load name format)
(get-ffi-obj name coremidi format
(lambda () (error 'coremidi (string-append "Error loading " name " from CoreMIDI.")))))
(define midi-client-create
(ffi-load "MIDIClientCreate"
(_fun _pointer _pointer _pointer (ptr : (_ptr o _pointer)) -> (ret : _os-status)
-> (check-retval 'midi-client-create ret ptr))))
(define midi-client-dispose
(ffi-load "MIDIClientDispose" (_fun _pointer -> (ret : _os-status)
-> (check-retval 'midi-client-dispose ret ret))))
(define midi-output-port-create
(ffi-load "MIDIOutputPortCreate"
(_fun _pointer _pointer (ptr : (_ptr o _pointer)) -> (ret : _os-status)
-> (check-retval 'midi-output-port-create ret ptr))))
(define midi-get-number-of-destinations
(ffi-load "MIDIGetNumberOfDestinations" (_fun -> _item-count)))
(define midi-get-destination
(ffi-load "MIDIGetDestination" (_fun _item-count -> _pointer)))
(define midi-packet-list-init
(ffi-load "MIDIPacketListInit" (_fun _pointer -> _pointer)))
(define midi-packet-list-add
(ffi-load "MIDIPacketListAdd" (_fun _pointer _byte-count
_pointer _midi-ts
_byte-count
_pointer -> _pointer)))
(define midi-send
(ffi-load "MIDISend" (_fun _pointer _pointer _pointer -> (ret : _os-status)
-> (check-retval 'midi-send ret ret))))
(define cf-string-create-with-cstring (get-ffi-obj "CFStringCreateWithCString" corefoundation (_fun _pointer _string _int -> _pointer)
(lambda () (error 'corefoundation (string-append "Error loading CFStringCreateWithCString from CoreFoundation.")))))
(define (midi-destination (num 0))
(if (< (midi-get-number-of-destinations) 1)
(error 'midi-destination "No MIDI destinations available")
(midi-get-destination num)))
(define (midi-client name)
(midi-client-create
(cf-string-create-with-cstring #f name 0) #f #f))
(define (midi-port client name)
(midi-output-port-create
client (cf-string-create-with-cstring #f name 0)))
(struct midi-connection (client port destination) #:transparent)
(define (midi-open (destination 0) (client-name "rkt client") (port-name "rkt outport"))
(let ((client (midi-client client-name)))
(midi-connection client
(midi-port client port-name)
(midi-destination destination))))
(define (midi-close midi)
(midi-client-dispose (midi-connection-client midi)))
(define ON #x90) (define OFF #x80) (define AT #xA0) (define PC #xC0)
(define (message midi . args)
(define block (malloc _ubyte (length args)))
(define packet-list (malloc 256))
(for ((i (in-range (length args))))
(ptr-set! block _ubyte i (list-ref args i)))
(midi-packet-list-add packet-list 256
(midi-packet-list-init
packet-list)
0 (length args) block)
(midi-send (midi-connection-port midi)
(midi-connection-destination midi)
packet-list))
(define (note-on midi channel note (velocity 64))
(message midi (bitwise-ior ON (- channel 1)) note velocity))
(define (note-off midi channel note (velocity 64))
(message midi (bitwise-ior OFF (- channel 1)) note velocity))
(define (aftertouch midi channel note touch)
(message midi (bitwise-ior AT (- channel 1)) note touch))
(define (program-change midi channel preset)
(message midi (bitwise-ior PC (- channel 1)) preset))
(provide/contract
(midi-open (->* () (integer? string? string?) any))
(midi-close (--> midi-connection? any))
(note-on (->* (midi-connection? integer? integer?) (integer?) any))
(note-off (->* (midi-connection? integer? integer?) (integer?) any))
(aftertouch (--> midi-connection? integer? integer? integer? any))
(program-change (--> midi-connection? integer? integer? any)))