module Main where
import Control. Applicative ( ( <$> ) , ( <*> ) )
import Control
. Monad ( foldM
, forM
_ ) import Data. List ( ( \\) )
-- types
data House = House
{ color :: Color -- <trait> :: House -> <Trait>
, man :: Man
, pet :: Pet
, drink :: Drink
, smoke :: Smoke
}
data Color = Red | Green | Blue | Yellow | White
data Man = Eng | Swe | Dan | Nor | Ger
data Pet = Dog | Birds | Cats | Horse | Zebra
data Drink = Coffee | Tea | Milk | Beer | Water
data Smoke = PallMall | Dunhill | Blend | BlueMaster | Prince
type Solution = [ House]
main = do
solutions :: [ Solution]
solutions = foldM next [ ] [ 1 .. 6 ]
where
next
:: Solution
-> Int -> [ Solution
] next sol pos | pos <= 5 = [ h:sol | h <- newHouses sol, consistent h pos]
newHouses :: Solution -> Solution
newHouses sol = -- all combinations of traits not yet used
House <$> new color <*> new man <*> new pet <*> new drink <*> new smoke
where
new trait
= [ minBound .. ] \\
map trait sol
-- :: [<Trait>]
consistent house pos
= and -- consistent with the rules: [ man `is` Eng <=> color `is` Red -- 2
, man `is` Swe <=> pet `is` Dog -- 3
, man `is` Dan <=> drink `is` Tea -- 4
, color `is` Green <=> drink `is` Coffee -- 6
, pet `is` Birds <=> smoke `is` PallMall -- 7
, color `is` Yellow <=> smoke `is` Dunhill -- 8
, const ( pos
== 3 ) <=> drink `is` Milk
-- 9 , const ( pos
== 1 ) <=> man `is` Nor
-- 10 , drink `is` Beer <=> smoke `is` BlueMaster -- 13
, man `is` Ger <=> smoke `is` Prince -- 14
]
where
infix 4 <=>
p <=> q = p house == q house -- both True or both False
is
:: Eq a
=> ( House
-> a
) -> a
-> House
-> Bool ( trait `is` value) house = trait house == value
finalCheck
:: [ House
] -> Bool finalCheck solution
= and -- fulfills the rules: [ ( color `is` Green) `leftOf` ( color `is` White) -- 5
, ( smoke `is` Blend ) `nextTo` ( pet `is` Cats ) -- 11
, ( smoke `is` Dunhill) `nextTo` ( pet `is` Horse) -- 12
, ( color `is` Blue ) `nextTo` ( man `is` Nor ) -- 15
, ( smoke `is` Blend ) `nextTo` ( drink `is` Water) -- 16
]
where
nextTo p q = leftOf p q || leftOf q p
leftOf p q
bW9kdWxlIE1haW4gd2hlcmUKCmltcG9ydCBDb250cm9sLkFwcGxpY2F0aXZlICgoPCQ+KSwgKDwqPikpCmltcG9ydCBDb250cm9sLk1vbmFkIChmb2xkTSwgZm9yTV8pCmltcG9ydCBEYXRhLkxpc3QgKChcXCkpCgotLSB0eXBlcwpkYXRhIEhvdXNlID0gSG91c2UgICAKICAgIHsgY29sb3IgOjogQ29sb3IgICAgICAtLSA8dHJhaXQ+IDo6IEhvdXNlIC0+IDxUcmFpdD4KICAgICwgbWFuICAgOjogTWFuCiAgICAsIHBldCAgIDo6IFBldAogICAgLCBkcmluayA6OiBEcmluawogICAgLCBzbW9rZSA6OiBTbW9rZQogICAgfQogICAgZGVyaXZpbmcgKEVxLCBTaG93KQoKZGF0YSBDb2xvciA9IFJlZCB8IEdyZWVuIHwgQmx1ZSB8IFllbGxvdyB8IFdoaXRlCiAgICBkZXJpdmluZyAoRXEsIFNob3csIEVudW0sIEJvdW5kZWQpCgpkYXRhIE1hbiA9IEVuZyB8IFN3ZSB8IERhbiB8IE5vciB8IEdlcgogICAgZGVyaXZpbmcgKEVxLCBTaG93LCBFbnVtLCBCb3VuZGVkKQoKZGF0YSBQZXQgPSBEb2cgfCBCaXJkcyB8IENhdHMgfCBIb3JzZSB8IFplYnJhCiAgICBkZXJpdmluZyAoRXEsIFNob3csIEVudW0sIEJvdW5kZWQpCgpkYXRhIERyaW5rID0gQ29mZmVlIHwgVGVhIHwgTWlsayB8IEJlZXIgfCBXYXRlcgogICAgZGVyaXZpbmcgKEVxLCBTaG93LCBFbnVtLCBCb3VuZGVkKQoKZGF0YSBTbW9rZSA9IFBhbGxNYWxsIHwgRHVuaGlsbCB8IEJsZW5kIHwgQmx1ZU1hc3RlciB8IFByaW5jZQogICAgZGVyaXZpbmcgKEVxLCBTaG93LCBFbnVtLCBCb3VuZGVkKQoKdHlwZSBTb2x1dGlvbiA9IFtIb3VzZV0KCm1haW4gOjogSU8gKCkKbWFpbiA9IGRvCiAgZm9yTV8gc29sdXRpb25zICQgXHNvbCAtPiBtYXBNXyBwcmludCBzb2wKICAgICAgICAgICAgICAgICAgICAgICAgICAgID4+IHB1dFN0ckxuICItLS0tIgogIHB1dFN0ckxuICJObyBNb3JlIFNvbHV0aW9ucyIKCgpzb2x1dGlvbnMgOjogW1NvbHV0aW9uXQpzb2x1dGlvbnMgPSBmb2xkTSBuZXh0IFtdIFsxLi42XQogICAgd2hlcmUKICAgICAgbmV4dCA6OiBTb2x1dGlvbiAtPiBJbnQgLT4gW1NvbHV0aW9uXQogICAgICBuZXh0IHNvbCBwb3MgfCBwb3MgPD0gNSAgPSBbaDpzb2wgfCBoIDwtIG5ld0hvdXNlcyBzb2wsIGNvbnNpc3RlbnQgaCBwb3NdCiAgICAgICAgICAgICAgICAgICB8IG90aGVyd2lzZSA9IFtyIHwgbGV0IHIgPSByZXZlcnNlIHNvbCwgZmluYWxDaGVjayByXQoKCm5ld0hvdXNlcyA6OiBTb2x1dGlvbiAtPiBTb2x1dGlvbgpuZXdIb3VzZXMgc29sID0gICAgLS0gYWxsIGNvbWJpbmF0aW9ucyBvZiB0cmFpdHMgbm90IHlldCB1c2VkCiAgICBIb3VzZSA8JD4gbmV3IGNvbG9yIDwqPiBuZXcgbWFuIDwqPiBuZXcgcGV0IDwqPiBuZXcgZHJpbmsgPCo+IG5ldyBzbW9rZQogICAgd2hlcmUKICAgICAgbmV3IHRyYWl0ID0gW21pbkJvdW5kIC4uXSBcXCBtYXAgdHJhaXQgc29sICAtLSA6OiBbPFRyYWl0Pl0KCgpjb25zaXN0ZW50IDo6IEhvdXNlIC0+IEludCAtPiBCb29sCmNvbnNpc3RlbnQgaG91c2UgcG9zID0gYW5kICAgICAgICAgICAgICAgICAgLS0gY29uc2lzdGVudCB3aXRoIHRoZSBydWxlczoKICAgIFsgbWFuICAgYGlzYCBFbmcgICAgIDw9PiAgIGNvbG9yIGBpc2AgUmVkICAgICAgICAgICAgICAtLSAgMgogICAgLCBtYW4gICBgaXNgIFN3ZSAgICAgPD0+ICAgcGV0ICAgYGlzYCBEb2cgICAgICAgICAgICAgIC0tICAzCiAgICAsIG1hbiAgIGBpc2AgRGFuICAgICA8PT4gICBkcmluayBgaXNgIFRlYSAgICAgICAgICAgICAgLS0gIDQKICAgICwgY29sb3IgYGlzYCBHcmVlbiAgIDw9PiAgIGRyaW5rIGBpc2AgQ29mZmVlICAgICAgICAgICAtLSAgNgogICAgLCBwZXQgICBgaXNgIEJpcmRzICAgPD0+ICAgc21va2UgYGlzYCBQYWxsTWFsbCAgICAgICAgIC0tICA3CiAgICAsIGNvbG9yIGBpc2AgWWVsbG93ICA8PT4gICBzbW9rZSBgaXNgIER1bmhpbGwgICAgICAgICAgLS0gIDgKICAgICwgY29uc3QgKHBvcyA9PSAzKSAgIDw9PiAgIGRyaW5rIGBpc2AgTWlsayAgICAgICAgICAgICAtLSAgOQogICAgLCBjb25zdCAocG9zID09IDEpICAgPD0+ICAgbWFuICAgYGlzYCBOb3IgICAgICAgICAgICAgIC0tIDEwCiAgICAsIGRyaW5rIGBpc2AgQmVlciAgICA8PT4gICBzbW9rZSBgaXNgIEJsdWVNYXN0ZXIgICAgICAgLS0gMTMKICAgICwgbWFuICAgYGlzYCBHZXIgICAgIDw9PiAgIHNtb2tlIGBpc2AgUHJpbmNlICAgICAgICAgICAtLSAxNAogICAgXQogICAgd2hlcmUKICAgICAgaW5maXggNCA8PT4KICAgICAgcCA8PT4gcSAgPSAgcCBob3VzZSA9PSBxIGhvdXNlICAgLS0gYm90aCBUcnVlIG9yIGJvdGggRmFsc2UKCgppcyA6OiBFcSBhID0+IChIb3VzZSAtPiBhKSAtPiBhIC0+IEhvdXNlIC0+IEJvb2wKKHRyYWl0IGBpc2AgdmFsdWUpIGhvdXNlICA9ICB0cmFpdCBob3VzZSA9PSB2YWx1ZQoKCmZpbmFsQ2hlY2sgOjogW0hvdXNlXSAtPiBCb29sCmZpbmFsQ2hlY2sgc29sdXRpb24gPSBhbmQgICAgICAgICAgICAgICAgICAgIC0tIGZ1bGZpbGxzIHRoZSBydWxlczoKICAgIFsgKGNvbG9yIGBpc2AgR3JlZW4pICAgYGxlZnRPZmAgKGNvbG9yIGBpc2AgV2hpdGUpICAtLSAgNQogICAgLCAoc21va2UgYGlzYCBCbGVuZCAgKSBgbmV4dFRvYCAocGV0ICAgYGlzYCBDYXRzICkgIC0tIDExCiAgICAsIChzbW9rZSBgaXNgIER1bmhpbGwpIGBuZXh0VG9gIChwZXQgICBgaXNgIEhvcnNlKSAgLS0gMTIKICAgICwgKGNvbG9yIGBpc2AgQmx1ZSAgICkgYG5leHRUb2AgKG1hbiAgIGBpc2AgTm9yICApICAtLSAxNQogICAgLCAoc21va2UgYGlzYCBCbGVuZCAgKSBgbmV4dFRvYCAoZHJpbmsgYGlzYCBXYXRlcikgIC0tIDE2CiAgICBdCiAgICB3aGVyZQogICAgICBuZXh0VG8gOjogKEhvdXNlIC0+IEJvb2wpIC0+IChIb3VzZSAtPiBCb29sKSAtPiBCb29sCiAgICAgIG5leHRUbyBwIHEgPSBsZWZ0T2YgcCBxIHx8IGxlZnRPZiBxIHAKICAgICAgbGVmdE9mIHAgcSAKICAgICAgICAgIHwgKF86aDpfKSA8LSBkcm9wV2hpbGUgKG5vdCAuIHApIHNvbHV0aW9uID0gcSBoCiAgICAgICAgICB8IG90aGVyd2lzZSAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICA9IEZhbHNl
stdout
House {color = Yellow, man = Nor, pet = Cats, drink = Water, smoke = Dunhill}
House {color = Blue, man = Dan, pet = Horse, drink = Tea, smoke = Blend}
House {color = Red, man = Eng, pet = Birds, drink = Milk, smoke = PallMall}
House {color = Green, man = Ger, pet = Zebra, drink = Coffee, smoke = Prince}
House {color = White, man = Swe, pet = Dog, drink = Beer, smoke = BlueMaster}
----
No More Solutions