busy-beaver-3.hs

{-# language LambdaCase #-}
import Machine.Turing

zeroTape :: Tape Bool
zeroTape = Tape zeroes False zeroes
  where zeroes = False :| zeroes

-- | the 3-state busy beaver
-- https://en.wikipedia.org/wiki/Turing_machine_examples#3-state_Busy_Beaver
busyBeaver3 :: State Bool
busyBeaver3 = a
  where
    a = State $ \case
      False -> Just (GoRight, True, b)
      True  -> Just (GoLeft , True, c)
    b = State $ \case
      False -> Just (GoLeft , True, a)
      True  -> Just (GoRight, True, b)
    c = State $ \case
      False -> Just (GoLeft , True, b)
      True  -> Nothing

beaverStates :: [(State Bool, Tape Bool)]
beaverStates = iterTuring busyBeaver3 emptyTape

Machine.Turing.hs

module Machine.Turing where

data Stream a = a :| Stream a

data Tape a = Tape (Stream a) a (Stream a)

data Move = GoLeft | Stay | GoRight

applyMove :: Move -> Tape a -> Tape a
applyMove GoLeft (Tape (l :| ls) x rs) = Tape ls l (x :| rs)
applyMove GoRight (Tape ls x (r :| rs)) = Tape (x :| ls) r rs
applyMove Stay t = t

-- | A turing machine is defined by its initial state. The machine's
-- set of possible states is the set of possible @State a@s that
-- can eventually be produced from the initial state.
-- This representation allows for infinite state-sets, but it
-- it can also encode finite state-sets without any issues.
newtype State a = State { appState :: a -> Maybe (Move, a, State a) }

stepTuring :: State a -- ^ initial state
           -> Tape a  -- ^ initial tape
           -> Maybe (State a, Tape a)
stepTuring (State f) (Tape l x r) = case f x of
  Nothing               -> Nothing
  Just (move, x', next) -> (next, applyMove move (Tape l x' r))
  
-- | Produce a stream of a machine's successive states,
-- returns a list to model halting:
-- finite list <=> machine halts
iterTuring :: State a -> Tape a -> [(State a, Tape a)]
iterTuring = unfoldr (uncurry stepTuring)