0 | {- Tian Z (ecburx@burx.vip) -}
  1 |
  2 | module IdrisGL.SDL.SDL_event
  3 |
  4 | import System.FFI
  5 |
  6 | import IdrisGL.DataType
  7 | import IdrisGL.SDL.SDL_keycode
  8 |
  9 | ||| Events.
 10 | public export
 11 | data Eve 
 12 |   = ||| Unavailable event.
 13 |   E_UNAVAILABLE
 14 |   | ||| Quit event.
 15 |   E_QUIT
 16 |   {- Key events -}
 17 |   | ||| Key pressed event.
 18 |   E_KEYDOWN Key
 19 |   | ||| Key release event.
 20 |   E_KEYUP   Key
 21 |   {- Mouse events -}
 22 |   | ||| Moving mouse and its position.
 23 |   E_MOUSEMOTION       (Int, Int)
 24 |   | ||| Mouse button pressed and its position.
 25 |   E_L_MOUSEBUTTONDOWN (Int, Int)
 26 |   |
 27 |   E_M_MOUSEBUTTONDOWN (Int, Int)
 28 |   |
 29 |   E_R_MOUSEBUTTONDOWN (Int, Int)
 30 |   | ||| Mouse button released and its position.
 31 |   E_L_MOUSEBUTTONUP   (Int, Int)
 32 |   |
 33 |   E_M_MOUSEBUTTONUP   (Int, Int)
 34 |   |
 35 |   E_R_MOUSEBUTTONUP   (Int, Int)
 36 |   | ||| Mouse wheel event and its position.
 37 |   E_MOUSEWHEEL        (Int, Int)
 38 |
 39 | EventStruct : Type
 40 | EventStruct = Struct "Event" [("ePtr", AnyPtr), ("mouseX", Int), ("mouseY", Int), ("mouseButton", Int)]
 41 |
 42 | {- 
 43 |     FFI 
 44 | -}
 45 |
 46 | frgn : String -> String
 47 | frgn func = "C:" ++ func ++ ",sdl_events"
 48 |
 49 | --
 50 |
 51 | %foreign frgn "keyEveCode"
 52 | prim_keyEveCode : AnyPtr -> Int
 53 |
 54 | keyEveCode : Event -> Int
 55 | keyEveCode (MkEvent e) = prim_keyEveCode e
 56 |
 57 | %foreign frgn "mouseEveCode"
 58 | prim_mouseEveCode : AnyPtr -> EventStruct
 59 |
 60 | mouseEveCode : Event -> (Int, Int, Int)
 61 | mouseEveCode (MkEvent e) =
 62 |   let e'       = prim_mouseEveCode e
 63 |       x : Int := getField e' "mouseX"
 64 |       y : Int := getField e' "mouseY"
 65 |       b : Int := getField e' "mouseButton"
 66 |   in (x, y, b)
 67 |
 68 | --
 69 |
 70 | getEve : Int -> Event -> Eve
 71 | getEve 256  _             = E_QUIT
 72 |
 73 | getEve 768  e             = E_KEYDOWN (getKey $ keyEveCode e)
 74 | getEve 769  e             = E_KEYUP   (getKey $ keyEveCode e)
 75 |
 76 | getEve 1024 e with (mouseEveCode e)
 77 |   getEve 1024 e | (x,y,_) = E_MOUSEMOTION (x,y)
 78 |
 79 | getEve 1025 e with (mouseEveCode e)
 80 |   getEve 1025 e | (x,y,1) = E_L_MOUSEBUTTONDOWN (x,y)
 81 |   getEve 1025 e | (x,y,2) = E_M_MOUSEBUTTONDOWN (x,y)
 82 |   getEve 1025 e | (x,y,3) = E_R_MOUSEBUTTONDOWN (x,y)
 83 |   getEve 1025 e | (x,y,_) = E_UNAVAILABLE
 84 |
 85 | getEve 1026 e with (mouseEveCode e)
 86 |   getEve 1026 e | (x,y,1) = E_L_MOUSEBUTTONUP (x,y)
 87 |   getEve 1026 e | (x,y,2) = E_M_MOUSEBUTTONUP (x,y)
 88 |   getEve 1026 e | (x,y,3) = E_R_MOUSEBUTTONUP (x,y)
 89 |   getEve 1026 e | (x,y,_) = E_UNAVAILABLE
 90 |
 91 | getEve 1027 e with (mouseEveCode e) 
 92 |   getEve 1027 e | (x,y,_) = E_MOUSEWHEEL (x,y) -- TODO scroll direction
 93 |
 94 | getEve _    _             = E_UNAVAILABLE
 95 |
 96 | --
 97 |
 98 | %foreign frgn "newEve"
 99 | prim_newEve : AnyPtr
100 |
101 | ||| An SDL_Event pointer wrapper.
102 | export
103 | newEve : HasIO io => io Event
104 | newEve = pure $ MkEvent $ prim_newEve
105 |
106 | --
107 |
108 | %foreign frgn "eveType"
109 | prim_eveType : AnyPtr -> Int
110 |
111 | ||| Poll events and get its type.
112 | export
113 | eveType : (event : Event) -> Eve
114 | eveType event@(MkEvent e) = getEve (prim_eveType e) event
115 |
116 | --
117 |
118 | %foreign frgn "freeEve"
119 | prim_freeEve : AnyPtr -> PrimIO ()
120 |
121 | ||| Free an event initialized by newEve.
122 | export
123 | freeEve : HasIO io => Event -> io ()
124 | freeEve (MkEvent e) = primIO $ prim_freeEve e
125 |