Home

PureScript solution to Project Euler problem 54

2022-Mar-31 15:36
purescriptproject-euler

Problem details at Project Euler problem 54 page.

Test

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
module Euler054Test (euler54suite) where
 
import Prelude
 
import Data.Either (Either(..))
import Effect.Class (liftEffect)
import Euler054 (euler54, score)
import Test.Unit (TestSuite, suite, test)
import Test.Unit.Assert as Assert
 
euler54suite :: TestSuite
euler54suite =
  suite "Euler 54" do
    test "Warmup" do
      let text =
            """
            5H 5C 6S 7S KD 2C 3S 8S 8D TD
            5D 8C 9S JS AC 2C 5C 7D 8S QH
            2D 9C AS AH AC 3D 6D 7D TD QD
            4D 6S 9H QH QC 3D 6D 7H QD QS
            2H 2D 4C 4D 4S 3C 3D 3S 9S 9D
            """
      Assert.equal (Right 3) (score text)
 
      Assert.equal 3 =<< liftEffect (euler54 "etc/054-poker-warmup.txt")
 
    test "Real" do
      Assert.equal 376 =<< liftEffect (euler54 "etc/054-poker-real.txt")

Solution

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
module Euler054 where
 
import Prelude
 
import Data.Array (all, drop, filter, fromFoldable, group, length, range, reverse, sort, sortBy, take, zip)
import Data.Either (Either, either)
import Data.Map as M
import Data.Maybe (maybe)
import Data.String.CodeUnits (toCharArray)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Unfoldable (replicateA)
import Effect (Effect)
import Effect.Exception (throw)
import Node.Encoding (Encoding(..))
import Node.FS.Sync (readTextFile)
import Text.Parsing.Parser (ParseError, Parser, fail, runParser)
import Text.Parsing.Parser.Combinators (sepBy1)
import Text.Parsing.Parser.String (oneOf, whiteSpace)
 
data Suit = C | D | H | S
 
derive instance suitEq :: Eq Suit
derive instance suitOrd :: Ord Suit
 
data Card = Card Int Suit
 
derive instance cardEq :: Eq Card
derive instance cardOrd :: Ord Card
 
type Hand = Array Card
 
data Round = Round Hand Hand
 
derive instance roundEq :: Eq Round
derive instance roundOrd :: Ord Round
 
parser :: Parser String (Array Round)
parser =
  let valKeys = toCharArray "23456789TJQKA"
      valVals = range 2 14
      valMap = M.fromFoldable $ zip valKeys valVals
      val = oneOf valKeys >>= flip M.lookup valMap
        >>> maybe (fail "val") pure
 
      suitKeys = toCharArray "CDHS"
      suitVals = [C, D, H, S]
      suitMap = M.fromFoldable $ zip suitKeys suitVals
      suit = oneOf suitKeys >>= flip M.lookup suitMap
        >>> maybe (fail "suit") pure
       
      card = Card <$> val <*> suit
      hand = replicateA 5 (card <* whiteSpace)
 
      round = Round <$> (whiteSpace *> hand) <*> hand
  in fromFoldable <$> sepBy1 round whiteSpace
 
parse :: String -> Either ParseError (Array Round)
parse = flip runParser parser
 
cardSuit :: Card -> Suit
cardSuit (Card _ s) = s
 
cardSuits :: Hand -> Array Suit
cardSuits h = cardSuit <$> h
 
cardVal :: Card -> Int
cardVal (Card v _) = v
 
cardVals :: Hand -> Array Int
cardVals h = cardVal <$> h
 
sameSuit :: Hand -> Boolean
sameSuit h = 1 == (length $ group $ cardSuits h)
 
consecutive :: Array Int -> Boolean
consecutive a = all (\(Tuple j k) -> j + 1 == k) $ zip a (drop 1 a)
 
data HandFreq = HandFreq (Array (Tuple Int Card))
 
freq :: Array Card -> Array Int
freq cs =
  let c j k = cardVal j == cardVal k
      f j = length $ filter (c j) cs
  in map f cs
 
sortHandFreq :: Hand -> HandFreq
sortHandFreq h =
  let cf = zip (freq h) h
  in HandFreq $ sortBy (comparing fst <> comparing snd) cf
 
handRank :: Hand -> Array Int
handRank h =
  let hs = sort h
      HandFreq hsf = sortHandFreq h
      hr
        | sameSuit hs && cardVals hs == [14, 13, 12, 11, 10] = [10]
        | sameSuit hs && consecutive (cardVals hs) = [9]
            <> cardVals (drop 4 (map snd hsf))
        | map fst hsf == [1, 4, 4, 4, 4] = [8]
            <> cardVals (take 1 (map snd hsf))
        | map fst hsf == [2, 2, 3, 3, 3] = [7]
            <> cardVals (drop 2 (map snd hsf))
            <> cardVals (take 2 (map snd hsf))
        | sameSuit hs = [6]
            <> cardVals (drop 4 hs)
        | consecutive (cardVals hs) = [5]
            <> cardVals (drop 4 hs)
        | map fst hsf == [1, 1, 3, 3, 3] = [4]
            <> cardVals (drop 2 (map snd hsf))
            <> reverse (cardVals (take 2 (map snd hsf)))
        | map fst hsf == [1, 2, 2, 2, 2] = [3]
            <> cardVals (drop 3 (map snd hsf))
            <> reverse (cardVals (take 3 (map snd hsf)))
        | map fst hsf == [1, 1, 1, 2, 2] = [2]
            <> cardVals (drop 3 (map snd hsf))
            <> reverse (cardVals (take 3 (map snd hsf)))
        | otherwise = [1]
            <> reverse (cardVals hs)
  in hr
 
p1won :: Round -> Boolean
p1won (Round j k) = handRank j > handRank k
 
score :: String -> Either ParseError Int
score = pure <<< length <<< filter p1won <=< parse
 
euler54 :: String -> Effect Int
euler54 fn = do
  t <- readTextFile UTF8 fn
  either (throw <<< show) pure (score t)