diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..563996e --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*.ibc diff --git a/sdl.ipkg b/sdl.ipkg index 9dbcf06..9bc750f 100644 --- a/sdl.ipkg +++ b/sdl.ipkg @@ -2,10 +2,8 @@ package sdl sourcedir = src modules = Graphics.SDL, Graphics.Config, Effect.SDL -opts = "-p effects" +opts = "-p effects" makefile = MakefileSDLC objs = sdlrun.o, sdlrun.h -libs = SDL, SDL_gfx - diff --git a/src/Effect/SDL.idr b/src/Effect/SDL.idr index bc97a90..69c2af0 100644 --- a/src/Effect/SDL.idr +++ b/src/Effect/SDL.idr @@ -3,35 +3,45 @@ module Effect.SDL import Effects import public Graphics.SDL -Srf : Type -Srf = SDLSurface - +public export data Colour = MkCol Int Int Int Int +export black : Colour black = MkCol 0 0 0 255 +export white : Colour white = MkCol 255 255 255 255 +export red : Colour red = MkCol 255 0 0 255 +export green : Colour green = MkCol 0 255 0 255 +export blue : Colour blue = MkCol 0 0 255 255 +export yellow : Colour yellow = MkCol 255 255 0 255 +export cyan : Colour cyan = MkCol 0 255 255 255 +export magenta : Colour magenta = MkCol 255 0 255 255 +Srf : Type +Srf = SDLSurface + +export data Sdl : Effect where Initialise : Int -> Int -> Sdl () () (\v => Srf) Quit : Sdl () Srf (\v => ()) @@ -46,39 +56,47 @@ Handler Sdl IO where handle s Flip k = do flipBuffers s; k () s handle s Poll k = do x <- pollEvent; k x s - handle s (WithSurface f) k = do r <- f s; k r s + handle s (WithSurface f) k = do r <- f s; k r s +public export SDL : Type -> EFFECT SDL res = MkEff res Sdl +public export SDL_ON : EFFECT SDL_ON = SDL SDLSurface -initialise : Int -> Int -> { [SDL ()] ==> [SDL_ON] } Eff () +export +initialise : Int -> Int -> { [SDL ()] ==> [SDL_ON] } Eff () initialise x y = call $ Initialise x y -quit : { [SDL_ON] ==> [SDL ()] } Eff () +export +quit : { [SDL_ON] ==> [SDL ()] } Eff () quit = call Quit +export flip : { [SDL_ON] } Eff () flip = call Flip -poll : { [SDL_ON] } Eff (Maybe Event) +export +poll : { [SDL_ON] } Eff (Maybe Event) poll = call Poll +export getSurface : { [SDL_ON] } Eff SDLSurface getSurface = call $ WithSurface (\s => return s) -rectangle : Colour -> Int -> Int -> Int -> Int -> { [SDL_ON] } Eff () -rectangle (MkCol r g b a) x y w h +export +rectangle : Colour -> Int -> Int -> Int -> Int -> { [SDL_ON] } Eff () +rectangle (MkCol r g b a) x y w h = call $ WithSurface (\s => filledRect s x y w h r g b a) -ellipse : Colour -> Int -> Int -> Int -> Int -> { [SDL_ON] } Eff () -ellipse (MkCol r g b a) x y rx ry +export +ellipse : Colour -> Int -> Int -> Int -> Int -> { [SDL_ON] } Eff () +ellipse (MkCol r g b a) x y rx ry = call $ WithSurface (\s => filledEllipse s x y rx ry r g b a) -line : Colour -> Int -> Int -> Int -> Int -> { [SDL_ON] } Eff () -line (MkCol r g b a) x y ex ey +export +line : Colour -> Int -> Int -> Int -> Int -> { [SDL_ON] } Eff () +line (MkCol r g b a) x y ex ey = call $ WithSurface (\s => drawLine s x y ex ey r g b a) - - diff --git a/src/Graphics/Config.idr b/src/Graphics/Config.idr new file mode 100644 index 0000000..c39260d --- /dev/null +++ b/src/Graphics/Config.idr @@ -0,0 +1,2 @@ +%flag C "-L/usr/local/Cellar/sdl_gfx/2.0.25/lib -L/usr/local/lib -lSDL_gfx -lSDLmain -lSDL -Wl,-framework,Cocoa" +%flag C "-D_GNU_SOURCE=1 -D_THREAD_SAFE -I/usr/local/Cellar/sdl_gfx/2.0.25/include/SDL -I/usr/local/include/SDL" diff --git a/src/Graphics/SDL.idr b/src/Graphics/SDL.idr index 940a658..cbfda6d 100644 --- a/src/Graphics/SDL.idr +++ b/src/Graphics/SDL.idr @@ -3,26 +3,24 @@ module Graphics.SDL import Graphics.Config %include C "sdlrun.h" -%include C "SDL/SDL.h" %link C "sdlrun.o" -%lib C "SDL_gfx" -- Set up a window -abstract +export data SDLSurface = MkSurface Ptr -public +export startSDL : Int -> Int -> IO SDLSurface startSDL x y = do ptr <- do_startSDL return (MkSurface ptr) where do_startSDL = foreign FFI_C "startSDL" (Int -> Int -> IO Ptr) x y -public +export endSDL : IO () endSDL = foreign FFI_C "SDL_Quit" (IO ()) -public +export flipBuffers : SDLSurface -> IO (); flipBuffers (MkSurface ptr) = foreign FFI_C "flipBuffers" (Ptr -> IO ()) ptr @@ -30,7 +28,7 @@ flipBuffers (MkSurface ptr) -- Some drawing primitives -public +export filledRect : SDLSurface -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO () filledRect (MkSurface ptr) x y w h r g b a @@ -38,7 +36,7 @@ filledRect (MkSurface ptr) x y w h r g b a (Ptr -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO ()) ptr x y w h r g b a -public +export filledEllipse : SDLSurface -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO () filledEllipse (MkSurface ptr) x y rx ry r g b a @@ -46,7 +44,7 @@ filledEllipse (MkSurface ptr) x y rx ry r g b a (Ptr -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO ()) ptr x y rx ry r g b a -public +export drawLine : SDLSurface -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO () drawLine (MkSurface ptr) x y ex ey r g b a @@ -57,7 +55,7 @@ drawLine (MkSurface ptr) x y ex ey r g b a -- TODO: More keys still to add... careful to do the right mappings in -- KEY in sdlrun.c -public +public export data Key = KeyUpArrow | KeyDownArrow | KeyLeftArrow @@ -120,7 +118,7 @@ Eq Key where (KeyAny x) == (KeyAny y) = x == y _ == _ = False -public +public export data Button = Left | Middle | Right | WheelUp | WheelDown Eq Button where @@ -131,7 +129,7 @@ Eq Button where WheelDown == WheelDown = True _ == _ = False -public +public export data Event = KeyDown Key | KeyUp Key | MouseMotion Int Int Int Int @@ -152,10 +150,9 @@ Eq Event where = b == b' && x == x' && y == y' _ == _ = False -public +export pollEvent : IO (Maybe Event) pollEvent = do MkRaw e <- foreign FFI_C "pollEvent" (Ptr -> IO (Raw (Maybe Event))) prim__vm return e - diff --git a/src/MakefileSDLC b/src/MakefileSDLC index 5209312..faba77f 100644 --- a/src/MakefileSDLC +++ b/src/MakefileSDLC @@ -1,11 +1,11 @@ CC = gcc -CFLAGS = `idris --include` `sdl-config --cflags` +CFLAGS = `idris --include` `pkg-config --cflags SDL_gfx` sdlrun.o: config sdlrun.c sdlrun.h config: .PHONY - echo "%flag C \"`sdl-config --libs`\"" > Graphics/Config.idr - echo "%flag C \"`sdl-config --cflags`\"" >> Graphics/Config.idr + echo "%flag C \"`pkg-config --libs SDL_gfx`\"" > Graphics/Config.idr + echo "%flag C \"`pkg-config --cflags SDL_gfx`\"" >> Graphics/Config.idr clean: .PHONY rm sdlrun.o diff --git a/src/sdlrun.h b/src/sdlrun.h index 71f478a..35b7d1e 100644 --- a/src/sdlrun.h +++ b/src/sdlrun.h @@ -1,8 +1,6 @@ #ifndef __SDLRUN_H #define __SDLRUN_H -#include - // Start SDL, open a window with dimensions (x,y) void* startSDL(int x, int y); @@ -19,6 +17,6 @@ void drawLine(void* s_in, int r, int g, int b, int a); // Events -void* pollEvent(VM* vm); // builds an Idris value +void* pollEvent(void* vm); // builds an Idris value #endif diff --git a/test/.gitignore b/test/.gitignore new file mode 100644 index 0000000..bbaa5c4 --- /dev/null +++ b/test/.gitignore @@ -0,0 +1,3 @@ +etest +simple +test diff --git a/test/Makefile b/test/Makefile new file mode 100644 index 0000000..acee4c7 --- /dev/null +++ b/test/Makefile @@ -0,0 +1,14 @@ +.PHONY: all +all: etest test + +.PHONY: etest +etest: + idris --build etest.ipkg + +.PHONY: simple +simple: + idris --build simple.ipkg + +.PHONY: test +test: + idris --build test.ipkg diff --git a/test/etest.idr b/test/etest.idr index 1521eb0..3cdb5f4 100644 --- a/test/etest.idr +++ b/test/etest.idr @@ -1,7 +1,7 @@ module Main {- Test program for SDL effect - draws a rectangle and an ellipse on a -scrolling starfield background, with the position of the ellipse +scrolling starfield background, with the position of the ellipse controlled by the arrow keys -} import Effects @@ -26,28 +26,28 @@ data Vars = Position -- position of ellipse -- generation and console I/O Prog : Type -> Type -> Type -Prog i t = Eff IO [SDL i, - Position ::: STATE (Int, Int), - XMove ::: STATE Int, - YMove ::: STATE Int, - Frames ::: STATE Integer, - Starfield ::: STATE (List (Int, Int)), - RND, - STDIO] t +Prog i t = Eff t [SDL i, + Position ::: STATE (Int, Int), + XMove ::: STATE Int, + YMove ::: STATE Int, + Frames ::: STATE Integer, + Starfield ::: STATE (List (Int, Int)), + RND, + STDIO] -- Convenient shorthand for initialised SDL Running : Type -> Type Running t = Prog SDLSurface t -initStarfield : List (Int, Int) -> Int -> Eff m [RND] (List (Int, Int)) +initStarfield : List (Int, Int) -> Int -> Eff (List (Int, Int)) [RND] initStarfield acc 0 = return acc initStarfield acc n = do x <- rndInt 0 639 y <- rndInt 0 479 initStarfield ((fromInteger x, fromInteger y) :: acc) (n - 1) -updateStarfield : List (Int, Int) -> Eff m [RND] (List (Int, Int)) +updateStarfield : List (Int, Int) -> Eff (List (Int, Int)) [RND] updateStarfield xs = upd [] xs where - upd : List (Int, Int) -> List (Int, Int) -> Eff m [RND] (List (Int, Int)) + upd : List (Int, Int) -> List (Int, Int) -> Eff (List (Int, Int)) [RND] upd acc [] = return acc upd acc ((x, y) :: xs) = if (y > 479) then do @@ -56,7 +56,7 @@ updateStarfield xs = upd [] xs where else upd ((x, y+1) :: acc) xs -drawStarfield : List (Int, Int) -> Eff IO [SDL_ON] () +drawStarfield : List (Int, Int) -> Eff () [SDL_ON] drawStarfield [] = return () drawStarfield ((x, y) :: xs) = do line white x y x y drawStarfield xs @@ -132,12 +132,11 @@ emain = do initialise 640 480 when continue eventLoop main : IO () -main = run [(), Position := (320,200), - XMove := 0, - YMove := 0, +main = runInit [SDL (), + Position := (320,200), + XMove := 0, + YMove := 0, Frames := 0, Starfield := List.Nil, 1234567890, ()] emain - - diff --git a/test/etest.ipkg b/test/etest.ipkg new file mode 100644 index 0000000..4c5c7fa --- /dev/null +++ b/test/etest.ipkg @@ -0,0 +1,6 @@ +package etest + +pkgs = effects, sdl + +main = etest +executable = etest diff --git a/test/simple.idr b/test/simple.idr new file mode 100644 index 0000000..7e44c45 --- /dev/null +++ b/test/simple.idr @@ -0,0 +1,18 @@ +module Main + +import Graphics.SDL + +main : IO () +main = (do + surface <- startSDL 640 480 + rest surface) + where + rest : SDLSurface -> IO () + rest surface = do + filledRect surface 100 100 50 50 255 0 0 128 + flipBuffers surface + event <- pollEvent + case event of + Just (KeyDown KeyEscape) => pure () + Just (AppQuit) => pure () + _ => rest surface diff --git a/test/simple.ipkg b/test/simple.ipkg new file mode 100644 index 0000000..0c360db --- /dev/null +++ b/test/simple.ipkg @@ -0,0 +1,6 @@ +package test + +pkgs = effects, sdl + +main = simple +executable = simple diff --git a/test/test.idr b/test/test.idr index d1332c0..211bbfb 100644 --- a/test/test.idr +++ b/test/test.idr @@ -15,7 +15,7 @@ main = do surface <- startSDL 640 480 filledRect s 0 0 640 480 0 0 0 128 filledRect s 100 100 50 50 255 0 0 128 filledEllipse s x y 20 20 0 255 0 128 - when ((f `mod` 100) == 0) $ print f + when ((f `mod` 100) == 0) $ printLn f flipBuffers s processEvent s (f+1) (x+mx) (y+my) mx my event @@ -40,11 +40,9 @@ main = do surface <- startSDL 640 480 = do print k eventLoop s f x y mx my processEvent s f x y mx my (Just (MouseMotion mousex mousey _ _)) - = do print (mousex, mousey) + = do printLn (mousex, mousey) eventLoop s f x y mx my processEvent s f x y mx my (Just (MouseButtonUp Left mousex mousey)) - = do print (mousex, mousey) + = do printLn (mousex, mousey) eventLoop s f mousex mousey mx my processEvent s f x y mx my _ = eventLoop s f x y mx my - - diff --git a/test/test.ipkg b/test/test.ipkg new file mode 100644 index 0000000..1e91934 --- /dev/null +++ b/test/test.ipkg @@ -0,0 +1,6 @@ +package test + +pkgs = effects, sdl + +main = test +executable = test