praxis

commit 949a0ad5e1180ce8a9f8afbbb230a55099df6dae
parent 2b44bfc32034fb7a92779dee26aca673305068df
Author: Jared Tobin <jared@jtobin.ca>
Date:   Fri,  6 Jul 2018 19:38:47 +1200

Add top five scores exercise.

Diffstat:
M
20180529_blockchain/Blockchain.hs
 | 
24
++++++++++++------------
A
20180706_scores/Scores.hs
 | 
57
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++

2 files changed, 69 insertions(+), 12 deletions(-)
diff --git a/20180529_blockchain/Blockchain.hs b/20180529_blockchain/Blockchain.hs
@@ -64,14 +64,14 @@ genesis = Block {..} where
 
 adjoin :: String -> Blockchain -> Maybe Blockchain
 adjoin str Blockchain {..} = case chain of
-    [] -> Nothing
-    (Block {..} : _) -> Just $
-      let nindex = succ index
-          ndatum = str
-          nphash = chash
-          nchash = hash16 (show nindex <> ndatum <> nphash)
-          block  = Block nindex ndatum nphash nchash
-      in  Blockchain (block : chain)
+  [] -> Nothing
+  (Block {..} : _) -> Just $
+    let nindex = succ index
+        ndatum = str
+        nphash = chash
+        nchash = hash16 (show nindex <> ndatum <> nphash)
+        block  = Block nindex ndatum nphash nchash
+    in  Blockchain (block : chain)
 
 validate :: Blockchain -> Bool
 validate Blockchain {..} = L.foldl' alg True chain where
@@ -80,7 +80,7 @@ validate Blockchain {..} = L.foldl' alg True chain where
     | otherwise = error ("invalid block: " <> show block)
 
 test :: Blockchain
-test = do
+test =
   let gen = Blockchain [genesis]
 
       bchain =
@@ -89,9 +89,9 @@ test = do
         >>= adjoin "jared sends rachel one buck"
         >>= adjoin "rachel sends shawn one buck"
 
-  case bchain of
-    Nothing -> error "impossible"
-    Just bc -> bc
+  in  case bchain of
+        Nothing -> error "impossible"
+        Just bc -> bc
 
 main :: IO ()
 main = do
diff --git a/20180706_scores/Scores.hs b/20180706_scores/Scores.hs
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
+import qualified Control.Foldl as F
+import qualified Data.Heap as H
+import qualified Data.Map.Strict as MS
+
+accrue :: (Ord k, Ord a, Num a) => F.Fold (k, a) (MS.Map k (H.Heap a))
+accrue = F.Fold alg mempty id where
+  alg !acc (name, score) =
+    let updater = \case
+          Nothing -> Just (H.singleton score)
+          Just sc -> Just (
+            if   H.size sc >= 5
+            then case H.uncons sc of
+                   Nothing     -> error "impossible"
+                   Just (m, h) ->
+                     if   m < score
+                     then H.insert score h
+                     else sc
+            else H.insert score sc)
+
+    in  MS.alter updater name acc
+
+-- | Slightly different from spec: calculates average top scores, but using a
+--   *maximum* of five scores (not at least five scores).
+topFiveAvg
+  :: (Foldable f, Ord k, Ord b, Fractional b)
+  => f (k, b) -> MS.Map k b
+topFiveAvg = fmap (F.fold F.mean) . F.fold accrue
+
+test :: [(String, Double)]
+test = [
+    ("Jared", 72)
+  , ("Jared", 71)
+  , ("Jared", 81)
+  , ("Jared", 65)
+  , ("Jared", 51)
+  , ("Jared", 62)
+  , ("Jared", 78)
+  , ("Jared", 14)
+  , ("Shawn", 95)
+  , ("Shawn", 98)
+  , ("Shawn", 89)
+  , ("Shawn", 81)
+  , ("Shawn", 98)
+  , ("Shawn", 91)
+  , ("Shawn", 76)
+  , ("Rachel", 99)
+  , ("Rachel", 99)
+  , ("Rachel", 100)
+  , ("Rachel", 81)
+  ]
+
+main :: IO ()
+main = print (topFiveAvg test)