1i [
1,$ {
	s/^/[/
	s/$/], /
}
$i ]
$d

import "lib/github.com/diku-dk/sorts/radix_sort"

def (&&&) 'a 'b 'c (f: a -> b) (g: a -> c) (x: a): (b, c) = (f x, g x)
def odd (x: i64): bool = x % 2 == 1

def count 'a (f: a -> bool) (xs: []a): i64
  = map (f >-> i64.bool) xs |> reduce_comm (+) 0

def coordinateFromArray (as: [2]i64): (i64, i64)
  = (as[0], as[1])

def maximum = reduce_comm i64.max i64.lowest
def minimum = reduce_comm i64.min i64.highest

def concatMap [n] 'a 'b (f: a -> ?[l].[l]b) (placeholder: b) (xs: [n]a): *[]b
  = let totalLength = reduce (+) 0 <| map (\ x -> length (f x)) xs in
    ( loop (results, offset) = (replicate totalLength placeholder, 0)
      for x in xs
      do
        let bs = f x in
        let scatterIndices = indices bs |> map (+offset) in
        (scatter results scatterIndices bs, offset + length bs)
    ).0

def rectSize (a: (i64, i64)) (b: (i64, i64)) = 
  let dx = i64.max a.0 b.0 - i64.min a.0 b.0 in
  let dy = i64.max a.1 b.1 - i64.min a.1 b.1 in
  (dx + 1) * (dy + 1)

def pair_iota (n: i64): [n](i64, i64)
  = map (\ j -> (n, j)) (iota n)

def pairs 'a (xs: []a): [](a, a)
  = concatMap pair_iota (i64.highest, i64.highest) (indices xs)
    |> map (\ (i, j) -> (xs[i], xs[j]))

def findFirst 'a (f: a -> bool) (xs: []a): a
  = ( loop (i, x) = (0, xs[0])
      while not (f x)
      do (i + 1, xs[i+1])
    ) |> (.1)

def orderedPair (p: (i64, i64)): (i64, i64) = (i64.min p.0 p.1, i64.max p.0 p.1)

def overlapsWith (a: (i64, i64)) (b: (i64, i64)): bool 
  = a.0 < b.1 && b.0 < a.1

def anyInside (points: [](i64, i64)) (rectangle: (((i64, i64), (i64, i64)), i64))
  = let (lowerX, upperX) = orderedPair (rectangle.0.0.0, rectangle.0.1.0) in
    let (lowerY, upperY) = orderedPair (rectangle.0.0.1, rectangle.0.1.1) in
    map (\ (x, y) -> lowerX < x && x < upperX && lowerY < y && y < upperY) points
    |> or

def anyIntersects (edges: []((i64, i64), (i64, i64))) (rectangle: (((i64, i64), (i64, i64)), i64)): bool
  = let rectRangeX = orderedPair (rectangle.0.0.0, rectangle.0.1.0) in
    let rectRangeY = orderedPair (rectangle.0.0.1, rectangle.0.1.1) in
    map (\ e -> 
      let edgeRangeX = orderedPair (e.0.0, e.1.0) in
      let edgeRangeY = orderedPair (e.0.1, e.1.1) in
      (edgeRangeX `overlapsWith` rectRangeX) && (edgeRangeY `overlapsWith` rectRangeY)
    ) edges
    |> or

def part2 (sortedRectangles: [](((i64, i64), (i64, i64)), i64)) (points: [](i64, i64))
  = let edges = zip points (rotate 1 points) in
    let filled = \ r -> not (anyInside points r || anyIntersects edges r) in
    findFirst filled sortedRectangles
    |> (.1)

-- benchmark
-- ==
-- input @fut-input
-- auto output

def main (coordinateArrays: [][2]i64)
  = let coordinates = map coordinateFromArray coordinateArrays in
    let rectangleCorners = pairs coordinates in
    let rectangleSizes = map (id &&& uncurry rectSize) rectangleCorners in
    let sortedRectangles = radix_sort_by_key (.1) i64.num_bits i64.get_bit rectangleSizes |> reverse in
  (sortedRectangles[0].1, part2 sortedRectangles coordinates)

