steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://repo.or.cz/factor/jcg

db4
Slava Pestov 2008-07-27 16:56:29 -05:00
parent ebde016eed 3a7dd35e39
commit 10322c11e3
45 changed files with 2335 additions and 384 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
extra/cocoa/cocoa.factor
View File

@ -61,6 +61,7 @@ SYMBOL: super-sent-messages
"NSOpenGLView"
"NSOpenPanel"
"NSPasteboard"
"NSPropertyListSerialization"
"NSResponder"
"NSSavePanel"
"NSScreen"

16
extra/cocoa/plists/plists.factor
View File

@ -3,7 +3,7 @@
USING: strings arrays hashtables assocs sequences
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
combinators alien.c-types ;
combinators alien.c-types core-foundation ;
IN: cocoa.plists
GENERIC: >plist ( value -- plist )
@ -24,8 +24,8 @@ M: sequence >plist
[ >plist ] map <NSArray> ;
: write-plist ( assoc path -- )
>r >plist
r> normalize-path <NSString> 0 -> writeToFile:atomically:
[ >plist ] [ normalize-path <NSString> ] bi* 0
-> writeToFile:atomically:
[ "write-plist failed" throw ] unless ;
DEFER: plist>
@ -57,3 +57,13 @@ DEFER: plist>
{ [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] }
[ ]
} cond ;
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f f <void*>
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
*void* [ -> release "read-plist failed" throw ] when* ;
: read-plist ( path -- assoc )
normalize-path <NSString>
NSData swap -> dataWithContentsOfFile:
[ (read-plist) plist> ] [ "read-plist failed" throw ] if* ;

9
extra/combinators/lib/lib-tests.factor
View File

@ -2,6 +2,15 @@ USING: combinators.lib kernel math random sequences tools.test continuations
arrays vectors ;
IN: combinators.lib.tests
[ 6 -1 ] [ 5 0 1 [ + ] [ - ] bi, bi* ] unit-test
[ 6 -1 1 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri, tri* ] unit-test
[ 5 4 ] [ 5 0 1 [ + ] [ - ] bi*, bi ] unit-test
[ 5 4 5 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri*, tri ] unit-test
[ 5 6 ] [ 5 0 1 [ + ] bi@, bi ] unit-test
[ 5 6 7 ] [ 5 0 1 2 [ + ] tri@, tri ] unit-test
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test

19
extra/combinators/lib/lib.factor
View File

