readme.md

Hylomorphisms

One of many great articles from Bartosz Milewski is the Stalking a Hylomorphism in the Wild. My conclusions are that hylomorphisms

• Can be used to simplify implementation of many kinds of recursive search algorithms
• Can be considered as a functional design pattern
• Does not require deep understanding of category theory

In this article I will apply the same technique to another problem from Advent of code.

Hylo what?

A common pattern in functional programming is to use fold to collapse a sequence into an aggregate. For example, a sum can be expressed as a fold in Haskell as

sum :: [Int] -> Int
sum = foldr (+) 0

Functions that matches the type signature f a -> a for a functor f are called algebras. In the case of sum, f is the list functor [] and a, which is called the carrier type, is Int. In Haskell we can define

type Algebra f a = f a -> a

In category theory every concept comes with a "mirrored" concept where the arrows are reversed. The new concept is named Co plus the original one. Lets try that

type Coalgebra f a = a -> f a

Indeed there is such a thing. For lists, coalgebras can be expressed using unfoldr. Instead of collapsing a list into an aggregate, unfoldr builds up a list from a seed. For example the infinite list of fibonacci numbers can be expressed as

fib = unfoldr (\(p,c) -> Just (c, (c, p+c))) (1,1)

The intuition behind a hylomorphism is that it builds up a structure using a coalgebra and a seed and then tears it down using an algebra and an aggregate. It can be defined as

hylo :: Functor f => Algebra f a -> Coalgebra f b -> b -> a
hylo f g = f . fmap (hylo f g) . g

Putting theory into practice

The given problem is a kind of puzzle. Each piece, henceforth called tile, has four sides. Each tile side is associated with a bit sequence. The bit sequences of two adjacent sides must match. It is allowed to rotate and/or flip a tile to make it match. A tile is also associated with an integer id. The solution is given by multiplying the ids of the corner tiles of the finished puzzle.

The following data types are used to represent tiles and tile sides

type Side = [Bool]

data Tile = Tile { _tileId :: Int, _tileSides :: [Side] }

Layed out tiles are called a board and is represented as

type Index = (Int,Int)

data Board = Board { _indexToTile :: Map Index Tile, _holes :: [Index] }

At this point it is time to think about the coalgebra and the seed. The puzzle tiles are given as input data. That indicates that tiles are needed as a seed. Having only a set of tiles is not enough though. To solve the puzzle, tiles are added to the board; one by one. That means that a (partly solved) puzzle board is also required. The reasoning leads up to the following definition.

type Pool = [Tile]

data Seed = Seed {  _pool :: Pool, _board :: Board }

The search tree that the coalgebra should unfold is either

• a finished board where all the tiles have been put together
• a list of seeds based on different puzzle choices

This can be encoded as

data SearchTreeF a = Leaf Board | NodeF [a] deriving Functor

Remember that the coalgebra requires the search tree data structure needs to be a functor. The functor instance can be written by hand or, in many cases, just simply derived as above.

The coalgebra expresses one step of the recursive search algorithm; it takes the seed and produces a structure filled with new seeds that in turn can be unfolded.

The base case is simple; if there are no more tiles left to place onto the board the puzzle is finished.

buildSearchTree :: Coalgebra SearchTreeF Seed
buildSearchTree (Seed [] board) = Leaf board

If there are tiles; pick one from the pool and add it, possible rotated or flipped, to one of the free positions on the board. The tile may only be added to a free position if it matches the neighbors.

