stardewdle.hs

{-# LANGUAGE LambdaCase #-}

import Data.Functor.Identity (Identity(..))
import Data.List (intercalate, sort)
import Data.Ord (Ordering(..), comparing)

data CropType = Fruit | Vegetable | Flower | Forage
  deriving (Eq, Ord, Show)

data Season = Spring | Summer | Fall | Winter
  deriving (Eq, Ord, Show)

data Crop = Crop
  { cName :: String
  , cGrowth :: Integer
  , cPrice :: Integer
  , cRegrow :: Bool
  , cType :: CropType
  , cSeason :: [Season]
  }
  deriving (Show)

data SeasonDecision = Match | Mismatch | Partial
  deriving (Eq, Ord, Read, Show)

data Decision = Decision
  { dGrowth :: Ordering
  , dPrice :: Ordering
  , dRegrow :: Bool
  , dType :: Bool
  , dSeason :: SeasonDecision
  }
  deriving (Show)

flowers :: [Crop]
flowers =
  [ Crop "Blue Jaz" 7 50 False Flower [Spring]
  , Crop "Crocus" 7 50 False Flower [Winter]
  , Crop "Fairy Rose" 12 290 False Flower [Fall]
  , Crop "Poppy" 7 140 False Flower [Summer]
  , Crop "Summer Spangle" 8 90 False Flower [Summer]
  , Crop "Sunflower" 8 80 False Flower [Summer, Fall]
  , Crop "Sweat Pea" 7 50 False Flower [Summer]
  , Crop "Tulip" 6 30 False Flower [Spring]
  ]

forage :: [Crop]
forage =
  [ Crop "Chanterelle" 4 160 False Forage [Spring, Summer, Fall, Winter]
  , Crop "Common Mushroom" 7 40 False Forage [Fall]
  , Crop "Daffodil" 7 30 False Forage [Spring]
  , Crop "Dandelion" 7 40 False Forage [Spring]
  , Crop "Hazlenut" 7 90 False Forage [Fall]
  , Crop "Leek" 7 60 False Forage [Spring]
  , Crop "Morel" 4 150 False Forage [Spring, Summer, Fall, Winter]
  , Crop "Purple Mushroom" 4 250 False Forage [Spring, Summer, Fall, Winter]
  , Crop "Red Mushroom" 4 75 False Forage [Spring, Summer, Fall, Winter]
  , Crop "Snow Yam" 7 100 False Forage [Winter]
  , Crop "Wild Hoseradish" 7 50 False Forage [Spring]
  , Crop "Winter Root" 7 70 False Forage [Winter]
  ]

fruits :: [Crop]
fruits =
  [ Crop "Ancient Fruit" 28 550 True Fruit [Spring, Summer, Fall]
  , Crop "Apple" 28 100 True Fruit [Fall]
  , Crop "Apricot" 28 50 True Fruit [Spring]
  , Crop "Banana" 28 150 True Fruit [Summer]
  , Crop "Blackberry" 7 20 False Fruit [Fall]
  , Crop "Blueberry" 13 50 True Fruit [Summer]
  , Crop "Cactus Fruit" 12 75 True Fruit [Spring, Summer, Fall, Winter]
  , Crop "Cherry" 28 80 True Fruit [Spring]
  , Crop "Coffee Bean" 10 15 True Fruit [Spring, Summer]
  , Crop "Cranberries" 7 75 True Fruit [Fall]
  , Crop "Crystal Fruit" 7 150 False Fruit [Winter]
  , Crop "Grape" 10 80 True Fruit [Fall]
  , Crop "Hot Pepper" 5 40 True Fruit [Summer]
  , Crop "Mango" 28 130 True Fruit [Summer]
  , Crop "Melon" 12 250 False Fruit [Summer]
  , Crop "Orange" 28 100 True Fruit [Summer]
  , Crop "Peach" 28 140 True Fruit [Summer]
  , Crop "Pineapple" 14 300 True Fruit [Summer]
  , Crop "Pomegranate" 28 140 True Fruit [Fall]
  , Crop "Powdermelon" 7 60 False Fruit [Winter]
  , Crop "Qi Fruit" 4 1 False Fruit [Spring, Summer, Fall, Winter]
  , Crop "Rhubarb" 13 220 False Fruit [Spring]
  , Crop "Spice Berry" 7 80 False Fruit [Summer]
  , Crop "Starfruit" 13 750 False Fruit [Summer]
  , Crop "Strawberry" 8 130 True Fruit [Spring]
  , Crop "Sweet Gem Berry" 24 3000 False Fruit [Fall]
  , Crop "Wild Plum" 7 80 False Fruit [Fall]
  ]

vegetables :: [Crop]
vegetables =
  [ Crop "Amaranth" 7 150 False Vegetable [Fall]
  , Crop "Artichoke" 8 160 False Vegetable [Fall]
  , Crop "Beet" 6 100 False Vegetable [Fall]
  , Crop "Bok Choy" 4 80 False Vegetable [Fall]
  , Crop "Broccoli" 8 70 True Vegetable [Fall]
  , Crop "Carrot" 3 35 False Vegetable [Spring]
  , Crop "Cauliflower" 12 175 False Vegetable [Spring]
  , Crop "Corn" 14 50 True Vegetable [Summer, Fall]
  , Crop "Eggplant" 5 60 True Vegetable [Fall]
  , Crop "Garlic" 4 60 False Vegetable [Spring]
  , Crop "Green Bean" 10 40 True Vegetable [Spring]
  , Crop "Hops" 11 25 True Vegetable [Summer]
  , Crop "Kale" 6 110 False Vegetable [Spring]
  , Crop "Parsnip" 4 35 False Vegetable [Spring]
  , Crop "Potato" 6 80 False Vegetable [Spring]
  , Crop "Pumpkin" 13 320 False Vegetable [Fall]
  , Crop "Radish" 6 90 False Vegetable [Summer]
  , Crop "Red Cabbage" 9 260 False Vegetable [Summer]
  , Crop "Summer Squash" 6 45 True Vegetable [Summer]
  , Crop "Taro Root" 10 100 False Vegetable [Summer]
  , Crop "Tea Leaves" 20 50 True Vegetable [Spring, Summer, Fall]
  , Crop "Tomato" 11 60 True Vegetable [Summer]
  , Crop "Unmilled Rice" 8 30 False Vegetable [Spring]
  , Crop "Wheat" 4 25 False Vegetable [Summer, Fall]
  , Crop "Yam" 10 160 False Vegetable [Fall]
  ]

crops :: [Crop]
crops = flowers ++ forage ++ fruits ++ vegetables

type Oracle = Crop -> Decision
type OracleM m = Crop -> m Decision
type Chooser = [Crop] -> Maybe (Crop, [Crop])
type Trace = [(Crop, Decision, [Crop])]

solve :: Oracle -> Chooser -> [Crop] -> Either Trace Trace
solve oracle choose candidates = runIdentity $ solveM (Identity . oracle) choose candidates

solveM :: Monad m => OracleM m -> Chooser -> [Crop] -> m (Either Trace Trace)
solveM oracle choose = go [] where
  go guesses candidates = case choose candidates of
    Just (guess, candidates') -> oracle guess >>= \decision ->
      let guesses' = (guess, decision, candidates'') : guesses
          candidates'' = filter (decisionFilter decision guess) candidates'
      in if isSuccess decision
         then pure $ Right (reverse guesses')
         else go guesses' candidates''
    -- no valid guesses left, give up
    Nothing -> pure $ Left (reverse guesses)

-- stupid decider just to test
choose :: Chooser
choose (c:cs) = Just (c, cs)
choose [] = Nothing

isSuccess :: Decision -> Bool
isSuccess d = dGrowth d == EQ && dPrice d == EQ && dRegrow d && dType d && dSeason d == Match

decisionFilter :: Decision -> Crop -> Crop -> Bool
decisionFilter d guess c = growthOk && priceOk && regrowOk && typeOk && seasonOk where
  growthOk = dGrowth d == comparing cGrowth c guess
  priceOk = dPrice d == comparing cPrice c guess
  regrowOk = let match = cRegrow c == cRegrow guess in if dRegrow d then match else not match
  typeOk = let match = cType c == cType guess in if dType d then match else not match
  seasonOk = case dSeason d of
    Match -> sort (cSeason guess) == sort (cSeason c)
    -- the target has none of the guess's seasons
    Mismatch -> all (`notElem` cSeason guess) (cSeason c)
    -- guess and target have at least one season in common
    Partial -> any (`elem` cSeason guess) (cSeason c)

knownOracle :: Crop -> Oracle
knownOracle target guess = Decision
  { dGrowth = comparing cGrowth target guess
  , dPrice = comparing cPrice target guess
  , dRegrow = cRegrow target == cRegrow guess
  , dType = cType target == cType guess
  , dSeason =
      if sort (cSeason target) == sort (cSeason guess)
      then Match
      else if any (`elem` cSeason target) (cSeason guess)
           then Partial
           else Mismatch
  }

interactiveOracle :: OracleM IO
interactiveOracle guess = do
  putStrLn "== GUESS =="
  print guess
  putStrLn ""
  putStrLn "Growth Comparison (LT, EQ, GT): "
  dGrowth <- readLn
  putStrLn "Price Comparison (LT, EQ, GT): "
  dPrice <- readLn
  putStrLn "Regrow Comparison (True, False): "
  dRegrow <- readLn
  putStrLn "Type Comparison (True, False): "
  dType <- readLn
  putStrLn "Season Comparison (Match, Partial, Mismatch): "
  dSeason <- readLn
  pure $ Decision dGrowth dPrice dRegrow dType dSeason

printTrace :: Trace -> IO ()
printTrace = mapM_ go where
  go (guess, decision, remaining) = putStrLn $ "GUESS: " ++ guess' ++ " - " ++ decision' ++ " - remaining: " ++ remaining' where
    guess' = cName guess
    decision' = show decision
    remaining' = intercalate ", " $ map cName remaining

main :: IO ()
main = solveM interactiveOracle choose crops >>= \case
  Right trc -> putStrLn $ "SOLVED in " ++ show (length trc) ++ " guesses"
  Left _ -> putStrLn "NO SOLUTION"