it produces a textual representation of [][3]u32, try it on your example or input :]

1i [
1,$ {
	s/^/[/
	s/$/]/
}
2,$i,
$i ]
$d

Basic

import "lib/github.com/diku-dk/sorts/radix_sort"

type position = (u32, u32, u32)
def positionFromArray (p: [3]u32): position
  = (p[0], p[1], p[2])
def pair_iota (n: i64): [n](i64, i64)
  = map (\ j -> (n, j)) (iota n)
def gaussian_sum (n: i64) = n * (n + 1) / 2

def euclidean_distance (a: position) (b: position): f64
  = f64.sqrt 
    ( (f64.u32 a.0 - f64.u32 b.0) ** 2
    + (f64.u32 a.1 - f64.u32 b.1) ** 2
    + (f64.u32 a.2 - f64.u32 b.2) ** 2
    )

def distance_table [n] (positions: [n]position): [n][n]f64
  = let distance_function = \ i j -> euclidean_distance positions[i] positions[j] in
    tabulate_2d n n distance_function

def existsLength 'a 'b (f: a -> ?[l].[l]b) (x: a): i64
  = length (f x)

def concatMap [n] 'a 'b (f: a -> ?[l].[l]b) (placeholder: b) (xs: [n]a): *[]b
  = let totalLength = reduce (+) 0 <| map (\ x -> length (f x)) xs in
    ( loop (results, offset) = (replicate totalLength placeholder, 0)
      for x in xs
      do
        let bs = f x in
        let scatterIndices = indices bs |> map (+offset) in
        (scatter results scatterIndices bs, offset + length bs)
    ).0

def distance_array [n] (positions: [n]position): []((i64, i64), f64)
  = let table = distance_table positions in
    let triangle_indices = concatMap pair_iota (i64.highest, i64.highest) (iota n |> drop 1) in
    map (\ (i, j) -> ((i, j), table[i, j])) triangle_indices

def sort_distances (distances: []((i64, i64), f64)): []((i64, i64), f64)
  = radix_sort_float_by_key (.1) f64.num_bits f64.get_bit distances

type option 'a
  = #Empty
  | #Present a

def empty 'a : option a = #Empty

def overrideWith (old: u16) (new: u16) (x: option u16): option u16
  = match x
      case #Empty -> #Empty
      case #Present inner -> 
        if inner == old
        then #Present new
        else #Present inner

def orElse 'a (o: option a) (d: a): a
  = match o
      case #Empty -> d
      case #Present x -> x

def is_present 'a (o: option a): bool
  = match o
      case #Empty -> false
      case #Present _ -> true

