Haskell Langton Ant and Infinite loop

Question

I'm trying to implement a Langton Ant and in Haskell, the idea is that the ant will run forever, so I encoded it like this.

I have a function stepSystem :: (Ant, Universe) -> (Ant, Universe) that will run a single step for the ant. Ant here is a record with the position and the ant direction and universe is an 2d array of chars.

I then have a runSystem function that will run stepSystem indefinitely. The problem is that when I run this it just outputs one cycle then prints <<loop>> and exit. I read that this is because the Haskell runtime detected an unbounded loop, but in this case this is just what I want. What do to in this situation??

Here is the full code

module Main where

import Control.Concurrent
import Control.Monad
import Data.Array
import Data.Char
import Data.Function
import qualified System.Process as SP

data Direction
  = DUp
  | DDown
  | DLeft
  | DRight

data Color
  = Black
  | White

type Pos = (Int, Int)

type Universe = Array Pos Char

data Ant =
  Ant
    { pos :: Pos
    , dir :: Direction
    }

h = 50

w = 50

start = (h `div` 2, w `div` 2)

mkArray :: (Int, Int) -> Array (Int, Int) Char
mkArray (maxx, maxy) =
  array
    ((1, 1), (maxx, maxy))
    [((i, j), '.') | i <- [1 .. maxx], j <- [1 .. maxy]]

mkUniverse :: Universe
mkUniverse = mkArray (h, w)

mkAnt :: Ant
mkAnt =
  let (x, y) = start
   in Ant {pos = (x, y), dir = DUp}

-- sleep seconds
sleep :: Int -> IO ()
sleep n = threadDelay (n * 1000000)

-- clear terminal
clear :: IO ()
clear = do
  _ <- SP.system "reset"
  return ()

colorToChar :: Color -> Char
colorToChar Black = '.'
colorToChar White = '@'

charToColor :: Char -> Color
charToColor '.' = Black
charToColor '@' = White
charToColor c = error $ "invalid char " ++ [c]

printUniverse :: Universe -> IO ()
printUniverse m = do
  forM_ (assocs m) $ \((y, x), cell) -> do
    putChar cell
    putChar '\n' & when (x == w)

turnLeft :: Direction -> Direction
turnLeft DUp = DLeft
turnLeft DDown = DRight
turnLeft DLeft = DDown
turnLeft DRight = DUp

turnRight :: Direction -> Direction
turnRight DUp = DRight
turnRight DDown = DLeft
turnRight DLeft = DUp
turnRight DRight = DDown

turnAnt :: Color -> Direction -> Direction
turnAnt White = turnRight
turnAnt Black = turnLeft

flipColor :: Color -> Color
flipColor Black = White
flipColor White = Black

flipColorChr :: Char -> Char
flipColorChr = colorToChar . flipColor . charToColor

updateCell :: Pos -> Char -> Universe -> Universe
updateCell pos chr universe = universe // [(pos, chr)]

flipCell :: Pos -> Universe -> Universe
flipCell pos universe =
  let c = flipColorChr (universe ! pos)
   in updateCell pos c universe

decrementX :: Int -> Int
decrementX x
  | x == 0 = w
  | otherwise = x - 1

incrementX :: Int -> Int
incrementX x
  | x == w = 0
  | otherwise = x + 1

incrementY :: Int -> Int
incrementY y
  | y == h = 0
  | otherwise = y + 1

decrementY :: Int -> Int
decrementY y
  | y == 0 = h
  | otherwise = y - 1

moveForward :: Direction -> (Int, Int) -> (Int, Int)
moveForward DLeft (x, y) = (decrementX x, y)
moveForward DRight (x, y) = (incrementX x, y)
moveForward DUp (x, y) = (x, decrementY y)
moveForward DDown (x, y) = (x, incrementY y)

moveAnt :: Color -> Ant -> Ant
moveAnt currentColor Ant {pos = (x, y), dir = dir} =
  let (x, y) = moveForward dir (x, y)
   in Ant {pos = (x, y), dir = turnAnt currentColor dir}

getCurrentCellColor :: Ant -> Universe -> Color
getCurrentCellColor Ant {pos = (x, y)} universe =
  charToColor $ universe ! (x, y)

stepSystem :: (Ant, Universe) -> (Ant, Universe)
stepSystem (ant@Ant {pos = pos}, universe) =
  let currentCellColor = getCurrentCellColor ant universe
      newAnt = moveAnt currentCellColor ant
   in (newAnt, flipCell pos universe)

runSystem :: (Ant, Universe) -> IO ()
runSystem system@(ant, universe) = do
  printUniverse universe
  print "---------------"
  runSystem (stepSystem system)

main :: IO ()
main = runSystem (mkAnt, mkUniverse)

Answer 1

The issue lies here:

moveAnt :: Color -> Ant -> Ant
moveAnt currentColor Ant {pos = (x, y), dir = dir} =
  let (x, y) = moveForward dir (x, y)
   in Ant {pos = (x, y), dir = turnAnt currentColor dir}

Specifically, (x, y) = moveForward dir (x, y) is a self-recursive call. A bit subtle isn't it? Having name shadowing warning on would have at least pointed a possible confusion.

Changing the definition to

  let (x', y') = moveForward dir (x, y)
   in Ant {pos = (x', y'), dir = turnAnt currentColor dir}

fixes the problem. Personally I wouldn't even define x' or y': Ant {pos = moveForward dir (x, y), dir = turnAnt currentColor dir}.

Btw, I found the problem by running the functions in the repl:

λ> (ant@Ant {pos = pos}, universe) = (mkAnt, mkUniverse)
λ> printSystem (a, u) = print a >>  printUniverse u
λ> printSystem $  stepSystem $  stepSystem (ant, universe) 
Ant {pos = (^CInterrupted. -- Hangs here.
λ> 

Of course, I had to make your data types derive Show.