module IRL where

import Array
import List
import Monad
import GraphicsUtils
-- import qualified GraphicsWindows as GW (getEvent)

-- ----------------------------------------------------------------------
--
-- Data types
--
-- ----------------------------------------------------------------------

-- The Robot State
data RobotState 
  = RobotState 
        { position  :: Position
        , facing    :: Direction
        , pen       :: Bool 
        , color     :: Color
        , treasure  :: [Position]
        , pocket    :: Int
        }
     deriving Show

-- The Robot type, and its Monad instance

newtype Robot a 
  = Robot (RobotState -> Grid -> Window -> IO (RobotState, a))

instance Monad Robot where
  return a 
    = Robot (\s _ _ -> return (s,a))
  Robot sf0 >>= f
    = Robot $ \s0 g w -> do
                (s1,a1) <- sf0 s0 g w
                let Robot sf1 = f a1
                sf1 s1 g w

-- Positions
type Position = (Int,Int)

-- Directions, and two auxiliary functions on them
data Direction = North | East | South | West
     deriving (Eq,Show,Enum)

right,left :: Direction -> Direction
right d = toEnum (succ (fromEnum d) `mod` 4)
left  d = toEnum (pred (fromEnum d) `mod` 4)

-- The world
type Grid = Array Position [Direction]


-- ----------------------------------------------------------------------
--
-- Simple Functions manipulating the state
--
-- ----------------------------------------------------------------------


updateState :: (RobotState -> RobotState) -> Robot ()
updateState u = Robot (\s _ _ -> return (u s, ()))

queryState  :: (RobotState -> a) -> Robot a
queryState  q = Robot (\s _ _ -> return (s, q s))

turnLeft  :: Robot ()
turnLeft = updateState (\s -> s {facing = left (facing s)})

turnRight :: Robot ()
turnRight = updateState (\s -> s {facing = right (facing s)})

turnTo    :: Direction -> Robot ()
turnTo d = updateState (\s -> s {facing = d})

direction :: Robot Direction
direction = queryState facing

penUp :: Robot ()
penUp = updateState (\s -> s {pen = False})

penDown :: Robot ()
penDown = updateState (\s -> s {pen = True})

setPenColor  :: Color -> Robot ()
setPenColor c = updateState (\s -> s {color = c})

onCoin    :: Robot Bool
onCoin = queryState (\s -> position s `elem` treasure s)

coins     :: Robot Int
coins  = queryState pocket

blocked   :: Robot Bool
blocked = Robot $ \s g _ -> 
            return (s, facing s `notElem` (g ! position s))


-- ----------------------------------------------------------------------
--
-- The lifted boolean operations
--
-- ----------------------------------------------------------------------

cond      :: Robot Bool -> Robot a -> Robot a -> Robot a
cond p c a = do pred <- p
                if pred then c else a

cond_ p c = cond p c (return ())

while     :: Robot Bool -> Robot () -> Robot ()
while p b = cond_ p (b >> while p b)

(||*)     :: Robot Bool -> Robot Bool -> Robot Bool
b1 ||* b2 = do p <- b1
               if p then return True
                    else b2

(&&*)     :: Robot Bool -> Robot Bool -> Robot Bool
b1 &&* b2 = do p <- b1
               if p then b2
                    else return False

isnt :: Robot Bool -> Robot Bool
isnt = liftM not

(>*),(<*) :: Robot Int -> Robot Int -> Robot Bool
(>*) = liftM2 (>)
(<*) = liftM2 (<)


-- ----------------------------------------------------------------------
--
-- Picking up/dropping coins
--
-- ----------------------------------------------------------------------

pickCoin  :: Robot ()
pickCoin = cond_ onCoin
             (Robot $ \s _ w -> 
                do eraseCoin w (position s)
                   return (s {treasure = position s `delete` treasure s, 
                              pocket   = pocket s + 1}, ()              )
             )

dropCoin  :: Robot ()
dropCoin = cond_ (coins >* return 0)
             (Robot $ \s _ w -> 
                do drawCoin w (position s)
                   return (s {treasure = position s : treasure s,
                              pocket   = pocket s - 1}, ()       )
             )

