2020-20 part 2 in haskell
This commit is contained in:
parent
dbbabc0154
commit
a9e560d2aa
GPG key ID:
F92E51B86E07177E
1 changed files with 216 additions and 0 deletions
216
2020/20-Jurassic_Jigsaw/second.hs
Normal file
216
2020/20-Jurassic_Jigsaw/second.hs
Normal file
|
|
@ -0,0 +1,216 @@
|
|||
-- requires cabal install --lib megaparsec parser-combinators
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad (mapM_, void, when)
|
||||
import Data.List (elemIndex, foldl', intercalate, intersect, transpose)
|
||||
import Data.Maybe (catMaybes, fromJust, isJust)
|
||||
import Data.Map qualified as M
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import System.Exit (die)
|
||||
|
||||
exampleExpectedOutput = 273
|
||||
|
||||
type TileID = Int
|
||||
type Edge = [Bool]
|
||||
type Image = [Edge]
|
||||
data Tile = Tile { tileID :: TileID
|
||||
, image :: Image
|
||||
, edgesPermutations :: [Edge]
|
||||
}
|
||||
type Input = [Tile]
|
||||
|
||||
type Parser = Parsec Void String
|
||||
|
||||
parseInt :: Parser Int
|
||||
parseInt = do
|
||||
n <- some digitChar
|
||||
return $ read n
|
||||
|
||||
parseLine :: Parser Edge
|
||||
parseLine = do
|
||||
elts <- some (char '#' <|> char '.')
|
||||
void $ char '\n'
|
||||
return $ map (== '#') elts
|
||||
|
||||
parseTile :: Parser Tile
|
||||
parseTile = do
|
||||
void $ string "Tile "
|
||||
n <- parseInt
|
||||
void $ string ":\n"
|
||||
image <- some parseLine
|
||||
let edges = [head image, last image, map head image, map last image]
|
||||
inverted = map reverse edges
|
||||
return $ Tile n image (edges ++ inverted)
|
||||
|
||||
parseInput' :: Parser Input
|
||||
parseInput' = do
|
||||
tiles <- some $ parseTile <* (optional $ char '\n')
|
||||
void eof
|
||||
return tiles
|
||||
|
||||
parseInput :: String -> IO Input
|
||||
parseInput filename = do
|
||||
input <- readFile filename
|
||||
case runParser parseInput' filename input of
|
||||
Left bundle -> die $ errorBundlePretty bundle
|
||||
Right input' -> return input'
|
||||
|
||||
oneCornerTopLeftOriented :: [Tile] -> Tile
|
||||
oneCornerTopLeftOriented tiles = topLeftOrientation $ (map fst . filter ((== 4) . snd) $ map matchingEdges tiles) !! 0
|
||||
where
|
||||
matchingEdges :: Tile -> (Tile, Int)
|
||||
matchingEdges tile = (tile, sum $ map (matches tile) tiles)
|
||||
matches :: Tile -> Tile -> Int
|
||||
matches Tile{tileID=a, image=_, edgesPermutations=e} Tile{tileID=b, image=_, edgesPermutations=f}
|
||||
| a == b = 0
|
||||
| otherwise = length $ intersect e f
|
||||
topLeftOrientation :: Tile -> Tile
|
||||
topLeftOrientation Tile{tileID=tID, image=img, edgesPermutations=e} = case (leftMatches, topMatches) of
|
||||
(False, False) -> Tile tID img e
|
||||
(False, True) -> Tile tID (rotateRight img) e
|
||||
(True, False) -> Tile tID (rotateLeft img) e
|
||||
(True, True) -> Tile tID (rotateRight $ rotateRight img) e
|
||||
where
|
||||
leftMatches = or $ map (edgeMatch tID (map head img)) tiles
|
||||
topMatches = or $ map (edgeMatch tID (head img)) tiles
|
||||
edgeMatch :: TileID -> Edge -> Tile -> Bool
|
||||
edgeMatch i e tile
|
||||
| i == tileID tile = False
|
||||
| otherwise = isJust $ elemIndex e (edgesPermutations tile)
|
||||
|
||||
orientToMatchLeft :: Edge -> Image -> Image
|
||||
orientToMatchLeft edge img = rotateLeft . orientToMatchTop (reverse edge) $ rotateRight img -- it took me a long time to find out I needed to reverse the edge!
|
||||
|
||||
orientToMatchTop :: Edge -> Image -> Image
|
||||
orientToMatchTop edge img
|
||||
| edge == head img = img -- top is top
|
||||
| redg == head img = map reverse img -- top is reverse top
|
||||
| edge == head timg = timg -- top is left
|
||||
| redg == head timg = map reverse timg -- top is reverse left
|
||||
| edge == head rimg = rimg -- top is bottom
|
||||
| redg == head rimg = map reverse rimg -- top is reverse bottom
|
||||
| edge == head rtimg = rtimg -- top is right
|
||||
| redg == head rtimg = map reverse rtimg -- top is reverse right
|
||||
where
|
||||
redg = reverse edge
|
||||
timg = transpose img
|
||||
rimg = reverse img
|
||||
rtimg = reverse timg
|
||||
|
||||
buildTileGrid :: [[Tile]] -> M.Map TileID Tile -> [[Tile]]
|
||||
buildTileGrid tiles tilesMap
|
||||
| M.size tilesMap == 0 = tiles
|
||||
| isJust nextTileToTheRight = buildTileGrid ((init tiles) ++ [(last tiles) ++ [fromJust nextTileToTheRight]]) (M.delete (tileID $ fromJust nextTileToTheRight) tilesMap)
|
||||
| otherwise = buildTileGrid (tiles ++ [[nextTileBellow]]) (M.delete (tileID nextTileBellow) tilesMap)
|
||||
where
|
||||
lastPlacedTile :: Tile
|
||||
lastPlacedTile = last $ last tiles
|
||||
firstOnLastLine :: Tile
|
||||
firstOnLastLine = head $ last tiles
|
||||
nextTileToTheRight :: Maybe Tile
|
||||
nextTileToTheRight = case filter (edgeMatch rightEdge) (M.elems tilesMap) of
|
||||
[] -> Nothing
|
||||
[a] -> Just (orientedOnTheLeft a)
|
||||
where
|
||||
orientedOnTheLeft :: Tile -> Tile
|
||||
orientedOnTheLeft Tile{tileID=tid, image=img, edgesPermutations=e} = Tile{tileID=tid, image=orientToMatchLeft rightEdge img, edgesPermutations=e}
|
||||
rightEdge :: Edge
|
||||
rightEdge = map last $ image lastPlacedTile
|
||||
nextTileBellow :: Tile
|
||||
nextTileBellow = orientedOnTop . head $ filter (edgeMatch bottomEdge) (M.elems tilesMap)
|
||||
where
|
||||
orientedOnTop :: Tile -> Tile
|
||||
orientedOnTop Tile{tileID=tid, image=img, edgesPermutations=e} = Tile{tileID=tid, image=orientToMatchTop bottomEdge img, edgesPermutations=e}
|
||||
bottomEdge :: Edge
|
||||
bottomEdge = last . image $ firstOnLastLine
|
||||
edgeMatch :: Edge -> Tile -> Bool
|
||||
edgeMatch e tile = isJust $ elemIndex e (edgesPermutations tile)
|
||||
|
||||
cropImage :: Image -> Image
|
||||
cropImage = tail . init . transpose . tail . init . transpose
|
||||
|
||||
assembleLines :: [Image] -> Image
|
||||
assembleLines images
|
||||
| length (images !! 0) == 0 = []
|
||||
| otherwise = (concat $ map head images) : (assembleLines $ map tail images)
|
||||
|
||||
rotateLeft :: Image -> Image
|
||||
rotateLeft = reverse . transpose
|
||||
|
||||
rotateRight :: Image -> Image
|
||||
rotateRight = transpose . reverse
|
||||
|
||||
monster :: Image
|
||||
monster = [[ False, False, False, False, False, False, False, False, False, False, False, False, False, False, False, False, False, False, True, False ]
|
||||
,[ True, False, False, False, False, True, True, False, False, False, False, True, True, False, False, False, False, True, True, True ]
|
||||
,[ False, True, False, False, True, False, False, True, False, False, True, False, False, True, False, False, True, False, False, False ]]
|
||||
|
||||
countMonsters :: Bool -> Image -> Int
|
||||
countMonsters goDown i = --(if length z1 < length monster
|
||||
-- then 0
|
||||
-- else if length (z2 !! 0) < length (monster !! 0)
|
||||
-- then 0
|
||||
-- else if match then 1 else 0
|
||||
(if match then 1 else 0) + nexts
|
||||
where
|
||||
z1 :: [(Edge, Edge)]
|
||||
z1 = zip i monster
|
||||
z2 :: [[(Bool, Bool)]]
|
||||
z2 = map (\(e, e') -> zip e e') $ z1
|
||||
match :: Bool
|
||||
match = and $ map (and . map matchOne) z2
|
||||
matchOne :: (Bool, Bool) -> Bool
|
||||
matchOne (_, False) = True
|
||||
matchOne (i, True) = i
|
||||
nexts :: Int
|
||||
nexts = (if goDown && length i > 3 then (countMonsters True $ tail i) else 0) + (if length (i !! 0) > 20 then countMonsters False $ map tail i else 0)
|
||||
|
||||
compute :: Input -> Int
|
||||
compute tiles = spots - (monsters * 15)
|
||||
where
|
||||
topLeftTile :: Tile
|
||||
topLeftTile = oneCornerTopLeftOriented tiles
|
||||
tilesMap :: M.Map TileID Tile
|
||||
tilesMap = M.delete (tileID topLeftTile) (M.fromList $ zip (map tileID tiles) tiles)
|
||||
imagesGrid :: [[Image]]
|
||||
imagesGrid = map (map image) $ buildTileGrid [[topLeftTile]] tilesMap
|
||||
croppedImages :: [[Image]]
|
||||
croppedImages = map (map cropImage) imagesGrid
|
||||
assembledImage :: Image
|
||||
assembledImage = concat $ map assembleLines croppedImages
|
||||
permutations :: [Image]
|
||||
permutations = let r1 = rotateRight assembledImage
|
||||
r2 = rotateRight r1
|
||||
r3 = rotateRight r2
|
||||
rotations = [assembledImage, r1, r2, r3]
|
||||
inverted = map reverse rotations
|
||||
in rotations ++ inverted
|
||||
monsters :: Int
|
||||
monsters = sum $ map (countMonsters True) permutations
|
||||
spots :: Int
|
||||
spots = length . filter id $ concat assembledImage
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
example <- parseInput "example"
|
||||
--mapM_ (printImage . image) $ corners example
|
||||
--let topLeftTile = oneCornerTopLeftOriented example
|
||||
-- tilesMap = M.delete (tileID topLeftTile) (M.fromList $ zip (map tileID example) example)
|
||||
-- imagesGrid = map (map image) $ buildTileGrid [[topLeftTile]] tilesMap
|
||||
-- croppedImages = map (map cropImage) imagesGrid
|
||||
-- assembledImage = concat $ map assembleLines croppedImages
|
||||
-- permutations = let r1 = rotateRight assembledImage
|
||||
-- r2 = rotateRight r2
|
||||
-- r3 = rotateRight r3
|
||||
-- rotations = [assembledImage, r1, r2, r3]
|
||||
-- inverted = map reverse rotations
|
||||
-- in rotations ++ inverted
|
||||
--printImage assembledImage
|
||||
let exampleOutput = compute example
|
||||
when (exampleOutput /= exampleExpectedOutput) (die $ "example failed: got " ++ show exampleOutput ++ " instead of " ++ show exampleExpectedOutput)
|
||||
input <- parseInput "input"
|
||||
print $ compute input
|
||||
--where
|
||||
-- printImage img = mapM_ print $ map (map (\x -> if x then '#' else '.')) img
|
||||
Loading…
Add table
Reference in a new issue