basis/game/input/iokit/iokit.factor

   1 USING: cocoa cocoa.plists core-foundation iokit iokit.hid
   2 kernel cocoa.enumeration destructors math.parser cocoa.application
   3 core-foundation.data core-foundation.strings
   4 sequences locals combinators.short-circuit threads
   5 namespaces assocs arrays combinators hints alien
   6 core-foundation.run-loop accessors sequences.private
   7 alien.c-types alien.data math parser game.input vectors
   8 bit-arrays unix.types ;
   9 FROM: namespaces => change-global ;
  10 IN: game.input.iokit
  11
  12 SINGLETON: iokit-game-input-backend
  13
  14 SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
  15
  16 iokit-game-input-backend game-input-backend set-global
  17
  18 : make-hid-manager ( -- alien )
  19     f 0 IOHIDManagerCreate ;
  20
  21 : set-hid-manager-matching ( alien matching-seq -- )
  22     >plist IOHIDManagerSetDeviceMatchingMultiple ;
  23
  24 : devices-from-hid-manager ( manager -- vector )
  25     [
  26         IOHIDManagerCopyDevices
  27         [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
  28     ] with-destructors ;
  29
  30 CONSTANT: game-devices-matching-seq
  31     {
  32         H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
  33         H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
  34         H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
  35         H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
  36         H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
  37         H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
  38     }
  39
  40 CONSTANT: buttons-matching-hash
  41     H{ { "UsagePage" 9 } { "Type" 2 } }
  42 CONSTANT: keys-matching-hash
  43     H{ { "UsagePage" 7 } { "Type" 2 } }
  44 CONSTANT: x-axis-matching-hash
  45     H{ { "UsagePage" 1 } { "Usage" 0x30 } { "Type" 1 } }
  46 CONSTANT: y-axis-matching-hash
  47     H{ { "UsagePage" 1 } { "Usage" 0x31 } { "Type" 1 } }
  48 CONSTANT: z-axis-matching-hash
  49     H{ { "UsagePage" 1 } { "Usage" 0x32 } { "Type" 1 } }
  50 CONSTANT: rx-axis-matching-hash
  51     H{ { "UsagePage" 1 } { "Usage" 0x33 } { "Type" 1 } }
  52 CONSTANT: ry-axis-matching-hash
  53     H{ { "UsagePage" 1 } { "Usage" 0x34 } { "Type" 1 } }
  54 CONSTANT: rz-axis-matching-hash
  55     H{ { "UsagePage" 1 } { "Usage" 0x35 } { "Type" 1 } }
  56 CONSTANT: slider-matching-hash
  57     H{ { "UsagePage" 1 } { "Usage" 0x36 } { "Type" 1 } }
  58 CONSTANT: wheel-matching-hash
  59     H{ { "UsagePage" 1 } { "Usage" 0x38 } { "Type" 1 } }
  60 CONSTANT: hat-switch-matching-hash
  61     H{ { "UsagePage" 1 } { "Usage" 0x39 } { "Type" 1 } }
  62
  63 : device-elements-matching ( device matching-hash -- vector )
  64     [
  65         >plist 0 IOHIDDeviceCopyMatchingElements
  66         [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
  67     ] with-destructors ;
  68
  69 : button-count ( device -- button-count )
  70     buttons-matching-hash device-elements-matching length ;
  71
  72 : ?axis ( device hash -- axis/f )
  73     device-elements-matching ?first ;
  74
  75 : ?x-axis ( device -- ? )
  76     x-axis-matching-hash ?axis ;
  77 : ?y-axis ( device -- ? )
  78     y-axis-matching-hash ?axis ;
  79 : ?z-axis ( device -- ? )
  80     z-axis-matching-hash ?axis ;
  81 : ?rx-axis ( device -- ? )
  82     rx-axis-matching-hash ?axis ;
  83 : ?ry-axis ( device -- ? )
  84     ry-axis-matching-hash ?axis ;
  85 : ?rz-axis ( device -- ? )
  86     rz-axis-matching-hash ?axis ;
  87 : ?slider ( device -- ? )
  88     slider-matching-hash ?axis ;
  89 : ?hat-switch ( device -- ? )
  90     hat-switch-matching-hash ?axis ;
  91
  92 : device-property ( device key -- value )
  93     <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
  94 : element-property ( element key -- value )
  95     <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
  96 : set-element-property ( element key value -- )
  97     [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
  98 : transfer-element-property ( element from-key to-key -- )
  99     [ dupd element-property ] dip swap
 100     [ set-element-property ] [ 2drop ] if* ;
 101
 102 : mouse-device? ( device -- ? )
 103     1 2 IOHIDDeviceConformsTo ;
 104
 105 : controller-device? ( device -- ? )
 106     {
 107         [ 1 4 IOHIDDeviceConformsTo ]
 108         [ 1 5 IOHIDDeviceConformsTo ]
 109         [ 1 8 IOHIDDeviceConformsTo ]
 110     } 1|| ;
 111
 112 : element-usage ( element -- {usage-page,usage} )
 113     [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
 114     2array ;
 115
 116 : button? ( element -- ? )
 117     IOHIDElementGetUsagePage 9 = ; inline
 118 : keyboard-key? ( element -- ? )
 119     IOHIDElementGetUsagePage 7 = ; inline
 120 : axis? ( element -- ? )
 121     IOHIDElementGetUsagePage 1 = ; inline
 122
 123 : x-axis? ( {usage-page,usage} -- ? )
 124     IOHIDElementGetUsage 0x30 = ; inline
 125 : y-axis? ( {usage-page,usage} -- ? )
 126     IOHIDElementGetUsage 0x31 = ; inline
 127 : z-axis? ( {usage-page,usage} -- ? )
 128     IOHIDElementGetUsage 0x32 = ; inline
 129 : rx-axis? ( {usage-page,usage} -- ? )
 130     IOHIDElementGetUsage 0x33 = ; inline
 131 : ry-axis? ( {usage-page,usage} -- ? )
 132     IOHIDElementGetUsage 0x34 = ; inline
 133 : rz-axis? ( {usage-page,usage} -- ? )
 134     IOHIDElementGetUsage 0x35 = ; inline
 135 : slider? ( {usage-page,usage} -- ? )
 136     IOHIDElementGetUsage 0x36 = ; inline
 137 : wheel? ( {usage-page,usage} -- ? )
 138     IOHIDElementGetUsage 0x38 = ; inline
 139 : hat-switch? ( {usage-page,usage} -- ? )
 140     IOHIDElementGetUsage 0x39 = ; inline
 141
 142 CONSTANT: pov-values
 143     {
 144         pov-up pov-up-right pov-right pov-down-right
 145         pov-down pov-down-left pov-left pov-up-left
 146         pov-neutral
 147     }
 148
 149 : button-value ( value -- f/(0,1] )
 150     IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
 151 : axis-value ( value -- [-1,1] )
 152     kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
 153 : mouse-axis-value ( value -- n )
 154     IOHIDValueGetIntegerValue ;
 155 : pov-value ( value -- pov-direction )
 156     IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
 157
 158 : record-button ( state hid-value element -- )
 159     [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1 - ] tri* rot set-nth ;
 160
 161 : record-controller ( controller-state value -- )
 162     dup IOHIDValueGetElement {
 163         { [ dup button? ] [ record-button ] }
 164         { [ dup axis? ] [ {
 165             { [ dup x-axis? ] [ drop axis-value >>x drop ] }
 166             { [ dup y-axis? ] [ drop axis-value >>y drop ] }
 167             { [ dup z-axis? ] [ drop axis-value >>z drop ] }
 168             { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
 169             { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
 170             { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
 171             { [ dup slider? ] [ drop axis-value >>slider drop ] }
 172             { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
 173             [ 3drop ]
 174         } cond ] }
 175         [ 3drop ]
 176     } cond ;
 177
 178 HINTS: record-controller { controller-state alien } ;
 179
 180 : ?set-nth ( value nth seq -- )
 181     2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
 182
 183 : record-keyboard ( keyboard-state value -- )
 184     dup IOHIDValueGetElement dup keyboard-key? [
 185         [ IOHIDValueGetIntegerValue c-bool> ]
 186         [ IOHIDElementGetUsage ] bi*
 187         rot ?set-nth
 188     ] [ 3drop ] if ;
 189
 190 HINTS: record-keyboard { bit-array alien } ;
 191
 192 : record-mouse ( mouse-state value -- )
 193     dup IOHIDValueGetElement {
 194         { [ dup button? ] [ record-button ] }
 195         { [ dup axis? ] [ {
 196             { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
 197             { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
 198             { [ dup wheel?  ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
 199             { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
 200             [ 3drop ]
 201         } cond ] }
 202         [ 3drop ]
 203     } cond ;
 204
 205 HINTS: record-mouse { mouse-state alien } ;
 206
 207 M: iokit-game-input-backend read-mouse
 208     +mouse-state+ get-global ;
 209
 210 M: iokit-game-input-backend reset-mouse
 211     +mouse-state+ get-global
 212         0 >>dx
 213         0 >>dy
 214         0 >>scroll-dx
 215         0 >>scroll-dy
 216         drop ;
 217
 218 : default-calibrate-saturation ( element -- )
 219     [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
 220     [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
 221     bi ;
 222
 223 : default-calibrate-axis ( element -- )
 224     [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
 225     [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
 226     [ default-calibrate-saturation ]
 227     tri ;
 228
 229 : default-calibrate-slider ( element -- )
 230     [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
 231     [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
 232     [ default-calibrate-saturation ]
 233     tri ;
 234
 235 : (default) ( ? quot -- )
 236     [ f ] if* ; inline
 237
 238 : <device-controller-state> ( device -- controller-state )
 239     {
 240         [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
 241         [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
 242         [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
 243         [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
 244         [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
 245         [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
 246         [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
 247         [ ?hat-switch pov-neutral and ]
 248         [ button-count f <array> ]
 249     } cleave controller-state boa ;
 250
 251 : ?add-mouse-buttons ( device -- )
 252     button-count +mouse-state+ get-global buttons>>
 253     2dup length >
 254     [ set-length ] [ 2drop ] if ;
 255
 256 :: (device-matched-callback) ( context result sender device -- )
 257     {
 258         { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
 259         { [ device controller-device? ] [
 260             device <device-controller-state>
 261             device +controller-states+ get-global set-at
 262         ] }
 263         [ ]
 264     } cond ;
 265
 266 : device-matched-callback ( -- alien )
 267     [ (device-matched-callback) ] IOHIDDeviceCallback ;
 268
 269 :: (device-removed-callback) ( context result sender device -- )
 270     device +controller-states+ get-global delete-at ;
 271
 272 : device-removed-callback ( -- alien )
 273     [ (device-removed-callback) ] IOHIDDeviceCallback ;
 274
 275 ! Lion sends the input callback an IOHIDQueue as the "sender".
 276 ! Leopard and Snow Leopard send an IOHIDDevice.
 277 ! This function gets the IOHIDDevice regardless of which is received
 278 : get-input-device ( sender -- device )
 279     dup CFGetTypeID {
 280         { [ dup IOHIDDeviceGetTypeID = ] [ drop ] }
 281         { [ dup IOHIDQueueGetTypeID = ] [ drop IOHIDQueueGetDevice ] }
 282         [
 283             drop
 284             "input callback doesn't know how to deal with "
 285             swap CF>description append throw
 286         ]
 287     } cond ;
 288
 289 :: (device-input-callback) ( context result sender value -- )
 290     sender get-input-device :> device
 291     {
 292         { [ device mouse-device? ] [ +mouse-state+ get-global value record-mouse ] }
 293         { [ device controller-device? ] [
 294             device +controller-states+ get-global at value record-controller
 295         ] }
 296         [ +keyboard-state+ get-global value record-keyboard ]
 297     } cond ;
 298
 299 : device-input-callback ( -- alien )
 300     [ (device-input-callback) ] IOHIDValueCallback ;
 301
 302 : initialize-variables ( manager -- )
 303     +hid-manager+ set-global
 304     4 <vector> +controller-states+ set-global
 305     0 0 0 0 2 <vector> mouse-state boa
 306         +mouse-state+ set-global
 307     256 <bit-array> +keyboard-state+ set-global ;
 308
 309 M: iokit-game-input-backend (open-game-input)
 310     make-hid-manager {
 311         [ initialize-variables ]
 312         [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
 313         [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
 314         [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
 315         [ 0 IOHIDManagerOpen mach-error ]
 316         [ game-devices-matching-seq set-hid-manager-matching ]
 317         [
 318             CFRunLoopGetMain CFRunLoopDefaultMode
 319             IOHIDManagerScheduleWithRunLoop
 320         ]
 321     } cleave ;
 322
 323 M: iokit-game-input-backend (reset-game-input)
 324     { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
 325     [ f swap set-global ] each ;
 326
 327 M: iokit-game-input-backend (close-game-input)
 328     +hid-manager+ get-global [
 329         +hid-manager+ [
 330             [
 331                 CFRunLoopGetMain CFRunLoopDefaultMode
 332                 IOHIDManagerUnscheduleFromRunLoop
 333             ]
 334             [ 0 IOHIDManagerClose drop ]
 335             [ CFRelease ] tri
 336             f
 337         ] change-global
 338         f +keyboard-state+ set-global
 339         f +mouse-state+ set-global
 340         f +controller-states+ set-global
 341     ] when ;
 342
 343 M: iokit-game-input-backend get-controllers ( -- sequence )
 344     +controller-states+ get-global keys [ controller boa ] map ;
 345
 346 : ?join ( pre post sep -- string )
 347     2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
 348
 349 M: iokit-game-input-backend product-string ( controller -- string )
 350     handle>>
 351     [ kIOHIDManufacturerKey device-property ]
 352     [ kIOHIDProductKey      device-property ] bi " " ?join ;
 353 M: iokit-game-input-backend product-id ( controller -- integer )
 354     handle>>
 355     [ kIOHIDVendorIDKey  device-property ]
 356     [ kIOHIDProductIDKey device-property ] bi 2array ;
 357 M: iokit-game-input-backend instance-id ( controller -- integer )
 358     handle>> kIOHIDLocationIDKey device-property ;
 359
 360 M: iokit-game-input-backend read-controller ( controller -- controller-state )
 361     handle>> +controller-states+ get-global at clone ;
 362
 363 M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
 364     +keyboard-state+ get-global clone keyboard-state boa ;
 365
 366 M: iokit-game-input-backend calibrate-controller ( controller -- )
 367     drop ;