turtle.hs

{-# LANGUAGE GADTs, LambdaCase #-}

-- I haven't compiled this and wrote it before any coffee
-- so please don't laugh at me if it doesn't compile lol

module Turtle ( Turtle, left, right, forward, backward) where

import Graphics.Gloss
import Control.Monad.State
import Control.Lens
import Data.Fixed (mod')

type Degree = Double
type Length = Double

data Turtle a where
  -- These primitives give us a Monad instance, so we can
  -- use do-notation and the like.
  Pure :: a -> Turtle a
  Bind :: Turtle a -> (a -> Turtle b) -> Turtle b

  -- These ones are more related to our actual business logic.
  -- Part of the challenge and joy of building GADT DSLs is
  -- picking only the set of primitives you need, and using
  -- those primitives to build up more complex features.
  Rotate :: Degree -> Turtle ()
  Draw   :: Length -> Turtle ()

-- * Boilerplate for Functor and Monad.

instance Functor Turtle where
  fmap = liftA -- piggyback off the Applicative instance

instance Applicative Turtle where
  pure  = Pure
  (<*>) = ap -- piggyback off of the Monad instance

instance Monad Turtle where
  (>>=) = Bind

-- * Actions bound as primitives.

rotate :: Degree -> Turtle ()
rotate = Rotate

draw :: Degree -> Turtle ()
draw = Draw

-- * Combinator actions derived from primitives.

left, right :: Turtle ()
left  = rotate (negate 90)
right = rotate 90

box :: Length -> Turtle ()
box len = replicateM_ 4 $ do
  draw len
  right

-- Here's a sample interpreter, compiling to Gloss's Picture type
-- with a state variable to keep track of the turtle's position and
-- facing. Note that we don't track that statefulness in the Turtle
-- DSL itself: that's a feature, not a bug, since it gives us more
-- flexibility in terms of what we interpret to.

data Heading = H { _position :: Point
                 , _facing   :: Degree
                 , _picture  :: Picture
                 }

makeLenses ''Heading

initial :: Heading
initial = H (0, 0) 0 mempty

-- Note that this interpreter "shells out" its pure and bind operations
-- to the State monad itself.
compile :: Turtle a -> State Heading a
compile = \case
  Pure x   -> pure x
  Bind x f -> compile x >>= compile . f

  Draw len -> do
    oldPos@(oldX, oldY) <- use position
    (offX, offY) <- (,) <$> uses facing sin <*> uses facing cos
    let newPos = (oldX + offX, oldY + offY)
    position .= newPos
    picture <>= Line [oldPos, newPos]

  Rotate ang -> do
    old <- use facing
    facing .= mod' 360.0 (old + ang)