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 have to make a state machine, which equals a text editor's search funtion.
I need to use foldl/foldr to apply the function to every character of a string.
I have a few states, which I have to work with:
type State = Int
start :: State
start = 0
accept :: State
accept = (-2)
reject :: State
reject = (-1)
And I have type synonim : type Definition = [(State, Char -> State)]
The function should look like this: fsm :: Definition -> String -> Bool
My code looks like this right now:
transition :: Char -> State -> (Char -> State)
transition x y z
| x == z = y
| x == '*' = y
| otherwise = reject
transitions :: [(Char, State)] -> (Char -> State)
transitions ((a,b):xs) e
| a == e || a == '*' = b
| a /= e || a /= '*' = transitions xs e
| otherwise = reject
step :: Definition -> State -> Char -> State
step ((a,b):xs) e f
| a == e = b f
| a /= e = step xs e f
| otherwise = reject
It has a starting state, apply transition or transitions function and if it is accepted, the state accepted is the next starting state.
Here is some test cases, which I have to test the function:
fsm [ (start, transition '*' accept)] "x" == True
fsm [ (start, transition 'a' 1)
, (1, transition 'l' 2)
, (2, transition '*' accept)
] "alma" == True
fsm [ (start, transition '*' 1)
, (1, transition '*' 2)
, (2, transition 'x' 3)
, (3, transition '*' accept)
] "taxi" == True
fsm [ (start, transitions [('\n',accept), ('*', 1)])
, (1, transition '*' start)
] "aa\n" == True
If you fill in the initial state and the string to process in foldl, the types basically imply the rest:
-- foldl :: Foldable t => (State -> Char -> State) -> State -> [Char] -> State
fsm def str = foldl x start str
Here x must have type State -> Char -> State and give you the next state given the current one and the next character, which is what your step function does given a Definition that you have. This gives you:
fsm def str = foldl (step def) start str :: State
Now you have a State but need a Bool saying if it's accepted, which is just a simple comparison:
fsm def str = foldl (step def) start str == accept
Let's say I have a date type like this one:
type GroupNb = Int
type Code = Int
type Name = String
type Random = Int
data Group = Group GroupNb Code Name Random deriving Show
And I "add" some data(groups) in it.
Now, I want to get a list of all the GroupNb having 1 as the Code, and "test" as a Name.
groupNumbers :: [Group] -> [a]
groupNumbers (Group _ a b _) = nub[List.find (a == 1 && b == "test") [GroupNb]]
This solution doesn't work... How could I do something like that ?
If I have understood your problem correctly, you have a list of Group that you want to filter based on a predicate (code == 1 && name == "test"). That is exactly what the filter function is for. So this is what your code looks like:
someTest :: Group -> Bool
someTest (Group _ code name _) = code == 1 && name == "test"
allGroupPassingTest :: [Group] -> [Group]
allGroupPassingTest g = filter someTest g
The helper method someTest is the predicate that filter is using.
Your original code was quite broken, because in haskell functions must start with a lower case. You're equality test was also broken, because = is for assignment, not testing equality (you're looking for ==). I have no idea what the square brackets are doing in here nub[List.find (a = 1 && b = "test") [GroupNb]]. The only use of square brackets (to my knowledge) is to represent a list, or a list type. [GroupNb] looks like you are trying to cast your list to this type, but the way to cast is using statement :: TypeCast. List.find (a = 1 && b = "test") is almost right, but it (a = 1 && b = "test") should be written as a lambda like this (\(Group _ code name _) -> code == 1 && name == "test").
GroupNumbers :: Group -> [a]
GroupNumbers (Group _ a b _) = nub[List.find (a = 1 && b = "test") [GroupNb]]
I'm trying to recursively find the ith positive integer for which the predicate is true. I need to keep it general for every function.
ithTrueValue :: (Int -> Bool) -> Int-> Int
ithTrueValue func i
| i < 1 = error "Integer MUST BE greater than 0"
| ithTrueValue func i = 1 + ithTrueValue(func i-1 )
| otherwise = ithTrueValue(func i-1)
I get a type error:
ERROR file:.\new 10.hs:6 - Type error in guard
*** Term : ithTrueValue func i
*** Type : Int
*** Does not match : Bool
The problem is that ithTrueValue func i isn't boolean, it's an integer. I think there are really 4 cases to deal with here,
i is an insane value, like -1 or similar
The predicate is true at the current integer,
The predicate is false at the current integer
The predicate is true and this is the ith time it's true.
With that in mind let's restructure your code a bit
ithTrueValue f i = go 0 f i
so we're using this helper function called go which is going to count up the integers and keep track of what integer we're at
where go _ _ i | i <= 0 = error "i must be a positive integer" -- case 1.
go curr f i | f curr = if i == 1
then curr -- case 4.
else go (curr + 1) f (i - 1) -- case 2.
| otherwise = ??? -- case 3.
Where ??? is the case where the predicate is false. I'll leave it to you to figure out what to do in this case.
Now this works, but it's very.. low level. Explicit recursion is not the nicest way to write this sorta stuff. More pleasant is to rely on higher order functions, specifically
filter :: (a -> Bool) -> [a] -> [a]
So this will run down the list and leave all values where the predicate is true
ithTrueValue i f = ??? filter f [0..]
where ??? get's the ith value of the list. For this we use
(!!) :: [a] -> Int -> a
which just selects an index
ithTrueValue i f = filter f [0..] !! i
Your error is with this line:
| ithTrueValue func i = 1 + ithTrueValue(func i-1 )
^^^^^^^^^^^^^^^^^^^^^^^^^
iTruthValue takes 2 arguments, but because of the parens you're only calling it with one.
You probably wanted to write something like:
| ithTrueValue func i = 1 + ithTrueValue func (i-1)
I'm fairly new to Haskell and have a question about pattern-matching.
Here is a heavily simplified version of the code:
data Value = MyBool Bool | MyInt Integer
codeDuplicate1 :: Value -> Value -> IO Value
codeDuplicate1 = generalFunction True
codeDuplicate2 :: Value -> Value -> IO Value
codeDuplicate2 = generalFunction False
generalFunction :: Bool -> Value -> Value -> IO Value
generalFunction b x1 x2 = do result <- eval x1
case result of
MyBool b -> do putStrLn $ show b
return (MyBool b)
_ -> eval x2
eval :: Value -> IO Value
eval (MyInt x) | x > 10 = return (MyInt 10)
| x > 5 = return (MyBool True)
| otherwise = return (MyBool False)
Now, I realize that the argument b in generalFunction is not the same as the b in the case part, and therefore, this code will print b regardless of the input. I used the same name just to show my intentions. So my question is:
Is there a way to match the first b with the second, so that if the bs are the same it will print, otherwise it will evaluate x2? And, if there isn't, is there another good way to get the intended result?
I almost found the answer in this question, but I think this situation is slightly different.
You can use a guarded pattern. The first alternative will be executed if MyBool is matched and b == b2; otherwise the second alternative will be executed.
case result of
MyBool b2 | b == b2 -> do {print b; return $ MyBool b}
_ -> eval x2