{ gTPS = 90

      { gTPS = 124

   move = const Nothing
   lock = const True

   move = const Free

maze :: Automata () Hex
maze = Automata f

maze :: Automaton () Hex
maze = Automaton f

   --Demo Universe

   -- Demo universe

   generate v rs = foldr ($) (verse 11)
      $ set Robot { name = "@" , ops = mempty } 0
      : set Robot { name = "t0" , ops = Move <$> cycle [U,N,L] } (shift v 1 U 0)
      : set Robot { name = "t1" , ops = Move <$> cycle [N,L,U] } (shift v 2 U 0)
      : set Robot { name = "t2" , ops = Move <$> cycle [L,U,N] } (shift v 1 U $ shift v 1 H 0)
      : set Robot { name = "i" , ops = Move <$> repeat N } (shift v 8 I 0)
      : set Robot { name = "n" , ops = Move <$> repeat I } (shift v 2 I 0)
      : set Robot { name = "x" , ops = mempty } (shift v 7 M 0)
      : set Robot { name = "L0" , ops = Move <$> repeat L } (shift v 17 H 0)
      : set Robot { name = "L1" , ops = Move <$> repeat L } (shift v 18 H 0)
      : set Robot { name = "L2" , ops = Move <$> repeat L } (shift v 19 H 0)

   generate v rs = foldr ($) v
      $ set Robot { name = "@" , go = mempty } 0
      : set Robot { name = "t0" , go = Move <$> cycle [U,N,L] } (shift v 1 U 0)
      : set Robot { name = "t1" , go = Move <$> cycle [N,L,U] } (shift v 2 U 0)
      : set Robot { name = "t2" , go = Move <$> cycle [L,U,N] } (shift v 1 U $ shift v 1 H 0)
      : set Robot { name = "i" , go = Move <$> repeat N } (shift v 8 I 0)
      : set Robot { name = "n" , go = Move <$> repeat I } (shift v 2 I 0)
      : set Robot { name = "x" , go = mempty } (shift v 7 M 0)
      : set Robot { name = "L0" , go = Move <$> repeat L } (shift v 17 H 0)
      : set Robot { name = "L1" , go = Move <$> repeat L } (shift v 18 H 0)
      : set Robot { name = "L2" , go = Move <$> repeat L } (shift v 19 H 0)

   units = replicate 4 Wall <> replicate 6 Box { pushed = Nothing } <> replicate 6 Ball { pushed = Nothing }

   units = replicate 4 Wall <> replicate 6 Box <> replicate 6 Ball

data Unit = None | Wall | Box { pushed :: Maybe Dir } | Ball { pushed :: Maybe Dir } | Robot { name :: String , ops :: [Op] }
   deriving Show
data Op = Lock | Move Dir

data Unit = None | Wall | Box | Ball | Robot { name :: String , go :: [Move] }

      | Robot {} <- a , Move d : _ <- ops a = Just d
      | Box {} <- a = pushed a
      | Ball {} <- a = pushed a
      | otherwise = Nothing
   lock a
      | Wall <- a = True
      | Robot {} <- a = True
      | Box {} <- a = True
      | Ball {} <- a = True
      | otherwise = False

      | Robot {} <- a , m : _ <- go a = m
      | Wall <- a = Lock
      | otherwise = None

      | Just 'H' <- k = z { center = shift v 1 H $ center s } | Just 'J' <- k = z { center = shift v 1 N $ center s } | Just 'K' <- k = z { center = shift v 1 I $ center s }

      | Just 'H' <- k = z { center = shift v 1 H $ center s }
      | Just 'J' <- k = z { center = shift v 1 N $ center s }
      | Just 'K' <- k = z { center = shift v 1 I $ center s }

-- Unit Automata

-- Unit Automaton

demo :: Automata State Unit
demo = Automata f

demo :: Automaton State Unit
demo = Automaton f

      | Box {}   <- u                       = u { pushed = push }
      | Ball {}  <- u , Nothing <- pushed u = u { pushed = push }
      | Ball {}  <- u , Just _ <- push      = u { pushed = push }
      | Ball {}  <- u                       = u { pushed = Nothing }

      push :: Maybe Dir
         | [d] <- Map.keys $ Map.filterWithKey (\k w -> move w == Just (opposite k)) ns = Just $ opposite d
         | otherwise = Nothing

newtype Automata state a = Automata (Atom a => state -> Map Dir a -> a -> a)

newtype Automaton state a = Automaton (Atom a => state -> Map Dir a -> a -> a)

instance Semigroup (Automata state a) where
   Automata g <> Automata f = Automata (\s ns -> g s ns . f s ns)

instance Semigroup (Automaton state a) where
   Automaton g <> Automaton f = Automaton (\s ns -> g s ns . f s ns)

instance Monoid (Automata state a) where
   mempty = Automata (\_ _ -> id)

instance Monoid (Automaton state a) where
   mempty = Automaton (\_ _ -> id)

sim :: Atom a => Automata state a -> state -> Verse a -> Verse a
sim (Automata f) = step . f

sim :: Atom a => Automaton state a -> state -> Verse a -> Verse a
sim (Automaton f) = step . f

module Nove.Utils where
import Data.List.NonEmpty
-- | History
data History a = History { past :: NonEmpty a , future :: [a] }
-- step backwards in time
before :: History a -> History a
before (History (m :| p : ps) f) = History (p :| ps) (m:f)
before h = h
-- step forwards in time
after :: History a -> History a
after (History p (m:f)) = History (m <| p) f
after h = h
-- go to present
ultimate :: History a -> History a
ultimate h@(History _ []) = h
ultimate h = ultimate $ after h
-- get current
moment :: History a -> a
moment (History (m :| _) _) = m
-- record moment
record :: a -> History a -> History a
record m (History p f) = History (m <| p) f

data Dir = I | L | M | N | H | U
   deriving ( Eq, Ord, Enum, Bounded, Show )
data Move = Free | Lock | Move Dir

   move :: a -> Maybe Dir  -- wants to move
   lock :: a -> Bool

   move :: a -> Move  -- wants to move

data Dir = I | L | M | N | H | U
   deriving ( Eq, Ord, Enum, Bounded, Show )

import Zero ( (#) )

import Data.IntMap as IntMap ( IntMap, (!), foldrWithKey, fromDistinctAscList )
import Data.Map as Map ( Map, fromList, filterWithKey, elems )

import Data.IntMap as IntMap ( IntMap, (!), mapWithKey, foldrWithKey, mapWithKey, fromDistinctAscList )
import Data.Map as Map ( Map )

data Memo a = Memo
   { mauto :: a
   , mdest :: [Int]
   , mfree :: Bool
   }

step f v = v'

step f v = v { nodes = nodes' }

   v' :: Verse a
   v' = v { nodes = nodes' }

   ms :: IntMap (Maybe Dir)
   nodes' :: IntMap a

   (memo',nodes') = bimap intmap intmap $ IntMap.foldrWithKey go mempty $ nodes v
      where
      intmap :: [v] -> IntMap v
      intmap = IntMap.fromDistinctAscList . zip [0..]
   -- simulate atom and apply f
   go :: Int -> a -> ([Memo a], [a]) -> ([Memo a], [a])
   go i a (ms,as) = (m : ms , a' : as)
      where
      -- memoization for this node
      m :: Memo a
      m = Memo
         { mauto = w
         , mdest = dest
         , mfree = free
         }
      w :: a
      w = f (adjacents v i) a
      -- new atom
      a' :: a
         | free , [n] <- ins                        = n  -- move in
         | d : _ <- dest , mfree (memo' IntMap.! d) = void  -- move out
         | otherwise                                = w
      -- move in
      ins :: [a]
      ins = Map.elems $ Map.filterWithKey (\dir c -> move c == Just (opposite dir)) ns
      ns :: Map Dir a
      ns = Map.fromList $ (,) <*> (node v . flip (shift v 1) i) <$> total
      -- chain of destinations
      dest :: [Int]
         | Just dir <- move w , d <- shift v 1 dir i = d : mdest (memo' IntMap.! d)
         | otherwise = []

   (ms,nodes') = bimap intmap intmap $ foldrWithKey go mempty $ nodes v
   -- ms: future memory of movement intent

      -- is this node free?
      free :: Bool
         | lock w , null dest             = False
         | length ins > 1                 = False  -- stall
         | Just (_,d) <- floyd $ i : dest = False  -- i == d  -- floyd $ cycle [0,1] => Just (2,1) , so (i /= d) when reciprocal
         | otherwise                      = all (mfree . (memo' IntMap.!)) $ take 1 dest  -- dest is free

   intmap :: [v] -> IntMap v
   intmap = fromDistinctAscList . zip [0..]

   -- come = catMaybes $ f <$> total
   --    where

   go :: Int -> a -> ([Maybe Dir], [a]) -> ([Maybe Dir], [a])
   go i a = bimap id (f (adjacents v i) a :)

   --    f dir
   --       | n <- node v $ shift v 1 dir i , Just d <- move n , dir == opposite d = Just n
   --       | otherwise = Nothing

      , Nove.Utils

      , Nove.Chron