Difference between revisions of "Euler problems/181 to 190"
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
Problem 181
Investigating in how many ways objects of two different colours can be grouped.
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
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
Problem 184
Triangles containing the origin.
Solution:
problem_184 = undefined
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