NetWalk

import Control.Concurrent.MVar
import Control.Monad
import Data.Array
import Data.List
import System.Random
import Haste
import Haste.DOM
import Haste.Events
import Haste.Graphics.Canvas

bnds = ((0,0), (9,8))
srcTop = (div x 2, div y 2) where (x, y) = snd bnds
srcBot = (x, y + 1) where (x, y) = srcTop
isSrc i = i == srcTop || i == srcBot

data Tile = Tile { xy :: (Int, Int), ways :: [(Int, Int)] } | Blank deriving Eq

data Game = Game { board   :: Array (Int, Int) Tile
                 , live    :: Array (Int, Int) Bool
                 , state   :: State
                 , rands   :: [Int]
                 , packets :: [((Int, Int), (Int, Int), Int)]
                 }

data State = Won | Play deriving Eq

gen [] board (r:rs) = scramble (scrambleSrc board r) rs
gen seeds board (r:r1:rs) = let
  (as, b@(Tile i@(x, y) w):bs) = splitAt (mod r $ length seeds) seeds
  exits = [(j, dj) | dj@(dx,dy) <- [(1,0),(0,-1),(-1,0),(0,1)],
    let j = (x+dx, y+dy), inRange bnds j, (board!j) == Blank,
    i /= srcTop || dx == 0]
  in if null exits then gen (as ++ bs) board (r1:rs) else let
    (j, dj@(dx,dy)) = exits!!(r1 `mod` length exits)
    augT = Tile i (dj:w)
    newT = Tile j [(-dx, -dy)]
    in gen ((augT:newT:as) ++ bs) (board // [(i, augT), (j, newT)]) rs

scramble board rs = let
  f i r | isSrc i   = (i, board!i)
        | otherwise = (i, iterate rot (board!i) !! (r `mod` 4))
  in (array bnds $ zipWith f (range bnds) rs, drop (rangeSize bnds) rs)

scrambleSrc board r = iterate srcRot board !! (r `mod` 4)

followLive game = f [srcBot] (listArray bnds $ repeat False) 0 where
  f [] acc n =
    game { live = acc, state = if n == rangeSize bnds then Won else Play }
  f (i@(x, y):is) acc n
    | acc!i = f is acc n
    | otherwise = f (is ++ js) (acc // [(i, True)]) (n + 1)
    where
      board = Main.board game
      js = [j | (dx,dy) <- ways (board!i), let j = (x+dx, y+dy), inRange bnds j,
        (-dx, -dy) `elem` ways (board!j), not (acc!j)]

rot (Tile i w) = Tile i $ map (\(x, y) -> if y /= 0 then (-y, 0) else (0, x)) w
rot Blank      = Blank

srcRot board = let
  Tile _ w = rot $ Tile (0, 0) $ delete (0, -1) (ways $ board!srcBot) ++
    filter (== (0, -1)) (ways $ board!srcTop)
  in board // [(srcTop, Tile srcTop $ (0,  1) : filter (== (0, -1)) w),
               (srcBot, Tile srcBot $ (0, -1) : filter (/= (0, -1)) w)]

newPackets board i = [(i, dj, 0) | dj <- ways (board!i)]

initGame rs = let
  top = Tile srcTop [(0, 1)]
  bot = Tile srcBot [(0, -1)]
  (board, rs1) = gen [top, bot] (listArray bnds (repeat Blank) //
    [(srcTop, top), (srcBot, bot)]) rs
  in followLive $ Game board undefined Play rs1 []

-- We only handle the oldest event. We could simplify evq.
handle game@(Game board live state _ packets) (Mo (mx, my):_)
  | not $ inRange bnds i = (game, False)
  | state == Play        =
   (followLive $ game { board =
     if isSrc i then srcRot board else board // [(i, rot $ board!i)] }, True)
  | otherwise            =
   (game { packets = packets ++ newPackets board i }, False)
  where i = (mx `div` 32, my `div` 32)
handle game (Ke 113:_) = (initGame (rands game), True)
handle game _ = (game, False)

lineB :: Int -> Int -> Int -> Int -> Shape ()
lineB x y dx dy = line (0.5 + fromIntegral x, 0.5 + fromIntegral y) (0.5 + fromIntegral (x + dx), 0.5 + fromIntegral (y + dy))

rectB c x y dx dy = do
  color c $ fill $ rect (fromIntegral x, fromIntegral y) (fromIntegral (x + dx), fromIntegral (y + dy))
  color (RGB 0 0 0) $ stroke $ rect (fromIntegral x - 0.5, fromIntegral y - 0.5) (fromIntegral (x + dx) + 0.5, fromIntegral (y + dy) + 0.5)

drawB p (x, y) = draw p (fromIntegral x, fromIntegral y)

paint pic = do
  can <- createCanvas 32 32
  render can pic
  return can

data Event = Mo (Int, Int) | Ke Int

main = withElems ["canvas"] $ \[canvasE] -> do
  evq <- newMVar [Ke 113]
  void $ canvasE `onEvent` MouseDown $
    \m -> do
       modifyMVar_ evq $ pure . (++ [Mo $ mouseCoords m])
       preventDefault
  void $ documentBody `onEvent` KeyDown $
    \k -> modifyMVar_ evq $ pure . (++ [Ke $ keyCode k])
  Just canvas <- fromElem canvasE
  [grid, buf] <- let (x, y) = snd bnds in
    replicateM 2 $ createCanvas ((x+1)*32) ((y+1)*32)
  liveEnd <- paint $ rectB (RGB 255 255 0) 9 9 14 14
  deadEnd <- paint $ rectB (RGB 191 191 191) 10 10 13 13
  packet  <- paint $ color (RGB 0 0 0) (fill $ circle (16, 16) 5) >>
                     color (RGB 255 255 255) (fill $ circle (16, 16) 4)
  render grid $ color (RGB 192 192 192) $ sequence_
    $ [stroke $ lineB (x*32) 0 0 288 | x <- [1..9]]
    ++ [stroke $ lineB 0 (y*32) 320 0 | y <- [1..8]]
  sg <- getStdGen
  let
    colWire False = color (RGB 255 127 127)
    colWire  True = color (RGB 0 191 0)
    endPic False = deadEnd
    endPic True = liveEnd
    drawTile _ Blank = return ()
    drawTile live (Tile (x,y) w) = let (ox,oy) = (x*32, y*32) in do
      sequence_ [renderOnTop buf $ colWire live $ stroke $
        lineB (ox + 16) (oy + 16) (16 * dx) (16 * dy) | (dx,dy) <- w]
      when (length w == 1) $ renderOnTop buf $ drawB (endPic live) (ox, oy)
    loop game = handle game <$> swapMVar evq [] >>=
      \(game1@(Game board live state rs packets), isDirty) -> let
        adv packet@((x, y), (dx, dy), t) =
          if t < 16 - 1 then [((x, y), (dx, dy), t + 1)] else let
            (x1, y1) = (x + dx, y + dy)
            in [((x1, y1), dj, 0) | dj <- ways $ board!(x1, y1), dj /= (-dx, -dy)]
        in do
          when isDirty $ do
            render buf $ draw grid (0, 0)
            sequence_ [drawTile (live!i) (board!i) | i <- range bnds]
            renderOnTop buf $ let (x,y) = srcTop in
              rectB (RGB 95 95 191) (x * 32 + 9) (y * 32 + 9) 16 48
          render canvas $ draw buf (0, 0)
          game2 <- if state == Won then do
            sequence_ [renderOnTop canvas $ drawB packet
              (32*x + 2*t*dx, 32*y + 2*t*dy) | ((x,y), (dx,dy), t) <- packets]
            return $ game1 { packets = if null packets then
              newPackets board srcBot else concatMap adv packets }
          else return game1
          void $ setTimer (Once 20) $ loop game2
    in loop $ Game undefined undefined undefined (randomRs (0, 2^20 :: Int) sg) undefined