factory-lang/Main.hs

module Main where

-- TODO:
--   arithmetic
--   I/O

import Data.List
import Element

main :: IO ()
main = do
  input <- readFile "test.fac"
  let internalFactory = stringsToFactory $ lines input
  interpretLoop internalFactory [ Element
                                  0
                                  (1 + fst (entryPointLocation internalFactory))
                                  (snd $ entryPointLocation internalFactory)]
                                -- , Element
                                --   1
                                --   (2 + (fst $ entryPointLocation internalFactory))
                                --   (snd $ entryPointLocation internalFactory)]

interpretLoop :: Factory -> [Element] -> IO ()
interpretLoop f es = do
  let elements = stepInterpret f es
  printFactory f elements
  a <- getChar
  if a == 'q' then return () else interpretLoop f elements


-- printing factory state with elements overlayed
replaceNth :: Int -> a -> [a] -> [a]
replaceNth _ _ []           = []
replaceNth 0 a (first:rest) = a : rest
replaceNth n a (first:rest) = first : replaceNth (n-1) a rest

changeLine :: Element -> (Int, [Char]) -> (Int, [Char])
changeLine e (index, line)
  | yPos e == index = (index, replaceNth (xPos e) (head $ show $ value e) line)
  | otherwise       = (index, line)

changeTiles :: Element -> [(Int, [Char])] -> [(Int, [Char])]
changeTiles e []     = []
changeTiles e cs = map (changeLine e) cs

putElements :: [Element] -> [(Int, [Char])] -> [(Int, [Char])]
putElements [e] cs = changeTiles e cs
putElements (e:es) cs = changeTiles e (putElements es cs)

indexFactory :: Factory -> [(Int, [Tile])]
indexFactory tiles = indexed
  where indexed = zip [0..] tiles

indexCharFactory :: Factory -> [(Int, [Char])]
indexCharFactory f = zip [0..] charFactory
  where charFactory = showFactory f

showFactory :: Factory -> [[Char]]
showFactory [] = []
showFactory f  = map (map (head . show)) f

printFactory :: Factory -> [Element] -> IO ()
printFactory f es = mapM_ (print . snd) lines
  where lines = putElements es $ indexCharFactory f

type Entrypoint = Char

data Direction = North | South | East | West
  deriving (Eq, Ord)

data ModifierKind = Increment | Decrement
  deriving (Eq)

data Tile = Entrypoint
          | Track Direction
          | Modifier ModifierKind
          | Machine Char -- user defined machines
          | Ignored
  deriving (Eq)

instance Show Tile where
  show t = [tileToChar t]

type Factory = [[Tile]]

charToTile :: Char -> Tile
charToTile c = case c of
  'E' -> Entrypoint
  '>' -> Track East
  '<' -> Track West
  'v' -> Track South
  '^' -> Track North
  '+' -> Modifier Increment
  '-' -> Modifier Decrement
  _   -> Ignored

tileToChar :: Tile -> Char
tileToChar t = case t of
  Entrypoint         -> 'E'
  Track East         -> '>'
  Track West         -> '<'
  Track South        -> 'v'
  Track North        -> '^'
  Modifier Increment -> '+'
  Modifier Decrement -> '-'
  _                  -> ' '

stringsToFactory :: [[Char]] -> [[Tile]]
stringsToFactory [] = []
stringsToFactory s  = map (map charToTile) s

tupAdd :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
tupAdd (a, b) (c, d) = (a + c, b + d)

entryPointLocation :: Factory -> (Int, Int)
entryPointLocation []     = error "Couldn't find an entrypoint (E)."
entryPointLocation (l:ls) = case index of
    Nothing -> tupAdd (0, 1) (entryPointLocation ls)
    Just x  -> (x, 0)
  where index = elemIndex Entrypoint l

oobCheck :: Factory -> Element -> Bool
oobCheck f e = yPos e >= length f
               || xPos e >= length (f !! yPos e)

-- custom hashmap thingy, but uses lists so it's slow on large things (luckily this is small)
tileActionMap :: Tile -> [(Tile, Element -> Element)] -> (Element -> Element)
tileActionMap _ [] = id
tileActionMap tile (pair:rest)
  | tile == fst pair = snd pair
  | otherwise        = tileActionMap tile rest

-- TODO: make this safe, aka boundary check
spitOut :: Factory -> Element -> Element
spitOut f elem
  | (f !! yPos elem) !! (xPos elem + 1) == Track East  = incXPos elem
  | (f !! (yPos elem + 1)) !! xPos elem == Track South = incYPos elem
  | (f !! yPos elem) !! (xPos elem - 1) == Track West  = decXPos elem
  | (f !! (yPos elem - 1)) !! xPos elem == Track North = decYPos elem

update :: Factory -> Element -> Element
update f e = if oobCheck f e then error "Element out of bounds check failed!"
  else tileActionMap t tileActions e
  where t = (f !! yPos e) !! xPos e
        tileActions = [ (Track East,  \e -> Element (value e) (xPos e + 1) (yPos e))
                      , (Track West,  \e -> Element (value e) (xPos e - 1) (yPos e))
                      , (Track South, \e -> Element (value e) (xPos e) (yPos e + 1))
                      , (Track North, \e -> Element (value e) (xPos e) (yPos e - 1))
                      , (Modifier Increment, incVal . spitOut f)
                      , (Modifier Decrement, decVal . spitOut f)
                      ]

stepInterpret :: Factory -> [Element] -> [Element]
stepInterpret f = map (update f)