I'm working on the Alphametics puzzle
A set of words is written down in the form of an ordinary "long-hand" addition sum, and it is required that the letters of the alphabet be replaced with decimal digits so that the result is a valid arithmetic sum.Example:
SEND
MORE
-----
MONEY
This equation has a unique solution:
9567
1085
-----
10652
A non brute force solution is to use backtracking with memoization. My choice is to use the State Monad along with mutable Vectors.
The algorithm goes as follows:
If we are beyond the leftmost digit of the sum:
Return true if no carry, false otherwise.
Also check that there is no leading zero in the sum.
Else if addend and current column index is beyond the current row:
Recur on row beneath this one.
If we are currently trying to assign a char in one of the addends:
If char already assigned, recur on row beneath this one.
If not assigned, then:
For every possible choice among the digits not in use:
Make that choice and recur on row beneath this one.
If successful, return true.
Else, unmake assignment and try another digit.
Return false if no assignment worked to trigger backtracking.
Else if trying to assign a char in the sum:
If char already assigned:
If matches the sum digit, recur on next column to the left with carry.
Else, return false to trigger backtracking.
If char unassigned:
If correct digit already used, return false.
Else:
Assign it and recur on next column to the left with carry:
If successful return true.
Else, unmake assignment, and return false to trigger backtracking.
I'm having trouble with writing the part where a number is assigned to an addend.
Rust code for reference that needs to be translated to Haskell.
let used: HashSet<&u8> = HashSet::from_iter(solution.values());
let unused: Vec<u8> = (0..=9).filter(|x| !used.contains(x)).collect();
for i in unused {
if i == 0 && non_zero_letters.contains(&letter) {
continue;
}
solution.insert(letter, i);
if can_solve(
equation,
result,
non_zero_letters,
row + 1,
col,
carry + (i as u32),
solution,
) {
return true;
}
solution.remove(&letter);
}
false
My code, that I've yet to compile, and without the above case implemented, is shown below:
equation contains the addend rows.
result is the sum row.
solution is the assignments.
nonZeroLetters is an optimization that checks there are no leading zeros in any of the rows.
solve :: String -> Maybe [(Char, Int)]
solve puzzle = error "You need to implement this function."
type Solution = Vector Int
type Row = Vector Char
data PuzzleState = PuzzleState
{ equation :: Vector Row,
result :: Row,
nonZeroLetters :: Set Char,
solution :: MVector Row
}
canSolve :: Int -> Int -> Int -> State PuzzleState Bool
canSolve row col carry = do
PuzzleState {equation, result, nonZeroLetters, solution} <- get
let addend = row < length equation
let word = if addend then (equation ! row) else result
let n = length word
let letter = word ! col
let ord x = C.ord x - C.ord 'A'
let readC = UM.read (solution . ord)
i <- readC letter
let assigned = i >= 0
let isNonZero = flip S.member nonZeroLetters
case () of
_
| col >= n && addend -> canSolve (row + 1) col carry
| col == n && (not . addend) -> carry == 0
| addend && assigned -> canSolve (row + 1) col (carry + i)
ord :: Char -> Int
ord x = C.ord x - C.ord 'A'
readC ::
(PrimMonad m, UM.Unbox a) =>
MV.MVector (PrimState m) a ->
Char ->
m a
readC solution c = UM.read solution $ ord c
writeC ::
(PrimMonad m, UM.Unbox a) =>
UM.MVector (PrimState m) a ->
Char ->
a ->
m ()
writeC solution c x = UM.write solution $ ord c $ x
Here's the (invalid and incomplete) draft that I need help with. This is the part for which I showed Rust code above.
| addend -> let used <- M.mapM (0 <= UM.read solution) [0..length solution - 1]
unused = filter (\x -> x == 0 && isNonZero x) [0..9] \\ used
in do
i <- unused
writeC letter
Edit Jan 7, 2023:
Here's the cleaned up code that produces the compilation error shown at the end.
{-# LANGUAGE NamedFieldPuns #-}
module Alphametics (solve) where
import Control.Monad as M
import Control.Monad.Reader (ReaderT)
import qualified Control.Monad.Reader as R
import Control.Monad.ST (ST)
import qualified Control.Monad.ST as ST
import qualified Data.Char as C
import Data.List ((\\))
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import Data.Vector.Unboxed.Mutable (MVector)
import qualified Data.Vector.Unboxed.Mutable as UM
solve :: String -> Maybe [(Char, Int)]
solve puzzle = error "You need to implement this function."
data PuzzleState s = PuzzleState
{ equation :: V.Vector (U.Vector Char),
result :: U.Vector Char,
nonZeroLetters :: Set Char,
solution :: MVector s Int
}
type M s = ReaderT (PuzzleState s) (ST s)
canSolve :: Int -> Int -> Int -> M s Bool
canSolve row col carry = do
PuzzleState {equation, result, nonZeroLetters, solution} <- R.ask
let addend = row < length equation
let word = if addend then ((V.!) equation row) else result
let n = length word
let letter = (U.!) word col
let x = ord letter
y <- R.lift $ UM.read solution x
let assigned = y >= 0
let isNonZero = flip S.member nonZeroLetters
let sumDigit = carry `mod` 10
let used = filter (\i -> 0 <= UM.read solution i) [0 .. length solution - 1]
case () of
_
| col >= n && addend -> canSolve (row + 1) col carry
| col == n && (not addend) -> return $ carry == 0
| addend && assigned -> canSolve (row + 1) col (carry + y)
| addend ->
let unused = filter (\i -> i == 0 && isNonZero letter) [0 .. 9] \\ used
in assignAny unused y solution
| assigned && sumDigit == y -> canSolve 0 (col + 1) (carry `mod` 10)
| sumDigit `elem` used -> return $ False
| sumDigit == 0 && isNonZero letter -> return $ False
| otherwise -> assign 0 (col + 1) (carry `mod` 10) y sumDigit solution
where
ord x = C.ord x - C.ord 'A'
assignAny [] _ _ = return (False)
assignAny (i : xs) y solution = do
success <- assign (row + 1) col (carry + i) y i solution
if success then return (success) else assignAny xs y solution
assign r c cr y i solution = do
UM.write solution y i
success <- canSolve r c cr
M.when (not success) (UM.write solution y (-1))
return (success)
Error:
• Couldn't match type ‘s’
with ‘primitive-0.7.3.0:Control.Monad.Primitive.PrimState m0’
Expected: MVector
(primitive-0.7.3.0:Control.Monad.Primitive.PrimState (ST s)) Int
Actual: MVector
(primitive-0.7.3.0:Control.Monad.Primitive.PrimState m0) Int
‘s’ is a rigid type variable bound by
the type signature for:
canSolve :: forall s. Int -> Int -> Int -> M s Bool
at src/Alphametics.hs:31:1-41
There's a larger conceptual problem in your code that's been pointed out in the comments.
The State monad simulates a mutable state by passing invisible state values into and out of a sequence of monadic actions. The state values themselves are immutable, but since they are passed into and out of each action, an action can simulate mutation by returning a state value that's different than the one it was given.
On the other hand, the Data.Vector package provides two types of mutable vectors, IOVector and STVector. These are vectors with truly mutable elements, not simulated. They can be mutated within the IO and ST monads respectively, because these monads provide the capability for true mutation. Neither type can be mutated in a State monad, because the State mutation is only simulated. It would be too inefficient to implement a third type of mutable vector using State's simulated mutation.
In your program, you are using a State that includes a field solution with a (true) mutable vector for its value. This points to a probable design problem. Either you want to simulate mutation with a State or you want to use a true mutable vector that's made available to your program in some convenient manner, maybe via a ReaderT, and manipulated within an IO or ST base monad.
I actually can't quite understand your PuzzleState representation from the code you've provided. For example, solution has type MVector Row, which isn't a valid type, but maybe it's supposed to have the unused type Solution instead, except that Solution isn't mutable. And I'm not sure what nonZeroLetters represents.
However, if your intention is to access fixed character vectors of the addends and result that don't change over the course of solving the puzzle, and mutate an array mapping letters to their digit assignments, then you probably want a "context" that's something like:
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as UM
data PuzzleContext = PuzzleContext
{ equation :: V.Vector (U.Vector Char) -- fixed matrix of addends, as Chars
, result :: U.Vector Char -- fixed result as Chars
, solution :: UM.IOVector Int -- mutable array of digit assignments
}
made available using a monad M like:
import Control.Monad.Reader
type M = ReaderT PuzzleContext IO
This allows you to access the puzzle details:
canSolve :: ... -> M Bool
canSolve ... = do
PuzzleContext{equation, result, solution} <- ask
let c = equation V.! 0 U.! 2 -- access third letter of first addend
and mutate the solution:
let ord x = C.ord x - C.ord 'A'
UM.write solution (ord 'M') 6 -- try M=6
Note that solution is an immutable reference that comes out of the reader, but what it references is a mutable vector, which is why you can UM.write to its elements within the base IO monad.
As for helping you with your specific draft code, as I say I can't really understand your representation from the code you've written so far, so it's not clear to me how to help with that.
OP here, figured it out myself. This code, and an alternative implementation using State monad, are available here. I’ve done some benchmarking, and surprisingly, the immutable version using State appears to be faster than the mutable code below.
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Alphametics (solve) where
import Control.Monad as M
import Control.Monad.Reader (ReaderT)
import qualified Control.Monad.Reader as R
import Control.Monad.ST (ST)
import qualified Data.Char as C
import Data.List ((\\))
import qualified Data.List as L
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed as VU
import Data.Vector.Unboxed.Mutable (MVector)
import qualified Data.Vector.Unboxed.Mutable as UM
solve :: String -> Maybe [(Char, Int)]
solve puzzle
-- validate equation, "ABC + DEF == GH" is invalid,
-- sum isn't wide enough
| any (\x -> length x > (length . head) res) eqn = Nothing
| otherwise = findSoln $ VU.create $ do
let nonZeroLetters = S.fromList nz
-- process in reverse
let equation = (V.fromList . map (U.fromList . reverse)) eqn
let result = (U.fromList . reverse . head) res
solution <- UM.replicate 26 (-1)
_ <- R.runReaderT (canSolve 0 0 0) PuzzleState {..}
return solution
where
xs = filter (all C.isAsciiUpper) $ words puzzle
(eqn, res) = L.splitAt (length xs - 1) xs
-- leading letters can't be zero
nz = [head x | x <- xs, length x > 1]
chr x = C.chr (C.ord 'A' + x)
findSoln v = case [ (chr x, y)
| x <- [0 .. 25],
let y = v VU.! x,
y >= 0
] of
[] -> Nothing
x -> Just x
data PuzzleState s = PuzzleState
{ equation :: V.Vector (U.Vector Char),
result :: U.Vector Char,
nonZeroLetters :: Set Char,
solution :: MVector s Int
}
type M s = ReaderT (PuzzleState s) (ST s)
canSolve :: Int -> Int -> Int -> M s Bool
canSolve row col carry = do
PuzzleState {equation, result, nonZeroLetters, solution} <- R.ask
let addend = row < V.length equation
let word = if addend then equation V.! row else result
let n = U.length word
case () of
_
| col >= n && addend -> canSolve (row + 1) col carry
| col == n && not addend -> return $ carry == 0
| otherwise -> do
let letter = word U.! col
let x = ord letter
i <- readM solution x
let assigned = i >= 0
let canBeZero = flip S.notMember nonZeroLetters
let sumDigit = carry `mod` 10
used <- M.mapM (readM solution) [0 .. 25]
let unused =
filter
(\y -> y > 0 || canBeZero letter)
[0 .. 9]
\\ used
case () of
_
| addend && assigned -> canSolve (row + 1) col (carry + i)
| addend -> assignAny solution x unused
| assigned ->
if sumDigit == i
then canSolve 0 (col + 1) (carry `div` 10)
else return False
| sumDigit `elem` used -> return False
| sumDigit == 0 && (not . canBeZero) letter -> return False
| otherwise ->
assign
0
(col + 1)
(carry `div` 10)
solution
x
sumDigit
where
-- lift is needed because we're working in in a ReaderT monad,
-- whereas VM.read and VM.write work in the ST monad
readM solution = R.lift . UM.read solution
ord c = C.ord c - C.ord 'A'
assignAny _ _ [] = return False
assignAny solution ix (i : xs) = do
success <- assign (row + 1) col (carry + i) solution ix i
if success then return success else assignAny solution ix xs
assign r c cr solution ix i = do
UM.write solution ix i
success <- canSolve r c cr
M.unless success (UM.write solution ix (-1))
return success
I wrote data structure and some functions for automata, but I stuck with find_way function that will accept automata object and k.
type FSM q = ([q], Alphabet, [Transition q], q, [q])
type Alphabet = [Char]
type Transition q = (q, Char, q)
states :: FSM q -> [q]
states (u, _, _, _, _) = u
alph :: FSM q -> Alphabet
alph (_, a, _, _, _) = a
trans :: FSM q -> [Transition q]
trans (_, _, t, _, _) = t
start :: FSM q -> q
start (_, _, _, s, _) = s
final :: FSM q -> [q]
final (_, _, _, _, f) = f
--return a or Nothing if no transition found
delta :: Eq a => FSM a -> a -> Char -> Maybe a
delta m st symbol = listToMaybe [q1 | (q0, x, q1) <- trans m, q0 == st, x == symbol]
--return "No" or first accepted word found
goal:: Eq a => FSM a -> Int -> String
goal m k = fromMaybe "No" $ asum [find_way m k x | x <- alph m]
find_way :: Eq a => FSM a -> Int -> Char -> Maybe String
I guess the "obvious" way to implement this is for find_way to use delta to take one step in the automata, then recursively call goal with a modified FSM with a different initial state. Don't forget to add a base case somewhere for when the user asks whether a length-0 string gets accepted.
But that way is horribly inefficient. I recommend a different way:
Make a new type, type Witness a = (String, a) or similar. The idea of this type is that the pair contains String and the state you would get to if you started from an FSM's initial state and used that String.
Write a function successors :: Ord a => FSM a -> [Witness a] -> [Witness a] which, given a set of states, finds all the states that can be reached in just one transition from at least one of those states. There may be many ways to reach a given state, so make sure this de-duplicates its output, keeping just one Witness for each state (doesn't matter which one).
Iterate that function k times, starting from the set that only has the FSM's initial state and the empty string, then check if there's any states both in the output and the FSM's final states.
The first/obvious way is something like O(a^k), where a is the size of the alphabet and k is the length being queried. The proposed different way is more like O(k*n*(a+log(n))) where n is the total number of states (and a and k are as before).
I'm trying to implement a PDA in Haskell based on my lecturer's notes, she has described the general process to us and left the actual function implementation up to us. I feel like I have the majority of it working bar one little bug in the nextsteps function.
The rules of the PDA are as follows:
[((1,"a",""),(1,"a")),((1,"b",""),(1,"b")),((1,"a",""),(2,"")),((1,"b",""),(2,"")),((1,"",""),(2,"")),((2,"a","a"),(2,"")),((2,"b","b"),(2,""))]
run :: PDA -> String -> Result
run _ "" = Reject
run (state,finalState,rules) str = findpath [(state,str,""(state,finalState,rules)
data Result = Accept | Reject deriving Show
type PDA = (Int,[Int],[Transition])
-- Takes in the start state, the current value read by the input string, the current stack and the new state along with the change to the stack
-- ((1,"a",""),(1,"a"))
type Transition = ((Int, String, String),(Int,String))
-- contains the current state, current input string and current state of the stack
-- (1,"abba","ba")
type Configuration = (Int, String, String)
--if the list of configurations isnt accepted, apply the PDA transitions to it and try again
findpath :: [Configuration] -> PDA -> Result
findpath [] pda = Reject
findpath (h:t) (a,b,c) = if accept (h:t) b == True then Accept else findpath (nextsteps (h:t) c) (a,b,c)
accept' :: Configuration -> [Int] -> Bool
accept' config [] = False
accept' (x,y,z) [a] = if x == a && y == "" && z == "" then True else False
accept:: [Configuration] -> [Int] -> Bool
accept [] _ = False
accept _ [] = False
accept (h:t) finalState = if accept' h finalState then True else accept t finalState
-- apply a given transition to a configuration based on the values in the configuration and transition
step :: Configuration -> Transition -> [Configuration]
step (a,b,"")((d,"",""),(g,"")) = if a == d then [(g,b,"")] else []
step (a,(b:bs),"")((d,"",""),(g,h)) = if a == d then [(g,bs,[b])] else []
step (a,(b:bs),"") ((d,"",f),(g,"")) = if a == d then [(g,(b:bs),f)] else []
step (a,(b:bs),"") ((d,"",f),(g,h)) = if a == d then [(g,(b:bs),h)] else []
step (a,(b:bs),"") ((d,[e],""),(g,"")) = if a == d && b == e then [(g,bs,"")] else []
step (a,(b:bs),"") ((d,[e],""),(g,h)) = if a == d && b == e then [(g,bs,[b])] else []
step (a,(b:bs),"") ((d,[e],f),(g,"")) = if a == d && b == e then [(g,bs,"")] else []
step (a,(b:bs),"") ((d,[e],f),(g,h)) = if a == d && b == e then [] else []
step (a,b,c) ((d,"",""),(g,"")) = if a == d then [(g,b,c)] else []
step (a,(b:bs),c) ((d,"",""),(g,h)) = if a == d then [(g,bs,c)] else []
step (a,b,(c:cs))((d,"",[f]),(g,"")) = if a == d && c == f then [(g,b,cs)] else []
step (a,b,(c:cs)) ((d,"",[f]),(g,h)) = if a == d && c == f then [(g,b,cs++h)] else []
step (a,(b:bs),c) ((d,[e],""),(g,"")) = if a == d then [(g,bs,c)] else []
step (a,(b:bs),c) ((d,[e],""),(g,h)) = if a == d && b == e then [(g,bs,[b]++c)] else []
step (a,(b:bs),(c:cs)) ((d,[e],[f]),(g,""))= if a == d && b == e && c == f then [(g,bs,cs)] else []
step (a,(b:bs),(c:cs)) ((d,[e],[f]),(g,h)) = if a == d && b == e && c == f then [(g,bs,cs++h)] else []
-- apply the entire ruleset of the PDA over one configuration and return a list of the results
steps :: Configuration -> [Transition] -> [Configuration]
steps config [] = []
steps (a,b,c) (h:t) = if b /= "" then step (a,b,c) h ++ steps (a,b,c) t else []
-- take in a list of configurations and apply the entire rulest over each configuration and return a list of results
nextsteps :: [Configuration] -> [Transition] -> [Configuration]
nextsteps config [] = []
nextsteps (h : t) rules = steps h rules ++ nextsteps t rules
The program works for certain strings and not others, I'm certain its to do with my nextsteps function. In my lecturer's notes she gives the example
nextsteps [(1,"bbabba","a"),(2,"abbabba",""),(2,"bbabba","") rules = [(1,"babba","ba"),(2,"babba","a"),(2,"bbabba","a")]
However, when I call the function on the exact same inputs I get [(1,"babba","ba"),(2,"babba","a"),(2,"babba","a"),(2,"bbabba","a")].
I'm not sure where this extra duplicate value is coming from and is the main reason why strings that shouldn't be excepted are getting accepted. I have tried removing the tail of the configurations list and only applying the steps function to the head of the list, and that will make sure any list that shouldn't be accepted is Rejected, but also Rejected inputs that should be Accepted.
I'm trying to implement a lexer in Haskell. For easy console input and output, I've used an intermediate data type Transition Table.
type TransitionTable = [(Int, Transitions String Int)]
type Transitions a b = [(a, b)]
I want to take input from the user for all the states and transitions. I do not want to take the total number of states before hand. I want it to keep taking input for the transitions of each state until the user types "--" . If the user types "---", the current state is discarded and the input terminates.
After a lot of attempts I came up with this, which I think is horrible code.
-- |A function to emulate the while loop for easy IO functionality.
-- Defination:- while #comparator #func #start:
-- *comparator #arg: A function which returns True or False on the basis of #arg.
-- The loop stops when False is returned.
-- *func: The function which is executed repeadly.
-- It is responsible for returning the next #arg for the comparator on the basis of the current #arg.
-- *start: The starting value of #arg to pass to the comparator.
while :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
while comparator func start =
if comparator start then do
nxt <- func start
while comparator func nxt
else
return start
-- |A modification of putStr which flushes out stdout. Corrents buffer problems.
myPutStr :: String -> IO ()
myPutStr str = putStr str >> hFlush stdout >> return ()
-- Takes input from the console to generate a TransitionTable.
inputTransitionTable :: IO TransitionTable
inputTransitionTable = do
putStrLn "Type -- for next state and --- for completing input entering."
retVal <- while notFinished takeInfo (0, [])
return (snd retVal)
where
-- Returns True when input entry is over.
notFinished (i, _) = i > -1
-- Takes the current state number and the incomplete corrosponding transition table which is populated
-- with user input. Input ends when user enters "---". State number is set to -1 when input is over.
takeInfo (i, states) = do
putStrLn ("Adding transitions to state " ++ show i ++ ": ")
retVal <- while entryNotFinished takeStateInfo ("", [])
let (inpStr, stateInfo) = retVal
case inpStr == "---" of
True -> return (-1, states)
False -> return (i+1, states ++ [(i, stateInfo)])
-- Checks if input entry is over. Returns False if finished.
entryNotFinished (s, _)
| s == "--" || s == "---" = False
| otherwise = True
-- Takes the input state number along with the corresponding transitions.
-- Input ends when the user enters "--".
takeStateInfo (str, state_info) = do
myPutStr "\tEnter transitions symbol: "
symbol <- getLine
if symbol == "--" || symbol == "---" then
return (symbol, state_info)
else do
myPutStr "\t\tEnter the transition state number: "
state' <- getLine
let state = read state' :: Int
return (str, (symbol, state):state_info)
Basically this is how it runs:
*Main> x <- inputTransitionTable
Type -- for next state and --- for completing input entering.
Adding transitions to state 0:
Enter transitions symbol: a
Enter the transition state number: 1
Enter transitions symbol: b
Enter the transition state number: 2
Enter transitions symbol: --
Adding transitions to state 1:
Enter transitions symbol: a
Enter the transition state number: 2
Enter transitions symbol: b
Enter the transition state number: 3
Enter transitions symbol: --
Adding transitions to state 2:
Enter transitions symbol: a
Enter the transition state number: 3
Enter transitions symbol: --
Adding transitions to state 3:
Enter transitions symbol: --
Adding transitions to state 4:
Enter transitions symbol: ---
(0.03 secs, 344420 bytes)
-- Output
*Main> prettyPrintTransitionTable x
State Transitions
0 ("b",2) ("a",1)
1 ("b",3) ("a",2)
2 ("a",3)
3
Is there a better way to do this?
It could be as simple as this, if you add the "deriving Read" declarations and don't care about interaction.
main = do
allInput <- getContents -- scarfs all stdin up to eof
let inLines = lines allInput
let (tableLines, _:otherlines) = break (== "endtable") inLines
let table = ((read $ unlines tableLines) :: TransitionTable)
-- process otherlines here
As others have suggested, for a tasks related to parsing you should look at Parsec. While I have no experience with it, I can still suggest an alternative way of writing your parsing application.
module Main where
import Control.Monad (liftM)
computeTransitions :: [String] -> [(Int, [(String, Int)])]
computeTransitions is = foldl folder [] is
where
getState states = if null states then (0, []) else last states
getTransition transitions = if null transitions then 0 else (snd $ head transitions)
prepend state transition = let (c, ts) = state in (c, transition:ts)
swapLastState states state = if null states then [state] else init states ++ [state]
folder states i =
let currentState = getState states
currentTransition = getTransition (snd currentState)
in case i == "--" of False -> swapLastState states (prepend currentState (i, currentTransition + 1))
True -> states ++ [((fst currentState) + 1, [])]
main = do
inputLines <- liftM (takeWhile (/="---")) (liftM lines getContents)
let result = computeTransitions inputLines
mapM_ (\(s, t) -> putStrLn $ show s ++ "\t" ++ show t) result
I don't know if in your requirements was to print out the intermediary messages, but the computation of the transitions can be transformed to a fold operation (or foldM if you want to print intermediary messages); and instead of the "while" loop I've used the takeWhile function lifted to the Monadic space (so I can apply it on the type IO [String]).
Also note that getContents is lazy in evaluation, and in combination with lines will perform as a "while read line".
Edit:
With #pat's suggestion (and what hlint came up with), here is the refactored version:
module Main where
import Control.Monad (liftM)
computeTransitions :: [String] -> [(Int, [(String, Int)])]
computeTransitions = foldl folder []
where
getState [] = (0, [])
getState states = last states
getTransition [] = 0
getTransition ((_, t):_) = t
prepend (c,ts) transition = (c, transition:ts)
swapLastState [] state = [state]
swapLastState states state = init states ++ [state]
folder states i =
let currentState = getState states
currentTransition = getTransition (snd currentState)
in if i == "--"
then states ++ [(fst currentState + 1, [])]
else swapLastState states (prepend currentState (i, currentTransition + 1))
main = do
inputLines <- liftM (takeWhile (/="---") . lines) getContents
mapM_ (\(s, t) -> putStrLn $ show s ++ "\t" ++ show t) (computeTransitions inputLines)