-- ----------------------------------------------------------------------
--
-- Moving the Robot
--
-- ----------------------------------------------------------------------

move      :: Robot ()
move = cond_ (isnt blocked)
         (Robot $ \s _ w -> do
            let newPos = movePos (position s) (facing s)
            graphicsMove w s newPos
            return (s {position = newPos}, ())
         )

movePos :: Position -> Direction -> Position
movePos (x,y) d
  = case d of
      North -> (x,y+1)
      South -> (x,y-1)
      East  -> (x+1,y)
      West  -> (x-1,y)


-- ----------------------------------------------------------------------
--
-- Graphics stuff
--
-- ----------------------------------------------------------------------

d :: Int
d = 5       -- half the distance between grid points

wc, cc :: Color
wc = Green  -- color of walls
cc = Yellow -- color of coins

xWin, yWin :: Int
xWin = 600
yWin = 500

drawLine :: Window -> Color -> Point -> Point -> IO ()
drawLine w c p1 p2
  = drawInWindow w (withColor c (line p1 p2))

drawGrid :: Window -> Grid -> IO ()
drawGrid w wld
  = let (low@(xMin,yMin),hi@(xMax,yMax)) = bounds wld
        (x1,y1) = trans low
        (x2,y2) = trans hi
    in do drawLine w wc (x1-d,y1+d) (x1-d,y2-d)
          drawLine w wc (x1-d,y1+d) (x2+d,y1+d)
          sequence_ [drawPos w (trans (x,y)) (wld ! (x,y)) 
                    | x <- [xMin..xMax], y <- [yMin..yMax]]

drawPos :: Window -> Point -> [Direction] -> IO ()
drawPos w (x,y) ds
  = do if North `notElem` ds
          then drawLine w wc (x-d,y-d) (x+d,y-d)
          else return ()
       if East `notElem` ds
          then drawLine w wc (x+d,y-d) (x+d,y+d)
          else return ()

drawCoins :: Window -> RobotState -> IO ()
drawCoins w s = mapM_ (drawCoin w) (treasure s)

drawCoin :: Window -> Position -> IO ()
drawCoin w p = let (x,y) = trans p
               in drawInWindow w 
                   (withColor cc (ellipse (x-5,y-1) (x-1,y-5)))

eraseCoin :: Window -> Position -> IO ()
eraseCoin w p = let (x,y) = trans p
                in drawInWindow w 
                     (withColor Black (ellipse (x-5,y-1) (x-1,y-5)))

graphicsMove :: Window -> RobotState -> Position -> IO ()
graphicsMove w s newPos
  = do if pen s then drawLine w (color s) (trans (position s)) 
                                          (trans newPos)
                else return ()
       getWindowTick w

trans :: Position -> Point
trans (x,y) = (div xWin 2 + 2*d*x, div yWin 2 - 2*d*y)

-- ----------------------------------------------------------------------
--
-- The main function
--
-- ----------------------------------------------------------------------

isSpaceKey :: Key-> Bool
isSpaceKey k = isCharKey k && (keyToChar k == ' ')


spaceWait :: Window -> IO ()
spaceWait w
  = do k <- getKey w
       if isSpaceKey k then return ()
                 else spaceWait w

spaceClose :: Window -> IO ()
spaceClose w
  = do k <- getKey w
       if isSpaceKey k then closeWindow w
                 else spaceClose w

runRobot :: Robot () -> RobotState -> Grid -> IO ()
runRobot (Robot sf) s g
  = runGraphics $
    do w <- openWindowEx "Robot World" (Just (0,0)) 
              (xWin,yWin) Unbuffered (Just 10)
       drawGrid w g
       drawCoins w s
       spaceWait w
       (z, _) <- sf s g w
       spaceClose w
       printStats z

printStats :: RobotState -> IO ()
printStats st
  = let s= pocket st; m= length (treasure st)
    in if s+m /= 0 then 
          do putStr ("You collected "++ show s++ " and missed "++ show m)
             putStrLn (", for a success rate of "++ 
                       show ((s*100) `div` (s+m))++ "%")
       else putStrLn "There was nothing to collect."