sum-pyramid (empty) → 0.0
raw patch · 12 files changed
+881/−0 lines, 12 filesdep +basedep +combinatorialdep +comfort-arraysetup-changed
Dependencies added: base, combinatorial, comfort-array, containers, doctest-exitcode-stdio, doctest-lib, lapack, optparse-applicative, random, shell-utility, transformers, unique-logic-tf, utility-ht
Files
- LICENSE +30/−0
- Makefile +38/−0
- Setup.hs +2/−0
- puzzle.tex +30/−0
- src/Common.hs +21/−0
- src/LinearAlgebra.hs +201/−0
- src/Main.hs +282/−0
- src/UniqueLogic.hs +120/−0
- sum-pyramid.cabal +76/−0
- test/Test/LinearAlgebra.hs +25/−0
- test/Test/UniqueLogic.hs +44/−0
- test/TestMain.hs +12/−0
+ LICENSE view
@@ -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.
+ Makefile view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ puzzle.tex view
@@ -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}
+ src/Common.hs view
@@ -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
+ src/LinearAlgebra.hs view
@@ -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.+-}
+ src/Main.hs view
@@ -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<n && n<=1000)+ "positive, below 1000") $+ OP.long "size" <>+ OP.metavar "NATURAL" <>+ OP.help "Width of the pyramid")+ <*>+ (OP.option+ (OP.eitherReader $+ parseNumber "number" (\n -> 0<n && n<=1000000)+ "positive, below 1000000") $+ OP.long "number" <>+ OP.value 1 <>+ OP.metavar "NATURAL" <>+ OP.help "Number of puzzles")+ <*>+ (OP.option+ (OP.eitherReader $+ parseNumber "number" (\n -> 0<n && n<=1000000)+ "positive, below 1000000") $+ OP.long "max-value" <>+ 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
+ src/UniqueLogic.hs view
@@ -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
+ sum-pyramid.cabal view
@@ -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
+ test/Test/LinearAlgebra.hs view
@@ -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])"]]
+ test/Test/UniqueLogic.hs view
@@ -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)]"]]
+ test/TestMain.hs view
@@ -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