3 files changed, 127 insertions(+), 11 deletions(-)

M 2023/07.hs
M lib/Qulude.hs
M templates/template.hs

@@ 18,10 18,26 @@ import qualified Data.Maybe as Maybe
 import qualified Data.Sequence as Seq
 import qualified Data.Set as Set
 
-data Card = Ace | King | Queen | Jack | Joker | Num Int
-  deriving ( Show, Eq )
+data Card = Ace | King | Queen | Jack | Num Int
+  deriving Eq
 type Hand = [Card]
 
+instance Show Card where
+  show Ace = "A"
+  show King = "K"
+  show Queen = "Q"
+  show Jack = "J"
+  show (Num 10) = "T"
+  show (Num i) = show i
+
+instance Ord Card where
+  _ <= Ace = True
+  c <= King = c `notElem` [ Ace ]
+  c <= Queen = c `notElem` [ Ace, King ]
+  c <= Jack = c `notElem` [ Ace, King, Queen ]
+  Num c0 <= Num c1 = c0 <= c1
+  _ <= Num c1 = False
+
 type Parse = [(Hand, Int)]
 parser :: Parser Parse
 parser = many $ do


@@ 32,20 48,119 @@ parser = many $ do
   return (hand, bid)
   where cardP = (char 'A' $> Ace)
             <|> (char 'K' $> King)
-            <|> (char 'Q' $> King)
-            <|> (char 'T' $> Jack)
-            <|> (char 'J' $> Joker)
+            <|> (char 'Q' $> Queen)
+            <|> (char 'J' $> Jack)
+            <|> (char 'T' $> Num 10)
             <|> (digit <&> Num . read . flip (:) [])
 
-partA :: Parse -> Parse
-partA = id
+cards = [ Ace, King, Queen, Jack ] ++ [ Num i | i <- [2..10] ]
+
+data Type = Five Card
+          | Four Card
+          | FullHouse Card Card
+          | Three Card
+          | TwoPair Card Card
+          | OnePair Card
+          | High Card
+  deriving ( Show, Eq )
+
+instance Ord Type where
+  Five c <= Five d = c <= d
+  _ <= Five _ = True
+
+  Five _ <= Four _ = False
+  Four c <= Four d = c <= d
+  _ <= Four _ = True
+
+  Five _ <= FullHouse _ _ = False
+  Four _ <= FullHouse _ _ = False
+  FullHouse c0 c1 <= FullHouse d0 d1 = if c0 == d0 then c1 <= d1 else c0 <= d0
+  _ <= FullHouse _ _ = True
+
+  Five _ <= Three _ = False
+  Four _ <= Three _ = False
+  FullHouse _ _ <= Three _ = False
+  Three c <= Three d = c <= d
+  _ <= Three _ = True
+
+  Five _ <= TwoPair _ _ = False
+  Four _ <= TwoPair _ _ = False
+  FullHouse _ _ <= TwoPair _ _ = False
+  Three _ <= TwoPair _ _ = False
+  TwoPair c0 c1 <= TwoPair d0 d1 = if c0 == d0 then c1 <= d1 else c0 <= d0
+  _ <= TwoPair _ _ = True
+
+  Five _ <= OnePair _ = False
+  Four _ <= OnePair _ = False
+  FullHouse _ _ <= OnePair _ = False
+  Three _ <= OnePair _ = False
+  TwoPair _ _ <= OnePair _ = False
+  OnePair c <= OnePair d = c <= d
+  _ <= OnePair d = True
+
+  High c <= High d = c <= d
+  _ <= High _ = False
+
+maxMaybe :: Ord a => [a] -> Maybe a
+maxMaybe [] = Nothing
+maxMaybe as = Just . last $ List.sort as
+
+sameType :: Type -> Type -> Bool
+sameType (Five _) (Five _) = True
+sameType (Four _) (Four _) = True
+sameType (FullHouse _ _) (FullHouse _ _) = True
+sameType (Three _) (Three _) = True
+sameType (TwoPair _ _) (TwoPair _ _) = True
+sameType (OnePair _) (OnePair _) = True
+sameType (High _) (High _) = True
+sameType _ _ = False
+
+judge :: Hand -> Maybe Type
+judge h = maxMaybe $ good
+  where cs = [ (c, count $ (==) c <$> h) | c <- cards ]
+        fives = fmap Five $ mapMaybe (\(c, i) -> if i == 5 then Just c else Nothing) cs
+        fours = fmap Four $ mapMaybe (\(c, i) -> if i == 4 then Just c else Nothing) cs
+        threes = mapMaybe (\(c, i) -> if i == 3 then Just c else Nothing) cs
+        pairs = reverse . List.sort $ mapMaybe (\(c, i) -> if i == 2 then Just c else Nothing) cs
+        (twopairs, fullhouse) = case (threes, pairs) of
+                                (t:_, p:_) -> ([], [FullHouse t p])
+                                ([], p:q:_) -> ([], [TwoPair p q])
+                                (_, _) -> ([], [])
+        good = fives
+            ++ fours
+            ++ (fmap Three threes)
+            ++ fullhouse
+            ++ (fmap Three threes)
+            ++ twopairs
+            ++ (fmap OnePair pairs)
+
+        t2c (Five c) = [c]
+        t2c (Four c) = [c]
+        t2c (FullHouse c d) = [c, d]
+        t2c (Three c) = [c]
+        t2c (TwoPair c d) = [c, d]
+        t2c (OnePair c) = [c]
+        t2c (High c) = [c]
+
+        highest = fmap High $ filter (\c -> c `notElem` (concat (fmap t2c good))) h
+
+camel :: Hand -> Hand -> Ordering
+camel h0 h1 = cmp (judge h0) (judge h1)
+  where cmp (Just p) (Just q) = if sameType p q then compare h0 h1 else compare p q
+        cmp Nothing (Just _) = LT
+        cmp (Just _) Nothing = GT
+        cmp Nothing Nothing = compare h0 h1
+
+partA :: Parse -> Int
+partA hs = foldl (+) 0 $ fmap (\(r, b) -> r * b) $ zip [1..] $ fmap snd $ js
+  where js = List.sortBy (\(h0, _) (h1, _) -> camel h0 h1) hs
 
 --partB :: Parse -> Parse
 --partB = id
 
 main :: IO ()
 main = with parser $ do
-  run "07.example" "a example" partA
-  run "07.input" "a input" partA
+  run "07.example" "a example" partA -- 6440
+  run "07.input" "a input" partA -- 245794640
   --run "07.example" "b example" partB
   --run "07.input" "b input" partB

@@ 48,6 48,7 @@ module Qulude ( module Prelude
               , fromMaybe
               , catMaybes
               , mapMaybe
+              , listToMaybe
 
               , swap
 


@@ 68,7 69,7 @@ import Prelude hiding ( lines, cycle )
 
 import Data.List ( (\\), foldl' )
 import Data.Sequence ( (><), (<|), (|>), Seq ( (:<|), (:|>) ) )
-import Data.Maybe ( fromJust, fromMaybe, catMaybes, mapMaybe )
+import Data.Maybe ( fromJust, fromMaybe, catMaybes, mapMaybe, listToMaybe )
 import Data.Tuple ( swap )
 import Data.Function ( (&) )
 import Data.Either

@@ 12,7 12,7 @@ import qualified Data.Array as Array
 import qualified Data.Array.ST as STArray
 import qualified Data.Either as Either
 import qualified Data.List as List
---import Data.Array ( (!) )
+--import Data.Map ( (!) )
 import qualified Data.Map as Map
 import qualified Data.Maybe as Maybe
 import qualified Data.Sequence as Seq