# Difference between revisions of "Euler problems/181 to 190"

Henrylaxen (talk | contribs) (solution to problem 185) |
(another solution to problem 185) |
||

Line 175: | Line 175: | ||

unless done main |
unless done main |
||

+ | </haskell> |
||

+ | |||

+ | Here's another solution, and this one squeaks by in just under a minute on my machine. The basic idea is to just do a back-tracking search, but with some semi-smart pruning and guess ordering. The code is in pretty much the order I wrote it, so most prefixes of this code should also compile. This also means you should be able to figure out what each function does one at a time. |
||

+ | |||

+ | <haskell> |
||

+ | import Control.Monad |
||

+ | import Data.List |
||

+ | import qualified Data.Set as S |
||

+ | |||

+ | ensure p x = guard (p x) >> return x |
||

+ | selectDistinct 0 _ = [[]] |
||

+ | selectDistinct n [] = [] |
||

+ | selectDistinct n (x:xs) = map (x:) (selectDistinct (n - 1) xs) ++ selectDistinct n xs |
||

+ | |||

+ | data Environment a = Environment { guesses :: [(Int, [a])] |
||

+ | , restrictions :: [S.Set a] |
||

+ | , assignmentsLeft :: Int |
||

+ | } deriving (Eq, Ord, Show) |
||

+ | |||

+ | reorder e = e { guesses = sort . guesses $ e } |
||

+ | domain = S.fromList "0123456789" |
||

+ | initial = Environment gs (replicate a S.empty) a where |
||

+ | a = length . snd . head $ gs |
||

+ | gs = [(2, "5616185650518293"), (1, "3847439647293047"), (3, "5855462940810587"), (3, "9742855507068353"), (3, "4296849643607543"), (1, "3174248439465858"), (2, "4513559094146117"), (3, "7890971548908067"), (1, "8157356344118483"), (2, "2615250744386899"), (3, "8690095851526254"), (1, "6375711915077050"), (1, "6913859173121360"), (2, "6442889055042768"), (0, "2321386104303845"), (2, "2326509471271448"), (2, "5251583379644322"), (3, "1748270476758276"), (1, "4895722652190306"), (3, "3041631117224635"), (3, "1841236454324589"), (2, "2659862637316867")] |
||

+ | |||

+ | acceptableCounts e = small >= 0 && big <= assignmentsLeft e where |
||

+ | ns = (0:) . map fst . guesses $ e |
||

+ | small = minimum ns |
||

+ | big = maximum ns |
||

+ | |||

+ | positions s = map fst . filter (not . snd) . zip [0..] . zipWith S.member s |
||

+ | acceptableRestriction r (n, s) = length (positions s r) >= n |
||

+ | acceptableRestrictions e = all (acceptableRestriction (restrictions e)) (guesses e) |
||

+ | |||

+ | firstGuess = head . guesses |
||

+ | sanityCheck e = acceptableRestrictions e && acceptableCounts e |
||

+ | |||

+ | solve e@(Environment _ _ 0) = [[]] |
||

+ | solve e@(Environment [] r _) = sequence $ map (S.toList . (domain S.\\)) r |
||

+ | solve e' = do |
||

+ | is <- m |
||

+ | newE <- f is |
||

+ | rest <- solve newE |
||

+ | return $ interleaveAscIndices is (l is) rest |
||

+ | where |
||

+ | f = ensure sanityCheck . update e |
||

+ | m = selectDistinct n (positions g (restrictions e)) |
||

+ | e = reorder e' |
||

+ | l = fst . flip splitAscIndices g |
||

+ | (n, g) = firstGuess e |
||

+ | |||

+ | splitAscIndices = indices 0 where |
||

+ | indices _ [] xs = ([], xs) |
||

+ | indices n (i:is) (x:xs) |
||

+ | | i == n = let (b, e) = indices (n + 1) is xs in (x:b, e) |
||

+ | | True = let (b, e) = indices (n + 1) (i:is) xs in (b, x:e) |
||

+ | |||

+ | interleaveAscIndices = indices 0 where |
||

+ | indices _ [] [] ys = ys |
||

+ | indices n (i:is) (x:xs) ys |
||

+ | | i == n = x : indices (n + 1) is xs ys |
||

+ | | True = head ys : indices (n + 1) (i:is) (x:xs) (tail ys) |
||

+ | |||