def connect (circuits: *[](option u16)) (newCircuitId: u16) (connection: (i64, i64)): (u16, *[](option u16))
  = let circuitA = circuits[connection.0] in
    let circuitB = circuits[connection.1] in
    match (circuitA, circuitB)
      case (#Empty, #Empty) -> 
        ( newCircuitId + 1
        , scatter circuits [connection.0, connection.1] (rep (#Present newCircuitId))
        )
      case (#Present a, #Empty) -> 
        ( newCircuitId
        , scatter circuits [connection.1] [#Present a]
        )
      case (#Empty, #Present b) -> 
        ( newCircuitId
        , scatter circuits [connection.0] [#Present b]
        )
      case (#Present a, #Present b) ->
        ( newCircuitId
        , map (b `overrideWith` a) circuits
        )

def countCircuit (counts: *[]u64) (o: option u16): *[]u64 
  = match o
    case #Empty -> counts 
    case #Present i -> scatter counts [i64.u16 i] [counts[i64.u16 i] + 1]

def countCircuits (c: u16) (circuits: [](option u16)): *[i64.u16 c]u64
  = let circuitCounts = replicate (i64.u16 c) 0 in
    loop counts = circuitCounts
    for circuit in circuits
    do countCircuit counts circuit

def exampleConnectionCount = 10i64
def inputConnectionCount = 1000i64

def part1 (positions: i64) (connectionCount: i64) (distances: []((i64, i64), f64))
  = let connections = take connectionCount distances |> map (.0) in
    let circuitMap: *[positions](option u16) = replicate positions empty in
    ( loop (circuitCount, circuits) = (0, circuitMap)
      for connection in connections
      do
        connect circuits circuitCount connection
    ) |> uncurry countCircuits 
      |> radix_sort u64.num_bits u64.get_bit
      |> reverse
      |> take 3
      |> foldl (*) 1

def part2 (positionCount: i64) (distances: []((i64, i64), f64)) (positions: []position)
  = let circuitMap: *[positionCount](option u16) = replicate positionCount empty in
    ( loop (circuitCount, connectionIndex, circuits) = (0, 0, circuitMap)
      while not
        ( and (map is_present circuits)
        && and (map (== circuits[0]) circuits)
        )
      do
        let connection = distances[connectionIndex].0 in
        let (newCircuitId, circuits') = connect circuits circuitCount connection in
        (newCircuitId, connectionIndex+1, circuits')
    ).1
    |> \ i -> distances[i-1].0
    |> \ (a, b) -> positions[a].0 * positions[b].0

def main [n] (position_array: [n][3]u32)
  = let positions = map positionFromArray position_array in
    let unsorted_distances = distance_array positions in
    let sorted_distances = sort_distances unsorted_distances in
    ( part1 n inputConnectionCount sorted_distances
    , part2 n sorted_distances positions
    )

i [
s/\([0-9]\+\)-\([0-9]\+\)/\[\1, \2]/g
a ]

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE OverloadedStrings #-}
import qualified Data.Text.IO as TextIO
import Control.Monad ((<$!>))
import qualified Data.Array.Unboxed as Array
import qualified Data.Text as Text
import qualified Data.Char as Char
import Data.Array.Unboxed (UArray)
import qualified Data.List as List
import qualified Data.ByteString as ByteString
import Data.Word (byteSwap64, Word64)
import GHC.ByteOrder (ByteOrder(..), targetByteOrder)
import qualified Data.Bits as Bits

parse :: Text.Text -> UArray (Int, Int) Int
parse t = let
    banks = init $ Text.lines t
    bankSize = maybe 0 pred $ Text.findIndex (== '\n') t
    bankCount = Text.count "\n" t - 2
  in Array.listArray ((0, 0), (bankCount, bankSize)) $ List.concatMap (fmap Char.digitToInt . Text.unpack) banks

rowsOf :: UArray (Int, Int) Int -> Int
rowsOf = fst . snd . Array.bounds

colsOf :: UArray (Int, Int) Int -> Int
colsOf = snd . snd . Array.bounds

byteStringLeWord64 :: Word64 -> ByteString.ByteString
byteStringLeWord64 word = let
    leWord = case targetByteOrder of
      BigEndian -> byteSwap64 word
      LittleEndian -> word
  in ByteString.pack . map (fromIntegral . (leWord `Bits.shiftR`)) $ [0,8..56]

main :: IO ()
main = do
  batteryBanks <- parse <$!> TextIO.getContents
  putChar 'b'
  ByteString.putStr (ByteString.singleton 2) -- version
  ByteString.putStr (ByteString.singleton 2) -- dimensions
  TextIO.putStr "  u8" -- type
  ByteString.putStr (byteStringLeWord64 . fromIntegral . succ . rowsOf $ batteryBanks) -- outer dim
  ByteString.putStr (byteStringLeWord64 . fromIntegral . succ . colsOf $ batteryBanks) -- inner dim
  ByteString.putStr . ByteString.pack . fmap fromIntegral . Array.elems $ batteryBanks -- elements

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
module Main (main) where
import qualified Data.Text as Text
import Data.Array.Unboxed (UArray)
import qualified Data.Array.IArray as Array
import qualified Data.List as List
import Control.Monad ((<$!>), guard)
import qualified Data.Text.IO as TextIO
import Data.Maybe (fromMaybe)
import Control.Arrow ((&&&))

parse :: Text.Text -> UArray (Int, Int) Bool
parse t = let
    gridLines = init $ Text.lines t
    lineSize = maybe 0 pred $ Text.findIndex (== '\n') t
    lineCount = Text.count "\n" t - 2
  in Array.listArray ((0, 0), (lineCount, lineSize)) $ List.concatMap (fmap (== '@') . Text.unpack) gridLines

neighbors8 :: (Int, Int) -> [(Int, Int)]
neighbors8 p@(x, y) = do
  x' <- [pred x .. succ x]
  y' <- [pred y .. succ y]
  let p' = (x', y')
  guard (p /= p')
  pure p'

main :: IO ()
main = do
  grid <- parse <$!> TextIO.getContents
  print $ part1 grid
  print $ part2 grid

part2 :: UArray (Int, Int) Bool -> Int
part2 grid = case accessiblePositions grid of
  [] -> 0
  xs -> List.length xs + part2 (grid Array.// fmap (id &&& const False) xs)

part1 :: UArray (Int, Int) Bool -> Int
part1 = List.length . accessiblePositions

accessiblePositions :: UArray (Int, Int) Bool -> [(Int, Int)]
accessiblePositions grid = let
     lookupPosition = fromMaybe False . (grid Array.!?)
     positions = Array.indices grid
     paperRollPositions = List.filter lookupPosition positions
     isPositionAccessible = (< 4) . List.length . List.filter lookupPosition . neighbors8
   in List.filter isPositionAccessible paperRollPositions

It reads from stdin and writes the both solutions on a separate line to stdout.

{-# OPTIONS_GHC -Wall #-}
import qualified Data.Text.IO as TextIO
import Control.Monad ((<$!>))
import qualified Data.Array.Unboxed as Array
import qualified Data.Text as Text
import qualified Data.Char as Char
import Data.Array.Unboxed (UArray)
import qualified Data.Foldable as Foldable
import Control.Arrow ((&&&))
import qualified Data.List as List

parse :: Text.Text -> UArray (Int, Int) Int
parse t = let
    banks = init $ Text.lines t
    bankSize = maybe 0 pred $ Text.findIndex (== '\n') t
    bankCount = Text.count "\n" t - 2
  in Array.listArray ((0, 0), (bankCount, bankSize)) $ List.concatMap (fmap Char.digitToInt . Text.unpack) banks

rowsOf :: UArray (Int, Int) Int -> Int
rowsOf = fst . snd . Array.bounds

colsOf :: UArray (Int, Int) Int -> Int
colsOf = snd . snd . Array.bounds

main :: IO ()
main = do
  batteryBanks <- parse <$!> TextIO.getContents
  print $ part1 batteryBanks
  print $ part2 batteryBanks

part1 :: UArray (Int, Int) Int -> Int
part1 batteryBanks = Foldable.sum $ pickBatteries 2 batteryBanks <$> [0.. rowsOf batteryBanks]

part2 :: UArray (Int, Int) Int -> Int
part2 banks = Foldable.sum $ pickBatteries 12 banks <$> [0.. rowsOf banks]

pickBatteries :: Int -> UArray (Int, Int) Int -> Int -> Int
pickBatteries batteryCount banks row = let
    width = colsOf banks
    getBattery col = banks Array.! (row, col)

    go acc 0 _      = acc
    go acc n offset = let
        effectiveEnd = width - pred n
        availableIndices = [offset .. effectiveEnd]
        batteryWithIndices = (id &&& getBattery) <$> availableIndices
        (offset', selectedBattery) = maximumOn snd batteryWithIndices
      in go (acc * 10 + selectedBattery) (pred n) (succ offset')
  in go 0 batteryCount 0

maximumOn :: (Foldable t, Ord b) => (a -> b) -> t a -> a
maximumOn f collection = case Foldable.toList collection of
  [] -> error "maximumOn: empty foldable"
  (x:xs) -> List.foldl selectMax x xs
  where
    selectMax a b = if f a < f b then b else a

module Main (main) where
import qualified Text.ParserCombinators.ReadP as ReadP
import Numeric.Natural (Natural)
import Control.Monad ((<$!>), guard)
import qualified Data.List as List
import Control.Arrow ((>>>))
import qualified Data.Text as Text
import qualified Data.Foldable as Foldable

newtype Range = Range { getRange :: (Natural, Natural) }
  deriving Show

parseRange :: ReadP.ReadP Range
parseRange = do
  n1 <- ReadP.readS_to_P reads
  _ <- ReadP.char '-'
  n2 <- ReadP.readS_to_P reads
  pure . Range $ (n1, n2)

parseLine :: ReadP.ReadP [Range]
parseLine = parseRange `ReadP.sepBy` ReadP.char ','

main :: IO ()
main = do
  ranges <- fst . last . ReadP.readP_to_S parseLine <$!> getContents
  print $ part1 ranges
  print $ part2 ranges

part1 :: [Range] -> Natural
part1 = List.concatMap (uncurry enumFromTo . getRange)
  >>> List.filter isDoublePattern
  >>> Foldable.sum

part2 :: [Range] -> Natural
part2 = List.concatMap (uncurry enumFromTo . getRange)
  >>> List.filter isMultiplePattern
  >>> Foldable.sum

isMultiplePattern :: Natural -> Bool
isMultiplePattern n = let
    textN = Text.show n
    textLength = Text.length textN
  in flip any (divisorsOf textLength) $ \ divisor -> let
      patternLength = textLength `div` divisor
      patternPart = Text.take (fromIntegral patternLength) textN
    in Text.replicate (fromIntegral divisor) patternPart == textN

isDoublePattern :: Natural -> Bool
isDoublePattern n = let
  textN = Text.show n
  evenLength = even (Text.length textN)
  (first, second) = Text.splitAt (Text.length textN `div` 2) textN
  in evenLength && first == second

divisorsOf :: Integral b => b -> [b]
divisorsOf n = do
  x <- [2..n]
  guard ((n `mod` x) == 0)
  pure x

I picked it up in some forum discussion I read where somebody argued that using explicit matches litters the Codebase with re-definitions of the same functions. It makes grep-ing the source hard. I was easily influenced by this and adopted it.

I think this is not the way I like to go about it. I would rather use Hoogle, Haddock or HLS to search in my source.

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OrPatterns #-}
module Main (main) where

import Control.Monad ( (<$!>) )
import qualified Data.List as List

main :: IO ()
main = do
  rotations <- (fmap parseRotation . init . lines) <$!> getContents
  print $ part1 rotations
  print $ part2 rotations

part2 :: [Either Int Int] -> Int
part2 rotations = let

    foldRotation (position, zeroCount) operation = case operation of
      Left y -> let
        (zeroPasses, y') = y `divMod` 100
        position' = (position - y') `mod` 100
        zeroCount' = zeroPasses + zeroCount + if position <= y' then fromEnum $ position /= 0 else 0
        in (position', zeroCount')
      Right y -> let
        (zeroPasses, y') = y `divMod` 100
        position' = (position + y') `mod` 100
        zeroCount' = zeroPasses + zeroCount + if y' + position >= 100 then 1 else 0
        in (position', zeroCount')

  in snd $ List.foldl' foldRotation (50, 0) rotations

part1 :: [Either Int Int] -> Int
part1 rotations = let
    positions = List.scanl applyRotation 50 rotations
  in List.length . filter (== 0) $ positions

applyRotation :: Int -> Either Int Int -> Int
applyRotation x = \case
  Left y -> (x - y) `mod` 100
  Right y -> (x + y) `mod` 100

parseRotation :: String -> Either Int Int
parseRotation = \case
  'R':rest -> Right $ read rest
  'L':rest -> Left $ read rest
  bad -> error $ "invalid rotation operation: " ++ bad

-- | Old solution enumerating all the numbers

part2' :: [Either Int Int] -> Int
part2' rotations = let
  intermediatePositions _ [] = []
  intermediatePositions x (op:ops) = case op of
    Left 0; Right 0 -> intermediatePositions x ops
    Left y -> let x' = pred x `mod` 100 in x' : intermediatePositions x' (Left (pred y) : ops)
    Right y -> let x' = succ x `mod` 100 in x' : intermediatePositions x' (Right (pred y) : ops)
  in List.length . List.filter (== 0) . intermediatePositions 50 $ rotations