module Main where import qualified LinearAlgebra as LinAlg import qualified UniqueLogic as Logic import Common import qualified Combinatorics import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS import Control.Monad (replicateM, join) import Control.Applicative (pure, (<*>), (<|>)) import qualified System.Random as Random import Text.Printf (printf) import qualified Data.Array.Comfort.Boxed as BoxedArray import qualified Data.Array.Comfort.Shape as Shape import qualified Data.List.HT as ListHT import qualified Data.Set as Set import Data.Array.Comfort.Boxed (Array, (!)) import Data.Foldable (for_) import Data.Set (Set) import Data.Tuple.HT (mapPair, mapFst) import qualified Options.Applicative as OP import Shell.Utility.ParseArgument (parseNumber) randomR :: (Random.RandomGen g, Random.Random a) => (a,a) -> MS.State g a randomR rng = MS.state $ Random.randomR rng pick :: (Random.RandomGen g) => MS.StateT (Set a) (MS.State g) a pick = do set <- MS.get k <- MT.lift $ randomR (0, Set.size set - 1) MS.put $ Set.deleteAt k set return $ Set.elemAt k set data Allowed = Allowed {allowedAdd, allowedMul :: Bool} pyramid :: (Random.RandomGen g) => Allowed -> Array ShapeInt Integer -> MS.State g (Array (Shape.LowerTriangular ShapeInt) Op, Array (Shape.LowerTriangular ShapeInt) Integer) pyramid allowed base = do let nextRow xs = sequence $ flip ListHT.mapAdjacent xs $ \x0 x1 -> do op <- case allowed of Allowed True True -> fmap toEnum $ randomR (0,1) Allowed False True -> return Mul Allowed _ False -> return Add return $ (,) op $ case op of Add -> x0 + x1 Mul -> x0 * x1 let go xs = do (ops0,ys0) <- fmap unzip $ nextRow xs fmap (mapPair ((ops0:),(ys0:))) $ if null ys0 then return ([],[]) else go ys0 let xs0 = BoxedArray.toList base let shape@(Shape.ZeroBased n) = BoxedArray.shape base let shape1 = Shape.ZeroBased (n-1) (ops,xs) <- go xs0 return (BoxedArray.fromList (Shape.lowerTriangular shape1) $ concat $ reverse ops, BoxedArray.fromList (Shape.lowerTriangular shape) $ concat $ reverse (xs0:xs)) construct :: (Random.RandomGen g) => SolutionCheck Integer -> Allowed -> Int -> Integer -> MS.State g (Array (Shape.LowerTriangular ShapeInt) Op, Array (Shape.LowerTriangular ShapeInt) (Integer,Bool)) construct check allowed n maxV = do let shape = Shape.ZeroBased n let triShape = Shape.lowerTriangular shape xs <- replicateM n $ randomR (0,maxV) (ops,pyr) <- pyramid allowed $ BoxedArray.fromList shape xs let go = do selected <- MS.evalStateT (replicateM n pick) $ Set.fromList $ Shape.indices triShape let puzzle = map (\ij -> (ij, pyr!ij)) selected if check ops puzzle then return selected else go selected <- go return (ops, BoxedArray.zipWith (,) pyr $ BoxedArray.fromAssociations False triShape $ map (flip (,) True) selected) latexFromPuzzle :: String -> Either Int (Array (Shape.LowerTriangular ShapeInt) Op) -> Array (Shape.LowerTriangular ShapeInt) (Integer,Bool) -> [String] latexFromPuzzle hidden mops xs = let n = either id sizeFromOps mops in printf "\\begin{picture}(%d,%d)" (2*n) n : map (\(i,j) -> printf "\\put(%d,%d){\\framebox(2,1){}}" (n-1-i + 2*j) (n-i)) (Shape.indices $ Shape.lowerTriangular $ Shape.ZeroBased n) ++ (BoxedArray.toAssociations xs >>= \((i,j),(x,display)) -> if null hidden && not display then [] else let cell :: String cell = if display then printf "%d" x else printf "\\%s{%d}" hidden x in [printf "\\put(%d,%d){\\makebox(2,1)[c]{%s}}" (n-1-i + 2*j) (n-i) cell]) ++ (case mops of Left _ -> [] Right ops -> let half = 0.5 :: Double in BoxedArray.toAssociations ops >>= \((i,j),op) -> [printf "\\put(%d,%d){\\textcolor{white}{\\circle*{0.5}}}" (n-i + 2*j) (n-i), printf "\\put(%d,%d){\\circle{0.5}}" (n-i + 2*j) (n-i), printf "\\put(%.1f,%.1f){\\makebox(1,1)[c]{$%s$}}" (fromIntegral (n-i + 2*j) - half) (fromIntegral (n-i) - half) (case op of Add -> "+"; Mul -> "\\times{}")]) ++ "\\end{picture}" : [] mainCreate :: (SolutionCheck Integer, (Allowed,Bool)) -> Int -> Int -> Integer -> String -> String -> IO () mainCreate (check,(allowed,displayOps)) n number maxV env hidden = putStr . unlines . concatMap ((if null env then id else (\pic -> printf "\\begin{%s}" env : pic ++ printf "\\end{%s}" env : [])) . uncurry (latexFromPuzzle hidden) . mapFst (if displayOps then Right else const (Left n))) . MS.evalState (replicateM number $ construct check allowed n maxV) =<< Random.initStdGen commandCreate :: OP.Mod OP.CommandFields (IO ()) commandCreate = let parser = pure mainCreate <*> ( (OP.flag' (\ops xs -> LinAlg.solvable (sizeFromOps ops) (map fst xs), (Allowed {allowedAdd = True, allowedMul = False}, False)) $ OP.long "allow-gaps" <> OP.help "Employ both addition and multiplication") <|> (fmap ((,) Logic.solvableMixed) $ (OP.flag' (Allowed {allowedAdd = True, allowedMul = True}, True) $ OP.long "mixed" <> OP.help "Employ both addition and multiplication") <|> (OP.flag (Allowed {allowedAdd = True, allowedMul = False}, False) (Allowed {allowedAdd = False, allowedMul = True}, True) $ OP.long "multiplication" <> OP.help "Employ multiplication only") ) ) <*> (OP.option (OP.eitherReader $ parseNumber "size" (\n -> 0 OP.metavar "NATURAL" <> OP.help "Width of the pyramid") <*> (OP.option (OP.eitherReader $ parseNumber "number" (\n -> 0 OP.value 1 <> OP.metavar "NATURAL" <> OP.help "Number of puzzles") <*> (OP.option (OP.eitherReader $ parseNumber "number" (\n -> 0 OP.value 10 <> OP.metavar "NATURAL" <> OP.help "Upper bound for values in the base line") <*> (OP.strOption $ OP.long "environment" <> OP.value "" <> OP.metavar "NAME" <> OP.help "Custom LaTeX environment around pictures") <*> (OP.strOption $ OP.long "hidden" <> OP.value "" <> OP.metavar "NAME" <> OP.help "Custom LaTeX command for hidden figures") in OP.command "create" $ OP.info (OP.helper <*> parser) (OP.progDesc "create puzzle") {- solvable step-by-step (unique-logic): 1 1 3 16 122 1188 13844 185448 2781348 uniquely solvable (linear algebra): 1 1 3 17 149 1824 29001 573549 13604001 -} mainCount :: (Int -> [(Int,Int)] -> Bool) -> IO () mainCount check = for_ [0..] $ \n -> print $ length $ filter (check n) $ Combinatorics.tuples n $ Shape.indices $ Shape.lowerTriangular $ Shape.ZeroBased n commandCount :: OP.Mod OP.CommandFields (IO ()) commandCount = let parser = pure mainCount <*> (OP.flag Logic.solvable LinAlg.solvable $ OP.long "allow-gaps" <> OP.help "Count puzzles that are uniquely solvable, but not stepwise") in OP.command "count" $ OP.info (OP.helper <*> parser) (OP.progDesc "count solvable puzzles") info :: OP.Parser a -> OP.ParserInfo a info parser = OP.info (OP.helper <*> parser) (OP.fullDesc <> OP.progDesc "Sum pyramid aka Additionstreppe") main :: IO () main = join $ OP.execParser $ info $ OP.subparser $ commandCreate <> commandCount