{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeSynonymInstances  #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Path.Turtle
-- Copyright   :  (c) 2011 Michael Sloan
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Michael Sloan <mgsloan at gmail>,  Deepak Jois <deepak.jois@gmail.com>
-- Authors     :  Michael Sloan <mgsloan at gmail>, Deepak Jois <deepak.jois@gmail.com>
--
-- A module consisting of core types and functions to represent and operate on
-- a \"turtle\".
--
-- More info about turtle graphics:
-- <http://en.wikipedia.org/wiki/Turtle_graphics>
--
-----------------------------------------------------------------------------

module Diagrams.TwoD.Path.Turtle.Internal
  (
    -- * Turtle data types and accessors
    TurtleState(..), TurtlePath(..), PenStyle(..)

    -- * Motion commands
  , forward, backward, left, right

    -- * Pen style commands
  , setPenColor, setPenColour, setPenWidth

    -- * State setters
  , startTurtle, setHeading, towards
  , setPenPos

    -- * Drawing control
  , penUp, penDown, penHop, closeCurrent

    -- * Debugging
  , traceTurtle

    -- * Diagram related
  , getTurtleDiagram
  , getTurtlePath
  ) where

import           Debug.Trace      (traceShow)

import           Diagrams.Prelude

-- | Style attributes associated with the turtle pen
data PenStyle = PenStyle
  { penWidth :: Double         -- ^ Width of pen. Default is 1.0
  , penColor :: Colour Double  -- ^ Color of pen. Default is @black@
  } deriving Show

-- | Turtle path type that captures a list of paths and the style attributes
-- associated with them
data TurtlePath = TurtlePath
  { penStyle    :: PenStyle            -- ^ Style
  , turtleTrail :: Located (Trail R2)  -- ^ Path
  } deriving Show

-- | Core turtle data type. A turtle needs to keep track of its current
-- position, like its position, heading etc., and all the paths that it has
-- traversed so far.
--
-- We need to record a new path, everytime an attribute like style, pen position
-- etc changes, so that we can separately track styles for each portion of the
-- eventual path that the turtle took.
data TurtleState = TurtleState
  { -- | State of the pen. @False@ means that turtle movements will not draw
    -- anything
    isPenDown    :: Bool
     -- | Current position. This is updated everytime the turtle moves
  , penPos       :: P2
     -- | Orientation of the turtle in 2D space, given in degrees
  , heading      :: Deg
     -- | Path traversed by the turtle so far, without any style or pen
     -- attributes changing
  , currTrail    :: Located (Trail' Line R2)
     -- | Current style of the pen
  , currPenStyle :: PenStyle
     -- | List of paths along with style information, traversed by the turtle
     -- previously
  , paths        :: [TurtlePath]
  } deriving Show

-- | Default pen style, with @penWidth@ set to 1.0 and @penColor@ set to black
defaultPenStyle :: PenStyle
defaultPenStyle = PenStyle 1.0 black

-- | The initial state of turtle. The turtle is located at the origin, at an
-- orientation of 0 degrees with its pen position down. The pen style is
-- @defaultPenStyle@.
startTurtle :: TurtleState
startTurtle = TurtleState True origin 0 (mempty `at` origin) defaultPenStyle []

-- | Draw a segment along the turtle’s path and update its position. If the pen
-- is up, only the position is updated.
moveTurtle :: Segment Closed R2 -- ^ Segment representing the path to travel
           -> TurtleState       -- ^ Turtle to move
           -> TurtleState       -- ^ Resulting turtle
moveTurtle s t@(TurtleState pd pos h tr _ _) =
 if pd
   -- Add segment to current trail and update position
   then t { currTrail = newTrail
          , penPos = newPenPos
          }
   -- Update position only
   else t { penPos = newPenPos }
 where
   -- Rotate segment by orientation before adding to trail
   rotatedSeg  =  rotate h s
   newTrail    =  mapLoc (<> fromSegments [rotatedSeg]) tr
   -- Calculate the new position along the segment
   newPenPos   =  pos .+^ segOffset rotatedSeg

-- | Move the turtle forward by @x@ units
forward :: Double       -- ^ Distance to move
        -> TurtleState  -- ^ Turtle to move
        -> TurtleState  -- ^ Resulting turtle
forward x = moveTurtle (straight $ r2 (x,0))

-- | Move the turtle backward by @x@ units
backward :: Double       -- ^ Distance to move
         -> TurtleState  -- ^ Turtle to move
         -> TurtleState  -- ^ Resulting turtle
backward x = moveTurtle (straight $ r2 (negate x, 0))

-- | Turn the turtle by applying the given function to its current orientation
-- (in degrees)
turnTurtle :: (Deg -> Deg)   -- ^ Transformation to apply on current orientation
           -> TurtleState    -- ^ Turtle to turn
           -> TurtleState    -- ^ Resulting turtle
turnTurtle f t@(TurtleState _ _ h _ _ _) = t { heading = f h  }

-- | Turn the turtle anti-clockwise (left)
left :: Double       -- ^ Degree of turn
     -> TurtleState  -- ^ Turtle to turn
     -> TurtleState  -- ^ Resulting turtle
left d = turnTurtle (+ (Deg d))

-- | Turn the turtle clockwise (right)
right :: Double       -- ^ Degree of turn
      -> TurtleState  -- ^ Turtle to turn
      -> TurtleState  -- ^ Resulting turtle
right d = turnTurtle (subtract (Deg d))

-- | Turn the turtle to the given orientation, in degrees
setHeading :: Double       -- ^ Degree of orientation
           -> TurtleState  -- ^ Turtle to orient
           -> TurtleState  -- ^ Resulting turtle
setHeading d = turnTurtle (const $ Deg d)

-- | Sets the turtle orientation towards a given location.
towards :: P2           -- ^ Point to orient turtle towards
        -> TurtleState  -- ^ Turtle to orient
        -> TurtleState  -- ^ Resulting turtle
towards p  = setHeading =<< (360 *) . (/ tau) . uncurry atan2 . unr2 . (p .-.) . penPos

-- | Puts the turtle pen in “Up” mode. Turtle movements will not draw anything
--
-- Does nothing if the pen was already up. Otherwise, it creates a turtle with
-- the current trail added to @paths@.
penUp :: TurtleState  -- ^ Turtle to modify
      -> TurtleState  -- ^ Resulting turtle
penUp t
 | isPenDown t = t # makeNewTrail #  \t' -> t' { isPenDown = False }
 | otherwise   = t

-- | Puts the turtle pen in “Down” mode. Turtle movements will cause drawing to
-- happen
--
-- Does nothing if the pen was already down. Otherwise, starts a new trail
-- starting at the current position.
penDown :: TurtleState  -- ^ Turtle to modify
        -> TurtleState  -- ^ Resulting turtle
penDown t
  | isPenDown t = t
  | otherwise   = t # makeNewTrail #  \t' -> t' { isPenDown = True }

-- Start a new trail at current position
penHop :: TurtleState
       -> TurtleState
penHop t = t # makeNewTrail

-- Closes the current path, to the starting position of the current
-- trail. Has no effect when the pen is up.
closeCurrent :: TurtleState
             -> TurtleState
closeCurrent t
  | isPenDown t = t # closeTTrail
  | otherwise   = t
 where startPos = loc . currTrail $ t
       closeTTrail t'  = t' { penPos    = startPos
                            , currTrail = mempty `at` startPos
                            , paths     = addTrailToPath t'
                                            (mapLoc (wrapTrail . closeLine) $ currTrail t)
                            }

-- | Set the turtle X/Y position.
--
-- If pen is down and the current trail is non-empty, this will also add the
-- current trail to the @paths@ field.
setPenPos :: P2           -- ^ Position to place true
          -> TurtleState  -- ^ Turtle to position
          -> TurtleState  -- ^ Resulting turtle
setPenPos newPos t = t {penPos = newPos } # makeNewTrail

-- | Set a new pen width for turtle.
--
-- If pen is down, this adds the current trail to @paths@ and starts a new empty
-- trail.
setPenWidth :: Double       -- ^ Width of Pen
            -> TurtleState  -- ^ Turtle to change
            -> TurtleState  -- ^ Resulting Turtle
setPenWidth w = modifyCurrStyle (\s -> s { penWidth = w })
-- | Set a new pen color for turtle.
--
-- If pen is down, this adds the current trail to @paths@ and starts a new empty
-- trail.
setPenColour :: Colour Double  -- ^ Width of Pen
             -> TurtleState    -- ^ Turtle to change
             -> TurtleState    -- ^ Resulting Turtle
setPenColour c = modifyCurrStyle (\s -> s { penColor = c })

-- | alias of @setPenColour@
setPenColor :: Colour Double  -- ^ Width of Pen
            -> TurtleState    -- ^ Turtle to change
            -> TurtleState    -- ^ Resulting Turtle
setPenColor = setPenColour

-- | Creates a diagram from a turtle
--
-- Applies the styles to each trails in @paths@ separately and combines them
-- into a single diagram
getTurtleDiagram :: (Renderable (Path R2) b)
                 => TurtleState
                 -> Diagram b R2
getTurtleDiagram t =
  mconcat .
  map turtlePathToStroke .
  paths $ t # penUp -- Do a penUp to add @currTrail@ to @paths@

-- | Creates a path from a turtle, ignoring the styles.
getTurtlePath :: TurtleState -> Path R2
getTurtlePath = mconcat . map turtlePathToTrailLike . paths . penUp

-- * Helper functions

-- Makes a "TurtlePath" from a "Turtle"’s @currTrail@ field
makeTurtlePath :: TurtleState
               -> Located (Trail R2)
               -> TurtlePath
makeTurtlePath t tr = TurtlePath (currPenStyle t) tr

-- Returns a list of paths, with current trail added to a "Turtle"’s @paths@ field
addTrailToPath :: TurtleState
               -> Located (Trail R2)
               -> [TurtlePath]
addTrailToPath t tr
  | isTrailEmpty (unLoc tr) = paths t
  | otherwise               = makeTurtlePath t tr : paths t

-- Starts a new trail and adds current trail to path
makeNewTrail :: TurtleState
             -> TurtleState
makeNewTrail t = t { currTrail = mempty `at` penPos t
                   , paths = addTrailToPath t (mapLoc wrapTrail (currTrail t))
                   }

-- Modifies the current style after starting a new trail
modifyCurrStyle :: (PenStyle -> PenStyle)
                -> TurtleState
                -> TurtleState
modifyCurrStyle f t =  t # makeNewTrail # \t' -> t' { currPenStyle = (f . currPenStyle) t' }

-- Creates any TrailLike from a TurtlePath.
turtlePathToTrailLike :: (V t ~ R2, TrailLike t) => TurtlePath -> t
turtlePathToTrailLike (TurtlePath _ t) = trailLike t

-- Creates a diagram from a TurtlePath using the provided styles
turtlePathToStroke :: (Renderable (Path R2) b) => TurtlePath
                   -> Diagram b R2
turtlePathToStroke t@(TurtlePath (PenStyle lineWidth_  lineColor_) _) = d
 where d = lc lineColor_ .
           lw lineWidth_ .
           stroke $ turtlePathToTrailLike t

-- | Prints out turtle representation and returns it. Use for debugging
traceTurtle :: TurtleState
            -> TurtleState
traceTurtle t = traceShow t t