Solutions to SWUNG "kata challenges"

boreholes.hs

-- https://kata.geosci.ai/challenge/boreholes

import Text.Read (readMaybe)
import Data.Array -- Array sucks, but I want to stay inside the standard library
import Data.List (sort)

{- terrible hack! the problem syntax just happens to look
 - like the innards of a Haskell list.
 -}
parseBoreholes :: String -> Maybe [(Double, Double)]
parseBoreholes = readMaybe . ('[':) . (++ "]")

distance :: (Double, Double) -> (Double, Double) -> Double
distance (x1, y1) (x2, y2) = sqrt $ (x2 - x1) ** 2 + (y2 - y1) ** 2

distanceArray :: [(Double, Double)] -> Array (Int, Int) Double
distanceArray bs = array ((0, 0), (length bs - 1, length bs - 1)) $ do
  (i, b1) <- zip [0..] bs
  (j, b2) <- zip [i..] $ drop i bs
  let dist = distance b1 b2
  [((i, j), dist), ((j, i), dist)]

mean :: Fractional a => [a] -> a
mean xs = sum xs / fromIntegral (length xs)

countClump :: Int -> Double -> Array (Int, Int) Double -> Int
countClump n cutoff dists = length $ filter inClump [first..last] where
  ((first, _), (last, _)) = bounds dists
  neighborDists i = [dists ! (i, j) | j <- [first..last], i /= j]
  nearest = take n . sort . neighborDists
  inClump = (< cutoff) . mean . nearest

main :: IO ()
main = do
  maybeBoreholes <- parseBoreholes <$> getLine
  case maybeBoreholes of
    Just boreholes@(b1:b2:_) -> do
      let dists = distanceArray boreholes
          n = length boreholes
          m = mean $ filter (/= 0.0) $ elems dists
          clumpNeighbors = n `div` 5
          clumpCutoff = fromIntegral (round m) / 4 -- wacky
      putStr "Borehole count: "
      print n
      putStr "B1-to-B2 distance: "
      print $ round $ distance b1 b2
      putStr "Average distance: "
      print $ round m
      putStr "Clump count: "
      print $ countClump clumpNeighbors clumpCutoff dists
    _ -> putStrLn "invalid input"

samplenames.hs

-- https://kata.geosci.ai/challenge/sample-names
{-# LANGUAGE OverloadedStrings #-}

import Data.Maybe (catMaybes, fromMaybe)
import Data.List (sort)
import Data.Time
import Data.Time.Format.ISO8601 (iso8601ParseM)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

data SampleName = SampleName
  { id :: T.Text
  , basin :: T.Text
  , unit :: T.Text
  , kind :: T.Text
  , date :: T.Text
  , prep :: T.Text
  } deriving Show

parseSampleName :: T.Text -> Maybe SampleName
parseSampleName input = case T.splitOn "_" input of
  [id, basin, unit, kind, date, prep] ->
    Just $ SampleName id basin unit kind date prep
  _ -> Nothing

canonical :: T.Text -> T.Text
canonical s =
  let s' = T.toCaseFold s
   in fromMaybe s' $ do
     (first, s'') <- T.uncons s'
     (s''', last) <- T.unsnoc s''
     let middle = T.pack $ sort $ T.unpack s'''
     pure $ T.cons first $ T.snoc middle last

parseISO8601 :: T.Text -> Maybe Day
parseISO8601 = iso8601ParseM . T.unpack

longestGap :: [Day] -> Integer
longestGap [] = 0
longestGap [_] = 0
longestGap (x:y:rest) = max (diffDays y x) $ longestGap (y:rest)

main :: IO ()
main = do
    validSamples <-
      (catMaybes . fmap parseSampleName . T.lines) <$> TIO.getContents
    let ainsaSamples =
          filter ((== (canonical "Ainsa")) . canonical . basin) validSamples
    putStr "valid samples: "
    print $ length validSamples
    putStr "Ainsa matches: "
    print $ length ainsaSamples
    putStr "longest Ainsa gap: "
    print $ -- we count a little differently, hence the - 1
      (longestGap $ catMaybes $ (parseISO8601 . date) <$> ainsaSamples) - 1

sequences.hs

-- https://kata.geosci.ai/challenge/sequences

import qualified Data.Map.Strict as M

data Lithology
  = Mudstone
  | Fine
  | Sandstone
  deriving (Eq, Ord, Show)

lithologyFromCode :: Char -> Maybe Lithology
lithologyFromCode 'M' = Just Mudstone
lithologyFromCode 'F' = Just Fine -- it's just fine
lithologyFromCode 'S' = Just Sandstone
lithologyFromCode _ = Nothing

rle :: Eq a => [a] -> [(Int, a)]
rle [] = []
rle (x:xs) = go 1 x xs where
  go n x [] = [(n, x)]
  go n x (y:rest)
    | x == y = go (n + 1) x rest
    | otherwise = (n, x):(go 1 y rest)

transitionCounts :: (Eq a, Ord a) => [a] -> M.Map (a, a) Int
transitionCounts = go M.empty Nothing where
  go counts _ [] = counts
  go counts Nothing (y:ys) = go counts (Just y) ys
  go counts (Just x) (y:ys)
    | x == y = go counts (Just x) ys
    | otherwise = go (M.insertWith (+) (x, y) 1 counts) (Just y) ys

main :: IO ()
main = do
  maybeLiths <- traverse lithologyFromCode <$> getLine
  case maybeLiths of
    Just liths -> do
       let rleLiths = rle liths
           sands = filter ((== Sandstone) . snd) rleLiths
           counts = transitionCounts liths
       putStr "Total sandstone thickness: "
       print $ sum $ fst <$> sands
       putStr "Total sandstone beds: "
       print $ length sands
       putStr "Highest transition count: "
       print $ maximum $ M.elems counts
    Nothing -> putStrLn "error: invalid lithology sequence"