diff --git a/haskell/app/Main.hs b/haskell/app/Main.hs index f127705..cc46f6c 100644 --- a/haskell/app/Main.hs +++ b/haskell/app/Main.hs @@ -1,11 +1,11 @@ module Main (main) where import PolyCube +import Children import Text.Read (readMaybe) import System.Exit ( ExitCode(ExitFailure), exitWith ) import System.Environment (getArgs) import qualified Data.HashMap.Strict as Map -import Combinatorics main :: IO () main = do @@ -34,41 +34,7 @@ evaluateChildren :: Int -> PolyCube -> Map.HashMap [Offset3D] (Int, [Coord3D]) - evaluateChildren maxSize polycube = loop (getChildren (maxSize - size polycube) polycube) where loop :: [PolyCube] -> Map.HashMap [Offset3D] (Int, [Coord3D]) -> Map.HashMap [Offset3D] (Int, [Coord3D]) loop [] d = d - loop ((PolyCube o la s):pcs) d = if any (flip Map.member d . getOffsets) o + loop ((PolyCube o la s):pcs) d = if any (\x -> Map.member (getOffsets x) d) o then loop pcs d else loop pcs $ evaluateChildren maxSize (PolyCube o la s) $ Map.insert (getOffsets $ head o) (s, head o) d -getChildren :: Int -> PolyCube -> [PolyCube] -getChildren 0 _ = [] -getChildren i (PolyCube o la s) = foldr condGrowth [] $ foldr (\x acc -> tuples x possibleGrowth ++ acc) [] [1..i] where - condGrowth :: [Coord3D] -> [PolyCube] -> [PolyCube] - condGrowth gs ps = if any (\x -> elem x $ head o) gs - then ps - else PolyCube (zipWith (\x n -> insertAllSorted x $ rotateCubes gs n) o [1..24]) gs (s + length gs) : ps - transformations :: [Offset3D] - transformations = [ - Offset3D (-1, 0, 0), - Offset3D (0, -1, 0), - Offset3D (0, 0, -1), - Offset3D (1, 0, 0), - Offset3D (0, 1, 0), - Offset3D (0, 0, 1)] - applyTransformations :: Coord3D -> [Offset3D] -> [Coord3D] - applyTransformations _ [] = [] - applyTransformations p (x:xs) = applyOffset p x:applyTransformations p xs - possibleGrowth :: [Coord3D] - possibleGrowth = foldr (\x acc -> insertAllSorted acc (applyTransformations x transformations)) [] la - -insertAllSorted :: (Ord a) => [a] -> [a] -> [a] -insertAllSorted [] [] = [] -insertAllSorted [] [v] = [v] -insertAllSorted xs [] = xs -insertAllSorted xs (y:ys) = insertAllSorted (insertSorted xs y) ys - -insertSorted :: (Ord a) => [a] -> a -> [a] -insertSorted [] v = [v] -insertSorted (x:xs) v - | v < x = v:x:xs - | v > x = x:insertSorted xs v - | otherwise = x:xs - diff --git a/haskell/count.out b/haskell/count.out index a3cb6c9..c648375 100644 --- a/haskell/count.out +++ b/haskell/count.out @@ -1 +1 @@ -[1,1,2,8,25] +[1,1,2,8,25,136,728] diff --git a/haskell/package.yaml b/haskell/package.yaml index f043078..24bf127 100644 --- a/haskell/package.yaml +++ b/haskell/package.yaml @@ -37,6 +37,7 @@ library: source-dirs: src dependencies: - hashable + - combinatorial executables: pcc-haskell-exe: @@ -49,7 +50,6 @@ executables: dependencies: - pcc-haskell - unordered-containers - - combinatorial tests: pcc-haskell-test: diff --git a/haskell/pcc-haskell.cabal b/haskell/pcc-haskell.cabal index c946aac..07268a7 100644 --- a/haskell/pcc-haskell.cabal +++ b/haskell/pcc-haskell.cabal @@ -25,6 +25,7 @@ source-repository head library exposed-modules: + Children PolyCube other-modules: Paths_pcc_haskell @@ -35,6 +36,7 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , combinatorial , hashable default-language: Haskell2010 @@ -49,7 +51,6 @@ executable pcc-haskell-exe ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , combinatorial , pcc-haskell , unordered-containers default-language: Haskell2010 diff --git a/haskell/src/Children.hs b/haskell/src/Children.hs new file mode 100644 index 0000000..95dc2dc --- /dev/null +++ b/haskell/src/Children.hs @@ -0,0 +1,46 @@ +module Children ( + getChildren +) where + +import PolyCube +import Combinatorics + +-- generates legal children of given polycube up to a given size +getChildren :: Int -> PolyCube -> [PolyCube] +getChildren 0 _ = [] +getChildren i (PolyCube o la s) = foldr condGrowth [] $ foldr (\x acc -> tuples x possibleGrowth ++ acc) [] [1..i] where + condGrowth :: [Coord3D] -> [PolyCube] -> [PolyCube] + condGrowth gs ps = + if any (\x -> elem x $ head o) gs + then ps + else PolyCube (zipWith (\x n -> insertAllSorted x $ rotateCubes gs n) o [1..24]) gs (s + length gs) : ps + possibleGrowth :: [Coord3D] + possibleGrowth = foldr (\x acc -> insertAllSorted acc (generateNeighbors x)) [] la + +-- generate all neighbors of a Coord3D +generateNeighbors :: Coord3D -> [Coord3D] +generateNeighbors p = map (applyOffset p) transformations where + transformations :: [Offset3D] + transformations = [ + Offset3D (-1, 0, 0), + Offset3D (0, -1, 0), + Offset3D (0, 0, -1), + Offset3D (1, 0, 0), + Offset3D (0, 1, 0), + Offset3D (0, 0, 1)] + +-- inserts all elements from the second list into the first +insertAllSorted :: (Ord a) => [a] -> [a] -> [a] +insertAllSorted [] [] = [] +insertAllSorted [] [v] = [v] +insertAllSorted xs [] = xs +insertAllSorted xs (y:ys) = insertAllSorted (insertSorted xs y) ys + +-- inserts element into sorted list +insertSorted :: (Ord a) => [a] -> a -> [a] +insertSorted [] v = [v] +insertSorted (x:xs) v + | v < x = v:x:xs + | v > x = x:insertSorted xs v + | otherwise = x:xs + diff --git a/haskell/src/PolyCube.hs b/haskell/src/PolyCube.hs index c835e9f..bc664b0 100644 --- a/haskell/src/PolyCube.hs +++ b/haskell/src/PolyCube.hs @@ -40,6 +40,7 @@ data PolyCube = PolyCube { Eq ) +-- offset calculations getOffsets :: [Coord3D] -> [Offset3D] getOffsets [] = error "empty List" getOffsets [_] = [] @@ -51,8 +52,9 @@ diff (Coord3D (a, b, c)) (Coord3D (x, y, z)) = Offset3D (x-a, y-b, z-c) applyOffset :: Coord3D -> Offset3D -> Coord3D applyOffset (Coord3D (a, b, c)) (Offset3D (x, y, z)) = Coord3D (a+x, b+y, c+z) +-- calculates an oriented reprenentation rotateCubes :: [Coord3D] -> Int -> [Coord3D] -rotateCubes tree n = map (invert . flip . rotate n) tree where +rotateCubes ors n = map (invert . flip . rotate n) ors where rotate :: Int -> Coord3D -> (Int, (Int, Int, Int)) rotate i (Coord3D (a, b, c)) = case mod i 3 of 0 -> (j, (a, b, c))