packages feed

Foster 1.1.0 → 1.1.1

raw patch · 9 files changed

+428/−4 lines, 9 files

Files

Foster.cabal view
@@ -1,5 +1,5 @@ name:                Foster-version:             1.1.0+version:             1.1.1 synopsis:            Utilities to generate and solve puzzles description:         Utilities to generate and solve puzzles license:             MIT@@ -8,7 +8,7 @@ maintainer:          notjefff@gmail.com category:            Data build-type:          Simple-cabal-version:       >=1.10+cabal-version:       >=1.7  source-repository head   type: git@@ -16,6 +16,14 @@  executable foster    main-is:             Main.hs+  other-modules:       Foster.Checker,+                       Foster.Data,+                       Foster.Generator,+                       Foster.Interpreter,+                       Foster.IO,+                       Foster.Parser,+                       Foster.Solver,+                       Foster.Utils   build-depends:       base >=4.7 && <4.8,                         random >=1.0 && <1.1,                        containers >= 0.5 && < 0.6,@@ -23,12 +31,19 @@                        cmdtheline >= 0.2 && < 0.3,                        strict >= 0.3 && < 0.4   hs-source-dirs:      src-  default-language:    Haskell2010   ghc-options:         -Wall -fno-warn-orphans -threaded +RTS -N -RTS  Benchmark foster-benchmark   type:                exitcode-stdio-1.0   main-is:             Bench.hs+  other-modules:       Foster.Checker,+                       Foster.Data,+                       Foster.Generator,+                       Foster.Interpreter,+                       Foster.IO,+                       Foster.Parser,+                       Foster.Solver,+                       Foster.Utils   build-depends:       base >=4.7 && <4.8,                         random >=1.0 && <1.1,                        containers >= 0.5 && < 0.6,@@ -37,5 +52,4 @@                        strict >= 0.3 && < 0.4,                        criterion   hs-source-dirs:      src, benchmarks-  default-language:    Haskell2010   ghc-options:         -Wall -fno-warn-orphans -threaded +RTS -N -RTS
+ src/Foster/Checker.hs view
@@ -0,0 +1,23 @@+module Foster.Checker where++import Foster.Solver (solvePuzzle)+import Foster.IO (readUnsolvedPuzzle, showSolvedPuzzle)+import Control.Monad (unless)++-- @todo: also give column and show only the important part of the row+check :: FilePath -> FilePath -> Bool -> IO ()+check inp out sil = do+    unPuz <- readUnsolvedPuzzle inp+    solPuzStr1 <- readFile out++    solPuz2 <- solvePuzzle sil unPuz+    let solPuzStr2 = showSolvedPuzzle solPuz2+    let zipL = filter (\(_, b, c) -> b /= c) $ zip3 [1..] (lines solPuzStr1) (lines solPuzStr2)+    if null zipL+        then unless sil . putStrLn $ "Solution is correct"+        else unless sil $+            mapM_ (\(i, a, b) -> do+                putStrLn $ "Mismatch on line " ++ show (i :: Int) ++ ":"+                putStrLn $ "        " ++ a+                putStrLn "    Should be:"+                putStrLn $ "        " ++ b ++ "\n") zipL
+ src/Foster/Data.hs view
@@ -0,0 +1,34 @@+module Foster.Data where++import Data.List (intercalate)+import Data.Map (Map)++type PieceId        = String+type PieceContent   = Char+ +data Piece = Piece { getContent :: PieceContent+                   , getId      :: PieceId+                   , getNorthId :: PieceId+                   , getEastId  :: PieceId+                   , getSouthId :: PieceId+                   , getWestId  :: PieceId+                   } deriving (Eq)+                   +instance Show Piece where+	show (Piece c i ni ei si wi) = intercalate "\t" [i, [c], ni, ei, si, wi]+ +type UnsolvedPuzzle = [Piece]+type SolvedPuzzle  	= [[Piece]]+type PuzzleGroup    = Map PieceId Piece+type Size           = (Int, Int)++noneId :: PieceId+noneId = "VUOTO"++isTopLeft :: Piece -> Bool+isTopLeft p = getNorthId p == noneId && getWestId p == noneId++getPuzzleSize :: SolvedPuzzle -> (Int, Int)+getPuzzleSize sp = (w, h)+    where w = (length . head) sp+          h = length sp
+ src/Foster/Generator.hs view
@@ -0,0 +1,94 @@+module Foster.Generator (generate) where+ +import Foster.Data+import Foster.Utils+import Foster.IO (writeUnsolvedPuzzle)+import Control.Monad+import System.Random+import Data.Array.IO hiding (newArray)++calcNorthId :: Size -> Int -> PieceId+calcNorthId (w, _) i =+	let x = i - w+	in if x >= 0+		then show x+		else noneId+	+calcEastId :: Size -> Int -> PieceId+calcEastId (w, _) i =+	let x = i + 1+	in if (x `mod` w) /= 0+		then show x+		else noneId+		+calcSouthId :: Size -> Int -> PieceId+calcSouthId (w, h) i =+	let x = i + w+	in if (x `div` w) < h+		then show x+		else noneId+		+calcWestId :: Size -> Int -> PieceId+calcWestId (w, _) i =+	let x = i - 1+	in if (i `mod` w) /= 0+		then show x+		else noneId++generatePiece :: Size -> String -> Int -> Piece+generatePiece sz s i =+    let c = s !! (i `mod` length s)+    in  Piece+            c +            (show i)+            (calcNorthId sz i)+            (calcEastId sz i)+            (calcSouthId sz i)+            (calcWestId sz i)++generatePieces :: Size -> Bool -> String -> IO [Piece]+generatePieces siz@(w, h) sil str = do+    putStrLn str+    let tot = w * h+    ps <- mapM +        (\i -> do+            unless sil $ putPercOver (i + 1, tot) "Generating"+            return $ generatePiece siz str i)+        [0..(tot - 1)]+    unless sil $ putStrLn "" >> flush+    return ps++-- @todo: +--      we can probably get rid of this+--      with a total injective mapping function+--      to generate pieces already "shuffled"+shuffle :: Bool -> [a] -> IO [a]+shuffle sil xs = do+        ar <- newArray n xs+        es <- forM [1..n] $ \i -> do+            unless sil $ putPercOver (i, n) "Shuffling"+            j <- randomRIO (i,n)+            vi <- readArray ar i+            vj <- readArray ar j+            writeArray ar j vi+            return vj+        unless sil $ putStrLn "" >> flush+        return es+  where+    n = length xs+    newArray :: Int -> [a] -> IO (IOArray Int a)+    newArray ni = newListArray (1, ni)++generatePuzzle :: Size -> String -> Bool -> IO UnsolvedPuzzle+generatePuzzle (w, h) str sil = do+    ps <- generatePieces (w, h) sil str+    shuffle sil ps++generate :: Size -> String -> FilePath -> Bool -> IO ()+generate (h, w) str out sil = do+    puz <- generatePuzzle (w, h) str sil+    unless sil $ putPercOver (0, 1) "Saving" >> flush+    writeUnsolvedPuzzle out puz+    unless sil $ do+        putPercOver (1, 1) "Saving" >> putStr "\n"+        putStrLn $ "Generated → " ++ out
+ src/Foster/IO.hs view
@@ -0,0 +1,42 @@+module Foster.IO +    ( writeUnsolvedPuzzle+    , readUnsolvedPuzzle+    , writeSolvedPuzzle+    , showSolvedPuzzle+    ) where++import System.IO (withFile, hPutStr, hPrint, IOMode(..))+import Control.Monad (liftM)+import Foster.Data+import Foster.Utils (getFileLines)+import Foster.Parser++writeUnsolvedPuzzle :: FilePath -> UnsolvedPuzzle -> IO ()+writeUnsolvedPuzzle out puz =+    withFile out WriteMode $ \fh ->+        mapM_ (hPrint fh) puz++readUnsolvedPuzzle :: FilePath -> IO UnsolvedPuzzle+readUnsolvedPuzzle inputPath =+    liftM parsePieces (getFileLines inputPath)++showPuzzleString :: SolvedPuzzle -> String+showPuzzleString = map getContent . concat++showPuzzleSize :: SolvedPuzzle -> String+showPuzzleSize = (\(w, h) -> concat [show h, " ", show w]) . getPuzzleSize++showPuzzleTable :: SolvedPuzzle -> String+showPuzzleTable = concatMap ((++ "\n") . map getContent)++showSolvedPuzzle :: SolvedPuzzle -> String+showSolvedPuzzle puz =+    concat+        [ showPuzzleString puz, "\n\n"+        , showPuzzleTable puz, "\n"+        , showPuzzleSize puz ]++writeSolvedPuzzle :: FilePath -> SolvedPuzzle -> IO ()+writeSolvedPuzzle out puz =+    withFile out WriteMode $ \fh ->+        hPutStr fh (showSolvedPuzzle puz)
+ src/Foster/Interpreter.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}++module Foster.Interpreter+    ( interpret+    ) where++import Foster.Generator (generate)+import Foster.Solver (solve)+import Foster.Checker (check)+import Control.Applicative+import System.Console.CmdTheLine+import Foster.Data (Size)++instance ArgVal Size where+    converter = pair ','++instance ArgVal (Maybe Size) where+    converter = just++silentArg :: Term Bool+silentArg = value . flag $ optInfo ["silent", "s"]++sizeArg :: Term Size +sizeArg =+    required . pos 0 Nothing $+        posInfo+            { posName = "SIZE"+            , posDoc = "size defined as 'rows,columns';"+                    ++ " for example: 'foster generate 20,10'"+            }++stringArg :: Term String+stringArg =+    value . opt "ƒøsT3r! " $+        (optInfo ["t", "text"])+            { optName = "TEXT"+            , optDoc = "string to be used and eventually repeated"+            }++inArg :: Term FilePath+inArg = +    value . opt "input.txt" $ +        (optInfo ["i", "input"])+             { optName = "INPUT"+             , optDoc  = "input file"+             }++outButReallyInArg :: Term FilePath+outButReallyInArg =+    value . opt "input.txt" $+        (optInfo ["o", "output"])+            { optName = "OUTPUT"+            , optDoc = "output file"+            }++outArg :: Term FilePath+outArg = +    value . opt "output.txt" $ +        (optInfo ["o", "output"])+             { optName = "OUTPUT"+             , optDoc  = "output file"+             }++generateTerm :: (Term (IO ()), TermInfo)+generateTerm = +    ( generate +        <$> sizeArg+        <*> stringArg+        <*> outButReallyInArg+        <*> silentArg+    , defTI +        { termName = "generate"+        , termDoc = "Generates a new puzzle"+        } )++solveTerm :: (Term (IO ()), TermInfo)+solveTerm = +    ( solve +        <$> fileExists inArg+        <*> validPath outArg+        <*> silentArg+    , defTI +        { termName = "solve"+        , termDoc = "Solves a puzzle"+        } )++checkTerm :: (Term (IO ()), TermInfo)+checkTerm = +    ( check+        <$> fileExists inArg+        <*> fileExists outArg+        <*> silentArg+    , defTI+        { termName = "check"+        , termDoc = "Checks that a solution to a puzzle is correct"+        } )++baseTerm :: (Term (IO ()), TermInfo)+baseTerm = +    ( ret $ pure $ helpFail Plain Nothing+    , defTI+        { termName = "foster"+        , version = "1.1.1"+        }+    )++interpret :: IO () +interpret =+    runChoice baseTerm+        [ generateTerm+        , solveTerm+        , checkTerm ]
+ src/Foster/Parser.hs view
@@ -0,0 +1,17 @@+module Foster.Parser where++import Foster.Data+import Foster.Utils (splitOn)++parsePiece :: String -> Piece+parsePiece s = +    let segs = splitOn (== '\t') s+    in  Piece { getContent    = head $ segs !! 1+              , getId         = head segs+              , getNorthId    = segs !! 2+              , getEastId     = segs !! 3+              , getSouthId    = segs !! 4+              , getWestId     = segs !! 5 }++parsePieces :: [String] -> UnsolvedPuzzle+parsePieces = map parsePiece
+ src/Foster/Solver.hs view
@@ -0,0 +1,56 @@+module Foster.Solver+    ( solve+    , solvePuzzle+    ) where++import Data.Map (Map)+import Data.List (find)+import Foster.Data+import Foster.Utils+import Control.Monad (unless)+import Foster.IO (writeSolvedPuzzle, readUnsolvedPuzzle)+import qualified Data.Map as M+import Debug.Trace (trace, traceShow)++buildMap :: UnsolvedPuzzle -> Map PieceId Piece+buildMap ps = M.fromList . map buildMapElem $ ps+    where buildMapElem :: Piece -> (PieceId, Piece)+          buildMapElem p = (getId p, p)++getPiecesAlong :: (Piece -> PieceId) -> Map PieceId Piece -> Piece -> [Piece]+getPiecesAlong ex m p+    | ex p == noneId   = [p]+    | otherwise             =+        let (Just np) = M.lookup (ex p) m+        in  p : getPiecesAlong ex m np++solvePuzzle :: Bool -> UnsolvedPuzzle -> IO SolvedPuzzle+solvePuzzle sil ps = do+    unless sil $ putPercOver (0, 4) "Preparing" >> flush+    let m = buildMap ps+    m `seq` unless sil $ putPercOver (1, 4) "Preparing" >> flush+    let (Just tl) = find isTopLeft ps+    tl `seq` unless sil $ putPercOver (2, 4) "Preparing" >> flush+    let firstCol = getPiecesAlong getSouthId m tl+    firstCol `seq` unless sil $ putPercOver (3, 4) "Preparing" >> flush+    let rs = length firstCol+    rs `seq` unless sil $ putPercOver (4, 4) "Preparing" >> putStrLn ""+    sp <- mapM +        (\(i, p) -> do+            unless sil $ putPercOver (i, rs) "Solving"+            return $ getPiecesAlong getEastId m p) +        (zip [1..rs] firstCol)+    putStrLn "" >> flush+    return sp++solve :: FilePath -> FilePath -> Bool -> IO ()+solve inp out sil = do+    unless sil $ putPercOver (0, 1) "Reading" >> flush+    up <- readUnsolvedPuzzle inp+    unless sil $ putPercOver (1, 1) "Reading" >> putStrLn ""+    sp <- solvePuzzle sil up+    unless sil $ putPercOver (0, 1) "Saving" >> flush+    writeSolvedPuzzle out sp+    unless sil $ do+        putPercOver (1, 1) "Saving" >> putStrLn ""+        putStrLn $ "Solved → " ++ out
+ src/Foster/Utils.hs view
@@ -0,0 +1,32 @@+module Foster.Utils where++import Control.Monad+import System.IO (stdout, hFlush)+import System.IO.Strict (readFile)+import Prelude hiding (readFile)++getFileLines :: FilePath -> IO [String]+getFileLines path = liftM lines (readFile path)++splitOn :: (a -> Bool) -> [a] -> [[a]]+splitOn _ [] = []+splitOn c ls = +    let (l, r) = break c ls+    in l : (splitOn c . drop 1 $ r)++putStrOver :: String -> IO ()+putStrOver str = putStr $ "\r" ++ str ++ "\o33[K"++putPercOver :: (Int, Int) -> String -> IO ()+putPercOver (a, b) str = do+    let perc = (a * 100) `div` b+    putStrOver . concat $+        [ "[", show perc, "%] "+        , str, "..."+        ]++flush :: IO ()+flush = hFlush stdout++flushAll :: IO ()+flushAll = hFlush stdout