├── Makefile ├── README.md ├── sdl.ipkg ├── src ├── Effect │ └── SDL.idr ├── Graphics │ └── SDL.idr ├── MakefileSDLC ├── sdlrun.c └── sdlrun.h └── test ├── etest.idr └── test.idr /Makefile: -------------------------------------------------------------------------------- 1 | install: 2 | idris --install sdl.ipkg 3 | 4 | clean: 5 | idris --clean sdl.ipkg 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | SDL-idris 2 | ========= 3 | 4 | SDL bindings package for idris 5 | -------------------------------------------------------------------------------- /sdl.ipkg: -------------------------------------------------------------------------------- 1 | package sdl 2 | 3 | sourcedir = src 4 | modules = Graphics.SDL, Graphics.Config, Effect.SDL 5 | opts = "-p effects" 6 | 7 | makefile = MakefileSDLC 8 | 9 | objs = sdlrun.o, sdlrun.h 10 | libs = SDL, SDL_gfx 11 | 12 | -------------------------------------------------------------------------------- /src/Effect/SDL.idr: -------------------------------------------------------------------------------- 1 | module Effect.SDL 2 | 3 | import Effects 4 | import public Graphics.SDL 5 | import System 6 | 7 | %access public export 8 | 9 | Srf : Type 10 | Srf = SDLSurface 11 | 12 | data Colour = MkCol Int Int Int Int 13 | 14 | black : Colour 15 | black = MkCol 0 0 0 255 16 | 17 | white : Colour 18 | white = MkCol 255 255 255 255 19 | 20 | red : Colour 21 | red = MkCol 255 0 0 255 22 | 23 | green : Colour 24 | green = MkCol 0 255 0 255 25 | 26 | blue : Colour 27 | blue = MkCol 0 0 255 255 28 | 29 | yellow : Colour 30 | yellow = MkCol 255 255 0 255 31 | 32 | cyan : Colour 33 | cyan = MkCol 0 255 255 255 34 | 35 | magenta : Colour 36 | magenta = MkCol 255 0 255 255 37 | 38 | data Sdl : Effect where 39 | Initialise : Int -> Int -> Sdl () () (\v => Srf) 40 | Quit : Sdl () Srf (\v => ()) 41 | Flip : Sdl () Srf (\v => Srf) 42 | Poll : Sdl (Maybe Event) a (\v => a) 43 | 44 | WithSurface : (Srf -> IO a) -> Sdl a Srf (\v => Srf) 45 | 46 | Handler Sdl IO where 47 | handle () (Initialise x y) k = do Just srf <- startSDL x y 48 | | Nothing => do putStrLn "Can't create window" 49 | exit 1 50 | k () srf 51 | handle s Quit k = do endSDL; k () () 52 | 53 | handle s Flip k = do flipBuffers s; k () s 54 | handle s Poll k = do x <- pollEvent; k x s 55 | handle s (WithSurface f) k = do r <- f s; k r s 56 | 57 | public export 58 | SDL : Type -> EFFECT 59 | SDL res = MkEff res Sdl 60 | 61 | public export 62 | SDL_ON : EFFECT 63 | SDL_ON = SDL SDLSurface 64 | 65 | initialise : Int -> Int -> { [SDL ()] ==> [SDL_ON] } Eff () 66 | initialise x y = call $ Initialise x y 67 | 68 | quit : { [SDL_ON] ==> [SDL ()] } Eff () 69 | quit = call Quit 70 | 71 | flip : { [SDL_ON] } Eff () 72 | flip = call Flip 73 | 74 | poll : { [SDL_ON] } Eff (Maybe Event) 75 | poll = call Poll 76 | 77 | getSurface : { [SDL_ON] } Eff SDLSurface 78 | getSurface = call $ WithSurface (\s => pure s) 79 | 80 | rectangle : Colour -> Int -> Int -> Int -> Int -> { [SDL_ON] } Eff () 81 | rectangle (MkCol r g b a) x y w h 82 | = call $ WithSurface (\s => filledRect s x y w h r g b a) 83 | 84 | ellipse : Colour -> Int -> Int -> Int -> Int -> { [SDL_ON] } Eff () 85 | ellipse (MkCol r g b a) x y rx ry 86 | = call $ WithSurface (\s => filledEllipse s x y rx ry r g b a) 87 | 88 | line : Colour -> Int -> Int -> Int -> Int -> { [SDL_ON] } Eff () 89 | line (MkCol r g b a) x y ex ey 90 | = call $ WithSurface (\s => drawLine s x y ex ey r g b a) 91 | 92 | 93 | -------------------------------------------------------------------------------- /src/Graphics/SDL.idr: -------------------------------------------------------------------------------- 1 | module Graphics.SDL 2 | 3 | import Graphics.Config 4 | 5 | %include C "sdlrun.h" 6 | %include C "SDL/SDL.h" 7 | %link C "sdlrun.o" 8 | %lib C "SDL_gfx" 9 | 10 | -- Set up a window 11 | 12 | export 13 | data SDLSurface = MkSurface Ptr 14 | 15 | export 16 | startSDL : Int -> Int -> IO (Maybe SDLSurface) 17 | startSDL x y = do ptr <- do_startSDL 18 | if !(nullPtr ptr) 19 | then pure Nothing 20 | else pure (Just (MkSurface ptr)) 21 | where do_startSDL = foreign FFI_C "startSDL" (Int -> Int -> IO Ptr) x y 22 | 23 | export 24 | endSDL : IO () 25 | endSDL = foreign FFI_C "SDL_Quit" (IO ()) 26 | 27 | export 28 | flipBuffers : SDLSurface -> IO (); 29 | flipBuffers (MkSurface ptr) 30 | = foreign FFI_C "flipBuffers" (Ptr -> IO ()) ptr 31 | 32 | 33 | -- Some drawing primitives 34 | 35 | export 36 | filledRect : SDLSurface -> Int -> Int -> Int -> Int -> 37 | Int -> Int -> Int -> Int -> IO () 38 | filledRect (MkSurface ptr) x y w h r g b a 39 | = foreign FFI_C "filledRect" 40 | (Ptr -> Int -> Int -> Int -> Int -> 41 | Int -> Int -> Int -> Int -> IO ()) ptr x y w h r g b a 42 | 43 | export 44 | filledEllipse : SDLSurface -> Int -> Int -> Int -> Int -> 45 | Int -> Int -> Int -> Int -> IO () 46 | filledEllipse (MkSurface ptr) x y rx ry r g b a 47 | = foreign FFI_C "filledEllipse" 48 | (Ptr -> Int -> Int -> Int -> Int -> 49 | Int -> Int -> Int -> Int -> IO ()) ptr x y rx ry r g b a 50 | 51 | export 52 | drawLine : SDLSurface -> Int -> Int -> Int -> Int -> 53 | Int -> Int -> Int -> Int -> IO () 54 | drawLine (MkSurface ptr) x y ex ey r g b a 55 | = foreign FFI_C "drawLine" 56 | (Ptr -> Int -> Int -> Int -> Int -> 57 | Int -> Int -> Int -> Int -> IO ()) ptr x y ex ey r g b a 58 | 59 | -- TODO: More keys still to add... careful to do the right mappings in 60 | -- KEY in sdlrun.c 61 | 62 | public export 63 | data Key = KeyUpArrow 64 | | KeyDownArrow 65 | | KeyLeftArrow 66 | | KeyRightArrow 67 | | KeyEsc 68 | | KeySpace 69 | | KeyTab 70 | | KeyF1 71 | | KeyF2 72 | | KeyF3 73 | | KeyF4 74 | | KeyF5 75 | | KeyF6 76 | | KeyF7 77 | | KeyF8 78 | | KeyF9 79 | | KeyF10 80 | | KeyF11 81 | | KeyF12 82 | | KeyF13 83 | | KeyF14 84 | | KeyF15 85 | | KeyLShift 86 | | KeyRShift 87 | | KeyLCtrl 88 | | KeyRCtrl 89 | | KeyAny Char 90 | 91 | Eq Key where 92 | KeyUpArrow == KeyUpArrow = True 93 | KeyDownArrow == KeyDownArrow = True 94 | KeyLeftArrow == KeyLeftArrow = True 95 | KeyRightArrow == KeyRightArrow = True 96 | 97 | KeyEsc == KeyEsc = True 98 | KeyTab == KeyTab = True 99 | KeySpace == KeySpace = True 100 | 101 | KeyF1 == KeyF1 = True 102 | KeyF2 == KeyF2 = True 103 | KeyF3 == KeyF3 = True 104 | KeyF4 == KeyF4 = True 105 | KeyF5 == KeyF5 = True 106 | KeyF6 == KeyF6 = True 107 | KeyF7 == KeyF7 = True 108 | KeyF8 == KeyF8 = True 109 | KeyF9 == KeyF9 = True 110 | KeyF10 == KeyF10 = True 111 | KeyF11 == KeyF11 = True 112 | KeyF12 == KeyF12 = True 113 | KeyF13 == KeyF13 = True 114 | KeyF14 == KeyF14 = True 115 | KeyF15 == KeyF15 = True 116 | 117 | KeyLShift == KeyLShift = True 118 | KeyRShift == KeyRShift = True 119 | KeyLCtrl == KeyLCtrl = True 120 | KeyRCtrl == KeyRCtrl = True 121 | 122 | (KeyAny x) == (KeyAny y) = x == y 123 | _ == _ = False 124 | 125 | public export 126 | data Button = Left | Middle | Right | WheelUp | WheelDown 127 | 128 | Eq Button where 129 | Left == Left = True 130 | Middle == Middle = True 131 | Right == Right = True 132 | WheelUp == WheelUp = True 133 | WheelDown == WheelDown = True 134 | _ == _ = False 135 | 136 | public export 137 | data Event = KeyDown Key 138 | | KeyUp Key 139 | | MouseMotion Int Int Int Int 140 | | MouseButtonDown Button Int Int 141 | | MouseButtonUp Button Int Int 142 | | Resize Int Int 143 | | AppQuit 144 | 145 | Eq Event where 146 | (KeyDown x) == (KeyDown y) = x == y 147 | (KeyUp x) == (KeyUp y) = x == y 148 | AppQuit == AppQuit = True 149 | (MouseMotion x y rx ry) == (MouseMotion x' y' rx' ry') 150 | = x == x' && y == y' && rx == rx' && ry == ry' 151 | (MouseButtonDown b x y) == (MouseButtonDown b' x' y') 152 | = b == b' && x == x' && y == y' 153 | (MouseButtonUp b x y) == (MouseButtonUp b' x' y') 154 | = b == b' && x == x' && y == y' 155 | _ == _ = False 156 | 157 | public export 158 | pollEvent : IO (Maybe Event) 159 | pollEvent 160 | = do vm <- getMyVM 161 | MkRaw e <- 162 | foreign FFI_C "pollEvent" (Ptr -> IO (Raw (Maybe Event))) vm 163 | pure e 164 | 165 | -------------------------------------------------------------------------------- /src/MakefileSDLC: -------------------------------------------------------------------------------- 1 | CC = gcc 2 | CFLAGS = `idris --include` `sdl-config --cflags` 3 | 4 | sdlrun.o: config sdlrun.c sdlrun.h 5 | 6 | config: .PHONY 7 | echo "%flag C \"`sdl-config --libs`\"" > Graphics/Config.idr 8 | echo "%flag C \"`sdl-config --cflags`\"" >> Graphics/Config.idr 9 | 10 | clean: .PHONY 11 | rm sdlrun.o 12 | 13 | .PHONY: 14 | -------------------------------------------------------------------------------- /src/sdlrun.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include 6 | 7 | SDL_Surface* graphicsInit(int xsize, int ysize) { 8 | SDL_Surface *screen; 9 | 10 | if(SDL_Init(SDL_INIT_TIMER | SDL_INIT_VIDEO | SDL_INIT_AUDIO) <0 ) 11 | { 12 | printf("Unable to init SDL: %s\n", SDL_GetError()); 13 | return NULL; 14 | } 15 | 16 | screen = SDL_SetVideoMode(xsize, ysize, 32, 17 | SDL_HWSURFACE | SDL_DOUBLEBUF); 18 | if (screen==NULL) { 19 | printf("Unable to init SDL: %s\n", SDL_GetError()); 20 | return NULL; 21 | } 22 | 23 | return screen; 24 | } 25 | 26 | void filledRect(void *s_in, 27 | int x, int y, int w, int h, 28 | int r, int g, int b, int a) 29 | { 30 | SDL_Surface* s = (SDL_Surface*)s_in; 31 | Uint32 colour 32 | = SDL_MapRGBA(s->format, (Uint8)r, (Uint8)g, (Uint8)b, (Uint8) a); 33 | SDL_Rect rect = { x, y, w, h }; 34 | SDL_FillRect(s, &rect, colour); 35 | } 36 | 37 | void filledEllipse(void* s_in, 38 | int x, int y, int rx, int ry, 39 | int r, int g, int b, int a) 40 | { 41 | SDL_Surface* s = (SDL_Surface*)s_in; 42 | filledEllipseRGBA(s, x, y, rx, ry, r, g, b, a); 43 | } 44 | 45 | void drawLine(void* s_in, 46 | int x, int y, int ex, int ey, 47 | int r, int g, int b, int a) 48 | { 49 | SDL_Surface* s = (SDL_Surface*)s_in; 50 | lineRGBA(s, x, y, ex, ey, r, g, b, a); 51 | } 52 | 53 | void flipBuffers(void* s_in) { 54 | SDL_Surface* s = (SDL_Surface*)s_in; 55 | SDL_Flip(s); 56 | } 57 | 58 | void* startSDL(int x, int y) { 59 | SDL_Surface *s = graphicsInit(x, y); 60 | // drawRect(s, 100, 100, 50, 50, 255, 0, 0, 128); 61 | // while(1) { 62 | return (void*)s; 63 | } 64 | 65 | VAL MOTION(VM* vm, int x, int y, int relx, int rely) { 66 | VAL m; 67 | idris_constructor(m, vm, 2, 4, 0); 68 | idris_setConArg(m, 0, MKINT((intptr_t)x)); 69 | idris_setConArg(m, 1, MKINT((intptr_t)y)); 70 | idris_setConArg(m, 2, MKINT((intptr_t)relx)); 71 | idris_setConArg(m, 3, MKINT((intptr_t)rely)); 72 | return m; 73 | } 74 | 75 | VAL BUTTON(VM* vm, int tag, int b, int x, int y) { 76 | VAL button; 77 | 78 | switch(b) { 79 | case SDL_BUTTON_LEFT: 80 | idris_constructor(button, vm, 0, 0, 0); 81 | break; 82 | case SDL_BUTTON_MIDDLE: 83 | idris_constructor(button, vm, 1, 0, 0); 84 | break; 85 | case SDL_BUTTON_RIGHT: 86 | idris_constructor(button, vm, 2, 0, 0); 87 | break; 88 | case SDL_BUTTON_WHEELUP: 89 | idris_constructor(button, vm, 3, 0, 0); 90 | break; 91 | case SDL_BUTTON_WHEELDOWN: 92 | idris_constructor(button, vm, 4, 0, 0); 93 | break; 94 | default: 95 | idris_constructor(button, vm, 0, 0, 0); 96 | break; 97 | } 98 | 99 | VAL event; 100 | idris_constructor(event, vm, tag, 3, 0); 101 | idris_setConArg(event, 0, button); 102 | idris_setConArg(event, 1, MKINT((intptr_t)x)); 103 | idris_setConArg(event, 2, MKINT((intptr_t)y)); 104 | 105 | return event; 106 | } 107 | 108 | VAL RESIZE(VM* vm, int w, int h) { 109 | VAL m; 110 | idris_constructor(m, vm, 5, 2, 0); 111 | idris_setConArg(m, 0, MKINT((intptr_t)w)); 112 | idris_setConArg(m, 1, MKINT((intptr_t)h)); 113 | return m; 114 | } 115 | VAL KEY(VM* vm, int tag, SDLKey key) { 116 | VAL k; 117 | 118 | switch(key) { 119 | case SDLK_UP: 120 | idris_constructor(k, vm, 0, 0, 0); 121 | break; 122 | case SDLK_DOWN: 123 | idris_constructor(k, vm, 1, 0, 0); 124 | break; 125 | case SDLK_LEFT: 126 | idris_constructor(k, vm, 2, 0, 0); 127 | break; 128 | case SDLK_RIGHT: 129 | idris_constructor(k, vm, 3, 0, 0); 130 | break; 131 | case SDLK_ESCAPE: 132 | idris_constructor(k, vm, 4, 0, 0); 133 | break; 134 | case SDLK_SPACE: 135 | idris_constructor(k, vm, 5, 0, 0); 136 | break; 137 | case SDLK_TAB: 138 | idris_constructor(k, vm, 6, 0, 0); 139 | break; 140 | case SDLK_F1: 141 | idris_constructor(k, vm, 7, 0, 0); 142 | break; 143 | case SDLK_F2: 144 | idris_constructor(k, vm, 8, 0, 0); 145 | break; 146 | case SDLK_F3: 147 | idris_constructor(k, vm, 9, 0, 0); 148 | break; 149 | case SDLK_F4: 150 | idris_constructor(k, vm, 10, 0, 0); 151 | break; 152 | case SDLK_F5: 153 | idris_constructor(k, vm, 11, 0, 0); 154 | break; 155 | case SDLK_F6: 156 | idris_constructor(k, vm, 12, 0, 0); 157 | break; 158 | case SDLK_F7: 159 | idris_constructor(k, vm, 13, 0, 0); 160 | break; 161 | case SDLK_F8: 162 | idris_constructor(k, vm, 14, 0, 0); 163 | break; 164 | case SDLK_F9: 165 | idris_constructor(k, vm, 15, 0, 0); 166 | break; 167 | case SDLK_F10: 168 | idris_constructor(k, vm, 16, 0, 0); 169 | break; 170 | case SDLK_F11: 171 | idris_constructor(k, vm, 17, 0, 0); 172 | break; 173 | case SDLK_F12: 174 | idris_constructor(k, vm, 18, 0, 0); 175 | break; 176 | case SDLK_F13: 177 | idris_constructor(k, vm, 19, 0, 0); 178 | break; 179 | case SDLK_F14: 180 | idris_constructor(k, vm, 20, 0, 0); 181 | break; 182 | case SDLK_F15: 183 | idris_constructor(k, vm, 21, 0, 0); 184 | break; 185 | case SDLK_LSHIFT: 186 | idris_constructor(k, vm, 22, 0, 0); 187 | break; 188 | case SDLK_RSHIFT: 189 | idris_constructor(k, vm, 23, 0, 0); 190 | break; 191 | case SDLK_LCTRL: 192 | idris_constructor(k, vm, 24, 0, 0); 193 | break; 194 | case SDLK_RCTRL: 195 | idris_constructor(k, vm, 25, 0, 0); 196 | break; 197 | default: 198 | idris_constructor(k, vm, 26, 1, 0); 199 | // safe because there's no further allocation. 200 | idris_setConArg(k, 0, MKINT((intptr_t)key)); 201 | break; 202 | } 203 | 204 | VAL event; 205 | idris_constructor(event, vm, tag, 1, 0); 206 | idris_setConArg(event, 0, k); 207 | 208 | return event; 209 | } 210 | 211 | /* 212 | data Button = Left | Middle | Right | WheelUp | WheelDown 213 | 214 | data Event = KeyDown Key 215 | | KeyUp Key 216 | | MouseMotion Int Int Int Int 217 | | MouseButtonDown Button Int Int 218 | | MouseButtonUp Button Int Int 219 | | AppQuit 220 | 221 | pollEvent : IO (Maybe Event) 222 | */ 223 | 224 | void* pollEvent(VM* vm) 225 | { 226 | VAL idris_event; 227 | 228 | SDL_Event event; // = (SDL_Event *) GC_MALLOC(sizeof(SDL_Event)); 229 | int r = SDL_PollEvent(&event); 230 | 231 | idris_requireAlloc(128); // Conservative! 232 | 233 | if (r==0) { 234 | idris_constructor(idris_event, vm, 0, 0, 0); // Nothing 235 | } 236 | else { 237 | VAL ievent = NULL; 238 | switch(event.type) { 239 | case SDL_KEYDOWN: 240 | ievent = KEY(vm, 0, event.key.keysym.sym); 241 | break; 242 | case SDL_KEYUP: 243 | ievent = KEY(vm, 1, event.key.keysym.sym); 244 | break; 245 | case SDL_MOUSEMOTION: 246 | ievent = MOTION(vm, event.motion.x, event.motion.y, 247 | event.motion.xrel, event.motion.yrel); 248 | break; 249 | case SDL_MOUSEBUTTONDOWN: 250 | ievent = BUTTON(vm, 3, event.button.button, 251 | event.button.x, event.button.y); 252 | break; 253 | case SDL_MOUSEBUTTONUP: 254 | ievent = BUTTON(vm, 4, event.button.button, 255 | event.button.x, event.button.y); 256 | break; 257 | case SDL_VIDEORESIZE: 258 | ievent = RESIZE(vm, event.resize.w, event.resize.h); 259 | break; 260 | case SDL_QUIT: 261 | idris_constructor(ievent, vm, 6, 0, 0); 262 | break; 263 | default: 264 | idris_constructor(idris_event, vm, 0, 0, 0); // Nothing 265 | idris_doneAlloc(); 266 | return idris_event; 267 | } 268 | idris_constructor(idris_event, vm, 1, 1, 0); 269 | idris_setConArg(idris_event, 0, ievent); // Just ievent 270 | } 271 | 272 | idris_doneAlloc(); 273 | return idris_event; 274 | } 275 | 276 | /* 277 | int main(int argc, char* argv[]) { 278 | SDL_Surface *s = graphicsInit(640,480); 279 | SDL_Event event; 280 | filledRect(s, 100, 100, 50, 50, 255, 0, 0, 128); 281 | flipBuffers(s); 282 | int done = 0; 283 | while(!done) { 284 | int r = SDL_PollEvent(&event); 285 | if (r != 0) { 286 | switch(event.type) { 287 | case SDL_KEYUP: 288 | done = 1; 289 | break; 290 | default: 291 | break; 292 | } 293 | } 294 | } 295 | } 296 | */ 297 | 298 | -------------------------------------------------------------------------------- /src/sdlrun.h: -------------------------------------------------------------------------------- 1 | #ifndef __SDLRUN_H 2 | #define __SDLRUN_H 3 | 4 | #include 5 | 6 | // Start SDL, open a window with dimensions (x,y) 7 | void* startSDL(int x, int y); 8 | 9 | // Drawing primitives 10 | void filledRect(void *s, 11 | int x, int y, int w, int h, 12 | int r, int g, int b, int a); 13 | void flipBuffers(void* s_in); 14 | void filledEllipse(void* s_in, 15 | int x, int y, int rx, int ry, 16 | int r, int g, int b, int a); 17 | void drawLine(void* s_in, 18 | int x, int y, int ex, int ey, 19 | int r, int g, int b, int a); 20 | 21 | // Events 22 | void* pollEvent(VM* vm); // builds an Idris value 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /test/etest.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | {- Test program for SDL effect - draws a rectangle and an ellipse on a 4 | scrolling starfield background, with the position of the ellipse 5 | controlled by the arrow keys -} 6 | 7 | import Effects 8 | 9 | import Effect.SDL 10 | import Effect.State 11 | import Effect.StdIO 12 | import Effect.Random 13 | 14 | -- Global variables we'll manage as State effects 15 | 16 | data Vars = Position -- position of ellipse 17 | | XMove -- movement of ellipse 18 | | YMove -- movement of ellipse 19 | | Frames -- count of frames so far 20 | | Starfield -- position of stars in the background 21 | 22 | -- SDL effect is parameterised by an underyling 'surface' resource which 23 | -- only exists when initialised. 24 | 25 | -- The program supports SDL, carries state, and supports random number 26 | -- generation and console I/O 27 | 28 | Prog : Type -> Type -> Type 29 | Prog i t = Eff t [SDL i, 30 | Position ::: STATE (Int, Int), 31 | XMove ::: STATE Int, 32 | YMove ::: STATE Int, 33 | Frames ::: STATE Integer, 34 | Starfield ::: STATE (List (Int, Int)), 35 | RND, 36 | STDIO] 37 | 38 | -- Convenient shorthand for initialised SDL 39 | Running : Type -> Type 40 | Running t = Prog SDLSurface t 41 | 42 | initStarfield : List (Int, Int) -> Int -> Eff m [RND] (List (Int, Int)) 43 | initStarfield acc 0 = return acc 44 | initStarfield acc n = do x <- rndInt 0 639 45 | y <- rndInt 0 479 46 | initStarfield ((fromInteger x, fromInteger y) :: acc) (n - 1) 47 | 48 | updateStarfield : List (Int, Int) -> Eff m [RND] (List (Int, Int)) 49 | updateStarfield xs = upd [] xs where 50 | upd : List (Int, Int) -> List (Int, Int) -> Eff m [RND] (List (Int, Int)) 51 | upd acc [] = return acc 52 | upd acc ((x, y) :: xs) 53 | = if (y > 479) then do 54 | x <- rndInt 0 639 55 | upd ((fromInteger x, 0) :: acc) xs 56 | else 57 | upd ((x, y+1) :: acc) xs 58 | 59 | drawStarfield : List (Int, Int) -> Eff IO [SDL_ON] () 60 | drawStarfield [] = return () 61 | drawStarfield ((x, y) :: xs) = do line white x y x y 62 | drawStarfield xs 63 | 64 | -- Main program - set up SDL, put the ellipse in a starting position, 65 | -- set up an intiial starfield in random locations, then run an 66 | -- event loop. 67 | 68 | emain : Prog () () 69 | emain = do initialise 640 480 70 | Position :- put (320, 200) 71 | s <- initStarfield [] 100 72 | Starfield :- put s 73 | eventLoop 74 | quit 75 | where process : Maybe Event -> Running Bool 76 | process (Just AppQuit) = return False 77 | 78 | process (Just (KeyDown KeyLeftArrow)) = do XMove :- put (-1) 79 | return True 80 | process (Just (KeyUp KeyLeftArrow)) = do XMove :- put 0 81 | return True 82 | process (Just (KeyDown KeyRightArrow)) = do XMove :- put 1 83 | return True 84 | process (Just (KeyUp KeyRightArrow)) = do XMove :- put 0 85 | return True 86 | process (Just (KeyDown KeyUpArrow)) = do YMove :- put (-1) 87 | return True 88 | process (Just (KeyUp KeyUpArrow)) = do YMove :- put 0 89 | return True 90 | process (Just (KeyDown KeyDownArrow)) = do YMove :- put 1 91 | return True 92 | process (Just (KeyUp KeyDownArrow)) = do YMove :- put 0 93 | return True 94 | process _ = return True 95 | 96 | draw : Running () 97 | draw = do rectangle black 0 0 640 480 98 | rectangle cyan 50 50 50 50 99 | (x, y) <- Position :- get 100 | ellipse yellow x y 20 20 101 | s <- Starfield :- get 102 | drawStarfield s 103 | flip 104 | 105 | -- update the world state by moving the ellipse to a new position 106 | -- and scrolling the starfield. Also print the number of frames 107 | -- drawn so far every so often. 108 | 109 | updateWorld : Running () 110 | updateWorld 111 | = do f <- Frames :- get 112 | s <- Starfield :- get 113 | s' <- updateStarfield s 114 | Starfield :- put s' 115 | Frames :- put (f + 1) 116 | when ((f `mod` 100) == 0) (putStrLn (show f)) 117 | 118 | (x, y) <- Position :- get 119 | xm <- XMove :- get 120 | ym <- YMove :- get 121 | Position :- put (x + xm, y + ym) 122 | 123 | -- Event loop simply has to draw the current state, update the 124 | -- state according to how the ellipse is moving, then process 125 | -- any incoming events 126 | 127 | eventLoop : Running () 128 | eventLoop = do draw 129 | updateWorld 130 | e <- poll 131 | continue <- process e 132 | when continue eventLoop 133 | 134 | main : IO () 135 | main = run [(), Position := (320,200), 136 | XMove := 0, 137 | YMove := 0, 138 | Frames := 0, 139 | Starfield := List.Nil, 140 | 1234567890, 141 | ()] emain 142 | 143 | 144 | -------------------------------------------------------------------------------- /test/test.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Graphics.SDL 4 | 5 | main : IO () 6 | main = do surface <- startSDL 640 480 7 | flipBuffers surface 8 | 9 | eventLoop surface 0 320 200 0 0 10 | where eventLoop : SDLSurface -> Integer -> Int -> Int -> Int -> Int -> IO () 11 | processEvent : SDLSurface -> Integer -> Int -> Int -> Int -> Int -> Maybe Event -> IO () 12 | 13 | eventLoop s f x y mx my 14 | = do event <- pollEvent 15 | filledRect s 0 0 640 480 0 0 0 128 16 | filledRect s 100 100 50 50 255 0 0 128 17 | filledEllipse s x y 20 20 0 255 0 128 18 | when ((f `mod` 100) == 0) $ print f 19 | flipBuffers s 20 | processEvent s (f+1) (x+mx) (y+my) mx my event 21 | 22 | processEvent s f x y mx my (Just (KeyDown KeyLeftArrow)) 23 | = eventLoop s f x y (-1) my 24 | processEvent s f x y mx my (Just (KeyUp KeyLeftArrow)) 25 | = eventLoop s f x y 0 my 26 | processEvent s f x y mx my (Just (KeyDown KeyRightArrow)) 27 | = eventLoop s f x y 1 my 28 | processEvent s f x y mx my (Just (KeyUp KeyRightArrow)) 29 | = eventLoop s f x y 0 my 30 | processEvent s f x y mx my (Just (KeyDown KeyUpArrow)) 31 | = eventLoop s f x y mx (-1) 32 | processEvent s f x y mx my (Just (KeyUp KeyUpArrow)) 33 | = eventLoop s f x y mx 0 34 | processEvent s f x y mx my (Just (KeyDown KeyDownArrow)) 35 | = eventLoop s f x y mx 1 36 | processEvent s f x y mx my (Just (KeyUp KeyDownArrow)) 37 | = eventLoop s f x y mx 0 38 | processEvent s f x y mx my (Just AppQuit) = return () 39 | processEvent s f x y mx my (Just (KeyDown (KeyAny k))) 40 | = do print k 41 | eventLoop s f x y mx my 42 | processEvent s f x y mx my (Just (MouseMotion mousex mousey _ _)) 43 | = do print (mousex, mousey) 44 | eventLoop s f x y mx my 45 | processEvent s f x y mx my (Just (MouseButtonUp Left mousex mousey)) 46 | = do print (mousex, mousey) 47 | eventLoop s f mousex mousey mx my 48 | processEvent s f x y mx my _ = eventLoop s f x y mx my 49 | 50 | 51 | --------------------------------------------------------------------------------