buildSearchTree (Seed pool board) =
    NodeF [ Seed (removeTileFromPool t pool) (addTileToBoard t' hole board) |
                t     <- pool,
                t'    <- rotationsAndFlips t,
                hole  <- _holes board,
                matches t' hole board
          ]

To calculate the final answer the corner tiles of the puzzle are required. The algebra thus needs to collapse the search tree into corner tiles of the finished boards. Note that there might be many boards if the puzzle solutions is not unique.

The base case again is quite straight forward. When given a board, just extract the corner tiles.

getCorners :: Algebra SearchTreeF [[Tile]]
getCorners (Leaf board) =
    let
        indexToTile = _indexToTile board
        keys = Map.keysSet indexToTile
        cornerTiles = do
            (minX,minY) <- Set.lookupMin keys
            (maxX,maxY) <- Set.lookupMax keys
            mapM (`Map.lookup` indexToTile) [(minX,minY),(minX,maxY),(maxX,minY),(maxX,maxY)]
    in
        case cornerTiles of
            Just tiles -> [tiles]
            Nothing -> []

For internal nodes, it is even simpler; just merge the list of solutions into one big list.

getCorners (NodeF solutions) = concat solutions

Having defined both a coalgebra and an algebra the hylomorphism can fuse them together to create the actual solver.

solve :: [Tile] -> Int
solve tiles =
    let corners = head $ hylo getCorners buildSearchTree (Seed tiles emptyBoard)
    in foldr ((*) . _tileId) 1 corners

hylo2.hs

-- https://adventofcode.com/2020/day/20
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (Maybe)
import qualified Data.Maybe as Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Debug.Trace (trace)

type Side = [Bool]

data TileF a = Tile { _tileId :: Int, _tileSides :: a } deriving Functor

type Tile = TileF [Side]

instance Eq (TileF a) where
    t1 == t2 = _tileId t1 == _tileId t2

rotationsAndFlips :: Tile -> [Tile]
rotationsAndFlips t = concatMap rotations [t, flipTile t]
    where
        rotateTile = fmap (\(x:xs) -> xs ++ [x])
        flipTile   = fmap (\[s1,s2,s3,s4] -> map reverse [s3, s2, s1, s4])
        rotations  = take 4 . iterate rotateTile

type Index = (Int,Int)

data Board = Board { _indexToTile :: Map Index Tile, _holes :: [Index] }

emptyBoard :: Board
emptyBoard = Board Map.empty [(0,0)]

addTileToBoard :: Tile -> Index -> Board -> Board
addTileToBoard t i@(x,y) (Board indexToTile holes) = Board indexToTile' holes'
    where
        indexToTile' = Map.insert i t indexToTile
        holes' =
            [ h | h <- holes, h /= i] <>
            [ h | h <- [ (x-1,y), (x+1,y), (x,y+1), (x,y-1) ], Maybe.isNothing (Map.lookup h indexToTile), not (elem h holes) ]

matches :: Tile -> Index -> Board -> Bool
matches (Tile _ [up,right,down,left]) hole (Board indexToTile _) = all match (neighbors hole)
    where
        neighbors (x,y) =
                [
                  (PUp,    (x  , y+1)),
                  (PRight, (x+1, y  )),
                  (PDown,  (x  , y-1)),
                  (PLeft,  (x-1, y  ))
                ]

        match (placement, neighborIndex) =
            case (placement, _tileSides <$> Map.lookup neighborIndex indexToTile) of
                (_,      Nothing                             ) -> True
                (PDown,  Just [nup , _      , _     , _     ]) -> nup    == reverse down
                (PLeft,  Just [_   , nright , _     , _     ]) -> nright == reverse left
                (PUp,    Just [_   , _      , ndown , _     ]) -> ndown  == reverse up
                (PRight, Just [_   , _      , _     , nleft ]) -> nleft  == reverse right

data Placement = PLeft | PRight | PUp | PDown

type Pool = [Tile]

data Seed = Seed {  _pool :: Pool, _board :: Board }

removeTileFromPool :: Tile -> Pool -> Pool
removeTileFromPool t = filter (/=t)

data SearchTreeF a = Leaf Board | NodeF [a] deriving Functor

type Coalgebra f a = a -> f a
type Algebra f a = f a -> a

hylo :: Functor f => Algebra f a -> Coalgebra f b -> b -> a
hylo f g = f . fmap (hylo f g) . g

buildSearchTree :: Coalgebra SearchTreeF Seed
buildSearchTree (Seed [] board) = Leaf board
buildSearchTree (Seed pool board) =
        trace ("pool size = " ++ (show . length $ pool) ++ ", holes = " ++ (show . length . _holes $ board)) $
            NodeF [ Seed (removeTileFromPool t pool) (addTileToBoard t' hole board) |
                        t  <- pool,
                        t' <- rotationsAndFlips t,
                        hole  <- _holes board,
                        matches t' hole board
                ]

getCorners :: Algebra SearchTreeF [[Tile]]
getCorners (NodeF solutions) = concat solutions
getCorners (Leaf board) =
    let
        indexToTile = _indexToTile board
        keys = Map.keysSet indexToTile
        cornerTiles = do
            (minX,minY) <- Set.lookupMin keys
            (maxX,maxY) <- Set.lookupMax keys
            mapM (`Map.lookup` indexToTile) [(minX,minY),(minX,maxY),(maxX,minY),(maxX,maxY)]
    in
        case cornerTiles of
            Just tiles -> [tiles]
            Nothing -> []

solve :: [Tile] -> Int
solve tiles =
    let corners = head $ hylo getCorners buildSearchTree (Seed tiles emptyBoard)
    in foldr ((*) . _tileId) 1 corners


parseTile :: [String] -> Tile
parseTile (header:bitsRaw) =
    let
        id = read $ take 4 $ drop 5 $ header
        bits = map (map (=='#')) bitsRaw
        bitsRot = transpose bits
            where
                transpose ([]:_) = []
                transpose x = map head x : transpose (map tail x)
    in
        Tile id [head bits, last bitsRot, reverse $ last bits, reverse $ head bitsRot]

parseTiles :: String -> [Tile]
parseTiles input =
        let rows = filter (/="") $ lines input
        in map parseTile (group 11 rows)
    where
        group :: Int -> [a] -> [[a]]
        group _ [] = []
        group n l
            | n > 0 = take n l : group n (drop n l)
            | otherwise = error "Negative or zero n"


main :: IO ()
main = do
        input <- readFile "input.txt"
        let tiles = parseTiles input
        let solution = solve tiles
        putStrLn $ "result=" ++ show solution
        if solution == 20899048083289 then do
            putStrLn "sample correct"
        else if solution == 79412832860579 then do
            putStrLn "real correct"
        else do
            putStrLn "---"