Apple's multitouch with demo (run using gracket)

multitouch.rkt

#lang racket/gui

; Ported from http://pb.lericson.se/p/FpbYhX/

(require ffi/unsafe
         ffi/unsafe/atomic)

(define libmulti (ffi-lib "/System/Library/PrivateFrameworks/MultitouchSupport.framework/MultitouchSupport"))

(define CFArrayRef _pointer)
(define CFMutableArrayRef _pointer)
(define CFIndex _long)

(define CFArrayGetCount
  (get-ffi-obj "CFArrayGetCount" libmulti
               (_fun CFArrayRef -> CFIndex)))

(define CFArrayGetValueAtIndex
  (get-ffi-obj "CFArrayGetValueAtIndex" libmulti
               (_fun CFArrayRef CFIndex -> _pointer)))

(define MTDeviceCreateList
  (get-ffi-obj "MTDeviceCreateList" libmulti
               (_fun -> CFMutableArrayRef)))

(define-cstruct _MTPoint ([x _float] [y _float]))
(define-cstruct _MTVector ([position _MTPoint] [velocity _MTPoint]))
(define-cstruct _MTData ([frame _int]
                         [timestamp _double]
                         [identifier _int]
                         [state _int]
                         [unknown1 _int]
                         [unknown2 _int]
                         [normalized _MTVector]
                         [size _float]
                         [unknown3 _int]
                         [angle _float]
                         [major_axis _float]
                         [minor_axis _float]
                         [unknown4 _MTVector]
                         [unknown5_1 _int]
                         [unknown5_2 _int]
                         [unknown6 _float]))
(define MTDataRef _MTData-pointer)


;; A queue that implements locking by atomic actions,
;; since an async-apply function cannot block on a lock.
(define sema (make-semaphore))
(define queue null)
(define (enqueue thunk)
  (set! queue (append queue (list thunk)))
  (semaphore-post sema))
(define (dequeue)
  (semaphore-wait sema)
  (start-atomic)
  (let ([v (car queue)])
    (set! queue (cdr queue))
    (end-atomic)
    v))

(define MTContactCallbackFunction
  (_fun #:async-apply enqueue _int MTDataRef _int _double _int -> _int))

(define MTDeviceRef _pointer)

(define MTRegisterContactFrameCallback
  (get-ffi-obj "MTRegisterContactFrameCallback" libmulti
               (_fun MTDeviceRef MTContactCallbackFunction -> _void)))

(define MTDeviceStart
  (get-ffi-obj "MTDeviceStart" libmulti
               (_fun MTDeviceRef _int -> _void)))


(define (multitouch-register-callback proc)
  (let ([devices (MTDeviceCreateList)])
    (for ([i (in-range (CFArrayGetCount devices))])
         (let ([device (CFArrayGetValueAtIndex devices i)])
           (MTRegisterContactFrameCallback device proc)
           (MTDeviceStart device 0)))))

(multitouch-register-callback
   (lambda (device data-ptr n-fingers timestamp frame)
     (for ([i (in-range n-fingers)])
          (let* ([data (ptr-ref data-ptr _MTData i)]
                 [vector (MTData-normalized data)]
                 [position (MTVector-position vector)]
                 [x (* 100 (MTPoint-x position))]
                 [y (* 100 (MTPoint-y position))]
                 [size (* 30 (MTData-size data))])
            (draw-circle (send canvas get-dc) x y size)))
            ;(printf "d=~a x=~a, y=~a, size=~a\n" i x y size)))
     0))

(displayln "Running")

;; Thread to run async calls in the background:
 (thread (lambda ()
           (let loop ()
             (let ([thunk (dequeue)])
               (thunk)
               (loop)))))

; Demo

(define FRAMEWIDTH 800)
(define FRAMEHIGHT 600)

(define frame (new frame% [label "Multitouch Example"]
                   [width FRAMEWIDTH]
                   [height FRAMEHIGHT]))

(define canvas (new canvas% [parent frame]))

(define yellow-brush (make-object brush% "YELLOW" 'solid))
(define blue-pen (make-object pen% "BLUE" 1 'solid))

(define (convert-x x)
  (/ (* x FRAMEWIDTH) 100))

(define (convert-y y)
  (- FRAMEHIGHT (/ (* y FRAMEHIGHT) 100)))

(define (draw-circle dc x y size)
  (send dc set-pen blue-pen)
  (send dc set-brush yellow-brush)
  (send dc draw-ellipse (convert-x x) (convert-y y) size size))

(send frame show #t)
(send frame center)
(send frame set-cursor (make-object cursor% 'blank))

; Wait a second to let the window get ready
(sleep/yield 1)