@ -8,6 +8,25 @@ generalizations macros continuations locals ;
IN: combinators.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Currying cleave combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bi, ( obj quot quot -- quot' quot' )
[ [ curry ] curry ] bi@ bi ; inline
: tri, ( obj quot quot quot -- quot' quot' quot' )
[ [ curry ] curry ] tri@ tri ; inline
: bi*, ( obj obj quot quot -- quot' quot' )
[ [ curry ] curry ] bi@ bi* ; inline
: tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
[ [ curry ] curry ] tri@ tri* ; inline
: bi@, ( obj obj quot -- quot' quot' )
[ curry ] curry bi@ ; inline
: tri@, ( obj obj obj quot -- quot' quot' quot' )
[ curry ] curry tri@ ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Generalized versions of core combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

5
extra/core-foundation/core-foundation.factor
View File

@ -43,6 +43,11 @@ TYPEDEF: int CFNumberType
: kCFNumberCGFloatType 16 ; inline
: kCFNumberMaxType 16 ; inline
TYPEDEF: int CFPropertyListMutabilityOptions
: kCFPropertyListImmutable 0 ; inline
: kCFPropertyListMutableContainers 1 ; inline
: kCFPropertyListMutableContainersAndLeaves 2 ; inline
FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;

1
extra/game-input/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

1
extra/game-input/backend/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

8
extra/game-input/backend/backend.factor Normal file
View File

@ -0,0 +1,8 @@
USING: kernel system combinators parser ;
IN: game-input.backend
<< {
{ [ os macosx? ] [ "game-input.backend.iokit" use+ ] }
{ [ os windows? ] [ "game-input.backend.dinput" use+ ] }
{ [ t ] [ ] }
} cond >>

1
extra/game-input/backend/dinput/authors.txt Executable file
View File

@ -0,0 +1 @@
Joe Groff

282
extra/game-input/backend/dinput/dinput.factor Executable file
View File

@ -0,0 +1,282 @@
USING: windows.dinput windows.dinput.constants game-input
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 continuations byte-arrays
locals game-input.backend.dinput.keys-array ;
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 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 ;
dinput-game-input-backend game-input-backend set-global

15
extra/game-input/backend/dinput/keys-array/keys-array.factor Executable file
View File

@ -0,0 +1,15 @@
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

1
extra/game-input/backend/dinput/summary.txt Executable file
View File

@ -0,0 +1 @@
DirectInput backend for game-input

4
extra/game-input/backend/dinput/tags.txt Executable file
View File

@ -0,0 +1,4 @@
input
gamepads
joysticks
windows

1
extra/game-input/backend/iokit/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

275
extra/game-input/backend/iokit/iokit.factor Executable file
View File

@ -0,0 +1,275 @@
USING: cocoa cocoa.plists core-foundation iokit iokit.hid
kernel cocoa.enumeration destructors math.parser cocoa.application
sequences locals combinators.short-circuit game-input threads
symbols namespaces assocs vectors arrays combinators
core-foundation.run-loop accessors sequences.private
alien.c-types math ;
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 dup empty? [ drop f ] [ first ] if ;
: ?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 (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 ;
iokit-game-input-backend game-input-backend set-global

1
extra/game-input/backend/iokit/summary.txt Normal file
View File

@ -0,0 +1 @@
IOKit HID Manager backend for game-input

4
extra/game-input/backend/iokit/tags.txt Normal file
View File

@ -0,0 +1,4 @@
gamepads
joysticks
mac
input

1
extra/game-input/backend/summary.txt Normal file
View File

@ -0,0 +1 @@
Platform-specific backends for game-input

3
extra/game-input/backend/tags.txt Normal file
View File

@ -0,0 +1,3 @@
gamepads
joysticks
input

126
extra/game-input/game-input-docs.factor Executable file
View File

@ -0,0 +1,126 @@
USING: help.markup help.syntax kernel ui.gestures quotations
sequences strings math ;
IN: game-input
ARTICLE: "game-input" "Game controller input"
"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl
"The game input interface must be initialized before being used:"
{ $subsection open-game-input }
{ $subsection close-game-input }
{ $subsection with-game-input }
"Once the game input interface is open, connected controller devices can be enumerated:"
{ $subsection get-controllers }
{ $subsection find-controller-products }
{ $subsection find-controller-instance }
"These " { $link controller } " objects can be queried of their identity:"
{ $subsection product-string }
{ $subsection product-id }
{ $subsection instance-id }
"A hook is provided for invoking the system calibration tool:"
{ $subsection calibrate-controller }
"The current state of a controller or the keyboard can be read:"
{ $subsection read-controller }
{ $subsection read-keyboard }
{ $subsection controller-state }
{ $subsection keyboard-state } ;
HELP: open-game-input
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
HELP: close-game-input
{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ;
HELP: game-input-opened?
{ $values { "?" "a boolean" } }
{ $description "Returns true if the game input interface is open, false otherwise." } ;
HELP: with-game-input
{ $values { "quot" quotation } }
{ $description "Initializes the game input interface for the dynamic extent of " { $snippet "quotation" } "." } ;
{ open-game-input close-game-input with-game-input game-input-opened? } related-words
HELP: get-controllers
{ $values { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers. The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "get-controllers" } "." } ;
HELP: find-controller-products
{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers with the given " { $link product-id } ". The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "find-controller-products" } "." } ;
HELP: find-controller-instance
{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "instance-id" "An instance ID as returned by " { $link instance-id } "." } { "controller/f" "A " { $link controller } " object, or " { $link f } } }
{ $description "Returns the " { $link controller } " instance identified by " { $snippet "product-id" } " and " { $snippet "instance-id" } ". If the identified device is not currently attached, " { $link f } " is returned." } ;
HELP: controller
{ $class-description "Objects of this class represent game controller devices such as joysticks and gamepads. They should be treated as opaque by client code." } ;
HELP: product-string
{ $values { "controller" controller } { "string" string } }
{ $description "Returns a human-readable string describing the game controller device represented by " { $snippet "controller" } ". This string is not necessarily unique to the product or instance; to uniquely identify the device, see " { $link product-id } " and " { $link instance-id } "." } ;
HELP: product-id
{ $values { "controller" controller } { "id" "A unique identifier" } }
{ $description "Returns an identifier uniquely representing the kind of game controller device represented by " { $snippet "controller" } ". This identifier will be the same for devices of the same make and manufacturer. The type of the identifier value is platform-specific, but equivalent " { $snippet "product-id" } "s are guaranteed to be testable with the " { $link = } " word. The identifier can be used to find devices of the same kind with the " { $link find-controller-products } " word." } ;
HELP: instance-id
{ $values { "controller" controller } { "id" "A unique identifier" } }
{ $description "Returns an identifier uniquely representing the game controller device represented by " { $snippet "controller" } ". This identifier paired with the device's " { $link product-id } " provides a unique identifier for a particular device that persists between reboots (but not necessarily between computers). This unique identifier can be used to find the same device again with the " { $snippet "find-controller-instance" } " word. Depending on the platform, the instance-id may change if the device is plugged into a different port. The type of the identifier value is platform-specific, but equivalent " { $snippet "instance-id" } "s are guaranteed to be testable with the " { $link = } " word." } ;
{ product-string product-id instance-id find-controller-products find-controller-instance } related-words
HELP: calibrate-controller
{ $values { "controller" controller } }
{ $description "Invokes the operating system's calibration tool for " { $snippet "controller" } ". If the operating system does not have a calibration tool, this word does nothing." } ;
HELP: read-controller
{ $values { "controller" controller } { "controller-state" controller-state } }
{ $description "Reads the current state of " { $snippet "controller" } ". See the documentation for the " { $link controller-state } " class for details of the returned value's format. If the device is no longer available, " { $link f } " is returned." }
{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "controller-state" } " object next time " { $snippet "read-controller" } " is called on the same controller. You should " { $link clone } " any values from the returned tuple you need to preserve." } ;
{ controller-state controller read-controller } related-words
HELP: read-keyboard
{ $values { "keyboard-state" keyboard-state } }
{ $description "Reads the current raw state of the keyboard. See the documentation for the " { $link keyboard-state } " class for details on the returned value's format." }
{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
$nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
HELP: controller-state
{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
{ $list
{ { $snippet "x" } " contains the position of the device's X axis." }
{ { $snippet "y" } " contains the position of the device's Y axis." }
{ { $snippet "z" } " contains the position of the device's Z axis, if any." }
{ { $snippet "rx" } " contains the rotational position of the device's X axis, if available." }
{ { $snippet "ry" } " contains the rotational position of the device's Y axis, if available." }
{ { $snippet "rz" } " contains the rotational position of the device's Z axis, if available." }
{ { $snippet "slider" } " contains the position of the device's throttle slider, if any." }
{ { $snippet "pov" } " contains the state of the device's POV hat, if any." }
{ { $snippet "buttons" } " contains a sequence of values indicating the state of every button on the device." }
}
"The values are formatted as follows:"
{ $list
{ "For the axis slots (" { $snippet "x" } ", " { $snippet "y" } ", " { $snippet "z" } ", " { $snippet "rx" } ", " { $snippet "ry" } ", " { $snippet "rz" } "), a " { $link float } " value between -1.0 and 1.0 is returned." }
{ "For the " { $snippet "slider" } " slot, a value between 0.0 and 1.0 is returned." }
{ "For the " { $snippet "pov" } " slot, one of the following symbols is returned:" { $list
{ { $link pov-neutral } }
{ { $link pov-up } }
{ { $link pov-up-right } }
{ { $link pov-right } }
{ { $link pov-down-right } }
{ { $link pov-down } }
{ { $link pov-down-left } }
{ { $link pov-left } }
{ { $link pov-up-left } }
} }
{ "For each element of the " { $snippet "buttons" } " array, " { $link f } " indicates that the corresponding button is released. If the button is pressed, a value between 0.0 and 1.0 is returned indicating the pressure on the button (or simply 1.0 if the device's buttons are on/off only)." }
{ "A value of " { $link f } " in any slot (besides the elements of " { $snippet "buttons" } ") indicates that the corresponding element is not present on the device." } } } ;
HELP: keyboard-state
{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
{ keyboard-state read-keyboard } related-words
ABOUT: "game-input"

60
extra/game-input/game-input.factor Executable file
View File

@ -0,0 +1,60 @@
USING: arrays accessors continuations kernel symbols
combinators.lib sequences namespaces ;
IN: game-input
SYMBOLS: game-input-backend game-input-opened ;
HOOK: (open-game-input) game-input-backend ( -- )
HOOK: (close-game-input) game-input-backend ( -- )
: game-input-opened? ( -- ? )
game-input-opened get ;
: open-game-input ( -- )
game-input-opened? [
(open-game-input)
game-input-opened on
] unless ;
: close-game-input ( -- )
game-input-opened? [
(close-game-input)
game-input-opened off
] when ;
: with-game-input ( quot -- )
open-game-input [ close-game-input ] [ ] cleanup ;
TUPLE: controller handle ;
TUPLE: controller-state x y z rx ry rz slider pov buttons ;
M: controller-state clone
call-next-method dup buttons>> clone >>buttons ;
SYMBOLS:
pov-neutral
pov-up pov-up-right pov-right pov-down-right
pov-down pov-down-left pov-left pov-up-left ;
HOOK: get-controllers game-input-backend ( -- sequence )
HOOK: product-string game-input-backend ( controller -- string )
HOOK: product-id game-input-backend ( controller -- id )
HOOK: instance-id game-input-backend ( controller -- id )
: find-controller-products ( product-id -- sequence )
get-controllers [ product-id = ] with filter ;
: find-controller-instance ( product-id instance-id -- controller/f )
get-controllers [
[ product-id = ]
[ instance-id = ] bi, bi* and
] 2with find nip ;
HOOK: read-controller game-input-backend ( controller -- controller-state )
HOOK: calibrate-controller game-input-backend ( controller -- )
TUPLE: keyboard-state keys ;
M: keyboard-state clone
call-next-method dup keys>> clone >>keys ;
HOOK: read-keyboard game-input-backend ( -- keyboard-state )

1
extra/game-input/scancodes/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

175
extra/game-input/scancodes/scancodes.factor Normal file
View File

@ -0,0 +1,175 @@
IN: game-input.scancodes
: key-undefined HEX: 0000 ; inline
: key-error-roll-over HEX: 0001 ; inline
: key-error-post-fail HEX: 0002 ; inline
: key-error-undefined HEX: 0003 ; inline
: key-a HEX: 0004 ; inline
: key-b HEX: 0005 ; inline
: key-c HEX: 0006 ; inline
: key-d HEX: 0007 ; inline
: key-e HEX: 0008 ; inline
: key-f HEX: 0009 ; inline
: key-g HEX: 000a ; inline
: key-h HEX: 000b ; inline
: key-i HEX: 000c ; inline
: key-j HEX: 000d ; inline
: key-k HEX: 000e ; inline
: key-l HEX: 000f ; inline
: key-m HEX: 0010 ; inline
: key-n HEX: 0011 ; inline
: key-o HEX: 0012 ; inline
: key-p HEX: 0013 ; inline
: key-q HEX: 0014 ; inline
: key-r HEX: 0015 ; inline
: key-s HEX: 0016 ; inline
: key-t HEX: 0017 ; inline
: key-u HEX: 0018 ; inline
: key-v HEX: 0019 ; inline
: key-w HEX: 001a ; inline
: key-x HEX: 001b ; inline
: key-y HEX: 001c ; inline
: key-z HEX: 001d ; inline
: key-1 HEX: 001e ; inline
: key-2 HEX: 001f ; inline
: key-3 HEX: 0020 ; inline
: key-4 HEX: 0021 ; inline
: key-5 HEX: 0022 ; inline
: key-6 HEX: 0023 ; inline
: key-7 HEX: 0024 ; inline
: key-8 HEX: 0025 ; inline
: key-9 HEX: 0026 ; inline
: key-0 HEX: 0027 ; inline
: key-return HEX: 0028 ; inline
: key-escape HEX: 0029 ; inline
: key-backspace HEX: 002a ; inline
: key-tab HEX: 002b ; inline
: key-space HEX: 002c ; inline
: key-- HEX: 002d ; inline
: key-= HEX: 002e ; inline
: key-[ HEX: 002f ; inline
: key-] HEX: 0030 ; inline
: key-\ HEX: 0031 ; inline
: key-#-non-us HEX: 0032 ; inline
: key-; HEX: 0033 ; inline
: key-' HEX: 0034 ; inline
: key-` HEX: 0035 ; inline
: key-, HEX: 0036 ; inline
: key-. HEX: 0037 ; inline
: key-/ HEX: 0038 ; inline
: key-caps-lock HEX: 0039 ; inline
: key-f1 HEX: 003a ; inline
: key-f2 HEX: 003b ; inline
: key-f3 HEX: 003c ; inline
: key-f4 HEX: 003d ; inline
: key-f5 HEX: 003e ; inline
: key-f6 HEX: 003f ; inline
: key-f7 HEX: 0040 ; inline
: key-f8 HEX: 0041 ; inline
: key-f9 HEX: 0042 ; inline
: key-f10 HEX: 0043 ; inline
: key-f11 HEX: 0044 ; inline
: key-f12 HEX: 0045 ; inline
: key-print-screen HEX: 0046 ; inline
: key-scroll-lock HEX: 0047 ; inline
: key-pause HEX: 0048 ; inline
: key-insert HEX: 0049 ; inline
: key-home HEX: 004a ; inline
: key-page-up HEX: 004b ; inline
: key-delete HEX: 004c ; inline
: key-end HEX: 004d ; inline
: key-page-down HEX: 004e ; inline
: key-right-arrow HEX: 004f ; inline
: key-left-arrow HEX: 0050 ; inline
: key-down-arrow HEX: 0051 ; inline
: key-up-arrow HEX: 0052 ; inline
: key-keypad-numlock HEX: 0053 ; inline
: key-keypad-/ HEX: 0054 ; inline
: key-keypad-* HEX: 0055 ; inline
: key-keypad-- HEX: 0056 ; inline
: key-keypad-+ HEX: 0057 ; inline
: key-keypad-enter HEX: 0058 ; inline
: key-keypad-1 HEX: 0059 ; inline
: key-keypad-2 HEX: 005a ; inline
: key-keypad-3 HEX: 005b ; inline
: key-keypad-4 HEX: 005c ; inline
: key-keypad-5 HEX: 005d ; inline
: key-keypad-6 HEX: 005e ; inline
: key-keypad-7 HEX: 005f ; inline
: key-keypad-8 HEX: 0060 ; inline
: key-keypad-9 HEX: 0061 ; inline
: key-keypad-0 HEX: 0062 ; inline
: key-keypad-. HEX: 0063 ; inline
: key-\-non-us HEX: 0064 ; inline
: key-application HEX: 0065 ; inline
: key-power HEX: 0066 ; inline
: key-keypad-= HEX: 0067 ; inline
: key-f13 HEX: 0068 ; inline
: key-f14 HEX: 0069 ; inline
: key-f15 HEX: 006a ; inline
: key-f16 HEX: 006b ; inline
: key-f17 HEX: 006c ; inline
: key-f18 HEX: 006d ; inline
: key-f19 HEX: 006e ; inline
: key-f20 HEX: 006f ; inline
: key-f21 HEX: 0070 ; inline
: key-f22 HEX: 0071 ; inline
: key-f23 HEX: 0072 ; inline
: key-f24 HEX: 0073 ; inline
: key-execute HEX: 0074 ; inline
: key-help HEX: 0075 ; inline
: key-menu HEX: 0076 ; inline
: key-select HEX: 0077 ; inline
: key-stop HEX: 0078 ; inline
: key-again HEX: 0079 ; inline
: key-undo HEX: 007a ; inline
: key-cut HEX: 007b ; inline
: key-copy HEX: 007c ; inline
: key-paste HEX: 007d ; inline
: key-find HEX: 007e ; inline
: key-mute HEX: 007f ; inline
: key-volume-up HEX: 0080 ; inline
: key-volume-down HEX: 0081 ; inline
: key-locking-caps-lock HEX: 0082 ; inline
: key-locking-num-lock HEX: 0083 ; inline
: key-locking-scroll-lock HEX: 0084 ; inline
: key-keypad-, HEX: 0085 ; inline
: key-keypad-=-as-400 HEX: 0086 ; inline
: key-international-1 HEX: 0087 ; inline
: key-international-2 HEX: 0088 ; inline
: key-international-3 HEX: 0089 ; inline
: key-international-4 HEX: 008a ; inline
: key-international-5 HEX: 008b ; inline
: key-international-6 HEX: 008c ; inline
: key-international-7 HEX: 008d ; inline
: key-international-8 HEX: 008e ; inline
: key-international-9 HEX: 008f ; inline
: key-lang-1 HEX: 0090 ; inline
: key-lang-2 HEX: 0091 ; inline
: key-lang-3 HEX: 0092 ; inline
: key-lang-4 HEX: 0093 ; inline
: key-lang-5 HEX: 0094 ; inline
: key-lang-6 HEX: 0095 ; inline
: key-lang-7 HEX: 0096 ; inline
: key-lang-8 HEX: 0097 ; inline
: key-lang-9 HEX: 0098 ; inline
: key-alternate-erase HEX: 0099 ; inline
: key-sysreq HEX: 009a ; inline
: key-cancel HEX: 009b ; inline
: key-clear HEX: 009c ; inline
: key-prior HEX: 009d ; inline
: key-enter HEX: 009e ; inline
: key-separator HEX: 009f ; inline
: key-out HEX: 00a0 ; inline
: key-oper HEX: 00a1 ; inline
: key-clear-again HEX: 00a2 ; inline
: key-crsel-props HEX: 00a3 ; inline
: key-exsel HEX: 00a4 ; inline
: key-left-control HEX: 00e0 ; inline
: key-left-shift HEX: 00e1 ; inline
: key-left-alt HEX: 00e2 ; inline
: key-left-gui HEX: 00e3 ; inline
: key-right-control HEX: 00e4 ; inline
: key-right-shift HEX: 00e5 ; inline
: key-right-alt HEX: 00e6 ; inline
: key-right-gui HEX: 00e7 ; inline

1
extra/game-input/scancodes/summary.txt Normal file
View File

@ -0,0 +1 @@
Scan code constants for HID keyboards

2
extra/game-input/scancodes/tags.txt Normal file
View File

@ -0,0 +1,2 @@
keyboard
input

1
extra/game-input/summary.txt Normal file
View File

@ -0,0 +1 @@
Cross-platform joystick, gamepad, and raw keyboard input

3
extra/game-input/tags.txt Normal file
View File

@ -0,0 +1,3 @@
joysticks
gamepads
input

1
extra/iokit/hid/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

11
extra/iokit/hid/hid.factor
View File

@ -20,8 +20,8 @@ IN: iokit.hid
: kIOHIDPrimaryUsageKey "PrimaryUsage" ; inline
: kIOHIDPrimaryUsagePageKey "PrimaryUsagePage" ; inline
: kIOHIDMaxInputReportSizeKey "MaxInputReportSize" ; inline
: kIOHIDMaxOutputReportSizeKey "MaxOutputReportSize" ; inline
: kIOHIDMaxFeatureReportSizeKey "MaxFeatureReportSize" ; inline
: kIOHIDMaxOutputReportSizeKey "MaxOutputReportSize" ; inline
: kIOHIDMaxFeatureReportSizeKey "MaxFeatureReportSize" ; inline
: kIOHIDReportIntervalKey "ReportInterval" ; inline
: kIOHIDElementKey "Elements" ; inline
@ -77,7 +77,7 @@ IN: iokit.hid
: kIOHIDElementTypeFeature 257 ; inline
: kIOHIDElementTypeCollection 513 ; inline
: kIOHIDElementCollectionTypePhysical HEX: 00 ; inline
: kIOHIDElementCollectionTypePhysical HEX: 00 ; inline
: kIOHIDElementCollectionTypeApplication HEX: 01 ; inline
: kIOHIDElementCollectionTypeLogical HEX: 02 ; inline
: kIOHIDElementCollectionTypeReport HEX: 03 ; inline
@ -90,10 +90,10 @@ IN: iokit.hid
: kIOHIDReportTypeFeature 2 ; inline
: kIOHIDReportTypeCount 3 ; inline
: kIOHIDOptionsTypeNone HEX: 00 ; inline
: kIOHIDOptionsTypeNone HEX: 00 ; inline
: kIOHIDOptionsTypeSeizeDevice HEX: 01 ; inline
: kIOHIDQueueOptionsTypeNone HEX: 00 ; inline
: kIOHIDQueueOptionsTypeNone HEX: 00 ; inline
: kIOHIDQueueOptionsTypeEnqueueAll HEX: 01 ; inline
: kIOHIDElementFlagsConstantMask HEX: 0001 ; inline
@ -269,3 +269,4 @@ FUNCTION: IOHIDValueRef IOHIDTransactionGetValue ( IOHIDTransactionRef transacti
FUNCTION: IOReturn IOHIDTransactionCommit ( IOHIDTransactionRef transaction ) ;
FUNCTION: IOReturn IOHIDTransactionCommitWithCallback ( IOHIDTransactionRef transaction, CFTimeInterval timeout, IOHIDCallback callback, void* context ) ;
FUNCTION: void IOHIDTransactionClear ( IOHIDTransactionRef transaction ) ;

1
extra/iokit/hid/summary.txt Normal file
View File

@ -0,0 +1 @@
HID Manager bindings

3
extra/iokit/hid/tags.txt Normal file
View File

@ -0,0 +1,3 @@
mac
bindings
system

0
extra/iokit/iokit.factor Normal file → Executable file
View File

1
extra/joystick-demo/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

145
extra/joystick-demo/joystick-demo.factor Executable file
View File

@ -0,0 +1,145 @@
USING: ui ui.gadgets sequences kernel arrays math colors
ui.render math.vectors accessors fry ui.gadgets.packs game-input
game-input.backend ui.gadgets.labels ui.gadgets.borders alarms
calendar locals combinators.lib strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: joystick-demo
: SIZE { 151 151 } ;
: INDICATOR-SIZE { 4 4 } ;
: FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: axis-gadget < gadget indicator z-indicator pov ;
M: axis-gadget pref-dim* drop SIZE ;
: (rect-polygon) ( lo hi -- polygon )
2dup
[ [ second ] [ first ] bi* swap 2array ]
[ [ first ] [ second ] bi* 2array ] 2bi swapd 4array ;
: indicator-polygon ( -- polygon )
{ 0 0 } INDICATOR-SIZE (rect-polygon) ;
: pov-polygons
V{
{ pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } }
{ pov-up { { 70 65 } { 75 60 } { 80 65 } } }
{ pov-up-right { { 83 60 } { 90 60 } { 90 67 } } }
{ pov-right { { 85 70 } { 90 75 } { 85 80 } } }
{ pov-down-right { { 90 83 } { 90 90 } { 83 90 } } }
{ pov-down { { 70 85 } { 75 90 } { 80 85 } } }
{ pov-down-left { { 67 90 } { 60 90 } { 60 83 } } }
{ pov-left { { 65 70 } { 60 75 } { 65 80 } } }
{ pov-up-left { { 67 60 } { 60 60 } { 60 67 } } }
} ;
: <indicator-gadget> ( color -- indicator )
indicator-polygon <polygon-gadget> ;
: (>loc) ( axisloc -- windowloc )
0.5 v*n { 0.5 0.5 } v+ SIZE v* [ >integer ] map
INDICATOR-SIZE 2 v/n v- ;
: (xy>loc) ( x y -- xyloc )
2array (>loc) ;
: (z>loc) ( z -- zloc )
0.0 swap 2array (>loc) ;
: (xyz>loc) ( x y z -- xyloc zloc )
[ [ 0.0 ] unless* ] tri@
[ (xy>loc) ] dip (z>loc) ;
: move-axis ( gadget x y z -- )
(xyz>loc) rot
[ indicator>> (>>loc) ]
[ z-indicator>> (>>loc) ] bi, bi* ;
: move-pov ( gadget pov -- )
swap pov>> [ interior>> -rot = [ gray ] [ white ] if >>color drop ]
with assoc-each ;
:: add-pov-gadget ( gadget direction polygon -- gadget direction gadget )
gadget white polygon <polygon-gadget> [ add-gadget ] keep
direction swap ;
: add-pov-gadgets ( gadget -- gadget )
pov-polygons [ add-pov-gadget ] assoc-map >>pov ;
: <axis-gadget> ( -- gadget )
axis-gadget new-gadget
add-pov-gadgets
black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
: add-gadget-with-border ( parent child -- parent )
2 <border> gray <solid> >>boundary add-gadget ;
: add-controller-label ( gadget controller -- gadget )
[ >>controller ] [ product-string <label> add-gadget ] bi ;
: add-axis-gadget ( gadget shelf -- gadget shelf )
<axis-gadget> [ >>axis ] [ add-gadget-with-border ] bi, bi* ;
: add-raxis-gadget ( gadget shelf -- gadget shelf )
<axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi, bi* ;
:: (add-button-gadgets) ( gadget shelf -- )
gadget controller>> read-controller buttons>> length [
number>string [ ] <bevel-button>
shelf over add-gadget drop
] map gadget (>>buttons) ;
: add-button-gadgets ( gadget shelf -- gadget shelf )
[ (add-button-gadgets) ] 2keep ;
: <joystick-demo-gadget> ( controller -- gadget )
joystick-demo-gadget new-gadget
{ 0 1 } >>orientation
swap add-controller-label
<shelf> add-axis-gadget add-raxis-gadget add-gadget
<shelf> add-button-gadgets add-gadget ;
: update-buttons ( buttons button-states -- )
[ >>selected? drop ] 2each ;
: kill-update-axes ( gadget -- )
gray <solid> >>interior
[ [ cancel-alarm ] when* f ] change-alarm
relayout-1 ;
: (update-axes) ( gadget controller-state -- )
{
[ [ axis>> ] [ [ x>> ] [ y>> ] [ z>> ] tri ] bi* move-axis ]
[ [ raxis>> ] [ [ rx>> ] [ ry>> ] [ rz>> ] tri ] bi* move-axis ]
[ [ axis>> ] [ pov>> ] bi* move-pov ]
[ [ buttons>> ] [ buttons>> ] bi* update-buttons ]
[ drop relayout-1 ]
} 2cleave ;
: update-axes ( gadget -- )
dup controller>> read-controller
[ (update-axes) ] [ kill-update-axes ] if* ;
M: joystick-demo-gadget graft*
dup '[ , update-axes ] FREQUENCY every >>alarm
drop ;
M: joystick-demo-gadget ungraft*
alarm>> [ cancel-alarm ] when* ;
: joystick-window ( controller -- )
[ <joystick-demo-gadget> ] [ product-string ] bi
open-window ;
: joystick-demo ( -- )
[
open-game-input
0.1 seconds sleep ! It might take a moment to find devices...
get-controllers [ joystick-window ] each
] with-ui ;
MAIN: joystick-demo

1
extra/joystick-demo/summary.txt Normal file
View File

@ -0,0 +1 @@
Demonstrate gamepad and joystick input

2
extra/joystick-demo/tags.txt Normal file
View File

@ -0,0 +1,2 @@
gamepads
joysticks

1
extra/key-caps/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

180
extra/key-caps/key-caps.factor Executable file
View File

@ -0,0 +1,180 @@
USING: game-input game-input.backend game-input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors
words arrays assocs math calendar fry alarms ui
ui.gadgets.borders ui.gestures ;
IN: key-caps
: key-locations H{
{ key-escape { { 0 0 } { 10 10 } } }
{ key-f1 { { 20 0 } { 10 10 } } }
{ key-f2 { { 30 0 } { 10 10 } } }
{ key-f3 { { 40 0 } { 10 10 } } }
{ key-f4 { { 50 0 } { 10 10 } } }
{ key-f5 { { 65 0 } { 10 10 } } }
{ key-f6 { { 75 0 } { 10 10 } } }
{ key-f7 { { 85 0 } { 10 10 } } }
{ key-f8 { { 95 0 } { 10 10 } } }
{ key-f9 { { 110 0 } { 10 10 } } }
{ key-f10 { { 120 0 } { 10 10 } } }
{ key-f11 { { 130 0 } { 10 10 } } }
{ key-f12 { { 140 0 } { 10 10 } } }
{ key-` { { 0 15 } { 10 10 } } }
{ key-1 { { 10 15 } { 10 10 } } }
{ key-2 { { 20 15 } { 10 10 } } }
{ key-3 { { 30 15 } { 10 10 } } }
{ key-4 { { 40 15 } { 10 10 } } }
{ key-5 { { 50 15 } { 10 10 } } }
{ key-6 { { 60 15 } { 10 10 } } }
{ key-7 { { 70 15 } { 10 10 } } }
{ key-8 { { 80 15 } { 10 10 } } }
{ key-9 { { 90 15 } { 10 10 } } }
{ key-0 { { 100 15 } { 10 10 } } }
{ key-- { { 110 15 } { 10 10 } } }
{ key-= { { 120 15 } { 10 10 } } }
{ key-backspace { { 130 15 } { 20 10 } } }
{ key-tab { { 0 25 } { 15 10 } } }
{ key-q { { 15 25 } { 10 10 } } }
{ key-w { { 25 25 } { 10 10 } } }
{ key-e { { 35 25 } { 10 10 } } }
{ key-r { { 45 25 } { 10 10 } } }
{ key-t { { 55 25 } { 10 10 } } }
{ key-y { { 65 25 } { 10 10 } } }
{ key-u { { 75 25 } { 10 10 } } }
{ key-i { { 85 25 } { 10 10 } } }
{ key-o { { 95 25 } { 10 10 } } }
{ key-p { { 105 25 } { 10 10 } } }
{ key-[ { { 115 25 } { 10 10 } } }
{ key-] { { 125 25 } { 10 10 } } }
{ key-\ { { 135 25 } { 15 10 } } }
{ key-caps-lock { { 0 35 } { 20 10 } } }
{ key-a { { 20 35 } { 10 10 } } }
{ key-s { { 30 35 } { 10 10 } } }
{ key-d { { 40 35 } { 10 10 } } }
{ key-f { { 50 35 } { 10 10 } } }
{ key-g { { 60 35 } { 10 10 } } }
{ key-h { { 70 35 } { 10 10 } } }
{ key-j { { 80 35 } { 10 10 } } }
{ key-k { { 90 35 } { 10 10 } } }
{ key-l { { 100 35 } { 10 10 } } }
{ key-; { { 110 35 } { 10 10 } } }
{ key-' { { 120 35 } { 10 10 } } }
{ key-return { { 130 35 } { 20 10 } } }
{ key-left-shift { { 0 45 } { 25 10 } } }
{ key-z { { 25 45 } { 10 10 } } }
{ key-x { { 35 45 } { 10 10 } } }
{ key-c { { 45 45 } { 10 10 } } }
{ key-v { { 55 45 } { 10 10 } } }
{ key-b { { 65 45 } { 10 10 } } }
{ key-n { { 75 45 } { 10 10 } } }
{ key-m { { 85 45 } { 10 10 } } }
{ key-, { { 95 45 } { 10 10 } } }
{ key-. { { 105 45 } { 10 10 } } }
{ key-/ { { 115 45 } { 10 10 } } }
{ key-right-shift { { 125 45 } { 25 10 } } }
{ key-left-control { { 0 55 } { 15 10 } } }
{ key-left-gui { { 15 55 } { 15 10 } } }
{ key-left-alt { { 30 55 } { 15 10 } } }
{ key-space { { 45 55 } { 45 10 } } }
{ key-right-alt { { 90 55 } { 15 10 } } }
{ key-right-gui { { 105 55 } { 15 10 } } }
{ key-application { { 120 55 } { 15 10 } } }
{ key-right-control { { 135 55 } { 15 10 } } }
{ key-print-screen { { 155 0 } { 10 10 } } }
{ key-scroll-lock { { 165 0 } { 10 10 } } }
{ key-pause { { 175 0 } { 10 10 } } }
{ key-insert { { 155 15 } { 10 10 } } }
{ key-home { { 165 15 } { 10 10 } } }
{ key-page-up { { 175 15 } { 10 10 } } }
{ key-delete { { 155 25 } { 10 10 } } }
{ key-end { { 165 25 } { 10 10 } } }
{ key-page-down { { 175 25 } { 10 10 } } }
{ key-up-arrow { { 165 45 } { 10 10 } } }
{ key-left-arrow { { 155 55 } { 10 10 } } }
{ key-down-arrow { { 165 55 } { 10 10 } } }
{ key-right-arrow { { 175 55 } { 10 10 } } }
{ key-keypad-numlock { { 190 15 } { 10 10 } } }
{ key-keypad-/ { { 200 15 } { 10 10 } } }
{ key-keypad-* { { 210 15 } { 10 10 } } }
{ key-keypad-- { { 220 15 } { 10 10 } } }
{ key-keypad-7 { { 190 25 } { 10 10 } } }
{ key-keypad-8 { { 200 25 } { 10 10 } } }
{ key-keypad-9 { { 210 25 } { 10 10 } } }
{ key-keypad-+ { { 220 25 } { 10 20 } } }
{ key-keypad-4 { { 190 35 } { 10 10 } } }
{ key-keypad-5 { { 200 35 } { 10 10 } } }
{ key-keypad-6 { { 210 35 } { 10 10 } } }
{ key-keypad-1 { { 190 45 } { 10 10 } } }
{ key-keypad-2 { { 200 45 } { 10 10 } } }
{ key-keypad-3 { { 210 45 } { 10 10 } } }
{ key-keypad-enter { { 220 45 } { 10 20 } } }
{ key-keypad-0 { { 190 55 } { 20 10 } } }
{ key-keypad-. { { 210 55 } { 10 10 } } }
} ;
: KEYBOARD-SIZE { 230 65 } ;
: FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: key-caps-gadget < gadget keys alarm ;
: make-key-gadget ( scancode dim array -- )
[
swap [
" " [ ] <bevel-button>
swap [ first >>loc ] [ second >>dim ] bi
] [ execute ] bi*
] dip set-nth ;
: add-keys-gadgets ( gadget -- gadget )
key-locations 256 f <array>
[ [ make-key-gadget ] curry assoc-each ]
[ [ [ add-gadget ] when* ] each ]
[ >>keys ] tri ;
: <key-caps-gadget> ( -- gadget )
key-caps-gadget new-gadget
add-keys-gadgets ;
M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
: update-key-caps-state ( gadget -- )
read-keyboard keys>> over keys>>
[ [ (>>selected?) ] [ drop ] if* ] 2each
relayout-1 ;
M: key-caps-gadget graft*
dup '[ , update-key-caps-state ] FREQUENCY every >>alarm
drop ;
M: key-caps-gadget ungraft*
alarm>> [ cancel-alarm ] when* ;
M: key-caps-gadget handle-gesture*
drop nip [ key-down? ] [ key-up? ] bi or not ;
: key-caps ( -- )
[
open-game-input
<key-caps-gadget> 5 <border> "Key Caps" open-window
] with-ui ;
MAIN: key-caps

1
extra/key-caps/summary.txt Normal file
View File

@ -0,0 +1 @@
Graphical keyboard diagram

1
extra/key-caps/tags.txt Normal file
View File

@ -0,0 +1 @@
keyboard

11
extra/math/blas/matrices/matrices-docs.factor
View File

@ -34,7 +34,16 @@ ARTICLE: "math.blas-types" "BLAS interface types"
{ $subsection <double-complex-blas-matrix> }
"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
{ $subsection <empty-vector> }
{ $subsection <empty-matrix> } ;
{ $subsection <empty-matrix> }
"BLAS vectors and matrices can also be constructed from other Factor sequences:"
{ $subsection >float-blas-vector }
{ $subsection >double-blas-vector }
{ $subsection >float-complex-blas-vector }
{ $subsection >double-complex-blas-vector }
{ $subsection >float-blas-matrix }
{ $subsection >double-blas-matrix }
{ $subsection >float-complex-blas-matrix }
{ $subsection >double-complex-blas-matrix } ;
ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
"Transposing and slicing matrices:"

951
extra/windows/dinput/constants/constants.factor
View File

File diff suppressed because it is too large Load Diff

352
extra/windows/dinput/dinput.factor
View File

@ -31,10 +31,12 @@ TYPEDEF: void* LPDIENUMCREATEDEFFECTOBJECTSCALLBACK
[ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
dip alien-callback ; inline
TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
: LPDIENUMEFFECTSINFILECALLBACK
[ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
dip alien-callback ; inline
TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCE" "LPVOID" } "stdcall" ]
: LPDIENUMDEVICEOBJECTSCALLBACKW
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCEW" "LPVOID" } "stdcall" ]
dip alien-callback ; inline
TYPEDEF: DWORD D3DCOLOR
@ -105,29 +107,35 @@ TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
C-STRUCT: DIDEVCAPS
{ "DWORD" "wSize" }
{ "DWORD" "wFlags" }
{ "DWORD" "wDevType" }
{ "DWORD" "wAxes" }
{ "DWORD" "wButtons" }
{ "DWORD" "wPOVs" }
{ "DWORD" "wFFSamplePeriod" }
{ "DWORD" "wFFMinTimeResolution" }
{ "DWORD" "wFirmwareRevision" }
{ "DWORD" "wHardwareRevision" }
{ "DWORD" "wFFDriverVersion" } ;
{ "DWORD" "dwSize" }
{ "DWORD" "dwFlags" }
{ "DWORD" "dwDevType" }
{ "DWORD" "dwAxes" }
{ "DWORD" "dwButtons" }
{ "DWORD" "dwPOVs" }
{ "DWORD" "dwFFSamplePeriod" }
{ "DWORD" "dwFFMinTimeResolution" }
{ "DWORD" "dwFirmwareRevision" }
{ "DWORD" "dwHardwareRevision" }
{ "DWORD" "dwFFDriverVersion" } ;
TYPEDEF: DIDEVCAPS* LPDIDEVCAPS
TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS
C-STRUCT: DIDEVICEOBJECTINSTANCEW
{ "DWORD" "dwSize" }
{ "GUID" "guidInstance" }
{ "GUID" "guidProduct" }
{ "DWORD" "dwDevType" }
{ "WCHAR[260]" "tszInstanceName" }
{ "WCHAR[260]" "tszProductName" }
{ "GUID" "guidFFDriver" }
{ "WORD" "wUsagePage" }
{ "WORD" "wUsage" } ;
{ "DWORD" "dwSize" }
{ "GUID" "guidType" }
{ "DWORD" "dwOfs" }
{ "DWORD" "dwType" }
{ "DWORD" "dwFlags" }
{ "WCHAR[260]" "tszName" }
{ "DWORD" "dwFFMaxForce" }
{ "DWORD" "dwFFForceResolution" }
{ "WORD" "wCollectionNumber" }
{ "WORD" "wDesignatorIndex" }
{ "WORD" "wUsagePage" }
{ "WORD" "wUsage" }
{ "DWORD" "dwDimension" }
{ "WORD" "wExponent" }
{ "WORD" "wReportId" } ;
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW
C-STRUCT: DIDEVICEOBJECTDATA
@ -161,6 +169,49 @@ C-STRUCT: DIPROPHEADER
{ "DWORD" "dwHow" } ;
TYPEDEF: DIPROPHEADER* LPDIPROPHEADER
TYPEDEF: DIPROPHEADER* LPCDIPROPHEADER
C-STRUCT: DIPROPDWORD
{ "DIPROPHEADER" "diph" }
{ "DWORD" "dwData" } ;
TYPEDEF: DIPROPDWORD* LPDIPROPDWORD
TYPEDEF: DIPROPDWORD* LPCDIPROPDWORD
C-STRUCT: DIPROPPOINTER
{ "DIPROPHEADER" "diph" }
{ "UINT_PTR" "uData" } ;
TYPEDEF: DIPROPPOINTER* LPDIPROPPOINTER
TYPEDEF: DIPROPPOINTER* LPCDIPROPPOINTER
C-STRUCT: DIPROPRANGE
{ "DIPROPHEADER" "diph" }
{ "LONG" "lMin" }
{ "LONG" "lMax" } ;
TYPEDEF: DIPROPRANGE* LPDIPROPRANGE
TYPEDEF: DIPROPRANGE* LPCDIPROPRANGE
C-STRUCT: DIPROPCAL
{ "DIPROPHEADER" "diph" }
{ "LONG" "lMin" }
{ "LONG" "lCenter" }
{ "LONG" "lMax" } ;
TYPEDEF: DIPROPCAL* LPDIPROPCAL
TYPEDEF: DIPROPCAL* LPCDIPROPCAL
C-STRUCT: DIPROPGUIDANDPATH
{ "DIPROPHEADER" "diph" }
{ "GUID" "guidClass" }
{ "WCHAR[260]" "wszPath" } ;
TYPEDEF: DIPROPGUIDANDPATH* LPDIPROPGUIDANDPATH
TYPEDEF: DIPROPGUIDANDPATH* LPCDIPROPGUIDANDPATH
C-STRUCT: DIPROPSTRING
{ "DIPROPHEADER" "diph" }
{ "WCHAR[260]" "wsz" } ;
TYPEDEF: DIPROPSTRING* LPDIPROPSTRING
TYPEDEF: DIPROPSTRING* LPCDIPROPSTRING
C-STRUCT: CPOINT
{ "LONG" "lP" }
{ "DWORD" "dwLog" } ;
C-STRUCT: DIPROPCPOINTS
{ "DIPROPHEADER" "diph" }
{ "DWORD" "dwCPointsNum" }
{ "CPOINT[8]" "cp" } ;
TYPEDEF: DIPROPCPOINTS* LPDIPROPCPOINTS
TYPEDEF: DIPROPCPOINTS* LPCDIPROPCPOINTS
C-STRUCT: DIENVELOPE
{ "DWORD" "dwSize" }
{ "DWORD" "dwAttackLevel" }
@ -383,19 +434,264 @@ FUNCTION: HRESULT DirectInput8Create ( HINSTANCE hinst, DWORD dwVersion, REFIID
: DIDFT_ENUMCOLLECTION ( n -- instance ) 8 shift HEX: FFFF bitand ; inline
: DIDFT_NOCOLLECTION HEX: 00FFFF00 ; inline
: DIDOI_FFACTUATOR HEX: 00000001 ; inline
: DIDOI_FFEFFECTTRIGGER HEX: 00000002 ; inline
: DIDOI_POLLED HEX: 00008000 ; inline
: DIDOI_ASPECTPOSITION HEX: 00000100 ; inline
: DIDOI_ASPECTVELOCITY HEX: 00000200 ; inline
: DIDOI_ASPECTACCEL HEX: 00000300 ; inline
: DIDOI_ASPECTFORCE HEX: 00000400 ; inline
: DIDOI_ASPECTMASK HEX: 00000F00 ; inline
: DIDOI_GUIDISUSAGE HEX: 00010000 ; inline
: DISCL_EXCLUSIVE HEX: 00000001 ; inline
: DISCL_NONEXCLUSIVE HEX: 00000002 ; inline
: DISCL_FOREGROUND HEX: 00000004 ; inline
: DISCL_BACKGROUND HEX: 00000008 ; inline
: DISCL_NOWINKEY HEX: 00000010 ; inline
SYMBOL: +dinput+
: DIK_ESCAPE HEX: 01 ; inline
: DIK_1 HEX: 02 ; inline
: DIK_2 HEX: 03 ; inline
: DIK_3 HEX: 04 ; inline
: DIK_4 HEX: 05 ; inline
: DIK_5 HEX: 06 ; inline
: DIK_6 HEX: 07 ; inline
: DIK_7 HEX: 08 ; inline
: DIK_8 HEX: 09 ; inline
: DIK_9 HEX: 0A ; inline
: DIK_0 HEX: 0B ; inline
: DIK_MINUS HEX: 0C ; inline
: DIK_EQUALS HEX: 0D ; inline
: DIK_BACK HEX: 0E ; inline
: DIK_TAB HEX: 0F ; inline
: DIK_Q HEX: 10 ; inline
: DIK_W HEX: 11 ; inline
: DIK_E HEX: 12 ; inline
: DIK_R HEX: 13 ; inline
: DIK_T HEX: 14 ; inline
: DIK_Y HEX: 15 ; inline
: DIK_U HEX: 16 ; inline
: DIK_I HEX: 17 ; inline
: DIK_O HEX: 18 ; inline
: DIK_P HEX: 19 ; inline
: DIK_LBRACKET HEX: 1A ; inline
: DIK_RBRACKET HEX: 1B ; inline
: DIK_RETURN HEX: 1C ; inline
: DIK_LCONTROL HEX: 1D ; inline
: DIK_A HEX: 1E ; inline
: DIK_S HEX: 1F ; inline
: DIK_D HEX: 20 ; inline
: DIK_F HEX: 21 ; inline
: DIK_G HEX: 22 ; inline
: DIK_H HEX: 23 ; inline
: DIK_J HEX: 24 ; inline
: DIK_K HEX: 25 ; inline
: DIK_L HEX: 26 ; inline
: DIK_SEMICOLON HEX: 27 ; inline
: DIK_APOSTROPHE HEX: 28 ; inline
: DIK_GRAVE HEX: 29 ; inline
: DIK_LSHIFT HEX: 2A ; inline
: DIK_BACKSLASH HEX: 2B ; inline
: DIK_Z HEX: 2C ; inline
: DIK_X HEX: 2D ; inline
: DIK_C HEX: 2E ; inline
: DIK_V HEX: 2F ; inline
: DIK_B HEX: 30 ; inline
: DIK_N HEX: 31 ; inline
: DIK_M HEX: 32 ; inline
: DIK_COMMA HEX: 33 ; inline
: DIK_PERIOD HEX: 34 ; inline
: DIK_SLASH HEX: 35 ; inline
: DIK_RSHIFT HEX: 36 ; inline
: DIK_MULTIPLY HEX: 37 ; inline
: DIK_LMENU HEX: 38 ; inline
: DIK_SPACE HEX: 39 ; inline
: DIK_CAPITAL HEX: 3A ; inline
: DIK_F1 HEX: 3B ; inline
: DIK_F2 HEX: 3C ; inline
: DIK_F3 HEX: 3D ; inline
: DIK_F4 HEX: 3E ; inline
: DIK_F5 HEX: 3F ; inline
: DIK_F6 HEX: 40 ; inline
: DIK_F7 HEX: 41 ; inline
: DIK_F8 HEX: 42 ; inline
: DIK_F9 HEX: 43 ; inline
: DIK_F10 HEX: 44 ; inline
: DIK_NUMLOCK HEX: 45 ; inline
: DIK_SCROLL HEX: 46 ; inline
: DIK_NUMPAD7 HEX: 47 ; inline
: DIK_NUMPAD8 HEX: 48 ; inline
: DIK_NUMPAD9 HEX: 49 ; inline
: DIK_SUBTRACT HEX: 4A ; inline
: DIK_NUMPAD4 HEX: 4B ; inline
: DIK_NUMPAD5 HEX: 4C ; inline
: DIK_NUMPAD6 HEX: 4D ; inline
: DIK_ADD HEX: 4E ; inline
: DIK_NUMPAD1 HEX: 4F ; inline
: DIK_NUMPAD2 HEX: 50 ; inline
: DIK_NUMPAD3 HEX: 51 ; inline
: DIK_NUMPAD0 HEX: 52 ; inline
: DIK_DECIMAL HEX: 53 ; inline
: DIK_OEM_102 HEX: 56 ; inline
: DIK_F11 HEX: 57 ; inline
: DIK_F12 HEX: 58 ; inline
: DIK_F13 HEX: 64 ; inline
: DIK_F14 HEX: 65 ; inline
: DIK_F15 HEX: 66 ; inline
: DIK_KANA HEX: 70 ; inline
: DIK_ABNT_C1 HEX: 73 ; inline
: DIK_CONVERT HEX: 79 ; inline
: DIK_NOCONVERT HEX: 7B ; inline
: DIK_YEN HEX: 7D ; inline
: DIK_ABNT_C2 HEX: 7E ; inline
: DIK_NUMPADEQUALS HEX: 8D ; inline
: DIK_PREVTRACK HEX: 90 ; inline
: DIK_AT HEX: 91 ; inline
: DIK_COLON HEX: 92 ; inline
: DIK_UNDERLINE HEX: 93 ; inline
: DIK_KANJI HEX: 94 ; inline
: DIK_STOP HEX: 95 ; inline
: DIK_AX HEX: 96 ; inline
: DIK_UNLABELED HEX: 97 ; inline
: DIK_NEXTTRACK HEX: 99 ; inline
: DIK_NUMPADENTER HEX: 9C ; inline
: DIK_RCONTROL HEX: 9D ; inline
: DIK_MUTE HEX: A0 ; inline
: DIK_CALCULATOR HEX: A1 ; inline
: DIK_PLAYPAUSE HEX: A2 ; inline
: DIK_MEDIASTOP HEX: A4 ; inline
: DIK_VOLUMEDOWN HEX: AE ; inline
: DIK_VOLUMEUP HEX: B0 ; inline
: DIK_WEBHOME HEX: B2 ; inline
: DIK_NUMPADCOMMA HEX: B3 ; inline
: DIK_DIVIDE HEX: B5 ; inline
: DIK_SYSRQ HEX: B7 ; inline
: DIK_RMENU HEX: B8 ; inline
: DIK_PAUSE HEX: C5 ; inline
: DIK_HOME HEX: C7 ; inline
: DIK_UP HEX: C8 ; inline
: DIK_PRIOR HEX: C9 ; inline
: DIK_LEFT HEX: CB ; inline
: DIK_RIGHT HEX: CD ; inline
: DIK_END HEX: CF ; inline
: DIK_DOWN HEX: D0 ; inline
: DIK_NEXT HEX: D1 ; inline
: DIK_INSERT HEX: D2 ; inline
: DIK_DELETE HEX: D3 ; inline
: DIK_LWIN HEX: DB ; inline
: DIK_RWIN HEX: DC ; inline
: DIK_APPS HEX: DD ; inline
: DIK_POWER HEX: DE ; inline
: DIK_SLEEP HEX: DF ; inline
: DIK_WAKE HEX: E3 ; inline
: DIK_WEBSEARCH HEX: E5 ; inline
: DIK_WEBFAVORITES HEX: E6 ; inline
: DIK_WEBREFRESH HEX: E7 ; inline
: DIK_WEBSTOP HEX: E8 ; inline
: DIK_WEBFORWARD HEX: E9 ; inline
: DIK_WEBBACK HEX: EA ; inline
: DIK_MYCOMPUTER HEX: EB ; inline
: DIK_MAIL HEX: EC ; inline
: DIK_MEDIASELECT HEX: ED ; inline
: create-dinput ( -- )
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
f <void*> [ f DirectInput8Create ole32-error ] keep *void*
+dinput+ set ;
: DIK_BACKSPACE DIK_BACK ; inline
: DIK_NUMPADSTAR DIK_MULTIPLY ; inline
: DIK_LALT DIK_LMENU ; inline
: DIK_CAPSLOCK DIK_CAPITAL ; inline
: DIK_NUMPADMINUS DIK_SUBTRACT ; inline
: DIK_NUMPADPLUS DIK_ADD ; inline
: DIK_NUMPADPERIOD DIK_DECIMAL ; inline
: DIK_NUMPADSLASH DIK_DIVIDE ; inline
: DIK_RALT DIK_RMENU ; inline
: DIK_UPARROW DIK_UP ; inline
: DIK_PGUP DIK_PRIOR ; inline
: DIK_LEFTARROW DIK_LEFT ; inline
: DIK_RIGHTARROW DIK_RIGHT ; inline
: DIK_DOWNARROW DIK_DOWN ; inline
: DIK_PGDN DIK_NEXT ; inline
: delete-dinput ( -- )
+dinput+ [ com-release f ] change ;
: DIK_CIRCUMFLEX DIK_PREVTRACK ; inline
: DI8DEVTYPE_DEVICE HEX: 11 ; inline
: DI8DEVTYPE_MOUSE HEX: 12 ; inline
: DI8DEVTYPE_KEYBOARD HEX: 13 ; inline
: DI8DEVTYPE_JOYSTICK HEX: 14 ; inline
: DI8DEVTYPE_GAMEPAD HEX: 15 ; inline
: DI8DEVTYPE_DRIVING HEX: 16 ; inline
: DI8DEVTYPE_FLIGHT HEX: 17 ; inline
: DI8DEVTYPE_1STPERSON HEX: 18 ; inline
: DI8DEVTYPE_DEVICECTRL HEX: 19 ; inline
: DI8DEVTYPE_SCREENPOINTER HEX: 1A ; inline
: DI8DEVTYPE_REMOTE HEX: 1B ; inline
: DI8DEVTYPE_SUPPLEMENTAL HEX: 1C ; inline
: GET_DIDEVICE_TYPE ( dwType -- type ) HEX: FF bitand ; inline
: DIPROPRANGE_NOMIN HEX: 80000000 ; inline
: DIPROPRANGE_NOMAX HEX: 7FFFFFFF ; inline
: MAXCPOINTSNUM 8 ; inline
: DIPH_DEVICE 0 ; inline
: DIPH_BYOFFSET 1 ; inline
: DIPH_BYID 2 ; inline
: DIPH_BYUSAGE 3 ; inline
: DIMAKEUSAGEDWORD ( UsagePage Usage -- DWORD ) 16 shift bitor ; inline
: DIPROP_BUFFERSIZE 1 <alien> ; inline
: DIPROP_AXISMODE 2 <alien> ; inline
: DIPROPAXISMODE_ABS 0 ; inline
: DIPROPAXISMODE_REL 1 ; inline
: DIPROP_GRANULARITY 3 <alien> ; inline
: DIPROP_RANGE 4 <alien> ; inline
: DIPROP_DEADZONE 5 <alien> ; inline
: DIPROP_SATURATION 6 <alien> ; inline
: DIPROP_FFGAIN 7 <alien> ; inline
: DIPROP_FFLOAD 8 <alien> ; inline
: DIPROP_AUTOCENTER 9 <alien> ; inline
: DIPROPAUTOCENTER_OFF 0 ; inline
: DIPROPAUTOCENTER_ON 1 ; inline
: DIPROP_CALIBRATIONMODE 10 <alien> ; inline
: DIPROPCALIBRATIONMODE_COOKED 0 ; inline
: DIPROPCALIBRATIONMODE_RAW 1 ; inline
: DIPROP_CALIBRATION 11 <alien> ; inline
: DIPROP_GUIDANDPATH 12 <alien> ; inline
: DIPROP_INSTANCENAME 13 <alien> ; inline
: DIPROP_PRODUCTNAME 14 <alien> ; inline
: DIPROP_JOYSTICKID 15 <alien> ; inline
: DIPROP_GETPORTDISPLAYNAME 16 <alien> ; inline
: DIPROP_PHYSICALRANGE 18 <alien> ; inline
: DIPROP_LOGICALRANGE 19 <alien> ; inline
: DIPROP_KEYNAME 20 <alien> ; inline
: DIPROP_CPOINTS 21 <alien> ; inline
: DIPROP_APPDATA 22 <alien> ; inline
: DIPROP_SCANCODE 23 <alien> ; inline
: DIPROP_VIDPID 24 <alien> ; inline
: DIPROP_USERNAME 25 <alien> ; inline
: DIPROP_TYPENAME 26 <alien> ; inline
: GUID_XAxis GUID: {A36D02E0-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_YAxis GUID: {A36D02E1-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_ZAxis GUID: {A36D02E2-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_RxAxis GUID: {A36D02F4-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_RyAxis GUID: {A36D02F5-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_RzAxis GUID: {A36D02E3-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_Slider GUID: {A36D02E4-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_Button GUID: {A36D02F0-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_Key GUID: {55728220-D33C-11CF-BFC7-444553540000} ; inline
: GUID_POV GUID: {A36D02F2-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_Unknown GUID: {A36D02F3-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_SysMouse GUID: {6F1D2B60-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysKeyboard GUID: {6F1D2B61-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_Joystick GUID: {6F1D2B70-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysMouseEm GUID: {6F1D2B80-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysMouseEm2 GUID: {6F1D2B81-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysKeyboardEm GUID: {6F1D2B82-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysKeyboardEm2 GUID: {6F1D2B83-D5A0-11CF-BFC7-444553540000} ; inline

12
extra/windows/ole32/ole32.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows windows.types
kernel sequences windows windows.types debugger io accessors
math.order ;
IN: windows.ole32
@ -115,10 +115,14 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ;
TUPLE: ole32-error error-code ;
C: <ole32-error> ole32-error
M: ole32-error error.
"COM method failed: " print error-code>> (win32-error-string) print ;
: ole32-error ( hresult -- )
dup succeeded? [
drop
] [ (win32-error-string) throw ] if ;
dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
: ole-initialize ( -- )
f OleInitialize ole32-error ;

28
extra/windows/user32/user32.factor
View File

@ -528,6 +528,27 @@ C-STRUCT: TRACKMOUSEEVENT
{ "DWORD" "dwHoverTime" } ;
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
: DBT_DEVICEARRIVAL HEX: 8000 ; inline
: DBT_DEVICEREMOVECOMPLETE HEX: 8004 ; inline
: DBT_DEVTYP_DEVICEINTERFACE 5 ; inline
: DEVICE_NOTIFY_WINDOW_HANDLE 0 ; inline
: DEVICE_NOTIFY_SERVICE_HANDLE 1 ; inline
: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4 ; inline
C-STRUCT: DEV_BROADCAST_HDR
{ "DWORD" "dbch_size" }
{ "DWORD" "dbch_devicetype" }
{ "DWORD" "dbch_reserved" } ;
C-STRUCT: DEV_BROADCAST_DEVICEW
{ "DWORD" "dbcc_size" }
{ "DWORD" "dbcc_devicetype" }
{ "DWORD" "dbcc_reserved" }
{ "GUID" "dbcc_classguid" }
{ "WCHAR[1]" "dbcc_name" } ;
LIBRARY: user32
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
@ -1176,8 +1197,9 @@ ALIAS: RegisterClassEx RegisterClassExW
! FUNCTION: RegisterClipboardFormatA
! FUNCTION: RegisterClipboardFormatW
! FUNCTION: RegisterDeviceNotificationA
! FUNCTION: RegisterDeviceNotificationW
FUNCTION: HANDLE RegisterDeviceNotificationA ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
FUNCTION: HANDLE RegisterDeviceNotificationW ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
ALIAS: RegisterDeviceNotification RegisterDeviceNotificationW
! FUNCTION: RegisterHotKey
! FUNCTION: RegisterLogonProcess
! FUNCTION: RegisterMessagePumpHook
@ -1344,7 +1366,7 @@ FUNCTION: BOOL TranslateMessage ( MSG* lpMsg ) ;
! FUNCTION: UnpackDDElParam
FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ;
ALIAS: UnregisterClass UnregisterClassW
! FUNCTION: UnregisterDeviceNotification
FUNCTION: BOOL UnregisterDeviceNotification ( HANDLE hDevNotify ) ;
! FUNCTION: UnregisterHotKey
! FUNCTION: UnregisterMessagePumpHook
! FUNCTION: UnregisterUserApiHook