atuin-0.1.1: src/SDLprims.lhs
> {-# OPTIONS_GHC -fglasgow-exts #-}
> module SDLprims where
Epic primitives for calling SDL and basic operators
> import Epic.Epic
> initSDL :: Expr -> Expr -> Term
> initSDL xsize ysize
> = foreign_ tyPtr "startSDL" [(xsize, tyInt), (ysize, tyInt)]
> pollEvent = foreignConst_ tyPtr "pollEvent"
> pressAnyKey = foreignConst_ tyUnit "pressAnyKey"
> flipBuffers :: Expr -> Term
> flipBuffers s = foreign_ tyUnit "flipBuffers" [(s, tyPtr)]
Define some colours, and convert a colour into a tuple of the relevant
RGBA values.
> col_black = con_ 0
> col_red = con_ 1
> col_green = con_ 2
> col_blue = con_ 3
> col_yellow = con_ 4
> col_cyan = con_ 5
> col_magenta = con_ 6
> col_white = con_ 7
> rgba col = case_ col
> [con 0 (tuple_ @@ int 0 @@ int 0 @@ int 0 @@ int 255),
> con 1 (tuple_ @@ int 255 @@ int 0 @@ int 0 @@ int 255),
> con 2 (tuple_ @@ int 0 @@ int 255 @@ int 0 @@ int 255),
> con 3 (tuple_ @@ int 0 @@ int 0 @@ int 255 @@ int 255),
> con 4 (tuple_ @@ int 255 @@ int 255 @@ int 0 @@ int 255),
> con 5 (tuple_ @@ int 0 @@ int 255 @@ int 255 @@ int 255),
> con 6 (tuple_ @@ int 255 @@ int 0 @@ int 255 @@ int 255),
> con 7 (tuple_ @@ int 255 @@ int 255 @@ int 255 @@ int 255)]
Constants - it's a dynamically typed language so we wrap them in an ADT
which says what type they are.
> mkint i = con_ 0 @@ i
> mkstr s = con_ 1 @@ s
> mkchar c = con_ 2 @@ c
> mkbool b = con_ 3 @@ b
> mkcol c = con_ 4 @@ c
Every time we use a constant, we'll have to extract it from the wrapper.
If we're asking for the wrong type, quit with an error.
ANNOYANCE: Having to add type annotations because we only have Alternative
instances for (Expr -> e). Is there a way to make type inference know that
it must be an Expr because that's the only instance we define? i.e. can
we stop any other instances for (a -> e) being allowed somehow?
> getInt x = case_ x
> [con 0 (\ (x :: Expr) -> x), defaultcase (error_ "Not an Int")]
> getStr x = case_ x
> [con 1 (\ (x :: Expr) -> x), defaultcase (error_ "Not a String")]
> getChar x = case_ x
> [con 2 (\ (x :: Expr) -> x), defaultcase (error_ "Not a Char")]
> getBool x = case_ x
> [con 3 (\ (x :: Expr) -> x), defaultcase (error_ "Not a Bool")]
> getCol x = case_ x
> [con 4 (\ (x :: Expr) -> x), defaultcase (error_ "Not a Colour")]
Arithmetic operations
> primPlus x y = mkint $ op_ Plus (getInt x) (getInt y)
> primMinus x y = mkint $ op_ Minus (getInt x) (getInt y)
> primTimes x y = mkint $ op_ Times (getInt x) (getInt y)
> primDivide x y = mkint $ op_ Divide (getInt x) (getInt y)
Comparisons
> primEq x y = mkbool $ op_ OpEQ (getInt x) (getInt y)
> primLT x y = mkbool $ op_ OpLT (getInt x) (getInt y)
> primLE x y = mkbool $ op_ OpLE (getInt x) (getInt y)
> primGT x y = mkbool $ op_ OpGT (getInt x) (getInt y)
> primGE x y = mkbool $ op_ OpGE (getInt x) (getInt y)
Graphics primitive, just extracts the tuple of RGBA values for the colour
and calls the SDL_gfx primitive.
> drawLine :: Expr -> Expr -> Expr -> Expr -> Expr -> Expr -> Term
> drawLine surf x y ex ey col
> = case_ (rgba col)
> [tuple (\ r g b a ->
> foreign_ tyUnit "drawLine"
> [(surf, tyPtr),
> (x, tyInt), (y, tyInt),
> (ex, tyInt), (ey, tyInt),
> (r, tyInt), (g, tyInt),
> (b, tyInt), (a, tyInt)]) ]
We have integers and degrees, but sin and cos work with floats and radians.
Here's some primitives to do the necessary conversions.
> intToFloat x = foreign_ tyFloat "intToFloat" [(x, tyInt)]
> floatToInt x = foreign_ tyInt "floatToInt" [(x, tyFloat)]
> rad x = op_ FTimes (intToFloat x) (float (pi/180))
> esin x = foreign_ tyFloat "sin" [(rad x, tyFloat)]
> ecos x = foreign_ tyFloat "cos" [(rad x, tyFloat)]
Turtle functions.
In these, the arguments given by the user are in the Value ADT, so we'll
need to extract the integer.
To move forward, create a new state with the turtle at the new position,
and draw a line in the current colour between the two positions.
Return the new state.
> forward :: Expr -> Expr -> Term
> forward st dist = case_ st
> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr)
> (dir :: Expr) (col :: Expr) (pen :: Expr) ->
> let_ (op_ Plus x (floatToInt (op_ FTimes (intToFloat (getInt dist))
> (esin dir))))
> (\x' -> let_ (op_ Plus y (floatToInt
> (op_ FTimes (intToFloat (getInt dist))
> (ecos dir))))
> (\y' -> if_ pen (fn "drawLine" @@ surf @@ x @@ y
> @@ x' @@ y' @@ col)
> unit_ +>
> tuple_ @@ surf @@ x' @@ y' @@ dir @@ col @@ pen)))]
To turn right, create a new state with the turtle turned right.
Return the new state.
> right :: Expr -> Expr -> Term
> right st ang = case_ st
> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr)
> (dir :: Expr) (col :: Expr) (pen :: Expr) ->
> (tuple_ @@ surf @@ x @@ y @@ op_ Minus dir (getInt ang) @@ col @@ pen))]
To turn left, create a new state with the turtle turned left.
Return the new state.
> left :: Expr -> Expr -> Term
> left st ang = case_ st
> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr)
> (dir :: Expr) (col :: Expr) (pen :: Expr) ->
> (tuple_ @@ surf @@ x @@ y @@ op_ Plus dir (getInt ang) @@ col @@ pen))]
> colour :: Expr -> Expr -> Term
> colour st col' = case_ st
> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr)
> (dir :: Expr) (col :: Expr) (pen :: Expr) ->
> (tuple_ @@ surf @@ x @@ y @@ dir @@ getCol col' @@ pen))]
> pen :: Expr -> Expr -> Term
> pen st b = case_ st
> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr)
> (dir :: Expr) (col :: Expr) (pen :: Expr) ->
> (tuple_ @@ surf @@ x @@ y @@ dir @@ col @@ b))]
Repeat n times
> primRepeat :: Expr -> Expr -> Expr -> Term
> primRepeat st n e = case_ (getInt n)
> [constcase 0 st,
> defaultcase (let_ (e @@ st)
> (\st' -> fn "repeat" @@ st'
> @@ mkint (op_ Minus (getInt n) (int 1))
> @@ e))]
Turtle state consists of an SDL surface,
a position, a direction, a colour, and pen up/down:
(surf, x, y, dir, col, bool)
Note that we use primitives here, not the Value ADT, because we don't allow
the user direct access to this tuple.
> init_turtle surf = tuple_ @@ surf @@
> int 320 @@ int 240 @@ int 180 @@
> col_white @@ bool True
Export the primitives as Epic functions.
> sdlPrims = basic_defs ++
> [(name "initSDL", EpicFn initSDL),
> (name "pollEvent", EpicFn pollEvent),
> (name "flipBuffers", EpicFn flipBuffers),
> (name "drawLine", EpicFn drawLine),
> (name "forward", EpicFn forward),
> (name "left", EpicFn left),
> (name "right", EpicFn right),
> (name "colour", EpicFn colour),
> (name "pen", EpicFn pen),
> (name "repeat", EpicFn primRepeat),
> (name "pressAnyKey", EpicFn pressAnyKey)]