{- | Lonpos pyramid 101 puzzle Like Soma cube but with exclusively flat bricks made from balls that allow to stack the bricks in a diagonal fashion. There are two problems to solve: * arrange all bricks in a flat 5x11 rectangle * arrange all bricks in a square pyramid with a 5x5 base. -} module Main where import qualified Math.SetCover.Exact as ESC import qualified Math.SetCover.BitSet as BitSet import qualified Math.SetCover.Bit as Bit import qualified Math.SetCover.Cuboid as Cuboid import Math.SetCover.Cuboid (PackedCoords(PackedCoords), Coords(Coords), Size) import Control.Applicative (liftA2) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Foldable (forM_, foldMap) import Data.List (intercalate) import Data.Maybe (mapMaybe) import Data.Char (ord, chr) import Data.Word (Word16, Word64) import qualified System.IO as IO import Utility (hPutStrLnImmediate) import Text.Printf (printf) shapes :: [[String]] shapes = ( ".." : " ." : []) : ( "...." : []) : ( "..." : " ." : []) : ( ".." : ".." : []) : ( ".. " : " .." : " ." : []) : ( "... " : " .." : []) : ( "...." : " ." : []) : ( "...." : " . " : []) : ( "..." : ". ." : []) : ( ".. " : "..." : []) : ( "..." : " ." : " ." : []) : ( " . " : "..." : " . " : []) : [] propNumberOfAtoms :: Bool propNumberOfAtoms = Cuboid.numberOf2LayerAtoms shapes == 5*11 targetBase, targetPyramid :: [[String]] targetBase = let line = replicate 11 '.' in [replicate 5 line] targetPyramid = map (\n -> replicate n $ replicate n '.') [5,4,3,2,1] newtype Brick = Brick Int deriving (Eq, Ord) showBall :: Brick -> String showBall (Brick n) = if n<10 then show n else [chr $ ord 'A' + n-10] type Mask = Set.Set (Either Brick PackedCoords) type Assign = ESC.Assign (Map.Map PackedCoords Brick) Mask {- a = sqrt 2 A^T -> B^T: (1, 1, 0) -> ( 1, 1, 0) (1,-1, 0) -> ( 0, 0, a) (0, 0, a) -> (-1, 1, 0) B = M·A rotation around vector (1,1,0) by 90° M = 0.5 · ( 1 1 a) ( 1 1 -a) (-a a 0) scale z such that roots vanish S = diag (1,1,a) shear U = 0.5 · (2 -1) ( 2 -1) ( 2) U·S·M·S^-1·U^-1 = ( 1 0 1) ( 1 0 0) (-1 1 0) -} diagRot0 :: Num a => Coords a -> Coords a diagRot0 (Coords z y x) = Coords (y-x) x (x+z) {- rotation around vector (1,-1,0) by 90° M = 0.5 * ( 1 -1 a) (-1 1 a) (-a -a 0) U·S·M·S^-1·U^-1 = ( 1 0 1) ( 0 1 1) (-1 -1 -1) -} diagRot1 :: Num a => Coords a -> Coords a diagRot1 (Coords z y x) = Coords (-x-y-z) (y+z) (x+z) {- R = ( 0 1 0) (-1 0 0) ( 0 0 1) U·R·U^-1 = ( 0 1 0) (-1 0 -1) ( 0 0 1) -} vertRot :: Num a => Coords a -> Coords a vertRot (Coords z y x) = Coords z (-x-z) y {- Q = 0.5 · (a -a 0) (a a 0) (0 0 2) U·S·Q = 0.5 · a · (1 -1 -1) (1 1 -1) (0 0 2) With this matrix we could transform the coordinates such that we could use 'Cuboid.allOrientations' instead of 'rotations'. However, this would require a final division by 2. -} rotations :: Num a => [Coords a -> Coords a] rotations = liftA2 (.) [id, vertRot, vertRot.vertRot, vertRot.vertRot.vertRot] [id, diagRot0, diagRot0.diagRot0, diagRot0.diagRot0.diagRot0, diagRot1, diagRot1.diagRot1.diagRot1] transformedBrickAssign :: Size -> Brick -> [String] -> [Assign] transformedBrickAssign size k = map (brickAssign size k) . concatMap (Cuboid.allPositions size) . Set.toList . Set.fromList . (\ts -> map (Cuboid.normalForm . flip map ts) rotations) . map (\(Coords y x z) -> Coords z y x) . Cuboid.coordsFrom2LayerString brickAssign :: Size -> Brick -> [Coords Int] -> Assign brickAssign size k ts = let xs = map (Cuboid.packCoords size) ts in ESC.assign (Map.fromList $ map (flip (,) k) xs) $ Set.fromList $ Left k : map Right xs allAssigns :: Size -> [Assign] allAssigns size = concat $ zipWith (transformedBrickAssign size) (map Brick [0 ..]) shapes fittingAssigns :: Size -> [Coords Int] -> [Assign] fittingAssigns size target = let targetSet = Set.fromList $ map (Cuboid.packCoords size) target keepRights = Set.fromList . mapMaybe (either (const Nothing) Just) . Set.toList in filter (flip Set.isSubsetOf targetSet . keepRights . ESC.labeledSet) $ allAssigns size format :: Size -> [Map.Map PackedCoords Brick] -> String format size v = let filled = Map.unions v toppleSize (Coords x y z) = Coords z x y topple (Coords z x y) = Coords x y z in Cuboid.forNestedCoords unlines (intercalate " | ") (intercalate " ") (\c -> maybe "." showBall $ Map.lookup (Cuboid.packCoords size $ topple c) filled) (toppleSize size) printMask :: Size -> [Map.Map PackedCoords Brick] -> IO () printMask size = hPutStrLnImmediate IO.stdout . format size type BitMask = BitSet.Set (Bit.Sum Word16 Word64) packMask :: (PackedCoords -> Int) -> Mask -> BitMask packMask f = foldMap (\c -> BitSet.Set $ case c of Left (Brick k) -> Bit.bitLeft k Right k -> Bit.bitRight $ f k) packFlat :: Size -> PackedCoords -> Int packFlat _size (PackedCoords k) = k packPyramid :: Size -> PackedCoords -> Int packPyramid size@(Coords sizez _ _) p = case Cuboid.unpackCoords size p of Cuboid.Coords nz y x -> let z = sizez-1-nz in div (z*(z+1)*(2*z+1)) 6 + (z+1)*y + x main, mainBase, mainBits :: IO () -- 14 min for pyramid solutions mainBase = forM_ [targetPyramid, targetBase] $ \targetString -> do let target = Cuboid.coordsFromString targetString size = Cuboid.size target sol = ESC.partitions $ fittingAssigns size target printMask size $ head sol -- 2 min for pyramid solutions mainBits = forM_ [(targetPyramid, packPyramid), (targetBase, packFlat)] $ \(targetString, pack) -> do let target = Cuboid.coordsFromString targetString size = Cuboid.size target sol = ESC.partitions $ map (fmap (packMask (pack size))) $ fittingAssigns size target if True then mapM_ (printMask size) sol else printMask size $ head sol printf "total number of solutions: %d\n\n" $ length sol main = mainBits