Skip to content

Instantly share code, notes, and snippets.

@hraftery
Created November 10, 2021 03:00
Show Gist options
  • Save hraftery/183c36e7bff7a7d028c501b7b044f3a6 to your computer and use it in GitHub Desktop.
Save hraftery/183c36e7bff7a7d028c501b7b044f3a6 to your computer and use it in GitHub Desktop.
My Haskell solution to the "Alphametics" challenge at https://exercism.org/tracks/haskell/exercises/alphametics
module Alphametics (solve) where
import Data.Char (isSpace)
import Data.List (nub, intersect, transpose, elemIndex)
import Data.Maybe (fromJust)
solve :: String -> Maybe [(Char, Int)]
solve input = if length solutions == 1 then Just $ zip charMap (head solutions) else Nothing
where
toRowsOfChars = wordsBy "+=" -- create list of words from input (["SEND","MORE","MONEY"])
toNonZeros = map toNonZerosMap . nub . map head -- create list of chars that can't be zero from rowsOfChars ("SM")
toNonZerosMap x = fromJust $ elemIndex x charMap -- helper for above
toColsOfChars = transpose . map reverse -- create list of columns (right to left) from rowsOfChars (["DEY","NRE","EON","SMO","M"])
toCharMap = nub . concat -- create list of each char from colsOfChars ("DEYNROSM")
toEncPuzzle :: [Int] -> [Char] -> [Int] -- encode columns into lists of coefficents from colsOfChars ([[1,1,-1],[0,-1,0,1,1],[0,1,0,-1,0,1],[0,0,0,0,0,-1,1,1],[0,0,0,0,0,0,0,-1]])
toEncPuzzle acc x = map encodeChar $ oldChars ++ newChars
where
oldChars = take (length acc) charMap
newChars = intersect (nub x) $ drop (length acc) charMap
encodeChar c = let (lx:ix) = reverse x in -- create (last x) and (init x)
length (filter (==c) ix) + if c == lx then -1 else 0
toCandidates :: [([Int], Int)] -> [Int] -> [([Int], Int)] -- create all solutions without final column constaints (non-zeros and no carry out)
-- p : current puzzle column, prev : result from previous column
-- a : all, o : old, n : new, co : carry out, ci : carry in
toCandidates prev p = [(a,co) | (o,ci)<-prev, n<-digitCombs numNew,
let a = o++n, nub a == a,
co<-[0..length rowsOfChars - 2], ci + dot a p == 10*co]
where numNew = length p - (length . fst . head $ prev)
toSolutionsPrelim = map fst . filter (\x -> snd x == 0) -- apply no carry out constraint
toSolsFold acc x = filter (\sol -> (sol !! x) /= 0) acc -- apply non-zeros constraint
-- Below are all the intermediate results for each of the `to` functions above.
rowsOfChars = toRowsOfChars input
nonZeros = toNonZeros rowsOfChars
colsOfChars = toColsOfChars rowsOfChars
charMap = toCharMap colsOfChars
encodedPuzzle = tail $ scanl toEncPuzzle [] colsOfChars
candidates = foldl toCandidates [([],0)] encodedPuzzle
solutionsPrelim = toSolutionsPrelim candidates
solutions = foldl toSolsFold solutionsPrelim nonZeros
wordsBy :: [Char] -> String -> [String]
wordsBy chars = words . map (\c -> if c `elem` chars then ' ' else c)
dot :: Num a => [a] -> [a] -> a
dot = (sum.) . zipWith (*)
-- Produce all combinations of n digits
digitCombs :: (Num a, Enum a) => Int -> [[a]]
digitCombs 0 = [[]]
digitCombs n = [x:xs | x<-[0..9], xs<-digitCombs(n-1)]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment