Jindosh

jindosh.lhs

---
title:  Jindosh puzzle  
author: David Baynard  
date:   16 Jan 2019  
fontfamily:   libertine
csl:    chemical-engineering-science.csl
link-citations: true
abstract: |  
  
...

# Puzzle

Lady winslow, Doctor Marcolla, Countess Contee, Madam Natsiou, Baroness Finch

Row, different colours

Baroness Finch wore a jaunty red hat
Madam Natsiou was at the far left, next to the guest wearing a green Jacket
The lady in blue sat left of someone in purple
Blue spilled beer
Fraeport in white
Ring next to Fraeport
Winslow Bird pendant
Dabovka diamond
‘Someone else carried a valuable snuff tin and when she saw it, the visitor from Dunwall next to her almost spilled her neighbor’s whiskey’
Contee rum
‘The lady from Karnaca, full of absinthe, jumped up onto the table, falling onto the guest in the center seat, spilling the poor woman’s wine’
Doc Marcolla Baleton
Four heirlooms under the table: ring, war medal, diamond, snuff tin

Who owned each?

# Solution

## Preamble

```haskell
{-# LANGUAGE ApplicativeDo    #-}
{-# LANGUAGE DeriveAnyClass   #-}
{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE DerivingVia      #-}
{-# LANGUAGE NamedFieldPuns   #-}
{-# LANGUAGE OverloadedLists  #-}
{-# LANGUAGE TypeApplications #-}

module Main where

import           Control.Applicative
import           Control.Monad                         (guard, join)
import           Data.Bifunctor
import           Data.Foldable                         (find, for_)
import           Data.List                             (permutations)
import           Data.List.NonEmpty                    (NonEmpty, xor)
import           Data.Maybe                            (fromMaybe)
import           Data.Text.Prettyprint.Doc
import           Data.Text.Prettyprint.Doc.Render.Text
import           GHC.Generics                          (Generic)
```

## Evaluate

```haskell
main :: IO ()
main = solutions `for_` \s -> do
  (putDoc . solved) s
  putStr "\n"

solutions :: [ComboSet]
solutions = do
  let c0s = filter validateSingle allCombo
  farLeft <- c0s
  let c1s = filter (apart farLeft) c0s
  leftOfC <- c1s
  let c2s = filter (apart leftOfC) c1s
  centre <- c2s
  let c3s = filter (apart centre) c2s
  rightOfC <- c3s
  let c4s = filter (apart rightOfC) c3s
  farRight <- c4s
  let cs = ComboSet{farLeft, leftOfC, centre, rightOfC, farRight}
  guard $ validateSet cs
  guard $ validateRelation cs
  pure cs

solved :: ComboSet -> Doc a
solved ComboSet{farLeft, leftOfC, centre, rightOfC, farRight} = vsep
  [ prettyList $
    [ lady farLeft
    , lady leftOfC
    , lady centre
    , lady rightOfC
    , lady farRight
    ]
  , prettyList $
    [ heirloom farLeft
    , heirloom leftOfC
    , heirloom centre
    , heirloom rightOfC
    , heirloom farRight
    ]
  ]
```

## Data types

```haskell
data Combo = Combo
  { lady     :: Lady
  , colour   :: Colour
  , heirloom :: Heirloom
  , drink    :: Drink
  , city     :: City
  }
  deriving (Show, Eq, Ord)

instance Pretty Combo where
  pretty Combo{lady, colour, heirloom, drink, city} = align . vsep $
    [ pretty lady, pretty colour, pretty heirloom, pretty drink, pretty city
    ]

data ComboSet = ComboSet
  { farLeft  :: Combo
  , leftOfC  :: Combo
  , centre   :: Combo
  , rightOfC :: Combo
  , farRight :: Combo
  }
  deriving (Show, Eq, Ord)

instance Pretty ComboSet where
  pretty ComboSet{farLeft, leftOfC, centre, rightOfC, farRight} = fillSep . fmap (indent 6) $
    [pretty farLeft, pretty leftOfC, pretty centre, pretty rightOfC, pretty farRight]

(=~) :: Eq a => (s -> a) -> a -> s -> Bool
-- (=~) acc v = (== v) . acc
(=~) = flip $ (.) . (==)
infix 8 =~

apart :: Combo -> Combo -> Bool
apart x y = and @[]
  [ lady x     /= lady y
  , colour x   /= colour y
  , heirloom x /= heirloom y
  , drink x    /= drink y
  , city x     /= city y
  ]
```

```haskell
newtype Showing a = Showing a

instance Show a => Pretty (Showing a) where
  pretty (Showing a) = viaShow a
```

### Ladies

```haskell
data Lady = LadyWinslow | DoctorMarcolla | CountessContee | MadamNatsiou | BaronessFinch
  deriving (Eq, Ord, Enum, Bounded)
  deriving (Pretty) via Showing Lady

instance Show Lady where
  show LadyWinslow    = "Lady Winslow"
  show DoctorMarcolla = "Doctor Marcolla"
  show CountessContee = "Countess Contee"
  show MadamNatsiou   = "Madam Natsiou"
  show BaronessFinch  = "Baroness Finch"
```

### Seats

``` {.haskell .ignore}
data Seat = LL | LC | CC | RC | RR
  deriving (Eq, Ord, Enum, Bounded, Show, Pretty)

isNextTo :: Combo -> Combo -> Bool
isNextTo = curry $ (== 1) . abs . uncurry subtract . join bimap (fromEnum . seat)

isLeftOf :: Combo -> Combo -> Bool
isLeftOf = curry $ uncurry (<) . join bimap seat
```

### Colours

```haskell
data Colour = Red | Green | Blue | White | Purple
  deriving (Eq, Ord, Enum, Bounded, Show)
  deriving (Pretty) via Showing Colour
```

### Heirlooms

```haskell
data Heirloom = Pendant | Diamond | SnuffTin | Ring | WarMedal
  deriving (Eq, Ord, Enum, Bounded)
  deriving (Pretty) via Showing Heirloom

instance Show Heirloom where
  show Pendant   = "Bird Pendant"
  show Diamond   = "Diamond"
  show SnuffTin  = "Snuff Tin"
  show Ring      = "Ring"
  show WarMedal  = "WarMedal"
```

### Drinks

```haskell
data Drink = Whisky | Beer | Wine | Absinthe | Rum
  deriving (Eq, Ord, Enum, Bounded, Show)
  deriving (Pretty) via Showing Drink
```

### Cities

```haskell
data City = Fraeport | Dabovka | Baleton | Karnaca | Dunwall
  deriving (Eq, Ord, Enum, Bounded, Show)
  deriving (Pretty) via Showing City
```

## Logic

| Link           | Link                |
|----------------|---------------------|
| BaronessFinch  | Red                 |
| MadamNatsiou   | LL                  |
| LC             | Green               |
| seat Blue      | left of seat Purple |
| Blue           | Beer                |
| Fraeport       | White               |
| Ring           | next to Fraeport    |
| LadyWinslow    | Pendant             |
| Dabovka        | Diamond             |
| CountessContee | Rum                 |
| DoctorMarcolla | Baleton             |
| CC             | Wine                |
| Dunwall        | next to SnuffTin    |
| Dunwall        | next to Whisky      |
| Karnaca        | Absinthe            |
| Karnaca        | not CC              |

Ambiguities

-   Dunwall (next to Snufftin) neighbour's whisky

    Possible SnuffTin and Whiskey are together (seems to be the case)

### Validating Combos

```haskell
validateSingle :: Combo -> Bool
validateSingle c@Combo{lady, colour, heirloom, drink, city} = and @[]
  [ xnor [lady == BaronessFinch, colour == Red]
  , xnor [colour == Blue, drink == Beer]
  , xnor [city == Fraeport, colour == White]
  , xnor [lady == LadyWinslow, heirloom == Pendant]
  , xnor [city == Dabovka, heirloom == Diamond]
  , xnor [lady == CountessContee, drink == Rum]
  , xnor [lady == DoctorMarcolla, city == Baleton]
  , xnor [city == Karnaca, drink == Absinthe]
  , xnor [drink == Whisky, heirloom == SnuffTin]
  -- , xnor [lady == MadamNatsiou, seat == LL]
  -- , xnor [seat == LC, colour == Green]
  -- , xnor [seat == CC, drink == Wine]
  -- , xnor [city == Karnaca, seat /= CC]
  ]
```

### Validating ComboSets

```haskell
isNextTo :: (Combo -> Bool) -> (Combo -> Bool) -> ComboSet -> Bool
isNextTo f g = (||) <$> f `isLeftOf` g <*> g `isLeftOf` f
infix 5 `isNextTo`

isLeftOf :: (Combo -> Bool) -> (Combo -> Bool) -> ComboSet -> Bool
isLeftOf f g ComboSet{farLeft, leftOfC, centre, rightOfC, farRight} = or @[]
  [ f farLeft  && g leftOfC
  , f leftOfC  && g centre
  , f centre   && g rightOfC
  , f rightOfC && g farRight
  ]
infix 5 `isLeftOf`

validateSet :: ComboSet -> Bool
validateSet ComboSet{farLeft, leftOfC, centre, rightOfC, farRight} = and @[]
  [ lady farLeft   == MadamNatsiou
  , colour leftOfC == Green
  , drink centre   == Wine
  , city centre    /= Karnaca
  ]
```

```haskell
validateRelation :: ComboSet -> Bool
validateRelation cs = and @[]
  [ city =~ Dunwall `isNextTo` heirloom =~ SnuffTin $ cs
  , city =~ Dunwall `isNextTo` drink =~ Whisky      $ cs
  , city =~ Fraeport `isNextTo` heirloom =~ Ring    $ cs
  , colour =~ Blue `isLeftOf` colour =~ Purple      $ cs
  ]
```

``` {.haskell .ignore}
validateRelation :: ComboSet -> Bool
validateRelation c@(ComboSet cs) = and @[]
  [ (city =~ Dunwall, heirloom =~ SnuffTin) `relation` isNextTo $ cs
  , (city =~ Dunwall, drink =~ Whisky)      `relation` isNextTo $ cs
  , (city =~ Fraeport, heirloom =~ Ring)    `relation` isNextTo $ cs
  , (colour =~ Blue, colour =~ Purple)      `relation` isNextTo $ cs
  ]
```

### Helpers

```haskell
-- | Ensures that either every item in the list is true, or every item is false
--
-- TODO This is based on n-ary xnor i.e. true when even number of truths
guarding :: Alternative f => NonEmpty Bool -> f ()
guarding = guard . xnor

-- | N-ary xnor
xnor :: NonEmpty Bool -> Bool
xnor = not . xor

-- | Compare the combos matching the supplied filters using the supplied comparator
guardRelation :: Alternative f => ((c -> Bool), (c -> Bool)) -> (c -> c -> Bool) -> [c] -> f ()
guardRelation (f, g) cmp cs = maybe empty guard $
  cmp <$> find f cs <*> find g cs
infix 2 `guardRelation`

-- | Compare the combos matching the supplied filters using the supplied comparator
relation :: ((c -> Bool), (c -> Bool)) -> (c -> c -> Bool) -> [c] -> Bool
relation (f, g) cmp cs = fromMaybe False $
  cmp <$> find f cs <*> find g cs
infix 2 `relation`
```

## Generating values

### Helpers

```haskell
universe :: (Enum a, Bounded a) => [a]
universe = [minBound .. maxBound]

permUniverse :: (Enum a, Bounded a) => [[a]]
permUniverse = permutations universe
```

### Combos

```haskell
allCombo :: [Combo]
allCombo = do
  lady     <- universe @Lady
  colour   <- universe @Colour
  heirloom <- universe @Heirloom
  drink    <- universe @Drink
  city     <- universe @City
  pure Combo{lady, colour, heirloom, drink, city}
```

### Combosets

``` {.haskell .ignore}
allComboSet :: [ComboSet]
allComboSet = do
  ladies    <- permUniverse @Lady
  colours   <- permUniverse @Colour
  heirlooms <- permUniverse @Heirloom
  drinks    <- permUniverse @Drink
  cities    <- permUniverse @City
```

`ApplicativeDo` is needed for this `ZipList example`.

``` {.haskell .ignore}
  pure . ComboSet . getZipList $ do
    lady     <- ZipList ladies
    seat     <- ZipList seats
    colour   <- ZipList colours
    heirloom <- ZipList heirlooms
    drink    <- ZipList drinks
    city     <- ZipList cities
    pure Combo{lady, colour, heirloom, drink, city}
```

With `ParallelListComp` it would be possible to use the following, instead:

``` { .haskell .ignore }
  pure . ComboSet $
    [ Combo{lady, seat, colour, heirloom, drink, city}
      | lady     <- ladies
      | seat     <- seats
      | colour   <- colours
      | heirloom <- heirlooms
      | drink    <- drinks
      | city     <- cities
    ]
```