basis/linux/input-events/input-events.factor

   1 ! Copyright (C) 2021 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.data alien.enums
   4 arrays ascii assocs combinators combinators.smart grouping
   5 hashtables io io.backend io.directories io.encodings.binary
   6 io.files io.files.links io.pathnames kernel
   7 linux.input-events.ffi math namespaces pack prettyprint
   8 sequences splitting unix.time ;
   9 FROM: io => read ;
  10 IN: linux.input-events
  11
  12 : input-events-assoc ( path -- assoc )
  13     dup '[
  14         _ qualified-directory-files
  15         [ read-link normalize-path ] zip-with
  16     ] with-directory ;
  17
  18 : input-events-by-id-assoc ( -- assoc )
  19     "/dev/input/by-id/" input-events-assoc ;
  20
  21 : input-events-by-path-assoc ( -- assoc )
  22     "/dev/input/by-path/" input-events-assoc ;
  23
  24 : devices-by-type-assoc ( -- assoc )
  25     input-events-by-id-assoc [
  26         first "-" split1-last nip
  27         [ digit? ] trim-tail
  28     ] collect-by ;
  29
  30 : event-code-value ( type code value -- a b c )
  31     [ <INPUT_EVENT> ] 2dip
  32     pick {
  33         { EV_SYN [ [ <INPUT_SYN> ] dip ] }
  34         { EV_KEY [ [ <INPUT_KEY> ] dip ] }
  35         { EV_REL [ [ <INPUT_REL> ] dip ] }
  36         { EV_ABS [ [ <INPUT_ABS> ] dip ] }
  37         { EV_MSC [ [ <INPUT_MSC> ] dip ] }
  38         { EV_SW  [ [ <INPUT_SW> ] dip ] }
  39         { EV_LED [ [ <INPUT_LED> ] dip ] }
  40         { EV_SND [ [ <INPUT_SND> ] dip ] }
  41         { EV_REP [ [ <INPUT_REP> ] dip ] }
  42         { EV_FF [ [ <INPUT_FF> ] dip ] }
  43         ! { EV_PWR [ [ <INPUT_PWR> ] dip ] }
  44         ! { EV_FF_STATUS [ [ <INPUT_FF_STATUS> ] dip ] }
  45         [ drop ]
  46     } case ;
  47
  48 : evdev-explode-bitfield ( handle ev count -- seq )
  49     enum>number 8 /mod [ drop 1 + ] unless-zero evdev-get-bytes seq>explode-positions ;
  50
  51 : evdev-get-syn ( handle -- seq )
  52     0 EV_CNT evdev-explode-bitfield ;
  53
  54 : EV>seq ( handle EV -- seq )
  55     dup <INPUT_EVENT> {
  56         { EV_SYN [ drop evdev-get-syn [ <INPUT_EVENT> ] zip-with ] }
  57         { EV_KEY [ KEY_CNT evdev-explode-bitfield [ <INPUT_KEY> ] zip-with ] }
  58         { EV_REL [ REL_CNT evdev-explode-bitfield [ <INPUT_REL> ] zip-with ] }
  59         { EV_ABS [
  60             [ ABS_CNT evdev-explode-bitfield ]
  61             [ drop over [ evdev-get-abs ] with map ] 2bi
  62             [ [ <INPUT_ABS> ] zip-with ] dip zip
  63         ] }
  64         { EV_MSC [ MSC_CNT evdev-explode-bitfield [ <INPUT_MSC> ] zip-with ] }
  65         { EV_SW  [ SW_CNT evdev-explode-bitfield [ <INPUT_SW> ] zip-with ] }
  66         { EV_LED [ LED_CNT evdev-explode-bitfield [ <INPUT_LED> ] zip-with ] }
  67         { EV_SND [ SND_CNT evdev-explode-bitfield [ <INPUT_SND> ] zip-with ] }
  68         { EV_REP [
  69             drop evdev-get-repeat "II" unpack
  70             [ <INPUT_REP> swap 2array ] map-index
  71         ] }
  72         { EV_FF [ FF_CNT evdev-explode-bitfield [ <INPUT_FF> ] zip-with ] }
  73         ! { EV_PWR [ PWR_CNT evdev-explode-bitfield ] }
  74         { EV_FF_STATUS [ FF_STATUS_MAX evdev-explode-bitfield ] }
  75         ! [ nip drop "broken" ]
  76     } case ;
  77
  78 : evdev-get-all-bits ( handle -- all-bits )
  79     dup evdev-get-syn
  80     [
  81         [ nip <INPUT_EVENT> ]
  82         [ EV>seq ] 2bi 2array
  83     ] with map >hashtable ;
  84
  85 : evdev-get-all-mt-slots ( handle -- seq )
  86     INPUT_ABS enum>values [
  87         [ 65 int <c-array> ] dip
  88         0 pick set-nth
  89         [ byte-length ] keep evdev-get-mt-slots
  90         [ 0 = ] trim-tail
  91     ] with map sift
  92     [ unclip <INPUT_ABS> swap 2array ] map ;
  93
  94 : with-event-device ( ..x path quot: ( ..x path fd -- ..y ) -- ..y )
  95     [ binary over ] dip '[
  96         _ input-stream get handle>> fd>> @
  97     ] with-file-reader ; inline
  98
  99 : named ( value key -- pair )
 100     swap 2array ; inline
 101
 102 : get-event-device-info ( path -- hashtable )
 103     [
 104         '[
 105             _ "path" named
 106             _ {
 107                 [ evdev-get-id "id" named ]
 108                 [ evdev-get-name "name" named ]
 109                 [ evdev-get-physical "physical" named ]
 110                 [ evdev-get-unique "unique" named ]
 111                 [ evdev-get-prop "props" named ]
 112                 [ evdev-get-all-mt-slots "mt-slots" named ]
 113                 [ evdev-get-key seq>explode-positions [ <INPUT_KEY> ] zip-with "keys" named ]
 114                 [ evdev-get-led seq>explode-positions [ <INPUT_LED> ] zip-with "leds" named ]
 115                 [ evdev-get-sound seq>explode-positions [ <INPUT_SND> ] zip-with "sounds" named ]
 116                 [ evdev-get-switch seq>explode-positions [ <INPUT_SW> ] zip-with "switches" named ]
 117                 [ evdev-get-simulataneous-effects "effects" named ]
 118                 [ evdev-get-event-mask "event-mask" named ]
 119                 [ evdev-get-all-bits "capabilities" named ]
 120             } cleave
 121         ] output>array >hashtable
 122     ] with-event-device ;
 123
 124 : all-controller-stats ( -- seq )
 125     input-events-by-id-assoc values
 126     [ file-name "event" head? ] filter
 127     [ get-event-device-info ] map ;
 128
 129 : events-by-file-name ( -- hashtable )
 130     all-controller-stats [ "path" of file-name ] collect-by ;
 131
 132 : get-input-events-type ( str -- seq )
 133     [ input-events-by-id-assoc ] dip
 134     '[ first _ tail? ] filter ;
 135
 136 : get-input-events-joysticks ( -- seq ) "event-joystick" get-input-events-type ;
 137 : get-input-events-keyboards ( -- seq ) "event-kbd" get-input-events-type ;
 138 : get-input-events-mice ( -- seq ) "event-mouse" get-input-events-type ;
 139
 140 : read-input-events ( -- seq )
 141     240 read-partial 24 group [
 142         "QQSSi" unpack-le
 143         2 cut
 144         [ first2 <timeval> ]
 145         [ first3 event-code-value ] bi* 4array
 146     ] map ;
 147
 148 SLOT: state
 149 SLOT: quit?
 150
 151 : read-controller-loop ( controller -- )
 152     [ path>> ] [ state>> ] [ ] tri
 153     '[
 154         2drop
 155         [
 156             _ read-input-events [
 157                 ! "." write
 158                 first4
 159                 [ drop ] 3dip spin {
 160                     { EV_SYN [ dup SYN_REPORT = [ 2drop ] [ 2array . ] if ] }
 161                     { EV_KEY [ over 1 = [ pick set-at ] [ nip over delete-at ] if ] }
 162                     { EV_ABS [ pick set-at ] }
 163                     { EV_REL [ swap 2array . ] }
 164                     { EV_MSC [ swap 2array . ] }
 165                     [
 166                         "unhandled: " write 3array .
 167                         ! 3drop
 168                     ]
 169                 } case
 170             ] each
 171             . ! state
 172             ! drop ! state
 173             _ quit?>> not
 174         ] loop
 175     ] with-event-device ;