diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2024, Henning Thielemann + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Henning Thielemann nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,38 @@ +CABALOPTS := + +.PHONY: all + +all: puzzle.pdf + +puzzle.pdf: puzzle.tex mixed.tex multiplication.tex + pdflatex $< + +mixed.tex: src/Main.hs + cabal run --verbose=0 sum-pyramid $(CABALOPTS) -- \ + create --size 5 --number 12 \ + --environment puzzle --hidden hidden >$@ + cabal run --verbose=0 sum-pyramid $(CABALOPTS) -- \ + create --size 5 --number 12 --allow-gaps \ + --environment puzzle --hidden hidden >>$@ + cabal run --verbose=0 sum-pyramid $(CABALOPTS) -- \ + create --size 5 --number 12 --max-value=50 \ + --environment puzzle --hidden hidden >>$@ + cabal run --verbose=0 sum-pyramid $(CABALOPTS) -- \ + create --size 5 --number 24 --mixed \ + --environment puzzle --hidden hidden >>$@ + +multiplication.tex: src/Main.hs + cabal run --verbose=0 sum-pyramid $(CABALOPTS) -- \ + create --size 4 --number 12 --multiplication \ + --environment puzzle --hidden hidden >$@ + + +run-test: update-test + runhaskell Setup configure --user --enable-tests + runhaskell Setup build + runhaskell Setup test sum-pyramid-test --show-details=streaming + make puzzle.pdf + +update-test: + doctest-extract-0.1 -i src/ -o test/ --import-tested --executable-main=TestMain.hs \ + UniqueLogic LinearAlgebra diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/puzzle.tex b/puzzle.tex new file mode 100644 --- /dev/null +++ b/puzzle.tex @@ -0,0 +1,30 @@ +\documentclass[a4paper]{article} + +\usepackage[landscape,margin=1cm]{geometry} +\usepackage{times} +\usepackage{anyfontsize} +\usepackage{pict2e} +\usepackage{color} + +\newenvironment{puzzle}{\noindent\mbox{}\vfill}{\newpage} + +\newcommand\puzzles{ +\fontsize{36}{42}\selectfont +\setlength{\unitlength}{2.1em} +\input{mixed} +% +\setlength{\unitlength}{2.5em} +\input{multiplication} +} + +\begin{document} + +\bf + +\newcommand\hidden[1]{} +\puzzles{} + +\renewcommand\hidden[1]{\textcolor[gray]{0.5}{#1}} +\puzzles{} + +\end{document} diff --git a/src/Common.hs b/src/Common.hs new file mode 100644 --- /dev/null +++ b/src/Common.hs @@ -0,0 +1,21 @@ +module Common where + +import qualified Data.Array.Comfort.Boxed as BoxedArray +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Boxed (Array) + + + +data Op = Add | Mul + deriving (Eq, Ord, Enum, Show) + +sizeFromOps :: Array (Shape.LowerTriangular ShapeInt) op -> Int +sizeFromOps = succ . Shape.size . Shape.triangularSize . BoxedArray.shape + +type ShapeInt = Shape.ZeroBased Int + + +type SolutionCheck a = + BoxedArray.Array (Shape.LowerTriangular ShapeInt) Op -> + [((Int,Int),a)] -> + Bool diff --git a/src/LinearAlgebra.hs b/src/LinearAlgebra.hs new file mode 100644 --- /dev/null +++ b/src/LinearAlgebra.hs @@ -0,0 +1,201 @@ +module LinearAlgebra where + +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Singular as Singular +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix (ShapeInt, (#*|)) +import Numeric.LAPACK.Format ((##)) + +import qualified Combinatorics + +import qualified Data.Array.Comfort.Boxed as BoxedArray +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set +import Data.Array.Comfort.Storable (Array) + +import Data.Foldable (for_) +import Data.Tuple.HT (mapSnd) + + + +{- $setup +>>> import qualified Data.Array.Comfort.Storable as Array +>>> import Data.Tuple.HT (mapSnd) +>>> +>>> myRound :: Double -> Integer +>>> myRound = round +-} + + +example0 :: [Double] +example0 = [3,1,4,1,5] + +{- + ... + ... ... + ... ... ... + ... 100 ... .79 +.31 .41 ... .26 ... +-} +example2 :: [[Maybe Double]] +example2 = + let __ = Nothing; d = Just in + [__] : + [__, __] : + [__, __, __] : + [__, d 100, __, d 79] : + [d 31, d 41, __, d 26, __] : + [] + +pyramid :: + Array ShapeInt Double -> + Array (Shape.LowerTriangular ShapeInt) Double +pyramid xs = + let shape = Array.shape xs + baseRow = Shape.size shape - 1 + arr = + fmap (\(i,j) -> + if i==baseRow + then xs Array.! j + else arr BoxedArray.! (i+1,j) + arr BoxedArray.! (i+1,j+1)) $ + BoxedArray.indices $ Shape.lowerTriangular shape + in Array.fromBoxed arr + +basis :: + ShapeInt -> Matrix.General ShapeInt (Shape.LowerTriangular ShapeInt) Double +basis shape@(Shape.ZeroBased n) = + Matrix.fromRows (Shape.lowerTriangular shape) $ + map (pyramid . Vector.unit shape) $ take n [0..] + +addIndices :: [[Maybe a]] -> [((Int,Int), a)] +addIndices puzzle = do + (i, xs) <- zip [0..] puzzle + (j, Just x) <- zip [0..] xs + return ((i,j),x) + +{- | +>>> mapSnd (map myRound . Array.toList) $ solve 3 [((0,0),8), ((2,0),1), ((2,2),3)] +(3,[8,3,5,1,2,3]) +-} +solve :: + Int -> [((Int,Int),Double)] -> + (Int, Array (Shape.LowerTriangular ShapeInt) Double) +solve n indexed = + let fullBasis = Matrix.transpose $ basis (Matrix.shapeInt n) + selected = + Matrix.takeRowArray + (BoxedArray.vectorFromList (map fst indexed)) + fullBasis + in mapSnd ((fullBasis #*|) . Matrix.flattenColumn) + (Singular.leastSquaresMinimumNormRCond 1e-5 selected $ + Matrix.singleColumn Layout.ColumnMajor $ + Vector.autoFromList (map snd indexed)) + +solvable :: Int -> [(Int,Int)] -> Bool +solvable n = + let shape = Matrix.shapeInt n + fullBasis = basis shape + in \ixs -> + (n==) $ length $ takeWhile (1e-5<) $ Vector.toList $ + (#*| Vector.one shape) $ Singular.values $ + Matrix.takeColumnArray (BoxedArray.vectorFromList ixs) fullBasis + +solvables :: Int -> [[(Int,Int)]] +solvables n = + let check = solvable n + in filter check $ + Combinatorics.tuples n $ Shape.indices $ + Shape.lowerTriangular $ Matrix.shapeInt n + +{- +Check, whether a sum pyramid contains a sub-pyramid of size k +with more than k given fields. +If yes, then the pyramid has redundancies in a sub-pyramid +and is not solvable. +-} +wellcrowded :: Int -> [(Int,Int)] -> Bool +wellcrowded n ixs = + let triShape = Shape.lowerTriangular $ Matrix.shapeInt n + set = Set.fromList ixs + countSubTriangle (i,j) k = + length $ + filter (\(si,sj) -> Set.member (i+si,j+sj) set) $ + Shape.indices $ Shape.lowerTriangular $ Matrix.shapeInt k + in and $ do + (i,j) <- Shape.indices triShape + k <- [0..n-i] + return $ countSubTriangle (i,j) k <= k + +wellcrowdedIntSet :: Int -> [(Int,Int)] -> Bool +wellcrowdedIntSet n ixs = + let triShape = Shape.lowerTriangular $ Matrix.shapeInt n + set = IntSet.fromList $ map (Shape.offset triShape) ixs + countSubTriangle (i,j) k = + length $ + filter (\(si,sj) -> + flip IntSet.member set $ Shape.offset triShape (i+si,j+sj)) $ + Shape.indices $ Shape.lowerTriangular $ Matrix.shapeInt k + in and $ do + (i,j) <- Shape.indices triShape + k <- [0..n-i] + return $ countSubTriangle (i,j) k <= k + + +{- +Check whether the linear independence criterion matches +the subpyramid criterion 'wellcrowded'. +Well, it does not, the smallest counterexample is: + + * + . . + . * . +* . . * +-} +counterexamples :: Int -> [[(Int, Int)]] +counterexamples n = + let check = solvable n + in filter (\ixs -> check ixs /= wellcrowded n ixs) $ + Combinatorics.tuples n $ Shape.indices $ + Shape.lowerTriangular $ Matrix.shapeInt n + + +boolMatrix :: Int -> [(Int, Int)] -> Matrix.Lower ShapeInt Float +boolMatrix n ixs = + Triangular.fromLowerRowMajor $ + Array.fromAssociations 0 + (Shape.lowerTriangular $ Matrix.shapeInt n) + (map (\ix -> (ix,1::Float)) ixs) + + +test :: IO () +test = do + Triangular.fromLowerRowMajor (pyramid (Vector.autoFromList example0)) + ## "%.0f" + + let xs = example2 + in mapSnd Triangular.fromLowerRowMajor (solve (length xs) (addIndices xs)) + ## "%.0f" + + putStrLn "\nsolvable:" + let n = 3 + in for_ (solvables n) $ \ixs -> do + putStrLn "" + boolMatrix n ixs ## "%.0f" + + putStrLn "\nunsolvable:" + for_ [0..5] $ \n -> + for_ (counterexamples n) $ \ixs -> do + putStrLn "" + boolMatrix n ixs ## "%.0f" + +{- +https://oeis.org/A014068 + +map (\n -> Comb.binomial (div (n*(n+1)) 2) n) [1..10::Integer] + +Possibilities of choosing n numbers from a n-sized pyramid. +-} diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,282 @@ +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 diff --git a/src/UniqueLogic.hs b/src/UniqueLogic.hs new file mode 100644 --- /dev/null +++ b/src/UniqueLogic.hs @@ -0,0 +1,120 @@ +module UniqueLogic where + +import Common + +import qualified UniqueLogic.ST.TF.Rule as Rule +import qualified UniqueLogic.ST.TF.System.Simple as Sys +import qualified UniqueLogic.ST.TF.ZeroFractional as ZeroFrac + +import qualified Combinatorics + +import Control.Monad.ST (ST, runST) + +import qualified Data.Array.Comfort.Boxed as BoxedArray +import qualified Data.Array.Comfort.Shape as Shape +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import Data.Array.Comfort.Boxed ((!)) +import Data.Foldable (for_, traverse_) +import Data.Maybe (isJust) +import Data.Tuple.HT (mapSnd) + + +{- $setup +>>> import qualified Data.Array.Comfort.Boxed as BoxedArray +>>> import qualified Data.Array.Comfort.Shape as Shape +>>> import Common +-} + + +type Variable s a = Sys.Variable (ST s) a +type System s = Sys.T (ST s) + +system :: + BoxedArray.Array + (Shape.LowerTriangular ShapeInt) + (Variable s a -> + Variable s a -> + Variable s a -> + System s ()) -> + ST s + (BoxedArray.Array (Shape.LowerTriangular ShapeInt) (Variable s a), + System s ()) +system ops = do + let n = sizeFromOps ops + vars <- + Trav.sequence $ + BoxedArray.replicate + (Shape.lowerTriangular $ Shape.ZeroBased n) + Sys.globalVariable + return + (vars, + traverse_ + (\((i,j),rule) -> rule (vars!(i+1,j)) (vars!(i+1,j+1)) (vars!(i,j))) + (BoxedArray.toAssociations ops)) + + +{- | +>>> solve 3 [((0,0),1), ((1,0),1), ((2,0),1::Integer)] +BoxedArray...Triangular... 3... [Just 1,Just 1,Just 0,Just 1,Just 0,Just 0] + +>>> solve 3 [((0,0),1), ((2,0),1), ((2,2),1::Integer)] +BoxedArray...Triangular... 3... [Just 1,Nothing,Nothing,Just 1,Nothing,Just 1] +-} +solve :: + (Num a) => + Int -> [((Int,Int),a)] -> + BoxedArray.Array (Shape.LowerTriangular ShapeInt) (Maybe a) +solve n xs = + runST + (do + (vars, sys) <- + system $ + BoxedArray.replicate + (Shape.lowerTriangular $ Shape.ZeroBased $ n-1) + Rule.add + Sys.solve $ do + sys + for_ xs $ \(ij,x) -> + Rule.equ (vars!ij) =<< Sys.constant x + traverse Sys.query vars) + +{- | +>>> solveMixed (BoxedArray.fromList (Shape.lowerTriangular $ Shape.ZeroBased 1) [Mul]) [((0,0),0), ((1,1),0::Rational)] +BoxedArray...Triangular... 2... [Just (0 % 1),Nothing,Just (0 % 1)] +>>> solveMixed (BoxedArray.fromList (Shape.lowerTriangular $ Shape.ZeroBased 1) [Mul]) [((0,0),0), ((1,1),5::Rational)] +BoxedArray...Triangular... 2... [Just (0 % 1),Just (0 % 1),Just (5 % 1)] +-} +solveMixed :: + (ZeroFrac.C a) => + BoxedArray.Array (Shape.LowerTriangular ShapeInt) Op -> + [((Int,Int),a)] -> + BoxedArray.Array (Shape.LowerTriangular ShapeInt) (Maybe a) +solveMixed ops xs = + runST + (do + let rule op = + case op of + Add -> Rule.add + Mul -> Rule.mul + (vars, sys) <- system $ fmap rule ops + Sys.solve $ do + sys + for_ xs $ \(ij,x) -> + Rule.equ (vars!ij) =<< Sys.constant x + traverse Sys.query vars) + + +solvable :: Int -> [(Int, Int)] -> Bool +solvable n = Fold.all isJust . solve n . map (\ij -> (ij, 0::Integer)) + +solvables :: Int -> [[(Int,Int)]] +solvables n = + filter (solvable n) $ + Combinatorics.tuples n $ Shape.indices $ + Shape.lowerTriangular $ Shape.ZeroBased n + + +solvableMixed :: SolutionCheck Integer +solvableMixed ops puzzle = + Fold.all isJust $ solveMixed ops $ map (mapSnd toRational) puzzle diff --git a/sum-pyramid.cabal b/sum-pyramid.cabal new file mode 100644 --- /dev/null +++ b/sum-pyramid.cabal @@ -0,0 +1,76 @@ +Name: sum-pyramid +Version: 0.0 +Synopsis: Create Sum Pyramid (Additionstreppe) exercises +Description: + Create Sum Pyramid (Additionstreppe) exercises. + You specify the size of the pyramid and the number range of the base line + and the program emits LaTeX code for puzzles. + . + > sum-pyramid create --size 5 +Homepage: https://hub.darcs.net/thielema/sum-pyramid +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: haskell@henning-thielemann.de +Category: Math +Build-Type: Simple +Cabal-Version: >=1.10 + +Extra-Source-Files: + Makefile + puzzle.tex + +Source-Repository this + Tag: 0.0 + Type: darcs + Location: https://hub.darcs.net/thielema/sum-pyramid + +Source-Repository head + Type: darcs + Location: https://hub.darcs.net/thielema/sum-pyramid + +Executable sum-pyramid + Build-Depends: + lapack >=0.5.1 && <0.6, + unique-logic-tf >=0.5.1 && <0.6, + combinatorial >=0.1.1 && <0.2, + random >=1.2.1 && <1.3, + comfort-array >=0.5 && <0.6, + containers >=0.5.4 && <0.8, + transformers >=0.3 && <0.7, + shell-utility >=0.1 && <0.2, + optparse-applicative >=0.11 && <0.19, + utility-ht >=0.0.11 && <0.1, + base >=4.5 && <5 + Default-Language: Haskell2010 + GHC-Options: -Wall + Hs-Source-Dirs: src + Main-is: Main.hs + Other-Modules: + UniqueLogic + LinearAlgebra + Common + +Test-Suite sum-pyramid-test + Type: exitcode-stdio-1.0 + Build-Depends: + doctest-exitcode-stdio >=0.0 && <0.1, + doctest-lib >=0.1 && <0.2, + lapack, + unique-logic-tf, + combinatorial, + comfort-array, + containers, + transformers, + utility-ht, + base + Default-Language: Haskell2010 + GHC-Options: -Wall + Hs-Source-Dirs: src, test + Main-is: TestMain.hs + Other-Modules: + Test.UniqueLogic + Test.LinearAlgebra + UniqueLogic + LinearAlgebra + Common diff --git a/test/Test/LinearAlgebra.hs b/test/Test/LinearAlgebra.hs new file mode 100644 --- /dev/null +++ b/test/Test/LinearAlgebra.hs @@ -0,0 +1,25 @@ +-- Do not edit! Automatically created with doctest-extract from src/LinearAlgebra.hs +{-# LINE 25 "src/LinearAlgebra.hs" #-} + +module Test.LinearAlgebra where + +import LinearAlgebra +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 26 "src/LinearAlgebra.hs" #-} +import qualified Data.Array.Comfort.Storable as Array +import Data.Tuple.HT (mapSnd) + +myRound :: Double -> Integer +myRound = round + +test :: DocTest.T () +test = do + DocTest.printPrefix "LinearAlgebra:81: " +{-# LINE 81 "src/LinearAlgebra.hs" #-} + DocTest.example( +{-# LINE 81 "src/LinearAlgebra.hs" #-} + mapSnd (map myRound . Array.toList) $ solve 3 [((0,0),8), ((2,0),1), ((2,2),3)] + ) + [ExpectedLine [LineChunk "(3,[8,3,5,1,2,3])"]] diff --git a/test/Test/UniqueLogic.hs b/test/Test/UniqueLogic.hs new file mode 100644 --- /dev/null +++ b/test/Test/UniqueLogic.hs @@ -0,0 +1,44 @@ +-- Do not edit! Automatically created with doctest-extract from src/UniqueLogic.hs +{-# LINE 23 "src/UniqueLogic.hs" #-} + +module Test.UniqueLogic where + +import UniqueLogic +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 24 "src/UniqueLogic.hs" #-} +import qualified Data.Array.Comfort.Boxed as BoxedArray +import qualified Data.Array.Comfort.Shape as Shape +import Common + +test :: DocTest.T () +test = do + DocTest.printPrefix "UniqueLogic:58: " +{-# LINE 58 "src/UniqueLogic.hs" #-} + DocTest.example( +{-# LINE 58 "src/UniqueLogic.hs" #-} + solve 3 [((0,0),1), ((1,0),1), ((2,0),1::Integer)] + ) + [ExpectedLine [LineChunk "BoxedArray",WildCardChunk,LineChunk "Triangular",WildCardChunk,LineChunk " 3",WildCardChunk,LineChunk " [Just 1,Just 1,Just 0,Just 1,Just 0,Just 0]"]] + DocTest.printPrefix "UniqueLogic:61: " +{-# LINE 61 "src/UniqueLogic.hs" #-} + DocTest.example( +{-# LINE 61 "src/UniqueLogic.hs" #-} + solve 3 [((0,0),1), ((2,0),1), ((2,2),1::Integer)] + ) + [ExpectedLine [LineChunk "BoxedArray",WildCardChunk,LineChunk "Triangular",WildCardChunk,LineChunk " 3",WildCardChunk,LineChunk " [Just 1,Nothing,Nothing,Just 1,Nothing,Just 1]"]] + DocTest.printPrefix "UniqueLogic:83: " +{-# LINE 83 "src/UniqueLogic.hs" #-} + DocTest.example( +{-# LINE 83 "src/UniqueLogic.hs" #-} + solveMixed (BoxedArray.fromList (Shape.lowerTriangular $ Shape.ZeroBased 1) [Mul]) [((0,0),0), ((1,1),0::Rational)] + ) + [ExpectedLine [LineChunk "BoxedArray",WildCardChunk,LineChunk "Triangular",WildCardChunk,LineChunk " 2",WildCardChunk,LineChunk " [Just (0 % 1),Nothing,Just (0 % 1)]"]] + DocTest.printPrefix "UniqueLogic:85: " +{-# LINE 85 "src/UniqueLogic.hs" #-} + DocTest.example( +{-# LINE 85 "src/UniqueLogic.hs" #-} + solveMixed (BoxedArray.fromList (Shape.lowerTriangular $ Shape.ZeroBased 1) [Mul]) [((0,0),0), ((1,1),5::Rational)] + ) + [ExpectedLine [LineChunk "BoxedArray",WildCardChunk,LineChunk "Triangular",WildCardChunk,LineChunk " 2",WildCardChunk,LineChunk " [Just (0 % 1),Just (0 % 1),Just (5 % 1)]"]] diff --git a/test/TestMain.hs b/test/TestMain.hs new file mode 100644 --- /dev/null +++ b/test/TestMain.hs @@ -0,0 +1,12 @@ +-- Do not edit! Automatically created with doctest-extract. +module Main where + +import qualified Test.UniqueLogic +import qualified Test.LinearAlgebra + +import qualified Test.DocTest.Driver as DocTest + +main :: IO () +main = DocTest.run $ do + Test.UniqueLogic.test + Test.LinearAlgebra.test