factory-lang/Main.hs

module Main where

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

import Data.List
import System.Environment
import System.Exit

import Element
import Types
import Dirty

main :: IO ()
main = do
  args <- getArgs
  if length args < 1
    then die "No filename provided."
    else run $ args !! 0

run :: String -> IO ()
run inputFile = do
  input <- readFile inputFile
  let internalFactory = stringsToFactory $ lines input
  interpretLoop internalFactory [ Element
                                  0
                                  (fst $ entryPointLocation internalFactory)
                                  (snd $ entryPointLocation internalFactory)]

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

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)

singleton :: a -> [a]
singleton a = [a]

-- 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 _ [] = singleton
tileActionMap tile (pair:rest)
  | tile == fst pair = snd pair
  | otherwise        = tileActionMap tile rest

-- TODO: make this safe, aka boundary check
spitOut :: Direction -> Factory -> Element -> Element
spitOut dir f elem = case dir of
  East  -> spitOutEast f elem
  South -> spitOutSouth f elem
  West  -> spitOutWest f elem
  North -> spitOutNorth f elem

-- AAAAAAAA
spitOutEast :: Factory -> Element -> Element
spitOutEast 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

spitOutSouth :: Factory -> Element -> Element
spitOutSouth f 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
  | (f !! yPos elem) !! (xPos elem + 1) == Track East  = incXPos elem

spitOutWest :: Factory -> Element -> Element
spitOutWest f elem
  | (f !! yPos elem) !! (xPos elem - 1) == Track West  = decXPos elem
  | (f !! (yPos elem - 1)) !! xPos elem == Track North = decYPos elem
  | (f !! yPos elem) !! (xPos elem + 1) == Track East  = incXPos elem
  | (f !! (yPos elem + 1)) !! xPos elem == Track South = incYPos elem

spitOutNorth :: Factory -> Element -> Element
spitOutNorth f elem
  | (f !! (yPos elem - 1)) !! xPos elem == Track North = decYPos 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

duplicate :: Element -> [Element]
duplicate e = [e, e]

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,         singleton . incXPos)
                      , (Track West,         singleton . decXPos)
                      , (Track South,        singleton . incYPos)
                      , (Track North,        singleton . decYPos)
                      , (Modifier Increment, singleton . incVal . spitOut East f)
                      , (Modifier Decrement, singleton . decVal . spitOut East f)
                      , (Special Duplicate,  dupFunc)
                      , (Entrypoint,         singleton . spitOut East f)
                      ]
        dupFunc :: Element -> [Element]
        dupFunc elem = [ spitOut East f elem
                       , spitOut South f elem
                       ]

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