import Data.List
type Shape = [[Bool]]
nextgeneration :: [Shape] -> [Shape]
nextgeneration = uniq . sort . nextgeneration'
nextgeneration' :: [Shape] -> [Shape]
nextgeneration' (x:xs) = (nextshapes' x) ++ nextgeneration' xs
nextgeneration' [] = []
nextshapes' = map canonical . nextshapes''
nextshapes'' :: Shape -> [Shape]
nextshapes'' m = [trimmed (fromposition i (x,y)) | (x,y) <- (shiftedxor (topositions i))]
where i = inflate m
canonical :: Shape -> Shape
canonical m = head (sort [
m, r1 m, r2 m, r3 m,
mr0 m, mr1 m, mr2 m, mr3 m])
allforms m = uniq (sort [
m, r1 m, r2 m, r3 m,
mr0 m, mr1 m, mr2 m, mr3 m])
r1 = rotate_cw
r2 = r1 . rotate_cw
r3 = r2 . rotate_cw
mr0 = mirror_horiz
mr1 = mirror_horiz . r1
mr2 = mirror_horiz . r2
mr3 = mirror_horiz . r3
rotate_cw = map reverse . transpose
rotate_ccw = reverse . transpose
mirror_horiz = map reverse
onetrue m = foldr (||) False m
allfalse m = not (onetrue m)
trimmed :: Shape -> Shape
trimmed m = (trimright . trimleft) (dropWhileEnd allfalse (dropWhile (allfalse) m))
trimleft m = if null [head row | row <- m, (head row)]
then trimleft [tail row | row <- m]
else m
trimright m = if null [last row | row <- m, (last row)]
then trimright [init row | row <- m]
else m
fromposition :: Shape -> (Int,Int) -> Shape
fromposition m (x,y) = (take y m)
++ (fromposition' (m !! y) x):(drop (y+1) m)
fromposition' :: [Bool] -> Int -> [Bool]
fromposition' m x = (take x m) ++ True:(drop (x+1) m)
inflate :: Shape -> Shape
inflate m = [line]++[False:row++[False] | row <- m]++[line]
where line = replicate (2 + length (head m)) False
topositions :: Shape -> [(Int,Int)]
topositions m = topositions' (head m) (tail m) 0 0
topositions' :: [Bool] -> [[Bool]] -> Int -> Int -> [(Int,Int)]
topositions' [] [] _ _ = []
topositions' [] rows x y = topositions' (head rows) (tail rows) 0 (y+1)
topositions' (True:xs) rows x' y' = (x',y'):(topositions' xs rows (x'+1) y')
topositions' (False:xs) rows x' y' = topositions' xs rows (x'+1) y'
shiftedxor :: [(Int,Int)] -> [(Int,Int)]
shiftedxor l = [e | e <- (shifted l), not (e `elem` l)]
shifted :: [(Int,Int)] -> [(Int,Int)]
shifted = uniq . sort . shifted'
shifted' :: [(Int,Int)] -> [(Int,Int)]
shifted' ((x,y):xs) = (x-1,y):(x+1,y):(x,y-1):(x,y+1):(shifted' xs)
shifted' [] = []
uniq (x:y:xs)
| x == y = uniq(x:xs)
| True = x:uniq(y:xs)
uniq (x:[]) = x:[]
uniq [] = []
shapestr :: Shape -> [Char]
shapestr (row:[]) = '[':(shapestr' row)
shapestr (row:rows) = '[':(shapestr' row)++('\n':shapestr rows)
shapestr' (True:xs) = 'X':shapestr' xs
shapestr'(False:xs) = ' ':shapestr' xs
shapestr' [] = "]"
shapeSstr :: [Shape] -> [Char]
shapeSstr (x:y:ys) = (shapestr x)++",\n"++shapeSstr(y:ys)
shapeSstr (x:xs) = shapestr x
shapeSstr [] = ""
placements :: Shape -> [Shape]
placements x = foldr (++) [] [(allpositions y) | y <- allforms x]
allpositions :: Shape -> [Shape]
allpositions m = allpositions' m (length (head m)) (length m)
allpositions' :: Shape -> Int -> Int -> [Shape]
allpositions' m w h = [(oneposition m i j w h) | i <- [0..(10-w)], j <- [0..(6-h)]]
ten = replicate 10 False
oneposition :: Shape -> Int -> Int -> Int -> Int -> Shape
oneposition m i j w h = (replicate j ten) ++ [(
(take i ten) ++ row ++ (drop (i+w) ten)
) | row <- m] ++ (replicate (6-j-h) ten)
pentominos = [(snd p) | p <- sort [
(length (placements q), q) | q <- shapeFive
]] where shapeFive = (nextgeneration . nextgeneration .
nextgeneration . nextgeneration) [[[True]]]
-- List of remaining Shape
-- To list of solutions
-- TODO
-- solutions :: [Shape] -> [Shape]
-- solutions = solutions' pentominos []
-- solutions' :: [Shape] -> [Shape] -> [Shape]
-- solutions' [] stacked = stacked
main = do
-- putStrLn ("The "++(show (length pentominos))++" pentominos are:\n"++
-- shapeSstr pentominos);
-- putStrLn ("Placement counts for each are:\n"++(foldl (++) "" [
-- (show (length (placements p)))
-- ++ " placements for\n"++(shapestr p)++"\n"
-- | p <- pentominos
-- ]));
-- putStrLn $ show $ placements $ head pentominos;
putStrLn $ show $ head pentominos
putStrLn $ show $ head $ placements $ head pentominos;