# Euler problems/181 to 190

### From HaskellWiki

Henrylaxen (Talk | contribs) (solution to problem 185) |
|||

Line 47: | Line 47: | ||

<haskell> | <haskell> | ||

problem_184 = undefined | problem_184 = undefined | ||

+ | </haskell> | ||

+ | |||

+ | == [http://projecteuler.net/index.php?section=problems&id=185 Problem 185] == | ||

+ | Number Mind | ||

+ | |||

+ | Solution: | ||

+ | |||

+ | This approach does '''NOT''' solve the problem in under a minute, | ||

+ | unless of course you are extremely lucky. The best time I've | ||

+ | seen so far has been about 76 seconds. Before I came up with | ||

+ | this code, I tried to search for the solution by generating a | ||

+ | list of all possible solutions based on the information given in | ||

+ | the guesses. This was feasible with the 5 digit problem, but | ||

+ | completely intractable with the 16 digit problem. The approach | ||

+ | here, simple yet effective, is to make a random guess, and then | ||

+ | vary each digit in the guess from [0..9], generating a score of | ||

+ | how well the guess matched the given numbermind clues. You then | ||

+ | ''improve'' the guess by selecting those digits that had a unique | ||

+ | low score. It turns out this approach converges rather quickly, | ||

+ | but can often be stuck in cycles, so we test for this and try a | ||

+ | differenct random first guess if a cycle is detected. Once you | ||

+ | run the program, you might have time for a cup of coffee, or | ||

+ | maybe even a dinner. HenryLaxen 2008-03-12 | ||

+ | |||

+ | <haskell> | ||

+ | |||

+ | import Data.List | ||

+ | import Control.Monad | ||

+ | import Data.Char | ||

+ | import System.Random | ||

+ | |||

+ | type Mind = [([Char],Int)] | ||

+ | |||

+ | values :: [Char] | ||

+ | values = "0123456789" | ||

+ | |||

+ | |||

+ | score :: [Char] -> [Char] -> Int | ||

+ | score guess answer = foldr (\(a,b) y -> if a == b then y+1 else y) 0 | ||

+ | (zip guess answer) | ||

+ | |||

+ | scores :: Mind -> [Char] -> [Int] | ||

+ | scores m g = map (\x -> abs ((snd x) - score (fst x) g)) m | ||

+ | |||

+ | scoreMind :: Mind -> [Char] -> Int | ||

+ | scoreMind m g = sum $ scores m g | ||

+ | |||

+ | |||

+ | ex1 :: Mind | ||

+ | ex1 = | ||

+ | [("90342",2), | ||

+ | ("39458",2), | ||

+ | ("51545",2), | ||

+ | ("34109",1), | ||

+ | ("12531",1), | ||

+ | ("70794",0)] | ||

+ | |||

+ | ex2 :: Mind | ||

+ | ex2 = | ||

+ | [ | ||

+ | ("5616185650518293",2), | ||

+ | ("3847439647293047",1), | ||

+ | ("5855462940810587",3), | ||

+ | ("9742855507068353",3), | ||

+ | ("4296849643607543",3), | ||

+ | ("3174248439465858",1), | ||

+ | ("4513559094146117",2), | ||

+ | ("7890971548908067",3), | ||

+ | ("8157356344118483",1), | ||

+ | ("2615250744386899",2), | ||

+ | ("8690095851526254",3), | ||

+ | ("6375711915077050",1), | ||

+ | ("6913859173121360",1), | ||

+ | ("6442889055042768",2), | ||

+ | ("2321386104303845",0), | ||

+ | ("2326509471271448",2), | ||

+ | ("5251583379644322",2), | ||

+ | ("1748270476758276",3), | ||

+ | ("4895722652190306",1), | ||

+ | ("3041631117224635",3), | ||

+ | ("1841236454324589",3), | ||

+ | ("2659862637316867",2)] | ||

+ | |||

+ | |||

+ | guesses :: [Char] -> Int -> [[Char]] | ||

+ | guesses str pos = [ left ++ n:(tail right) | n<-values] | ||

+ | where (left,right) = splitAt pos str | ||

+ | |||

+ | bestGuess :: Mind -> [[Char]] -> [Int] | ||

+ | bestGuess mind guesses = | ||

+ | let scores = map (scoreMind mind) guesses | ||

+ | bestScore = minimum scores | ||

+ | bestGuesses = findIndices (==bestScore) scores | ||

+ | in bestGuesses | ||

+ | |||

+ | iterateGuesses :: Mind -> [Char] -> [Char] | ||

+ | iterateGuesses mind value = | ||

+ | let allguesses = map (guesses value) [0..(length value)-1] | ||

+ | mins = map (bestGuess mind) allguesses | ||

+ | in nextguess value mins | ||

+ | |||

+ | nextguess :: [Char] -> [[Int]] -> [Char] | ||

+ | nextguess prev mins = | ||

+ | let choose x = if length (snd x) == 1 then intToDigit ((snd x)!!0) else fst x | ||

+ | both = zip prev mins | ||

+ | in foldr (\x y -> (choose x) : y) "" both | ||

+ | |||

+ | |||

+ | iterateMind :: Mind -> [Char] -> [([Char], Int)] | ||

+ | iterateMind mind n = | ||

+ | let a = drop 2 $ inits $ iterate (iterateGuesses mind) n | ||

+ | b = last $ takeWhile (\x -> (last x) `notElem` (init x)) a | ||

+ | c = map (scoreMind mind) b | ||

+ | in zip b c | ||

+ | |||

+ | |||

+ | randomStart :: (Num a, Enum a) => a -> IO [Char] | ||

+ | randomStart n = mapM (\_ -> getStdRandom (randomR ('0','9'))) [1..n] | ||

+ | |||

+ | main :: IO () | ||

+ | main = do | ||

+ | let ex = ex1 | ||

+ | x <- randomStart (length (fst (head ex))) | ||

+ | let y = iterateMind ex x | ||

+ | let done = (snd (last y) == 0) | ||

+ | when done (putStrLn $ (fst.last) y) | ||

+ | unless done main | ||

+ | |||

</haskell> | </haskell> |

## Revision as of 13:39, 12 March 2008

## Contents |

## 1 Problem 181

Investigating in how many ways objects of two different colours can be grouped.

## 2 Problem 182

RSA encryption.

Solution:

fun a1 b1 = sum [ e | e <- [2..a*b-1], gcd e (a*b) == 1, gcd (e-1) a == 2, gcd (e-1) b == 2 ] where a = a1-1 b = b1-1 problem_182 = fun 1009 3643

## 3 Problem 183

Maximum product of parts.

Solution:

-- Does the decimal expansion of p/q terminate? terminating p q = 1 == reduce [2,5] (q `div` gcd p q) where reduce [] n = n reduce (x:xs) n | n `mod` x == 0 = reduce (x:xs) (n `div` x) | otherwise = reduce xs n -- The expression (round $ fromIntegral n / e) computes the integer k -- for which (n/k)^k is at a maximum. Also note that, given a rational number -- r and a natural number k, the decimal expansion of r^k terminates if -- and only if the decimal expansion of r does. answer = sum [if terminating n (round $ fromIntegral n / e) then -n else n | n <- [5 .. 10^4]] where e = exp 1 main = print answer

## 4 Problem 184

Triangles containing the origin.

Solution:

problem_184 = undefined

## 5 Problem 185

Number Mind

Solution:

This approach does **NOT** solve the problem in under a minute,
unless of course you are extremely lucky. The best time I've
seen so far has been about 76 seconds. Before I came up with
this code, I tried to search for the solution by generating a
list of all possible solutions based on the information given in
the guesses. This was feasible with the 5 digit problem, but
completely intractable with the 16 digit problem. The approach
here, simple yet effective, is to make a random guess, and then
vary each digit in the guess from [0..9], generating a score of
how well the guess matched the given numbermind clues. You then
*improve* the guess by selecting those digits that had a unique
low score. It turns out this approach converges rather quickly,
but can often be stuck in cycles, so we test for this and try a
differenct random first guess if a cycle is detected. Once you
run the program, you might have time for a cup of coffee, or
maybe even a dinner. HenryLaxen 2008-03-12

import Data.List import Control.Monad import Data.Char import System.Random type Mind = [([Char],Int)] values :: [Char] values = "0123456789" score :: [Char] -> [Char] -> Int score guess answer = foldr (\(a,b) y -> if a == b then y+1 else y) 0 (zip guess answer) scores :: Mind -> [Char] -> [Int] scores m g = map (\x -> abs ((snd x) - score (fst x) g)) m scoreMind :: Mind -> [Char] -> Int scoreMind m g = sum $ scores m g ex1 :: Mind ex1 = [("90342",2), ("39458",2), ("51545",2), ("34109",1), ("12531",1), ("70794",0)] ex2 :: Mind ex2 = [ ("5616185650518293",2), ("3847439647293047",1), ("5855462940810587",3), ("9742855507068353",3), ("4296849643607543",3), ("3174248439465858",1), ("4513559094146117",2), ("7890971548908067",3), ("8157356344118483",1), ("2615250744386899",2), ("8690095851526254",3), ("6375711915077050",1), ("6913859173121360",1), ("6442889055042768",2), ("2321386104303845",0), ("2326509471271448",2), ("5251583379644322",2), ("1748270476758276",3), ("4895722652190306",1), ("3041631117224635",3), ("1841236454324589",3), ("2659862637316867",2)] guesses :: [Char] -> Int -> [[Char]] guesses str pos = [ left ++ n:(tail right) | n<-values] where (left,right) = splitAt pos str bestGuess :: Mind -> [[Char]] -> [Int] bestGuess mind guesses = let scores = map (scoreMind mind) guesses bestScore = minimum scores bestGuesses = findIndices (==bestScore) scores in bestGuesses iterateGuesses :: Mind -> [Char] -> [Char] iterateGuesses mind value = let allguesses = map (guesses value) [0..(length value)-1] mins = map (bestGuess mind) allguesses in nextguess value mins nextguess :: [Char] -> [[Int]] -> [Char] nextguess prev mins = let choose x = if length (snd x) == 1 then intToDigit ((snd x)!!0) else fst x both = zip prev mins in foldr (\x y -> (choose x) : y) "" both iterateMind :: Mind -> [Char] -> [([Char], Int)] iterateMind mind n = let a = drop 2 $ inits $ iterate (iterateGuesses mind) n b = last $ takeWhile (\x -> (last x) `notElem` (init x)) a c = map (scoreMind mind) b in zip b c randomStart :: (Num a, Enum a) => a -> IO [Char] randomStart n = mapM (\_ -> getStdRandom (randomR ('0','9'))) [1..n] main :: IO () main = do let ex = ex1 x <- randomStart (length (fst (head ex))) let y = iterateMind ex x let done = (snd (last y) == 0) when done (putStrLn $ (fst.last) y) unless done main