tiles.hs

import Data.Bits (testBit)
import Data.List (any, elem)
import Codec.Picture
import qualified Data.Matrix as Matrix
import qualified Data.Vector as Vector (toList)

bitList :: Int -> [Bool]
bitList num = map (testBit num) [0,1..8]

bitMatrix :: [Bool] -> Matrix.Matrix Bool
bitMatrix = Matrix.fromList 3 3

flipRows :: Matrix.Matrix a -> Matrix.Matrix a
flipRows m = Matrix.fromLists $ map reverse $ rowList m

rowList :: Matrix.Matrix a -> [[a]]
rowList m = map
    (\i -> Vector.toList (Matrix.getRow i m))
    (take (Matrix.nrows m) [1, 2 ..])

-- Tile rotations
rotateMatrix90 :: Matrix.Matrix a -> Matrix.Matrix a
rotateMatrix90 m = flipRows $ Matrix.transpose m

rotateMatrix180 :: Matrix.Matrix a -> Matrix.Matrix a
rotateMatrix180 m = rotateMatrix90 $ rotateMatrix90 m

rotateMatrix270 :: Matrix.Matrix a -> Matrix.Matrix a
rotateMatrix270 m = rotateMatrix90 $ rotateMatrix90 $ rotateMatrix90 m

allRotations :: Matrix.Matrix a -> [Matrix.Matrix a]
allRotations m = [m, rotateMatrix90 m, rotateMatrix180 m, rotateMatrix270 m]

-- Tile image
matrixPixel :: Int -> Int -> Matrix.Matrix Bool -> PixelRGB8
matrixPixel x y m
    | m Matrix.! (x, y) = PixelRGB8 255 255 255
    | otherwise = PixelRGB8 0 0 0

tileCreator :: String -> Matrix.Matrix Bool -> IO ()
tileCreator path m = writePng path $ generateImage pixelRenderer 408 408
    where pixelRenderer x y = matrixPixel (fromIntegral (floor ((fromIntegral x) / 136) + 1)) (fromIntegral (floor ((fromIntegral y) / 136) + 1)) m

-- Tail recursive
uniques :: Eq a => [Matrix.Matrix a] -> [Matrix.Matrix a] -> [Matrix.Matrix a] -> [Matrix.Matrix a]
uniques [] l _ = l
uniques (m:rest) [] [] = uniques rest [m] $ allRotations m
uniques (m:rest) ulist rlist
    | any (`elem` (allRotations m)) rlist = uniques rest ulist rlist
    | otherwise = uniques rest (m:ulist) ((allRotations m) ++ rlist)

uniquesStart :: Eq a => [Matrix.Matrix a] -> [Matrix.Matrix a]
uniquesStart m = uniques m [] []

makeTiles :: [(String, Matrix.Matrix Bool)] -> [IO ()]
makeTiles tiles = map (\(p, m) -> tileCreator p m) tiles

main = sequence_ $ makeTiles $ zip filenames $ uniquesStart $ map bitMatrix $ map bitList [0, 1 .. 2^9 - 1]
    where filenames = ["images/" ++ show x ++ ".png" | x <- [0, 1 ..]]