module Test where
import System.Exit
main :: IO ()
main = exitWith ExitSuccess

module Main where
import Nove
import Nove.Verse
import Zero.Queue
import Data.Bifunctor ( bimap )
import Data.List ( find, intersperse )
import Data.Foldable ( toList )
import Data.Map as Map ( Map, elems, filterWithKey )
import Control.Monad ( join )
import Terminal.Game
import System.Random ( randoms, initStdGen )
-- Game IO loop
main :: IO ()
main = do
   (rs,r) <- splitAt (length units) . randoms <$> initStdGen
   playGame $ Game {
      gTPS = 10 ,
      gInitState = (State { rand = r , center = 0 , keys = (Nothing,mempty) } , generate (verse 11) rs) ,
      gLogicFunction = logic ,
      gDrawFunction = draw }
   where
   generate :: Verse Unit -> [Int] -> Verse Unit
   generate v rs = foldr ($) (verse 11)
      $ set Robot { name = "@" , ops = mempty } 0
      : set Robot { name = "r" , ops = Move <$> cycle [U,N,L] } (shift v 1 U 0)
      : set Robot { name = "g" , ops = Move <$> cycle [N,L,U] } (shift v 2 U 0)
      : set Robot { name = "b" , 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)
      : zipWith set units (flip mod (length $ nodes v) <$> rs)
   units :: [Unit]
   units = replicate 4 Wall <> replicate 6 Box
data Unit = None | Wall | Box | Robot { name :: String , ops :: [Op] }
   deriving Show
data Op = Lock | Move Dir
   deriving Show
instance Atom Unit where
   void = None
   move a
      | Robot {} <- a , Move d : _ <- ops a = Just d
      | otherwise = Nothing
   lock a
      | Wall <- a = True
      | Robot {} <- a = True
      | otherwise = False
data State = State
   { rand :: [Int]
   , center :: Int
   , keys :: (Maybe Char,Queue Char)
   }
-- Logic
logic :: GEnv -> (State,Verse Unit) -> Event -> Either () (State,Verse Unit)
logic _ _ (KeyPress 'q') = Left ()
logic _ (s,v) (KeyPress k) = Right (s { keys = keys' } , v)
   where
   -- prevent repeat before tick
   keys' :: (Maybe Char,Queue Char)
      | Just (q,_) <- dequeue $ snd $ keys s , k == q = keys s
      | otherwise = enqueue k <$> keys s
logic _ (s,v) Tick = Right (s' , sim (Automata demo) s' v)
   where
   z :: State
      | Just (c,q) <- dequeue (snd $ keys s) = s { keys = (Just c , q) }
      | otherwise = s { keys = (Nothing,snd $ keys s) }
   s' :: State
      | 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 'L' <- k = z { center = shift v 1 L $ center s }
      | otherwise = z
      where
      k = fst $ keys z
-- Draw
draw :: GEnv -> (State,Verse Unit) -> Plane
draw e (s,v) = centerFull e $ hcat [hex,ui] & (1,1) % makeTransparent ' ' (word "nove demo")
   where
   r :: Int
   r = radius v
   canvas :: Plane
   canvas = blankPlane (2 * succ (2 * r) + 2) (succ (2 * r) + 2)
   hex :: Plane
   hex = foldl (&) canvas $ [ write (x,y) | x <- [-r..r] , y <- [-r..r] , abs (x + y) <= r ]
   write :: (Int,Int) -> Draw
   write (x,y) = c %.< cell grapheme # style
      where
      a :: Unit
      a = node n v
      -- get index of node taking scroll into account
      n :: Int
      n = shift v mx L . shift v my I $ coordToIndex v (mod (x - div y r * r) (3 * r) , mod y r)
         where
         (mx,my) = indexToCoord v (center s)
      -- stretch, tilt, margin, translate to library coordinate system (1-based (y,x))
      c :: (Int,Int)
      c = join bimap succ (y + r , 2 * (x + r) + y)
      grapheme :: Char
         | None     <- a = '∙'
         | Wall     <- a = '#'
         | Box      <- a = 'o'
         | Robot {} <- a = '@'
      style :: Draw
         | None     <- a = rgbColor $ sRGB24 0x66 0x66 0x66  -- #666666
         | Wall     <- a = rgbColor $ sRGB24 0x99 0x99 0x99  -- #999999
         | Box      <- a = rgbColor $ sRGB24 0x66 0x66 0x66  -- #666666
         | Robot {} <- a , "@" <- name a = rgbColor $ sRGB24 0x66 0x66 0x66  -- #666666
         | Robot {} <- a , "r" <- name a = rgbColor $ sRGB24 0x99 0x66 0x66  -- #996666
         | Robot {} <- a , "g" <- name a = rgbColor $ sRGB24 0x66 0x99 0x66  -- #669966
         | Robot {} <- a , "b" <- name a = rgbColor $ sRGB24 0x66 0x66 0x99  -- #666699
         | Robot {} <- a , "n" <- name a = rgbColor $ sRGB24 0x99 0x99 0x66  -- #999966
         | Robot {} <- a , "i" <- name a = rgbColor $ sRGB24 0x66 0x99 0x99  -- #669999
         | otherwise = rgbColor $ sRGB24 0x66 0x66 0x66
   ui :: Plane
-- ui = word "> ui content here <"
   ui = foldl (&) canvas [(1,1) % vcat (intersperse (cell ' ') [key,info])]
      where
      key = word (maybe id (:) c $ toList q) # color Black Vivid
      (c,q) = keys s
      info
         | Just m <- find me $ nodes v = word $ show m
         | otherwise = word "no robot found!" # rgbColor (sRGB24 0x99 0x44 0x44)
-- util
me :: Unit -> Bool
me a
   | Robot {} <- a , "@" <- name a = True
   | otherwise = False
-- Automata
demo :: State -> Map Dir Unit -> Unit -> Unit
demo s ns u
   | me u = me'
   | Robot {} <- u = u { ops = drop 1 $ ops u }
   | otherwise = u
   where
   me'
      | Just 'h' <- fst $ keys s = u { ops = [Move H] }
      | Just 'j' <- fst $ keys s = u { ops = [Move N] }
      | Just 'k' <- fst $ keys s = u { ops = [Move I] }
      | Just 'l' <- fst $ keys s = u { ops = [Move L] }
      | otherwise = u { ops = [] }

module Nove where
import Nove.Verse
import Nove.Logic ( step )
import Data.Map as Map ( Map )
{- State should be independent of time and not recorded
-- so every recorded frame should be enough to reconstruct the universe without it
-- state stores stuff like the currently focused cell
-- it does not provide information about the universe
-- State can however influence the universe
-- as is the case for the random seed or user input
-}
-- a cell is defined by its behaviour
newtype Automata state a = Automata { automata :: 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 Monoid (Automata state a) where
   mempty = Automata (\_ _ -> id)
sim :: Atom a => Automata state a -> state -> Verse a -> Verse a
sim c = step . automata c

module Nove.Verse where
import Data.IntMap as IntMap ( IntMap, fromDistinctAscList, (!), adjust, insert )
import Data.Tuple ( swap )
{- Index coordinates
       + + + +              z z z x x x y y y
      z z z x +            - - - - - - - - -
     z z z x x +          x x x y y y z z z
    z z z x x x +   ->   x x x y y y z z z
     x x y y y +        x x x y y y z z z
      x y y y +        - - - - - - - - -
       y y y +        y y y z z z x x x
       + + + +            + + + +               6 7 8 0 1 2 3 4 5      0 0 0 0 0 0 0 0 0
      6 7 8 0 +          2 2 2 2 +             - - - - - - - - -      - - - - - - - - -
     6 7 8 0 1 +        1 1 1 1 1 +           0 1 2 3 4 5 6 7 8      2 2 2 2 2 2 2 2 2
    6 7 8 0 1 2 +      0 0 0 0 0 0 +         0 1 2 3 4 5 6 7 8      1 1 1 1 1 1 1 1 1
     1 2 3 4 5 +        2 2 2 2 2 +         0 1 2 3 4 5 6 7 8      0 0 0 0 0 0 0 0 0
      2 3 4 5 +          1 1 1 1 +         - - - - - - - - -      - - - - - - - - -
       3 4 5 +            0 0 0 +         3 4 5 6 7 8 0 1 2      2 2 2 2 2 2 2 2 2
         x                  y                     x                      y
Performance should be predictable: time over space -}
-- | Verse
class Atom a where
   void :: a  -- empty cel
   move :: a -> Maybe Dir  -- wants to move
   lock :: a -> Bool
data Verse a = Verse
   { radius :: Int
   , nodes :: IntMap a
   }
verse :: Atom a => Int -> Verse a
verse r = v
   where
   v = Verse
      { radius = r
      , nodes = IntMap.fromDistinctAscList $ zip [0..] (replicate (3 * r * r) void)
      }
-- | Navigation
coordToIndex :: Verse a -> (Int,Int) -> Int
coordToIndex v (x,y) = y * (radius v * 3) + x
indexToCoord :: Verse a -> Int -> (Int,Int)
indexToCoord v = swap . flip divMod (radius v * 3)
distance :: Int -> Int -> Int
distance _ _ = undefined
data Dir = I | L | M | N | H | U
   deriving ( Eq, Ord, Enum, Bounded, Show )
opposite :: Dir -> Dir
opposite I = N
opposite L = H
opposite M = U
opposite N = I
opposite H = L
opposite U = M
shift :: Verse a -> Int -> Dir -> Int -> Int
shift v n d i
   | L <- d = coordToIndex v $ f (mod (x + n) (r * 3) , y)
   | I <- d = coordToIndex v $ f (x , y + n)
   | U <- d = shift v n I . shift v n H $ i
   | H <- d = shift v (negate n) L i
   | N <- d = shift v (negate n) I i
   | M <- d = shift v (negate n) U i
   where
   (x,y) = indexToCoord v i
   r = radius v
   f (x',y')
      | y' >= r || y' < 0 = (mod (x' + t * 2 * r) (r * 3) , mod y' r)
      | otherwise = (x' , y')
      where
      t = div y' r  -- outbound multiplier
-- | Manipulation
node :: Atom a => Int -> Verse a -> a
node i v = nodes v IntMap.! i
upd :: Atom a => (a -> a) -> Int -> Verse a -> Verse a
upd f i v = v { nodes = IntMap.adjust f i $ nodes v }
set :: Atom a => a -> Int -> Verse a -> Verse a
set a i v = v { nodes = IntMap.insert i a $ nodes v }

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

module Nove.Logic where
import Nove.Verse
import Zero ( total, floyd )
import Data.IntMap as IntMap ( IntMap, (!), foldrWithKey, fromDistinctAscList )
import Data.Map as Map ( Map, fromList, (!) )
import Data.Bifunctor ( bimap )
data Memo = Memo
   { mdest :: [Int]
   , mfree :: Bool
   }
-- | Step in simulation
step :: forall a. Atom a => (Map Dir a -> a -> a) -> Verse a -> Verse a
step f v = v { nodes = nodes' }
   where
   -- fold go with future memo
   (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]) -> ([Memo], [a])
   go i a (ms,as) = (m : ms , f ns a' : as)
      where
      ns :: Map Dir a
      ns = fromList [(dir , nodes v IntMap.! shift v 1 dir i) | dir <- total]
      -- memoization for this node
      m :: Memo
      m = Memo
         { mdest = dest
         , mfree = free
         }
      -- chain of destinations
      dest :: [Int]
         | Just dir <- move a , d <- shift v 1 dir i = d : mdest (memo' IntMap.! d)
         | otherwise = []
      -- want to move here
      mvin :: [Dir]
      mvin = filter (\dir -> move (nodes v IntMap.! shift v 1 dir i) == Just (opposite dir)) total
      -- is this node free?
      free :: Bool
         | lock a , null dest             = False
         | length mvin > 1                = False  -- stall
         | Just (_,d) <- floyd $ i : dest = i == d  -- loops back to itself , floyd $ cycle [0,1] => Just (2,1) , so (i /= d) which means stall when reciprocal)
         | otherwise                      = all (mfree . (memo' IntMap.!)) $ take 1 dest  -- dest is free
      -- new atom
      a' :: a
         | free , [dir] <- mvin                     = ns Map.! dir
         | d : _ <- dest , mfree (memo' IntMap.! d) = void  -- move out
         | otherwise                                = a

cabal-version: 3.0
name: nove
version: 0.1.0.0
author: jrvieira
maintainer: github@jrvieira.com
extra-source-files: CHANGELOG.md
common opts
   default-language: GHC2021
   default-extensions: LexicalNegation
   ghc-options: -Wall -O2
library
   import: opts
   hs-source-dirs: src
   exposed-modules: Nove
   exposed-modules: Nove.Verse
      , Nove.Logic
      , Nove.Utils
   build-depends: base
      , zero
      , containers
      , unordered-containers
      , hashable
      , colour
      , ansi-terminal-game
test-suite test
   import: opts
   type: exitcode-stdio-1.0
   hs-source-dirs: test
   main-is: Test.hs
   build-depends: base
      , nove
executable demo
   import: opts
   ghc-options: -threaded -rtsopts
   hs-source-dirs: test
   main-is: Demo.hs
   build-depends: base
      , zero
      , nove
      , random
      , containers
      , ansi-terminal-game

packages: ./nove.cabal
-- , ./src/*/*.cabal
source-repository-package
   type: git
   location: git@gitlab.com:jrvieira1/zero.git
   branch: main
profiling: True
profiling-detail: all-functions

let SessionLoad = 1
let s:so_save = &g:so | let s:siso_save = &g:siso | setg so=0 siso=0 | setl so=-1 siso=-1
let v:this_session=expand("<sfile>:p")
silent only
silent tabonly
cd ~/nove
if expand('%') == '' && !&modified && line('$') <= 1 && getline(1) == ''
  let s:wipebuf = bufnr('%')
endif
let s:shortmess_save = &shortmess
if &shortmess =~ 'A'
  set shortmess=aoOA
else
  set shortmess=aoO
endif
badd +1 src/Nove.hs
badd +44 src/Nove/Logic.hs
badd +74 test/Demo.hs
badd +33 src/Nove/Verse.hs
argglobal
%argdel
$argadd .
edit src/Nove/Verse.hs
let s:save_splitbelow = &splitbelow
let s:save_splitright = &splitright
set splitbelow splitright
wincmd _ | wincmd |
vsplit
wincmd _ | wincmd |
vsplit
2wincmd h
wincmd w
wincmd w
let &splitbelow = s:save_splitbelow
let &splitright = s:save_splitright
wincmd t
let s:save_winminheight = &winminheight
let s:save_winminwidth = &winminwidth
set winminheight=0
set winheight=1
set winminwidth=0
set winwidth=1
exe 'vert 1resize ' . ((&columns * 139 + 209) / 419)
exe 'vert 2resize ' . ((&columns * 139 + 209) / 419)
exe 'vert 3resize ' . ((&columns * 139 + 209) / 419)
argglobal
balt src/Nove.hs
setlocal foldmethod=indent
setlocal foldexpr=0
setlocal foldmarker={{{,}}}
setlocal foldignore=#
setlocal foldlevel=1
setlocal foldminlines=1
setlocal foldnestmax=1
setlocal foldenable
let s:l = 33 - ((32 * winheight(0) + 52) / 104)
if s:l < 1 | let s:l = 1 | endif
keepjumps exe s:l
normal! zt
keepjumps 33
normal! 025|
wincmd w
argglobal
if bufexists(fnamemodify("src/Nove/Logic.hs", ":p")) | buffer src/Nove/Logic.hs | else | edit src/Nove/Logic.hs | endif
if &buftype ==# 'terminal'
  silent file src/Nove/Logic.hs
endif
balt src/Nove.hs
setlocal foldmethod=indent
setlocal foldexpr=0
setlocal foldmarker={{{,}}}
setlocal foldignore=#
setlocal foldlevel=1
setlocal foldminlines=1
setlocal foldnestmax=1
setlocal foldenable
let s:l = 44 - ((43 * winheight(0) + 52) / 104)
if s:l < 1 | let s:l = 1 | endif
keepjumps exe s:l
normal! zt
keepjumps 44
normal! 010|
wincmd w
argglobal
if bufexists(fnamemodify("test/Demo.hs", ":p")) | buffer test/Demo.hs | else | edit test/Demo.hs | endif
if &buftype ==# 'terminal'
  silent file test/Demo.hs
endif
balt src/Nove/Logic.hs
setlocal foldmethod=indent
setlocal foldexpr=0
setlocal foldmarker={{{,}}}
setlocal foldignore=#
setlocal foldlevel=1
setlocal foldminlines=1
setlocal foldnestmax=1
setlocal foldenable
let s:l = 74 - ((60 * winheight(0) + 52) / 104)
if s:l < 1 | let s:l = 1 | endif
keepjumps exe s:l
normal! zt
keepjumps 74
normal! 0
wincmd w
2wincmd w
exe 'vert 1resize ' . ((&columns * 139 + 209) / 419)
exe 'vert 2resize ' . ((&columns * 139 + 209) / 419)
exe 'vert 3resize ' . ((&columns * 139 + 209) / 419)
tabnext 1
if exists('s:wipebuf') && len(win_findbuf(s:wipebuf)) == 0 && getbufvar(s:wipebuf, '&buftype') isnot# 'terminal'
  silent exe 'bwipe ' . s:wipebuf
endif
unlet! s:wipebuf
set winheight=1 winwidth=20
let &shortmess = s:shortmess_save
let &winminheight = s:save_winminheight
let &winminwidth = s:save_winminwidth
let s:sx = expand("<sfile>:p:r")."x.vim"
if filereadable(s:sx)
  exe "source " . fnameescape(s:sx)
endif
let &g:so = s:so_save | let &g:siso = s:siso_save
set hlsearch
nohlsearch
doautoall SessionLoadPost
unlet SessionLoad
" vim: set ft=vim :

# nove
## sim engine for hex grid automata

_darcs
.git*
.DS_Store