+ | update (Environment ((_, a):gs) r l) is = Environment newGs restriction (l - length is) where |
||

+ | (assignment, newRestriction) = splitAscIndices is a |
||

+ | (_, oldRestriction) = splitAscIndices is r |
||

+ | restriction = zipWith S.insert newRestriction oldRestriction |
||

+ | newGs = map updateEntry gs |
||

+ | updateEntry (n', a') = (newN, newA) where |
||

+ | (dropped, newA) = splitAscIndices is a' |
||

+ | newN = n' - length (filter id $ zipWith (==) assignment dropped) |
||

+ | |||

+ | problem_185 = head . solve $ initial |
||

</haskell> |
</haskell> |

## Revision as of 22:40, 15 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
```

Here's another solution, and this one squeaks by in just under a minute on my machine. The basic idea is to just do a back-tracking search, but with some semi-smart pruning and guess ordering. The code is in pretty much the order I wrote it, so most prefixes of this code should also compile. This also means you should be able to figure out what each function does one at a time.

```
import Control.Monad
import Data.List
import qualified Data.Set as S
ensure p x = guard (p x) >> return x
selectDistinct 0 _ = [[]]
selectDistinct n [] = []
selectDistinct n (x:xs) = map (x:) (selectDistinct (n - 1) xs) ++ selectDistinct n xs
data Environment a = Environment { guesses :: [(Int, [a])]
, restrictions :: [S.Set a]
, assignmentsLeft :: Int
} deriving (Eq, Ord, Show)
reorder e = e { guesses = sort . guesses $ e }
domain = S.fromList "0123456789"
initial = Environment gs (replicate a S.empty) a where
a = length . snd . head $ gs
gs = [(2, "5616185650518293"), (1, "3847439647293047"), (3, "5855462940810587"), (3, "9742855507068353"), (3, "4296849643607543"), (1, "3174248439465858"), (2, "4513559094146117"), (3, "7890971548908067"), (1, "8157356344118483"), (2, "2615250744386899"), (3, "8690095851526254"), (1, "6375711915077050"), (1, "6913859173121360"), (2, "6442889055042768"), (0, "2321386104303845"), (2, "2326509471271448"), (2, "5251583379644322"), (3, "1748270476758276"), (1, "4895722652190306"), (3, "3041631117224635"), (3, "1841236454324589"), (2, "2659862637316867")]
acceptableCounts e = small >= 0 && big <= assignmentsLeft e where
ns = (0:) . map fst . guesses $ e
small = minimum ns
big = maximum ns
positions s = map fst . filter (not . snd) . zip [0..] . zipWith S.member s
acceptableRestriction r (n, s) = length (positions s r) >= n
acceptableRestrictions e = all (acceptableRestriction (restrictions e)) (guesses e)
firstGuess = head . guesses
sanityCheck e = acceptableRestrictions e && acceptableCounts e
solve e@(Environment _ _ 0) = [[]]
solve e@(Environment [] r _) = sequence $ map (S.toList . (domain S.\\)) r
solve e' = do
is <- m
newE <- f is
rest <- solve newE
return $ interleaveAscIndices is (l is) rest
where
f = ensure sanityCheck . update e
m = selectDistinct n (positions g (restrictions e))
e = reorder e'
l = fst . flip splitAscIndices g
(n, g) = firstGuess e
splitAscIndices = indices 0 where
indices _ [] xs = ([], xs)
indices n (i:is) (x:xs)
| i == n = let (b, e) = indices (n + 1) is xs in (x:b, e)
| True = let (b, e) = indices (n + 1) (i:is) xs in (b, x:e)
interleaveAscIndices = indices 0 where
indices _ [] [] ys = ys
indices n (i:is) (x:xs) ys
| i == n = x : indices (n + 1) is xs ys
| True = head ys : indices (n + 1) (i:is) (x:xs) (tail ys)
update (Environment ((_, a):gs) r l) is = Environment newGs restriction (l - length is) where
(assignment, newRestriction) = splitAscIndices is a
(_, oldRestriction) = splitAscIndices is r
restriction = zipWith S.insert newRestriction oldRestriction
newGs = map updateEntry gs
updateEntry (n', a') = (newN, newA) where
(dropped, newA) = splitAscIndices is a'
newN = n' - length (filter id $ zipWith (==) assignment dropped)
problem_185 = head . solve $ initial
```