+++ /dev/null
-USING: eval multiline system combinators ;
-IN: game-input.backend
-
-STRING: set-backend-for-macosx
-USING: namespaces parser game-input.backend.iokit ;
-<< "game-input" (use+) >>
-iokit-game-input-backend game-input-backend set-global
-;
-
-STRING: set-backend-for-windows
-USING: namespaces parser game-input.backend.dinput ;
-<< "game-input" (use+) >>
-dinput-game-input-backend game-input-backend set-global
-;
-
-{
- { [ os macosx? ] [ set-backend-for-macosx eval ] }
- { [ os windows? ] [ set-backend-for-windows eval ] }
- { [ t ] [ ] }
-} cond
-
+++ /dev/null
-USING: windows.dinput windows.dinput.constants parser symbols
-alien.c-types windows.ole32 namespaces assocs kernel arrays
-vectors windows.kernel32 windows.com windows.dinput shuffle
-windows.user32 windows.messages sequences combinators
-math.geometry.rect ui.windows accessors math windows alien
-alien.strings io.encodings.utf16 io.encodings.utf16n
-continuations byte-arrays locals
-game-input.backend.dinput.keys-array ;
-<< "game-input" (use+) >>
-IN: game-input.backend.dinput
-
-SINGLETON: dinput-game-input-backend
-
-SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
- +controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+ ;
-
-: create-dinput ( -- )
- f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
- f <void*> [ f DirectInput8Create ole32-error ] keep *void*
- +dinput+ set-global ;
-
-: delete-dinput ( -- )
- +dinput+ global [ com-release f ] change-at ;
-
-: device-for-guid ( guid -- device )
- +dinput+ get swap f <void*>
- [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
-
-: set-coop-level ( device -- )
- +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
- IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
-
-: set-data-format ( device format-symbol -- )
- get IDirectInputDevice8W::SetDataFormat ole32-error ;
-
-: configure-keyboard ( keyboard -- )
- [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
-: configure-controller ( controller -- )
- [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
-
-: find-keyboard ( -- )
- GUID_SysKeyboard device-for-guid
- [ configure-keyboard ]
- [ +keyboard-device+ set-global ] bi
- 256 <byte-array> <keys-array> keyboard-state boa
- +keyboard-state+ set-global ;
-
-: device-info ( device -- DIDEVICEIMAGEINFOW )
- "DIDEVICEINSTANCEW" <c-object>
- "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
- [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
-: device-caps ( device -- DIDEVCAPS )
- "DIDEVCAPS" <c-object>
- "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
- [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
-
-: <guid> ( memory -- byte-array )
- "GUID" heap-size memory>byte-array ;
-
-: device-guid ( device -- guid )
- device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
-
-: device-attached? ( device -- ? )
- +dinput+ get swap device-guid
- IDirectInput8W::GetDeviceStatus S_OK = ;
-
-: find-device-axes-callback ( -- alien )
- [ ! ( lpddoi pvRef -- BOOL )
- +controller-devices+ get at
- swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
- { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
- { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
- { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
- { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
- { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
- { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
- { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
- [ drop ]
- } cond drop
- DIENUM_CONTINUE
- ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
-
-: find-device-axes ( device controller-state -- controller-state )
- swap [ +controller-devices+ get set-at ] 2keep
- find-device-axes-callback over DIDFT_AXIS
- IDirectInputDevice8W::EnumObjects ole32-error ;
-
-: controller-state-template ( device -- controller-state )
- controller-state new
- over device-caps
- [ DIDEVCAPS-dwButtons f <array> >>buttons ]
- [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
- find-device-axes ;
-
-: device-known? ( guid -- ? )
- +controller-guids+ get key? ; inline
-
-: (add-controller) ( guid -- )
- device-for-guid {
- [ configure-controller ]
- [ controller-state-template ]
- [ dup device-guid +controller-guids+ get set-at ]
- [ +controller-devices+ get set-at ]
- } cleave ;
-
-: add-controller ( guid -- )
- dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
-
-: remove-controller ( device -- )
- [ +controller-devices+ get delete-at ]
- [ device-guid +controller-guids+ get delete-at ]
- [ com-release ] tri ;
-
-: find-controller-callback ( -- alien )
- [ ! ( lpddi pvRef -- BOOL )
- drop DIDEVICEINSTANCEW-guidInstance add-controller
- DIENUM_CONTINUE
- ] LPDIENUMDEVICESCALLBACKW ;
-
-: find-controllers ( -- )
- +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
- f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
-
-: set-up-controllers ( -- )
- 4 <vector> +controller-devices+ set-global
- 4 <vector> +controller-guids+ set-global
- find-controllers ;
-
-: find-and-remove-detached-devices ( -- )
- +controller-devices+ get keys
- [ device-attached? not ] filter
- [ remove-controller ] each ;
-
-: device-interface? ( dbt-broadcast-hdr -- ? )
- DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
-
-: device-arrived ( dbt-broadcast-hdr -- )
- device-interface? [ find-controllers ] when ;
-
-: device-removed ( dbt-broadcast-hdr -- )
- device-interface? [ find-and-remove-detached-devices ] when ;
-
-: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
- [ 2drop ] 2dip swap {
- { [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
- { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
- [ 2drop ]
- } cond ;
-
-TUPLE: window-rect < rect window-loc ;
-: <zero-window-rect> ( -- window-rect )
- window-rect new
- { 0 0 } >>window-loc
- { 0 0 } >>loc
- { 0 0 } >>dim ;
-
-: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
- "DEV_BROADCAST_DEVICEW" <c-object>
- "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
- DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
-
-: create-device-change-window ( -- )
- <zero-window-rect> create-window
- [
- (device-notification-filter)
- DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
- RegisterDeviceNotification
- +device-change-handle+ set-global
- ]
- [ +device-change-window+ set-global ] bi ;
-
-: close-device-change-window ( -- )
- +device-change-handle+ global
- [ UnregisterDeviceNotification drop f ] change-at
- +device-change-window+ global
- [ DestroyWindow win32-error=0/f f ] change-at ;
-
-: add-wm-devicechange ( -- )
- [ 4dup handle-wm-devicechange DefWindowProc ]
- WM_DEVICECHANGE add-wm-handler ;
-
-: remove-wm-devicechange ( -- )
- WM_DEVICECHANGE wm-handlers get-global delete-at ;
-
-: release-controllers ( -- )
- +controller-devices+ global [
- [ drop com-release ] assoc-each f
- ] change-at
- f +controller-guids+ set-global ;
-
-: release-keyboard ( -- )
- +keyboard-device+ global
- [ com-release f ] change-at
- f +keyboard-state+ set-global ;
-
-M: dinput-game-input-backend (open-game-input)
- create-dinput
- create-device-change-window
- find-keyboard
- set-up-controllers
- add-wm-devicechange ;
-
-M: dinput-game-input-backend (close-game-input)
- remove-wm-devicechange
- release-controllers
- release-keyboard
- close-device-change-window
- delete-dinput ;
-
-M: dinput-game-input-backend (reset-game-input)
- {
- +dinput+ +keyboard-device+ +keyboard-state+
- +controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+
- } [ f swap set-global ] each ;
-
-M: dinput-game-input-backend get-controllers
- +controller-devices+ get
- [ drop controller boa ] { } assoc>map ;
-
-M: dinput-game-input-backend product-string
- handle>> device-info DIDEVICEINSTANCEW-tszProductName
- utf16n alien>string ;
-
-M: dinput-game-input-backend product-id
- handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
-M: dinput-game-input-backend instance-id
- handle>> device-guid ;
-
-:: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
- device IDirectInputDevice8W::Acquire succeeded? [
- device acquired-quot call
- succeeded-quot call
- ] failed-quot if ; inline
-
-: pov-values
- {
- pov-up pov-up-right pov-right pov-down-right
- pov-down pov-down-left pov-left pov-up-left
- } ; inline
-
-: >axis ( long -- float )
- 32767 - 32767.0 /f ;
-: >slider ( long -- float )
- 65535.0 /f ;
-: >pov ( long -- symbol )
- dup HEX: FFFF bitand HEX: FFFF =
- [ drop pov-neutral ]
- [ 2750 + 4500 /i pov-values nth ] if ;
-: >buttons ( alien length -- array )
- memory>byte-array <keys-array> ;
-
-: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
- [ drop ] compose [ 2drop ] if ; inline
-
-: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
- {
- [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
- [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
- [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
- [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
- [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
- [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
- [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
- [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
- [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
- } 2cleave ;
-
-: get-device-state ( device byte-array -- )
- [ dup IDirectInputDevice8W::Poll ole32-error ] dip
- [ length ] keep
- IDirectInputDevice8W::GetDeviceState ole32-error ;
-
-: (read-controller) ( handle template -- state )
- swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
- [ fill-controller-state ] [ drop f ] with-acquisition ;
-
-M: dinput-game-input-backend read-controller
- handle>> dup +controller-devices+ get at
- [ (read-controller) ] [ drop f ] if* ;
-
-M: dinput-game-input-backend calibrate-controller
- handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
-
-M: dinput-game-input-backend read-keyboard
- +keyboard-device+ get
- [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
- [ ] [ f ] with-acquisition ;
+++ /dev/null
-USING: sequences sequences.private math alien.c-types
-accessors ;
-IN: game-input.backend.dinput.keys-array
-
-TUPLE: keys-array underlying ;
-C: <keys-array> keys-array
-
-: >key ( byte -- ? )
- HEX: 80 bitand c-bool> ;
-
-M: keys-array length underlying>> length ;
-M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
-
-INSTANCE: keys-array sequence
-
+++ /dev/null
-DirectInput backend for game-input
+++ /dev/null
-unportable
-games
+++ /dev/null
-USING: cocoa cocoa.plists core-foundation iokit iokit.hid
-kernel cocoa.enumeration destructors math.parser cocoa.application
-sequences locals combinators.short-circuit threads
-symbols namespaces assocs vectors arrays combinators
-core-foundation.run-loop accessors sequences.private
-alien.c-types math parser ;
-<< "game-input" (use+) >>
-IN: game-input.backend.iokit
-
-SINGLETON: iokit-game-input-backend
-
-: hid-manager-matching ( matching-seq -- alien )
- f 0 IOHIDManagerCreate
- [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
- keep ;
-
-: devices-from-hid-manager ( manager -- vector )
- [
- IOHIDManagerCopyDevices
- [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
- ] with-destructors ;
-
-: game-devices-matching-seq
- {
- H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
- H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
- H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
- } ; inline
-
-: buttons-matching-hash
- H{ { "UsagePage" 9 } { "Type" 2 } } ; inline
-: keys-matching-hash
- H{ { "UsagePage" 7 } { "Type" 2 } } ; inline
-: x-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } } ; inline
-: y-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } } ; inline
-: z-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } } ; inline
-: rx-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } } ; inline
-: ry-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } } ; inline
-: rz-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } ; inline
-: slider-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } ; inline
-: hat-switch-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } ; inline
-
-: device-elements-matching ( device matching-hash -- vector )
- [
- >plist 0 IOHIDDeviceCopyMatchingElements
- [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
- ] with-destructors ;
-
-: button-count ( device -- button-count )
- buttons-matching-hash device-elements-matching length ;
-
-: ?axis ( device hash -- axis/f )
- device-elements-matching [ f ] [ first ] if-empty ;
-
-: ?x-axis ( device -- ? )
- x-axis-matching-hash ?axis ;
-: ?y-axis ( device -- ? )
- y-axis-matching-hash ?axis ;
-: ?z-axis ( device -- ? )
- z-axis-matching-hash ?axis ;
-: ?rx-axis ( device -- ? )
- rx-axis-matching-hash ?axis ;
-: ?ry-axis ( device -- ? )
- ry-axis-matching-hash ?axis ;
-: ?rz-axis ( device -- ? )
- rz-axis-matching-hash ?axis ;
-: ?slider ( device -- ? )
- slider-matching-hash ?axis ;
-: ?hat-switch ( device -- ? )
- hat-switch-matching-hash ?axis ;
-
-: hid-manager-matching-game-devices ( -- alien )
- game-devices-matching-seq hid-manager-matching ;
-
-: device-property ( device key -- value )
- <NSString> IOHIDDeviceGetProperty plist> ;
-: element-property ( element key -- value )
- <NSString> IOHIDElementGetProperty plist> ;
-: set-element-property ( element key value -- )
- [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
-: transfer-element-property ( element from-key to-key -- )
- [ dupd element-property ] dip swap set-element-property ;
-
-: controller-device? ( device -- ? )
- {
- [ 1 4 IOHIDDeviceConformsTo ]
- [ 1 5 IOHIDDeviceConformsTo ]
- } 1|| ;
-
-: element-usage ( element -- {usage-page,usage} )
- [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
- 2array ;
-
-: button? ( {usage-page,usage} -- ? )
- first 9 = ; inline
-: keyboard-key? ( {usage-page,usage} -- ? )
- first 7 = ; inline
-: x-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 30 } = ; inline
-: y-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 31 } = ; inline
-: z-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 32 } = ; inline
-: rx-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 33 } = ; inline
-: ry-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 34 } = ; inline
-: rz-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 35 } = ; inline
-: slider? ( {usage-page,usage} -- ? )
- { 1 HEX: 36 } = ; inline
-: hat-switch? ( {usage-page,usage} -- ? )
- { 1 HEX: 39 } = ; inline
-
-: pov-values
- {
- pov-up pov-up-right pov-right pov-down-right
- pov-down pov-down-left pov-left pov-up-left
- pov-neutral
- } ; inline
-
-: button-value ( value -- f/(0,1] )
- IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
-: axis-value ( value -- [-1,1] )
- kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
-: pov-value ( value -- pov-direction )
- IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
-
-: record-controller ( controller-state value -- )
- dup IOHIDValueGetElement element-usage {
- { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
- { [ dup x-axis? ] [ drop axis-value >>x drop ] }
- { [ dup y-axis? ] [ drop axis-value >>y drop ] }
- { [ dup z-axis? ] [ drop axis-value >>z drop ] }
- { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
- { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
- { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
- { [ dup slider? ] [ drop axis-value >>slider drop ] }
- { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
- [ 3drop ]
- } cond ;
-
-SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
-
-: ?set-nth ( value nth seq -- )
- 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
-
-: record-keyboard ( value -- )
- dup IOHIDValueGetElement element-usage keyboard-key? [
- [ IOHIDValueGetIntegerValue c-bool> ]
- [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
- +keyboard-state+ get ?set-nth
- ] [ drop ] if ;
-
-: default-calibrate-saturation ( element -- )
- [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
- [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
- bi ;
-
-: default-calibrate-axis ( element -- )
- [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
- [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
- [ default-calibrate-saturation ]
- tri ;
-
-: default-calibrate-slider ( element -- )
- [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
- [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
- [ default-calibrate-saturation ]
- tri ;
-
-: (default) ( ? quot -- )
- [ f ] if* ; inline
-
-: <device-controller-state> ( device -- controller-state )
- {
- [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
- [ ?hat-switch pov-neutral and ]
- [ button-count f <array> ]
- } cleave controller-state boa ;
-
-: device-matched-callback ( -- alien )
- [| context result sender device |
- device controller-device? [
- device <device-controller-state>
- device +controller-states+ get set-at
- ] when
- ] IOHIDDeviceCallback ;
-
-: device-removed-callback ( -- alien )
- [| context result sender device |
- device +controller-states+ get delete-at
- ] IOHIDDeviceCallback ;
-
-: device-input-callback ( -- alien )
- [| context result sender value |
- sender controller-device?
- [ sender +controller-states+ get at value record-controller ]
- [ value record-keyboard ]
- if
- ] IOHIDValueCallback ;
-
-: initialize-variables ( manager -- )
- +hid-manager+ set-global
- 4 <vector> +controller-states+ set-global
- 256 f <array> +keyboard-state+ set-global ;
-
-M: iokit-game-input-backend (open-game-input)
- hid-manager-matching-game-devices {
- [ initialize-variables ]
- [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
- [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
- [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
- [ 0 IOHIDManagerOpen mach-error ]
- [
- CFRunLoopGetMain CFRunLoopDefaultMode
- IOHIDManagerScheduleWithRunLoop
- ]
- } cleave ;
-
-M: iokit-game-input-backend (reset-game-input)
- { +hid-manager+ +keyboard-state+ +controller-states+ }
- [ f swap set-global ] each ;
-
-M: iokit-game-input-backend (close-game-input)
- +hid-manager+ get-global [
- +hid-manager+ global [
- [
- CFRunLoopGetMain CFRunLoopDefaultMode
- IOHIDManagerUnscheduleFromRunLoop
- ]
- [ 0 IOHIDManagerClose drop ]
- [ CFRelease ] tri
- f
- ] change-at
- f +keyboard-state+ set-global
- f +controller-states+ set-global
- ] when ;
-
-M: iokit-game-input-backend get-controllers ( -- sequence )
- +controller-states+ get keys [ controller boa ] map ;
-
-: ?join ( pre post sep -- string )
- 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
-
-M: iokit-game-input-backend product-string ( controller -- string )
- handle>>
- [ kIOHIDManufacturerKey device-property ]
- [ kIOHIDProductKey device-property ] bi " " ?join ;
-M: iokit-game-input-backend product-id ( controller -- integer )
- handle>>
- [ kIOHIDVendorIDKey device-property ]
- [ kIOHIDProductIDKey device-property ] bi 2array ;
-M: iokit-game-input-backend instance-id ( controller -- integer )
- handle>> kIOHIDLocationIDKey device-property ;
-
-M: iokit-game-input-backend read-controller ( controller -- controller-state )
- handle>> +controller-states+ get at clone ;
-
-M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
- +keyboard-state+ get clone keyboard-state boa ;
-
-M: iokit-game-input-backend calibrate-controller ( controller -- )
- drop ;
+++ /dev/null
-IOKit HID Manager backend for game-input
+++ /dev/null
-unportable
-games
+++ /dev/null
-Platform-specific backends for game-input
--- /dev/null
+USING: windows.dinput windows.dinput.constants parser symbols
+alien.c-types windows.ole32 namespaces assocs kernel arrays
+vectors windows.kernel32 windows.com windows.dinput shuffle
+windows.user32 windows.messages sequences combinators locals
+math.geometry.rect ui.windows accessors math windows alien
+alien.strings io.encodings.utf16 io.encodings.utf16n
+continuations byte-arrays game-input.dinput.keys-array ;
+IN: game-input.dinput
+
+SINGLETON: dinput-game-input-backend
+
+dinput-game-input-backend game-input-backend set-global
+
+SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+ ;
+
+: create-dinput ( -- )
+ f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
+ f <void*> [ f DirectInput8Create ole32-error ] keep *void*
+ +dinput+ set-global ;
+
+: delete-dinput ( -- )
+ +dinput+ global [ com-release f ] change-at ;
+
+: device-for-guid ( guid -- device )
+ +dinput+ get swap f <void*>
+ [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
+
+: set-coop-level ( device -- )
+ +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
+ IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
+
+: set-data-format ( device format-symbol -- )
+ get IDirectInputDevice8W::SetDataFormat ole32-error ;
+
+: configure-keyboard ( keyboard -- )
+ [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
+: configure-controller ( controller -- )
+ [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
+
+: find-keyboard ( -- )
+ GUID_SysKeyboard device-for-guid
+ [ configure-keyboard ]
+ [ +keyboard-device+ set-global ] bi
+ 256 <byte-array> <keys-array> keyboard-state boa
+ +keyboard-state+ set-global ;
+
+: device-info ( device -- DIDEVICEIMAGEINFOW )
+ "DIDEVICEINSTANCEW" <c-object>
+ "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
+ [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
+: device-caps ( device -- DIDEVCAPS )
+ "DIDEVCAPS" <c-object>
+ "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
+ [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
+
+: <guid> ( memory -- byte-array )
+ "GUID" heap-size memory>byte-array ;
+
+: device-guid ( device -- guid )
+ device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
+
+: device-attached? ( device -- ? )
+ +dinput+ get swap device-guid
+ IDirectInput8W::GetDeviceStatus S_OK = ;
+
+: find-device-axes-callback ( -- alien )
+ [ ! ( lpddoi pvRef -- BOOL )
+ +controller-devices+ get at
+ swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
+ { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
+ { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
+ { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
+ { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
+ { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
+ { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
+ { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
+ [ drop ]
+ } cond drop
+ DIENUM_CONTINUE
+ ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
+
+: find-device-axes ( device controller-state -- controller-state )
+ swap [ +controller-devices+ get set-at ] 2keep
+ find-device-axes-callback over DIDFT_AXIS
+ IDirectInputDevice8W::EnumObjects ole32-error ;
+
+: controller-state-template ( device -- controller-state )
+ controller-state new
+ over device-caps
+ [ DIDEVCAPS-dwButtons f <array> >>buttons ]
+ [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
+ find-device-axes ;
+
+: device-known? ( guid -- ? )
+ +controller-guids+ get key? ; inline
+
+: (add-controller) ( guid -- )
+ device-for-guid {
+ [ configure-controller ]
+ [ controller-state-template ]
+ [ dup device-guid +controller-guids+ get set-at ]
+ [ +controller-devices+ get set-at ]
+ } cleave ;
+
+: add-controller ( guid -- )
+ dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
+
+: remove-controller ( device -- )
+ [ +controller-devices+ get delete-at ]
+ [ device-guid +controller-guids+ get delete-at ]
+ [ com-release ] tri ;
+
+: find-controller-callback ( -- alien )
+ [ ! ( lpddi pvRef -- BOOL )
+ drop DIDEVICEINSTANCEW-guidInstance add-controller
+ DIENUM_CONTINUE
+ ] LPDIENUMDEVICESCALLBACKW ;
+
+: find-controllers ( -- )
+ +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
+ f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
+
+: set-up-controllers ( -- )
+ 4 <vector> +controller-devices+ set-global
+ 4 <vector> +controller-guids+ set-global
+ find-controllers ;
+
+: find-and-remove-detached-devices ( -- )
+ +controller-devices+ get keys
+ [ device-attached? not ] filter
+ [ remove-controller ] each ;
+
+: device-interface? ( dbt-broadcast-hdr -- ? )
+ DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
+
+: device-arrived ( dbt-broadcast-hdr -- )
+ device-interface? [ find-controllers ] when ;
+
+: device-removed ( dbt-broadcast-hdr -- )
+ device-interface? [ find-and-remove-detached-devices ] when ;
+
+: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
+ [ 2drop ] 2dip swap {
+ { [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
+ { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
+ [ 2drop ]
+ } cond ;
+
+TUPLE: window-rect < rect window-loc ;
+: <zero-window-rect> ( -- window-rect )
+ window-rect new
+ { 0 0 } >>window-loc
+ { 0 0 } >>loc
+ { 0 0 } >>dim ;
+
+: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
+ "DEV_BROADCAST_DEVICEW" <c-object>
+ "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
+ DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
+
+: create-device-change-window ( -- )
+ <zero-window-rect> create-window
+ [
+ (device-notification-filter)
+ DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
+ RegisterDeviceNotification
+ +device-change-handle+ set-global
+ ]
+ [ +device-change-window+ set-global ] bi ;
+
+: close-device-change-window ( -- )
+ +device-change-handle+ global
+ [ UnregisterDeviceNotification drop f ] change-at
+ +device-change-window+ global
+ [ DestroyWindow win32-error=0/f f ] change-at ;
+
+: add-wm-devicechange ( -- )
+ [ 4dup handle-wm-devicechange DefWindowProc ]
+ WM_DEVICECHANGE add-wm-handler ;
+
+: remove-wm-devicechange ( -- )
+ WM_DEVICECHANGE wm-handlers get-global delete-at ;
+
+: release-controllers ( -- )
+ +controller-devices+ global [
+ [ drop com-release ] assoc-each f
+ ] change-at
+ f +controller-guids+ set-global ;
+
+: release-keyboard ( -- )
+ +keyboard-device+ global
+ [ com-release f ] change-at
+ f +keyboard-state+ set-global ;
+
+M: dinput-game-input-backend (open-game-input)
+ create-dinput
+ create-device-change-window
+ find-keyboard
+ set-up-controllers
+ add-wm-devicechange ;
+
+M: dinput-game-input-backend (close-game-input)
+ remove-wm-devicechange
+ release-controllers
+ release-keyboard
+ close-device-change-window
+ delete-dinput ;
+
+M: dinput-game-input-backend (reset-game-input)
+ {
+ +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+
+ } [ f swap set-global ] each ;
+
+M: dinput-game-input-backend get-controllers
+ +controller-devices+ get
+ [ drop controller boa ] { } assoc>map ;
+
+M: dinput-game-input-backend product-string
+ handle>> device-info DIDEVICEINSTANCEW-tszProductName
+ utf16n alien>string ;
+
+M: dinput-game-input-backend product-id
+ handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
+M: dinput-game-input-backend instance-id
+ handle>> device-guid ;
+
+:: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
+ device IDirectInputDevice8W::Acquire succeeded? [
+ device acquired-quot call
+ succeeded-quot call
+ ] failed-quot if ; inline
+
+: pov-values
+ {
+ pov-up pov-up-right pov-right pov-down-right
+ pov-down pov-down-left pov-left pov-up-left
+ } ; inline
+
+: >axis ( long -- float )
+ 32767 - 32767.0 /f ;
+: >slider ( long -- float )
+ 65535.0 /f ;
+: >pov ( long -- symbol )
+ dup HEX: FFFF bitand HEX: FFFF =
+ [ drop pov-neutral ]
+ [ 2750 + 4500 /i pov-values nth ] if ;
+: >buttons ( alien length -- array )
+ memory>byte-array <keys-array> ;
+
+: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
+ [ drop ] compose [ 2drop ] if ; inline
+
+: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
+ {
+ [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
+ [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
+ [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
+ [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
+ [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
+ [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
+ [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
+ [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
+ [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
+ } 2cleave ;
+
+: get-device-state ( device byte-array -- )
+ [ dup IDirectInputDevice8W::Poll ole32-error ] dip
+ [ length ] keep
+ IDirectInputDevice8W::GetDeviceState ole32-error ;
+
+: (read-controller) ( handle template -- state )
+ swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
+ [ fill-controller-state ] [ drop f ] with-acquisition ;
+
+M: dinput-game-input-backend read-controller
+ handle>> dup +controller-devices+ get at
+ [ (read-controller) ] [ drop f ] if* ;
+
+M: dinput-game-input-backend calibrate-controller
+ handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
+
+M: dinput-game-input-backend read-keyboard
+ +keyboard-device+ get
+ [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
+ [ ] [ f ] with-acquisition ;
--- /dev/null
+USING: sequences sequences.private math alien.c-types
+accessors ;
+IN: game-input.dinput.keys-array
+
+TUPLE: keys-array underlying ;
+C: <keys-array> keys-array
+
+: >key ( byte -- ? )
+ HEX: 80 bitand c-bool> ;
+
+M: keys-array length underlying>> length ;
+M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
+
+INSTANCE: keys-array sequence
+
--- /dev/null
+DirectInput backend for game-input
--- /dev/null
+unportable
+games
-USING: arrays accessors continuations kernel symbols
-combinators.lib sequences namespaces init vocabs ;
+USING: arrays accessors continuations kernel symbols system
+combinators.lib sequences namespaces init vocabs vocabs.loader
+combinators ;
IN: game-input
SYMBOLS: game-input-backend game-input-opened ;
game-input-opened off
(reset-game-input) ;
-: load-game-input-backend ( -- )
- game-input-backend get
- [ "game-input.backend" load-vocab drop ] unless ;
-
[ reset-game-input ] "game-input" add-init-hook
PRIVATE>
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
-load-game-input-backend
-
+{
+ { [ os windows? ] [ "game-input.dinput" require ] }
+ { [ os macosx? ] [ "game-input.iokit" require ] }
+ { [ t ] [ ] }
+} cond
--- /dev/null
+USING: cocoa cocoa.plists core-foundation iokit iokit.hid
+kernel cocoa.enumeration destructors math.parser cocoa.application
+sequences locals combinators.short-circuit threads
+symbols namespaces assocs vectors arrays combinators
+core-foundation.run-loop accessors sequences.private
+alien.c-types math parser game-input ;
+IN: game-input.iokit
+
+SINGLETON: iokit-game-input-backend
+
+iokit-game-input-backend game-input-backend set-global
+
+: hid-manager-matching ( matching-seq -- alien )
+ f 0 IOHIDManagerCreate
+ [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
+ keep ;
+
+: devices-from-hid-manager ( manager -- vector )
+ [
+ IOHIDManagerCopyDevices
+ [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
+ ] with-destructors ;
+
+: game-devices-matching-seq
+ {
+ H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
+ H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
+ H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
+ } ; inline
+
+: buttons-matching-hash
+ H{ { "UsagePage" 9 } { "Type" 2 } } ; inline
+: keys-matching-hash
+ H{ { "UsagePage" 7 } { "Type" 2 } } ; inline
+: x-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } } ; inline
+: y-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } } ; inline
+: z-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } } ; inline
+: rx-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } } ; inline
+: ry-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } } ; inline
+: rz-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } ; inline
+: slider-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } ; inline
+: hat-switch-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } ; inline
+
+: device-elements-matching ( device matching-hash -- vector )
+ [
+ >plist 0 IOHIDDeviceCopyMatchingElements
+ [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
+ ] with-destructors ;
+
+: button-count ( device -- button-count )
+ buttons-matching-hash device-elements-matching length ;
+
+: ?axis ( device hash -- axis/f )
+ device-elements-matching [ f ] [ first ] if-empty ;
+
+: ?x-axis ( device -- ? )
+ x-axis-matching-hash ?axis ;
+: ?y-axis ( device -- ? )
+ y-axis-matching-hash ?axis ;
+: ?z-axis ( device -- ? )
+ z-axis-matching-hash ?axis ;
+: ?rx-axis ( device -- ? )
+ rx-axis-matching-hash ?axis ;
+: ?ry-axis ( device -- ? )
+ ry-axis-matching-hash ?axis ;
+: ?rz-axis ( device -- ? )
+ rz-axis-matching-hash ?axis ;
+: ?slider ( device -- ? )
+ slider-matching-hash ?axis ;
+: ?hat-switch ( device -- ? )
+ hat-switch-matching-hash ?axis ;
+
+: hid-manager-matching-game-devices ( -- alien )
+ game-devices-matching-seq hid-manager-matching ;
+
+: device-property ( device key -- value )
+ <NSString> IOHIDDeviceGetProperty plist> ;
+: element-property ( element key -- value )
+ <NSString> IOHIDElementGetProperty plist> ;
+: set-element-property ( element key value -- )
+ [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
+: transfer-element-property ( element from-key to-key -- )
+ [ dupd element-property ] dip swap set-element-property ;
+
+: controller-device? ( device -- ? )
+ {
+ [ 1 4 IOHIDDeviceConformsTo ]
+ [ 1 5 IOHIDDeviceConformsTo ]
+ } 1|| ;
+
+: element-usage ( element -- {usage-page,usage} )
+ [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
+ 2array ;
+
+: button? ( {usage-page,usage} -- ? )
+ first 9 = ; inline
+: keyboard-key? ( {usage-page,usage} -- ? )
+ first 7 = ; inline
+: x-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 30 } = ; inline
+: y-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 31 } = ; inline
+: z-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 32 } = ; inline
+: rx-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 33 } = ; inline
+: ry-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 34 } = ; inline
+: rz-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 35 } = ; inline
+: slider? ( {usage-page,usage} -- ? )
+ { 1 HEX: 36 } = ; inline
+: hat-switch? ( {usage-page,usage} -- ? )
+ { 1 HEX: 39 } = ; inline
+
+: pov-values
+ {
+ pov-up pov-up-right pov-right pov-down-right
+ pov-down pov-down-left pov-left pov-up-left
+ pov-neutral
+ } ; inline
+
+: button-value ( value -- f/(0,1] )
+ IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
+: axis-value ( value -- [-1,1] )
+ kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
+: pov-value ( value -- pov-direction )
+ IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
+
+: record-controller ( controller-state value -- )
+ dup IOHIDValueGetElement element-usage {
+ { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
+ { [ dup x-axis? ] [ drop axis-value >>x drop ] }
+ { [ dup y-axis? ] [ drop axis-value >>y drop ] }
+ { [ dup z-axis? ] [ drop axis-value >>z drop ] }
+ { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
+ { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
+ { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
+ { [ dup slider? ] [ drop axis-value >>slider drop ] }
+ { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+ [ 3drop ]
+ } cond ;
+
+SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
+
+: ?set-nth ( value nth seq -- )
+ 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
+
+: record-keyboard ( value -- )
+ dup IOHIDValueGetElement element-usage keyboard-key? [
+ [ IOHIDValueGetIntegerValue c-bool> ]
+ [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
+ +keyboard-state+ get ?set-nth
+ ] [ drop ] if ;
+
+: default-calibrate-saturation ( element -- )
+ [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
+ [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
+ bi ;
+
+: default-calibrate-axis ( element -- )
+ [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
+ [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
+ [ default-calibrate-saturation ]
+ tri ;
+
+: default-calibrate-slider ( element -- )
+ [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
+ [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
+ [ default-calibrate-saturation ]
+ tri ;
+
+: (default) ( ? quot -- )
+ [ f ] if* ; inline
+
+: <device-controller-state> ( device -- controller-state )
+ {
+ [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
+ [ ?hat-switch pov-neutral and ]
+ [ button-count f <array> ]
+ } cleave controller-state boa ;
+
+: device-matched-callback ( -- alien )
+ [| context result sender device |
+ device controller-device? [
+ device <device-controller-state>
+ device +controller-states+ get set-at
+ ] when
+ ] IOHIDDeviceCallback ;
+
+: device-removed-callback ( -- alien )
+ [| context result sender device |
+ device +controller-states+ get delete-at
+ ] IOHIDDeviceCallback ;
+
+: device-input-callback ( -- alien )
+ [| context result sender value |
+ sender controller-device?
+ [ sender +controller-states+ get at value record-controller ]
+ [ value record-keyboard ]
+ if
+ ] IOHIDValueCallback ;
+
+: initialize-variables ( manager -- )
+ +hid-manager+ set-global
+ 4 <vector> +controller-states+ set-global
+ 256 f <array> +keyboard-state+ set-global ;
+
+M: iokit-game-input-backend (open-game-input)
+ hid-manager-matching-game-devices {
+ [ initialize-variables ]
+ [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
+ [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
+ [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
+ [ 0 IOHIDManagerOpen mach-error ]
+ [
+ CFRunLoopGetMain CFRunLoopDefaultMode
+ IOHIDManagerScheduleWithRunLoop
+ ]
+ } cleave ;
+
+M: iokit-game-input-backend (reset-game-input)
+ { +hid-manager+ +keyboard-state+ +controller-states+ }
+ [ f swap set-global ] each ;
+
+M: iokit-game-input-backend (close-game-input)
+ +hid-manager+ get-global [
+ +hid-manager+ global [
+ [
+ CFRunLoopGetMain CFRunLoopDefaultMode
+ IOHIDManagerUnscheduleFromRunLoop
+ ]
+ [ 0 IOHIDManagerClose drop ]
+ [ CFRelease ] tri
+ f
+ ] change-at
+ f +keyboard-state+ set-global
+ f +controller-states+ set-global
+ ] when ;
+
+M: iokit-game-input-backend get-controllers ( -- sequence )
+ +controller-states+ get keys [ controller boa ] map ;
+
+: ?join ( pre post sep -- string )
+ 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
+
+M: iokit-game-input-backend product-string ( controller -- string )
+ handle>>
+ [ kIOHIDManufacturerKey device-property ]
+ [ kIOHIDProductKey device-property ] bi " " ?join ;
+M: iokit-game-input-backend product-id ( controller -- integer )
+ handle>>
+ [ kIOHIDVendorIDKey device-property ]
+ [ kIOHIDProductIDKey device-property ] bi 2array ;
+M: iokit-game-input-backend instance-id ( controller -- integer )
+ handle>> kIOHIDLocationIDKey device-property ;
+
+M: iokit-game-input-backend read-controller ( controller -- controller-state )
+ handle>> +controller-states+ get at clone ;
+
+M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
+ +keyboard-state+ get clone keyboard-state boa ;
+
+M: iokit-game-input-backend calibrate-controller ( controller -- )
+ drop ;
--- /dev/null
+IOKit HID Manager backend for game-input
--- /dev/null
+unportable
+games
ERROR: invalid-baud baud ;
M: invalid-baud summary ( invalid-baud -- string )
- "Baud rate "
- swap baud>> number>string
- " not supported" 3append ;
+ baud>> number>string
+ "Baud rate " " not supported" surround ;
HOOK: lookup-baud os ( m -- n )
HOOK: open-serial os ( serial -- stream )
projects / factor.git / commitdiff