ShortestLongest

README.md

Solution to Shortest Longest, adapting my lazy length monoid into a monoid transformer.

Lib.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall -Wextra -Werror -Wno-name-shadowing -Wno-unused-top-binds #-}

module Lib
  ( shortestLongest,
  )
where

import Data.Coerce (coerce)
import Data.Foldable (fold)
import Data.Function (fix)
import Data.List (genericLength, genericSplitAt)
import Data.Monoid (Endo (..))

shortestLongest :: [[[a]]] -> [[a]]
shortestLongest = (`appEndo` []) . getDelay . earliest . map (latest . map logLength)

-- incrementally count the length of a list in exponentially larger chunks
logLength :: forall a. [a] -> Delay (Endo [[a]])
logLength bs = case bs of
  [] -> When 0 m
  _ : as -> Then (loop 2 as)
  where
    m = Endo (bs :)

    loop :: Integer -> [a] -> Delay (Endo [[a]])
    loop counted uncounted = case genericSplitAt (counted - 1) uncounted of
      (remaining, []) -> When (genericLength remaining) m
      (_, _ : uncounted) -> Then (loop (counted * 2) uncounted)

latest :: forall m. Monoid m => [Delay m] -> Delay m
latest = coerce (fold @[] @(Later m))

earliest :: forall m. Monoid m => [Delay m] -> Delay m
earliest = coerce (fold @[] @(Earlier m))

getDelay :: Delay m -> m
getDelay (Then d) = getDelay d
getDelay (When _ m) = m

data Delay m where
  When :: !Integer -> m -> Delay m
  Then :: Delay m -> Delay m

newtype Later m = Later {getLater :: Delay m}

instance Semigroup m => Semigroup (Later m) where
  (<>) = coerce later
    where
      later :: Delay m -> Delay m -> Delay m
      later a@(When u am) b@(When v bm) = case compare u v of
        LT -> b
        EQ -> When u (am <> bm)
        GT -> a
      later (When _ _) b = b
      later a (When _ _) = a
      later (Then a) (Then b) = Then (later a b)

instance Monoid m => Monoid (Later m) where
  mempty = Later (When 0 mempty)

newtype Earlier m = Earlier {getEarlier :: Delay m}

instance Semigroup m => Semigroup (Earlier m) where
  (<>) = coerce earlier
    where
      earlier :: Delay m -> Delay m -> Delay m
      earlier (Then a) (Then b) = Then (earlier a b)
      earlier (Then _) b = b
      earlier a (Then _) = a
      earlier a@(When u am) b@(When v bm) = case compare u v of
        LT -> a
        EQ -> When u (am <> bm)
        GT -> b

instance Monoid m => Monoid (Earlier m) where
  mempty = Earlier (fix Then)