cpmonad (empty) → 0.1.0.0
raw patch · 9 files changed
+1206/−0 lines, 9 filesdep +HUnitdep +QuickCheckdep +base
Dependencies added: HUnit, QuickCheck, base, bytestring, containers, cpmonad, data-default, deepseq, directory, hspec, hspec-contrib, microlens, microlens-th, mtl, optparse-applicative, process, random, temporary, transformers, vector, vector-algorithms
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- cpmonad.cabal +125/−0
- lib/Cpmonad.hs +539/−0
- lib/Cpmonad/Gen.hs +149/−0
- lib/Cpmonad/Misc.hs +31/−0
- lib/Cpmonad/Printer.hs +256/−0
- test/Cpmonad/PrinterSpec.hs +69/−0
- test/Spec.hs +12/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for cpmonad++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2025 drdilyor++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ cpmonad.cabal view
@@ -0,0 +1,125 @@+cabal-version: 3.0++name: cpmonad+version: 0.1.0.0++category: Tools+synopsis: Competitive programming problemsetting toolchain+description:+ Cpmonad (a typo of Comonad) is a set of tools for setting competitive programming+ problems. It features easy bidirectional parser/serializer, set of generators,+ and tools to automatically run the solutions on all tests. There is no need to+ write checkers for input and output formats.++ This is very much an experiment. It only supports Batch problems, and doesn't+ yet support exporting to polygon or other formats.++license: MIT+license-file: LICENSE+author: drdilyor+maintainer: drdilyor <drdilyor@outlook.com>++homepage: https://github.com/drdilyor/cpmonad+bug-reports: https://github.com/drdilyor/cpmonad/issues++build-type: Simple+extra-doc-files: CHANGELOG.md+extra-source-files:++source-repository head+ type: git+ location: https://github.com/drdilyor/cpmonad.git++common ghc+ ghc-options: -Wall -Wno-name-shadowing+ default-extensions:+ BangPatterns+ BinaryLiterals+ BlockArguments+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DeriveAnyClass+ DoAndIfThenElse+ EmptyDataDecls+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ OverloadedStrings+ OverloadedRecordDot+ PartialTypeSignatures+ PatternGuards+ PolyKinds+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeFamilies+ TypeSynonymInstances+ ViewPatterns+ DeriveAnyClass+ OverloadedStrings+ TypeFamilies++ default-language: GHC2021++common dependencies++-- TODO: weaken the ranges+ build-depends:+ base ^>=4.18.2.1,+ bytestring >= 0.11.5 && < 0.12,+ deepseq >= 1.4.8 && < 1.5,+ containers >= 0.6.7 && < 0.7,+ data-default >= 0.8.0 && < 0.9,+ directory >= 1.3.8 && < 1.4,+ mtl >= 2.3.1 && < 2.4,+ transformers >= 0.6.1 && < 0.7,+ microlens >= 0.4.14 && < 0.5,+ microlens-th >= 0.4.3 && < 0.5,+ optparse-applicative >= 0.18.1 && < 0.19,+ process >= 1.6.19 && < 1.7,+ random >= 1.2.1 && < 1.3,+ temporary >= 1.3 && < 1.4,+ vector >= 0.13.2 && < 0.14,+ vector-algorithms >= 0.9.1 && < 0.10,++library+ import: ghc, dependencies+ exposed-modules:+ Cpmonad,+ Cpmonad.Gen,+ Cpmonad.Printer,+ Cpmonad.Misc,+ hs-source-dirs: lib++test-suite test+ import: ghc, dependencies+ ghc-options: -Wno-missing-signatures+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: Cpmonad.PrinterSpec++ build-depends:+ cpmonad,+ hspec,+ hspec-contrib,+ QuickCheck,+ HUnit,++ hs-source-dirs: test
+ lib/Cpmonad.hs view
@@ -0,0 +1,539 @@+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}++{- |+Module : Cpmonad+Description: Competitive programming problemsetting toolchain+Copyright : (c) drdilyor, 2025+License : MIT+Stability : experimental+Portability: GNU/Linux++Cpmonad (a typo of Comonad) is a set of tools for setting competitive programming+problems. It features easy bidirectional parser/serializer, set of generators,+and tools to automatically run the solutions on all tests. There is no need to+write checkers for input and output formats.++This is very much an experiment. It only supports Batch problems, and doesn't+yet support exporting to polygon or other formats.+-}+module Cpmonad (+ -- * Problem+ Problem (..),+ generateTests,+ runSolutions,++ -- * Solution+ Solution (..),+ hs,+ hsio,+ cpp,++ -- * Tests+ Tests (..),+ UnseededTests,+ testset,+ subtask,+ seedTests,+ allTests,++ -- * Verdict+ Verdict (..),+ VerdictBad (..),+ wa,+ ac,+ mkPts,+ getPoints,+ hasPoints,+ mergeVerdict',++ -- * Other modules+ module Cpmonad.Gen,+ module Cpmonad.Printer,+ module Cpmonad.Misc,+) where++import Control.DeepSeq+import Control.Exception+import Control.Monad+import Data.ByteString.Builder qualified as B+import Data.ByteString.Char8 qualified as B+import Data.Default+import Data.List+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromJust)+import Data.Set qualified as Set+import Data.Vector qualified as V+import Data.Vector.Mutable qualified as VM+import GHC.Generics (Generic)+import System.CPUTime+import System.Directory+import System.Exit (ExitCode (..))+import System.IO+import System.IO.Error (isDoesNotExistError)+import System.IO.Temp (withTempFile)+import System.Process+import System.Timeout (timeout)++import Control.Applicative ((<|>))+import Control.Concurrent+import Cpmonad.Gen+import Cpmonad.Misc+import Cpmonad.Printer+import Data.IORef+import System.Random (StdGen)++{- | Central data specifying every part of the problem/task.++It has three type parameters:++- @i@ is passed to solutions+- @a@ is extra information stored with tests and passed onto grader.+- @o@ is what solutions need to compute++@i@ is written out as .in files, @a@ as .out files++A problem requires 3 printers for each of the type parameters.+@printerA@/@printerO@ accepts @i@ to support parsing outputs that depend on input.++Currently it only supports batch tasks.+-}+data Problem i a o where+ Problem+ :: (NFData i, NFData a, NFData o, Default i, Default a, Default o, Eq i, Eq a, Eq o)+ => { tests :: Tests (i, a)+ , sols :: [Solution i o]+ , check :: i -> a -> o -> Bool+ , printerI :: Printer i+ , printerA :: Printer (i, a)+ , printerO :: Printer (i, o)+ , timeLimit :: Int+ -- ^ time limit in microseconds+ }+ -> Problem i a o++-- | Generate all tests of the problem to a directory @tests@. Cleans the directory in the process+generateTests+ :: Int+ -- ^ number of (green)threads to use. Set it to @corecount - 1@ at most+ -> Problem i a o+ -> IO ()+generateTests threads Problem{..} = do+ wrapAction "cleaning up" $ cleanDirectory "tests"++ _ <- wrapAction "evaluating tests" $ do+ parallelPooled threads progressCounter $ map (evaluate . force) $ concat $ Map.elems tests.testsets+ putStrLn ""++ wrapAction "outputting tests" do+ parallelPooled threads progressCounter $ flip map (allTests tests) \(testName, (i, a)) -> do+ h <- openBinaryFile ("tests/" <> testName <> ".in") WriteMode+ hSetBuffering h (BlockBuffering $ Just 4096)+ B.hPutBuilder h . fromJust $ printerI.toPrinted i+ hClose h++ h <- openBinaryFile ("tests/" <> testName <> ".out") WriteMode+ hSetBuffering h (BlockBuffering $ Just 4096)+ B.hPutBuilder h . fromJust $ printerA.toPrinted (i, a)+ hClose h+ putStrLn ""++ wrapAction "parsing outputs" do+ parallelPooled threads progressCounter $ flip map (allTests tests) \(testName, (i, a)) -> do+ s <- B.readFile ("tests/" <> testName <> ".in")+ i' <- evaluate . force $ printerI.fromPrinted (def, s)+ case i' of+ Nothing -> throwIO $ AssertionFailed $ "tests/" <> testName <> ".in: failed to parse input"+ Just (i', _) | i' /= i -> throwIO $ AssertionFailed $ "tests/" <> testName <> ".in: parsed input is different from original"+ Just (i', _) -> do+ s <- B.readFile ("tests/" <> testName <> ".out")+ a' <- evaluate . force $ printerA.fromPrinted ((i', def), s)+ case a' of+ Nothing -> throwIO $ AssertionFailed $ "tests/" <> testName <> ".in: failed to parse input"+ Just ((_, a'), _) | a' /= a -> throwIO $ AssertionFailed $ "tests/" <> testName <> ".in: parsed input is different from original"+ Just _ -> pure ()+ putStrLn ""++ -- TODO: move this garbage out of here+ let debug = False+ when debug do+ -- only for checking the performance of the printer itself+ wrapAction "transcoding tests" do+ forM_ (allTests tests) \(_, (i, a)) -> do+ let i' = fmap fst . printerI.fromPrinted . (def,) . B.toStrict . B.toLazyByteString . fromJust $ printerI.toPrinted i+ let a' = i' >>= \i -> fmap (snd . fst) . printerA.fromPrinted . ((i, def),) . B.toStrict . B.toLazyByteString . fromJust $ printerA.toPrinted (i, a)+ i' `deepseq` a' `deepseq` pure ()++{- | Run all solutions on all tests.+It is required to call 'generateTests' before this unless the tests are up to date+-}+runSolutions+ :: Int+ -- ^ number of (green)threads to use. Set it to @corecount - 1@ at most+ -> Problem i a o+ -> IO ()+runSolutions threads Problem{..} = do+ sols <- wrapAction "compiling" do+ cleanDirectory "tmp"+ filterM compileSolution sols++ verdicts <- wrapAction "running" do+ forM sols \sol -> do+ let onProgress xs = do+ putStr ("\r" <> "sol " <> sol.name <> ": " <> status)+ hFlush stdout+ where+ status = flip map (V.toList xs) $ \case+ Nothing -> ' '+ Just (Bad e, _) -> case e of TLE -> 'T'; RE _ -> 'R'; PE -> 'P'; Other _ -> 'O'+ Just (pts, _) -> if hasPoints pts then '.' else 'X'++ results <- parallelPooled threads onProgress $ flip map (allTests tests) \(testName, (i, a)) -> do+ o <- runSolutionOnTest testName i sol+ evaluateOutput testName i a o+ putStrLn ""+ pure $ foldl1' mergeVerdict' results++ wrapAction "evaluating" do+ forM_ (zip sols verdicts) \case+ (sol, (Pts x, _)) | x > 0 -> do+ putStrLn $ "sol " <> sol.name <> ": Pts " <> show (round (x * 100) :: Int) <> "%"+ (sol, (verdict, (testName, i, _, o))) -> do+ let readFileHead f = withFile f ReadMode $ flip B.hGetSome 100+ putStrLn $ "sol " <> sol.name <> ": " <> case verdict of { Pts _ -> "WA"; Bad x -> show x } <> ":"++ input <- readFileHead ("tests/" <> testName <> ".in")+ B.putStrLn $ ">>> input:\n" <> input <> "\n"+ judgeOutput <- readFileHead ("tests/" <> testName <> ".out")+ B.putStrLn $ ">>> judge output:\n" <> judgeOutput <> "\n"+ case o of+ Just o -> B.putStrLn $ ">>> output:\n" <> (B.take 100 . B.toStrict . B.toLazyByteString . fromJust $ printerO.toPrinted (i, o)) <> "\n"+ _ -> pure ()+ where+ compileSolution = \case+ SolutionHs{} -> pure True+ SolutionExt{name, compileCmds} -> do+ putStrLn $ "-- " <> name+ handle @IOError (const $ putStrLn "-- compilation failed" >> pure False) do+ forM_ compileCmds (uncurry callProcess)+ pure True++ runSolutionOnTest testName i = \case+ SolutionHs{f} ->+ handle @SomeException (pure . Left . RE . show) $+ maybe (Left TLE) Right <$> timeout timeLimit (evaluate . force =<< f i)+ SolutionExt{runCmd = (cmd, args)} -> do+ withTempFile "tmp/" (testName <> ".out") \outPath hOut -> do+ code <- withFile ("tests/" <> testName <> ".in") ReadMode \hIn -> do+ let timeoutString = show (fromIntegral (round (fromIntegral timeLimit / 1000)) / 1000) <> "s"+ withCreateProcess+ -- GNU coreutils https://www.gnu.org/software/coreutils/timeout+ (proc "timeout" $ ["--signal=KILL", timeoutString, cmd] <> args)+ { delegate_ctlc = False+ , std_in = UseHandle hIn+ , -- hOut is closed here+ std_out = UseHandle hOut+ }+ \_ _ _ p -> waitForProcess p+ case code of+ -- timeout+ ExitFailure 124 -> do+ pure $ Left TLE+ ExitFailure 125 -> do+ pure $ Left $ RE "timeout command returned 125"+ ExitFailure code -> do+ pure $ Left $ RE $ "exit code " <> show code+ ExitSuccess -> do+ output <- B.readFile outPath+ pure $ case printerO.fromPrinted ((i, def), output) of+ Nothing -> Left PE+ Just ((_, o), _) -> Right o++ evaluateOutput testName i a o =+ pure $ case o of+ Left e -> (Bad e, (testName, i, a, Nothing))+ Right o+ | check i a o -> (ac, (testName, i, a, Just o))+ | otherwise -> (wa, (testName, i, a, Just o))++wrapAction :: String -> IO a -> IO a+wrapAction name step = do+ -- TODO: fix the time, use wall time+ putStrLn $ ":: " <> name <> " ..."+ start <- getCPUTime+ res <- step+ end <- getCPUTime+ let diffms = (round :: Double -> Int) $ fromIntegral (end - start) / (10 ^ (9 :: Int))+ putStrLn $ " took " <> show diffms <> "ms"+ pure res++cleanDirectory :: FilePath -> IO ()+cleanDirectory dir = do+ catchJust+ (\e -> if isDoesNotExistError e then Just e else Nothing)+ (removeDirectoryRecursive dir)+ (const $ pure ())+ createDirectoryIfMissing False dir++-- we use explicit semaphores because otherwise multiple greenthreads will be interleaved on a single core,+-- which will lead to TLEs because `timeout` considers total wall time+parallelPooled :: Int -> (V.Vector (Maybe a) -> IO ()) -> [IO a] -> IO [a]+parallelPooled n onProgress actions = do+ sem <- newQSem n+ results <- VM.replicate (length actions) Nothing+ hasProgress <- newEmptyMVar+ anError <- newIORef Nothing+ channel <- newChan+ onProgress =<< V.freeze results++ let debug = False+ forM_ (zip [0 ..] actions) $ \(i, action) -> forkIO $ do+ result <- try @SomeException $ bracket_ (waitQSem sem) (signalQSem sem) $ do+ when debug do+ putStrLn $ ">> " <> show i+ hFlush stdout+ x <- action >>= evaluate+ when debug do+ putStrLn $ "-- " <> show i+ hFlush stdout+ pure x+ writeChan channel (i, result)++ let progressThread = do+ () <- takeMVar hasProgress+ onProgress =<< V.freeze results+ threadDelay 200_000+ progressThread++ bracket (forkIO progressThread) killThread \_ -> do+ replicateM_ (length actions) do+ (i, val) <- readChan channel+ case val of+ Left e -> modifyIORef' anError (<|> Just e)+ Right x -> do+ VM.write results i $ Just x+ void $ tryPutMVar hasProgress ()++ onProgress =<< V.freeze results+ readIORef anError >>= \case+ Just e -> throwIO e+ _ -> V.toList . V.map fromJust <$> V.freeze results++progressBar :: V.Vector (Maybe a) -> IO ()+progressBar v = do+ putStr $ "\r " <> map (\case Just _ -> '.'; Nothing -> ' ') (V.toList v)+ hFlush stdout++progressCounter :: V.Vector (Maybe a) -> IO ()+progressCounter v = do+ putStr $ "\r " <> show doneCount <> "/" <> show (V.length v)+ hFlush stdout+ where+ doneCount = V.sum $ V.map (\case Just _ -> 1; Nothing -> 0) v++{- | A solution can either be a Haskell function or a collection of commands.+The commands can use the @tmp@ directory in the current directory.++/The names must be unique./++'SolutionExt'\'s @runCmd@\'s output will be redirected to a file.+-}+data Solution i o+ = SolutionHs {name :: String, f :: i -> IO o}+ | SolutionExt+ { name :: String+ , compileCmds :: [(FilePath, [String])]+ , runCmd :: (FilePath, [String])+ , cleanupCmds :: [(FilePath, [String])]+ }++-- | Pure Haskell solution+hs :: String -> (i -> o) -> Solution i o+hs name f = SolutionHs{name, f = pure . f}++-- | IO Haskell solution+hsio :: String -> (i -> IO o) -> Solution i o+hsio name f = SolutionHs{..}++-- | C++ solution with the file @\<name\>.cpp@ in the current directory and flags @-O2 and -Wall@+cpp+ :: String+ -- ^ name of the solution+ -> Solution i o+cpp name = cpp' ["-O2", "-Wall"] (name <> ".cpp") name++-- | C++ solution with explicit path to the .cpp file and explicit compile-flags+cpp'+ :: [String]+ -- ^ @g++@ flags+ -> FilePath+ -- ^ path to the @ cpp@ file+ -> String+ -- ^ name of the solution+ -> Solution i o+cpp' flags path name =+ SolutionExt+ { name+ , compileCmds = [("g++", [path, "-o", "tmp/" <> name <> ".exe"] <> flags)]+ , runCmd = ("tmp/" <> name <> ".exe", [])+ , cleanupCmds = []+ }++{- | Collection of 'testset's and 'subtask's.+A testset is a named list of @a@. Testsets can be included in subtasks.++/Tests that are never referenced from subtasks are ignored./++Important: doesn't not check for name collisions. Everything is merged!++Note: the type parameter @a@ has nothing to do with @a@ in 'Problem'!++==== __Examples:__++@+testset "sample" [pure 1, pure 2]+<> testset "small" $ replicate 5 $ genr 1 100+<> testset "big" $ replicate 5 $ genr 100 (10^9)+<> subtask "brute" ["sample", "small"] []+<> subtask "full" ["sample", "small", "big"] []+@+-}+data Tests a = Tests+ { testsets :: Map String [a]+ , subtaskIncludes :: Map String [String]+ -- ^ mapping from subtask names to testset names+ , subtasks :: [String]+ }+ deriving (Functor, Generic, NFData)++-- | Tests that need to be seeded yet+type UnseededTests a = Tests (Gen a)++instance Show (Tests a) where+ show Tests{..} =+ mconcat+ [ "Tests"+ , " {testsets = " <> show (([] :: [()]) <$ testsets)+ , ", subtaskIncludes = " <> show subtaskIncludes+ , ", subtasks = " <> show subtasks+ , "}"+ ]++instance Semigroup (Tests a) where+ a <> b =+ Tests+ { testsets = Map.unionWith (<>) a.testsets b.testsets+ , subtaskIncludes = Map.unionWith (<>) a.subtaskIncludes b.subtaskIncludes+ , subtasks = a.subtasks <> b.subtasks+ }++instance Monoid (Tests a) where+ mempty = Tests mempty mempty mempty++-- | Make a single testset with the given name and the objects+testset :: String -> [Gen a] -> UnseededTests a+testset name gens = mempty{testsets = Map.singleton name gens}++{- | Make a subtask with the given name, included testsets, and extra tests.+Extra tests are put after the included testcases+-}+subtask :: String -> [String] -> [Gen a] -> UnseededTests a+subtask name includes extra =+ mempty+ { subtaskIncludes = Map.singleton name includes+ , subtasks = singleton name+ }+ <> case extra of+ [] -> mempty+ _ ->+ mempty+ { testsets = Map.singleton ("subtask-" <> name) extra+ , subtaskIncludes = Map.singleton name ["subtask-" <> name]+ }++-- | Threads the StdGen through all the tests+seedTests :: StdGen -> UnseededTests a -> Tests a+seedTests s tests = tests{testsets = fst (runGen everything s)}+ where+ everything = traverse sequenceA tests.testsets++{- | The list of tests with their unique names.++/Tests that are never referenced from subtasks are ignored./++==== __Examples:__++>>> t1 = testset "a" [pure "a1", pure "a2"]+>>> t2 = testset "b" [pure "b1", pure "b2"]+>>> s = subtask "full" ["b", "a"] [pure "x"]+>>> allTests $ seedTests undefined $ t1 <> t2 <> s+[("0-b-0","b1"),("0-b-1","b2"),("1-a-0","a1"),("1-a-1","a2"),("2-subtask-full-0","x")]+-}+allTests :: Tests a -> [(String, a)]+allTests tests = do+ let allTestsets = unique $ concatMap (tests.subtaskIncludes Map.!) tests.subtasks+ (seti, setname) <- zip [0 ..] allTestsets+ (testi, test) <- zip [0 ..] $ tests.testsets Map.! setname+ pure (show seti <> "-" <> setname <> "-" <> show testi, test)+ where+ unique xs = reverse . snd $ foldl' (\(s, r) x -> if Set.member x s then (s, r) else (Set.insert x s, x : r)) (mempty, mempty) xs++-- | Verdict of a solution on a test+data Verdict+ = -- | the solution was graded successfully. Must be between 0 and 1+ Pts Float+ | -- | there was an error+ Bad VerdictBad+ deriving (Show, Eq)++-- | Verdict if there was an error running the solution+data VerdictBad+ = -- | output couldn't be parsed+ PE+ | -- | runtime error with extra information+ RE String+ | -- | time limit exceeded+ TLE+ | -- | any other message to the user+ Other String+ deriving (Show, Eq)++-- | Zero points. @Pts 0@+wa :: Verdict+wa = Pts 0++-- | Full points. @Pts 1@+ac :: Verdict+ac = Pts 1++-- | Constructs a 'Pts' by clamping the points between 0 and 1+mkPts :: Float -> Verdict+mkPts x = Pts (0 `max` x `min` 1)++-- | If 'Pts', gets the points, otherwise 0+getPoints :: Verdict -> Float+getPoints (Pts x) = x+getPoints _ = 0++-- | Whether it is 'Pts' and greater than zero+hasPoints :: Verdict -> Bool+hasPoints x = getPoints x > 0++-- | Return the argument which has smaller points. If an error, returns the left-most one+mergeVerdict' :: (Verdict, b) -> (Verdict, b) -> (Verdict, b)+mergeVerdict' a b = case (a, b) of+ ((Pts x, _), (Pts y, _))+ | x < y -> a+ | otherwise -> b+ ((Pts _, _), _) -> b+ (_, (Pts _, _)) -> a+ (_, _) -> a++-- | Semigroup based on 'mergeVerdict\''+instance Semigroup Verdict where+ a <> b = fst $ mergeVerdict' (a, ()) (b, ())++instance Monoid Verdict where+ mempty = Pts 1
+ lib/Cpmonad/Gen.hs view
@@ -0,0 +1,149 @@+module Cpmonad.Gen (+ Gen,+ GenST,+ runGen,+ runGenST,+ liftg,+ runIOGen,+ genr,+ genri,+ Indexable (..),+ choose,+ genpair,+ distribute,+ shuffle,+ genperm,+ gendistinct,+ state,+) where++import Control.Monad.ST+import Control.Monad.State.Strict (State, StateT, lift, runState, runStateT, state)+import Data.List+import Data.Set qualified as Set+import Data.Vector (Vector, (!))+import Data.Vector qualified as V+import Data.Vector.Algorithms.Merge qualified as VA+import Data.Vector.Mutable qualified as VM+import Data.Vector.Strict qualified as VS+import System.Random (StdGen, newStdGen, uniformR)++-- | Monad where usual generators live in+type Gen = State StdGen++-- | Monad when you want to do mutations for faster generation algorithms+type GenST s = StateT StdGen (ST s)++runGen :: Gen a -> StdGen -> (a, StdGen)+runGen = runState++-- | Convert 'GenST' to 'Gen'+runGenST :: (forall s. GenST s a) -> Gen a+runGenST g = state \s -> runST $ runStateT g s++liftg :: Gen a -> GenST s a+liftg = state . runState++-- | Seed the generator with 'newStdGen'+runIOGen :: Gen a -> IO a+runIOGen g = fst . runGen g <$> newStdGen++-- | Int between [a, b)+genr :: Int -> Int -> Gen Int+genr a b = state $ uniformR (a, b - 1)++-- | Int between [a, b]+genri :: Int -> Int -> Gen Int+genri a b = genr a (b - 1)++-- | Class of types that can be used with 'choose'+class Indexable c where+ index :: c a -> Int -> a+ size :: c a -> Int++instance Indexable [] where+ index = (Data.List.!!)+ size = Data.List.length++instance Indexable V.Vector where+ index = (V.!)+ size = V.length++instance Indexable VS.Vector where+ index = (VS.!)+ size = VS.length++-- | Choose an element of a collection+choose :: (Indexable c) => c a -> Gen a+choose xs = let n = size xs in index xs <$> genr 0 n++-- | Keep generating until predicate returns True. Stops after one million tries+genuntil :: (a -> Bool) -> Gen a -> Gen a+genuntil p g = go (1000_000 :: Int)+ where+ go 0 = error "genuntil: not found after a million tries"+ go i = do+ x <- g+ if p x+ then pure x+ else go (i - 1)++{- | Generate a pair of integers satisfying the binary predicate f.++Useful as @genpair (<=)@+-}+genpair :: (Int -> Int -> Bool) -> Gen Int -> Gen (Int, Int)+genpair f g = genuntil (uncurry f) $ liftA2 (,) g g++{- | Given @s@, generate @n@ numbers such that their sum adds up to @s@++Can be used to generate the parameters of the testcases.+-}+distribute+ :: Int+ -- ^ total sum @s@+ -> Int+ -- ^ number of numbers @n@+ -> Int+ -- ^ minimum number to generate+ -> Gen (Vector Int)+distribute _ n _ | n <= 0 = error "n must be positive"+distribute s n 0 = runGenST do+ v <- VM.generateM (n + 1) \i ->+ if+ | i == 0 -> pure 0+ | i == n -> pure s+ | otherwise -> liftg (genr 0 s)+ VA.sort v+ delimeters <- V.unsafeFreeze v+ pure $ V.zipWith (-) (V.drop 1 delimeters) delimeters+distribute s n low = V.map (+ low) <$> distribute (s - low * n) n 0++-- | Generate a shuffled version of the vector+shuffle :: Vector Int -> Gen (Vector Int)+shuffle v' = runGenST do+ let n = V.length v'+ let go v i+ | i == n = V.unsafeFreeze v+ | otherwise = do+ j <- liftg $ genr i n+ VM.swap v i j+ go v (i + 1)+ v <- V.thaw v'+ go v 0++-- | Generate a permutation+genperm :: Int -> Gen (Vector Int)+genperm n = shuffle $ V.enumFromN 0 n++-- | Generate n distinct @a@'s+gendistinct :: (Ord a) => Int -> Gen a -> Gen (Vector a)+gendistinct n g = runGenST do+ v <- VM.new n+ let go i seen v+ | i == n = V.unsafeFreeze v+ | otherwise = do+ x <- liftg $ genuntil (not . flip Set.member seen) g+ VM.write v i x+ go (i + 1) (Set.insert x seen) v+ go 0 Set.empty v
+ lib/Cpmonad/Misc.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Miscellaneous useful functions and orphan instances.+module Cpmonad.Misc where++import Data.Default+import Data.Vector (Vector)+import Data.Vector qualified as V+import Data.Vector.Strict qualified as VS+import Data.Vector.Algorithms.Merge qualified as VA++-- Utility functions++-- | Sort a vector+vsort :: Vector Int -> Vector Int+vsort v' = V.create do+ v <- V.unsafeThaw v'+ VA.sort v+ pure v++-- | Inverse of a permutation+vinverse :: Vector Int -> Vector Int+vinverse p = V.update_ p p (V.enumFromN 0 $ V.length p)++-- Orphan instances++instance Default (V.Vector a) where+ def = V.empty++instance Default (VS.Vector a) where+ def = VS.empty
+ lib/Cpmonad/Printer.hs view
@@ -0,0 +1,256 @@+{-# OPTIONS_GHC -Wno-unused-imports #-}++-- | Combinators for defining a parser and a serializer with a single definition+module Cpmonad.Printer (+ Printer (..),+ char,+ sp,+ endl,+ pint,+ pvec,+ pvecN,+ pvecint,+ pvecintN,+ pvecvecint,+ nest,+ len,+) where++import Control.Monad.ST (runST)+import Cpmonad.Misc+import Data.ByteString.Builder qualified as B+import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Char8 qualified as B+import Data.Default+import Data.Vector (Vector, (!))+import Data.Vector qualified as V+import Data.Vector.Mutable qualified as VM+import Lens.Micro++{- | A printer is both a parser and a serializer.++Parsing is done in an "FSM" fashion. Each parser gets the current state and+updates it with the new information. The state is initialized to 'def'.+To combine printers, the printers must operate on the same state type @a@.+Printers take lens to the part of the object to operate on. See the examples.++All of the builtin printers ignore extra whitespace.++__Important__: the printers here, on their own, are valid — parser is+an inverse of the serializer. But when combined, they can still become ambiguous.+To prevent that, you must use whitespace when combining parsers. If I were to+make 'pint' output space, it would lead to trailing spaces in lines. Therefore,+you need to choose between sp and endl explicit each time. 'Cpmonad.generateTests'+will check for this and will complain if your printer is invalid.++The following characters are considered whitespace: @" \\r\\n"@++==== __Examples:__++Full-blown example:++@+data Input = Input {_k :: Int, _arr :: Vector Int, _queries :: Vector (Int, Int)}+makeLenses ''Input+printer = pint (arr . len) <> sp <> pint k <> endl+ <> pvecint sp arr <> endl+ <> pint (queries . len)+ <> pvec endl queries (pint _1 <> sp <> pint _2) <> endl+@++Example input:++@+4 25+1 1 2 1+3+0 1+0 2+1 3+@++Parsed object:++@+Input1+ { _k = 25+ , _arr = [1,1,2,1]+ , _queries = [(0,1),(0,2),(1,3)]+ }+@++Printer for a single integers:++>>> pint id :: Printer Int++Example input:++@+42+@++Printer for a pair of integers++>>> pint _1 <> sp <> pint _2 :: Printer (Int, Int)++Example input:++@+42 37+@++Printer for an array of integers:++>>> pint len <> pvecint sp id :: Printer (Vector Int)++Example input:++@+5+1 2 3 40 500+@++Printer for an array of integers with explicit field containing their count:++>>> pint _1 <> pvecN sp _1 _2 (pint id) :: Printer (Int, Vector Int)++Example input: the same as above+-}+data Printer a = Printer+ { toPrinted :: a -> Maybe B.Builder+ , fromPrinted :: (a, ByteString) -> Maybe (a, ByteString)+ }++instance Semigroup (Printer a) where+ p1 <> p2 = Printer{..}+ where+ toPrinted xb = p1.toPrinted xb <> p2.toPrinted xb+ fromPrinted xs = p1.fromPrinted xs >>= p2.fromPrinted++skipSpace :: ByteString -> ByteString+skipSpace = B.dropWhile (\c -> c == ' ' || c == '\n' || c == '\r') -- idc about other ascii ws chars++-- | Outputs the character, and consumes character after skipping whitespace. /Don't use this for whitespace/+char :: Char -> Printer a+char c = Printer{..}+ where+ toPrinted !_ = Just $ B.char8 c+ fromPrinted (!x, !s) = do+ c' <- skipSpace s `B.indexMaybe` 0+ if c' == c then Just (x, B.tail s) else Nothing++-- | Outputs a single space, and consumes all whitespace. Doesn't change the state.+sp :: Printer a+sp = Printer{..}+ where+ toPrinted !_ = Just $ B.char8 ' '+ fromPrinted (!x, !s) = Just (x, skipSpace s)++-- | Outputs a newline (LF), and consumes all whitespace. Doesn't change the state.+endl :: Printer a+endl = Printer{..}+ where+ toPrinted !_ = Just $ B.char8 '\n'+ fromPrinted (!x, !s) = Just (x, skipSpace s)++-- | Focuses the printer on part of the state. See the implementation if confused.+nest :: Printer b -> Lens' a b -> Printer a+nest p f = Printer{..}+ where+ toPrinted !a = p.toPrinted (a ^. f)+ fromPrinted (!a, !s) =+ let x = p.fromPrinted (a ^. f, s)+ in case x of+ Just (b, c) -> Just (a & f .~ b, c)+ Nothing -> Nothing++-- extremely scuffed but trust me i couldn't find a better way+pint :: Lens' a Int -> Printer a+pint = nest Printer{..}+ where+ toPrinted !x = Just $ B.intDec x+ fromPrinted (!_, !s) = do+ (n, s') <- B.readInt (skipSpace s)+ pure (n, s')++pvec+ :: (Default b)+ => (forall c. Printer c)+ -- ^ separator (e.g. 'sp')+ -> Lens' a (Vector b)+ -> Printer b+ -> Printer a+pvec sep arr p = pvecN sep (arr . len) arr p++pvecN+ :: (Default b)+ => (forall c. Printer c)+ -- ^ separator+ -> SimpleGetter a Int+ -- ^ number of elements+ -> Lens' a (Vector b)+ -- ^ the vector itself+ -> Printer b+ -> Printer a+pvecN sep n arr p = Printer{..}+ where+ toPrinted !x+ | x ^. n /= V.length (x ^. arr) = Nothing+ | x ^. n == 0 = Just mempty+ | otherwise =+ p.toPrinted (V.head (x ^. arr))+ <> mconcat [sep.toPrinted () <> p.toPrinted el | el <- V.toList . V.tail $ x ^. arr]+ fromPrinted (!x, !s') =+ let count = x ^. n+ in if count == 0+ then Just (x & arr .~ V.empty, s')+ else runST do+ v <- VM.new count+ let go !s !i+ | i == count = pure (Just s)+ | otherwise =+ case sep.fromPrinted ((), s) of+ Nothing -> pure Nothing+ Just (_, s2) ->+ case p.fromPrinted (def, s2) of+ Nothing -> pure Nothing+ Just (val, s3) -> VM.write v i val >> go s3 (i + 1)+ res <- go s' 0+ v' <- V.freeze v+ pure $ (x & arr .~ v',) <$> res++pvecint :: (forall b. Printer b) -> Lens' a (V.Vector Int) -> Printer a+pvecint sep arr = pvec sep arr (pint id)++pvecintN :: (forall b. Printer b) -> SimpleGetter a Int -> Lens' a (V.Vector Int) -> Printer a+pvecintN sep n arr = pvecN sep n arr (pint id)++{- | This is a special parser for a matrix of integers. Each row is separated by newlines and+each number in the row is separated by spaces.+-}+pvecvecint :: SimpleGetter a Int -> SimpleGetter a Int -> Lens' a (Vector (Vector Int)) -> Printer a+pvecvecint n m arr = Printer{..}+ where+ toPrinted !x+ | x ^. n /= V.length (x ^. arr) = Nothing+ | otherwise =+ let vec i = (pvecintN sp _1 _2).toPrinted (x ^. m, (x ^. arr) ! i)+ in mconcat [vec i <> Just (B.char8 '\n') | i <- [0 .. x ^. n - 1]]+ fromPrinted (!x, !s') =+ let vec s i = (pvecintN sp _1 _2).fromPrinted ((x ^. m, (x ^. arr) ! i), s)+ in runST do+ let count = x ^. n+ v <- VM.new count+ let go !s !i+ | i == count = pure (Just s)+ | otherwise =+ case vec s i of+ Nothing -> pure Nothing+ Just ((_, vv), s'') -> VM.write v i vv >> go s'' (i + 1)+ res <- go s' 0+ v' <- V.freeze v+ pure $ (x & arr .~ v',) <$> res++-- | Iso between Vector and its length. When set, it fills the vector with n @def@\'s.+len :: (Default a) => Lens' (Vector a) Int+len = lens V.length (\_ n -> V.replicate n def)
+ test/Cpmonad/PrinterSpec.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module Cpmonad.PrinterSpec where++import Prelude hiding (print)+import Data.ByteString.Builder qualified as B+import Data.ByteString.Char8 qualified as B+import Data.ByteString.Char8(ByteString)+import Data.Default+import Data.List (intersperse)+import Data.String (IsString)+import Data.Vector qualified as V+import Lens.Micro+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import Cpmonad.Printer++toPrinted' :: Printer a -> a -> Maybe ByteString+toPrinted' p x = B.toStrict . B.toLazyByteString <$> p.toPrinted x++sepBySp :: IsString s => [s] -> Gen [s]+sepBySp = sequence . intersperse (elements [" ", " ", " "]) . map pure++spec :: Spec+spec = do+ describe "pint" do+ let print = toPrinted' (pint id)+ let parse s = (pint id).fromPrinted (0, s)++ prop "fromPrinted is inverse of toPrinted" $+ \x -> (print x >>= parse) `shouldBe` Just (x, "")+ it "consumes whitespace correctly" do+ parse " 42 " `shouldBe` Just (42, " ")++ describe "pvecint" do+ let print n v = toPrinted' (pvecintN sp _1 _2) (n, v)+ let parse n s = do ((_, v), s') <- (pvecintN sp _1 _2).fromPrinted ((n, def), s)+ pure (v, s')++ prop "fromPrinted is inverse of toPrinted" $+ \xs -> let v = V.fromList xs ; n = V.length v in+ (print n v >>= parse n) `shouldBe` Just (v, "")+ it "consumes whitespace correctly" do+ parse 2 " 1 \n 2 " `shouldBe` Just (V.fromList [1,2], " ")+++ describe "large parser" do+ let p = (pint _1 <> sp <> pint _2 <> endl)+ <> pvecvecint _1 _2 _3+ <> (pint _4 <> endl)+ <> pvecN endl _4 _5 (pint _1 <> sp <> pint _2)+ let print = toPrinted' p+ let parse s = p.fromPrinted ((0, 0, V.empty, 0, V.empty), s)++ it "simple" do+ parse "1 2\n0 0\n2\n1 1\n2 2" `shouldBe` Just ((1, 2, V.singleton $ V.fromList [0, 0], 2, V.fromList [(1,1), (2,2)]), "")++ let input = do+ m <- sized $ \s -> chooseInt (1, 1 `max` s)+ mat <- listOf1 (vectorOf m arbitrary)+ qs <- listOf arbitrary+ pure (length mat, m, V.fromList $ map V.fromList mat, length qs, V.fromList qs)++ prop "fromPrinted is inverse of toPrinted" $ forAll input+ \x -> (print x >>= parse) == Just (x, "")++ it "consumes whitespace correctly" do+ parse " 1 2 \n 0 0 2 1 1 \n2 2 \n" `shouldBe` Just ((1, 2, V.singleton $ V.fromList [0, 0], 2, V.fromList [(1,1), (2,2)]), " \n")
+ test/Spec.hs view
@@ -0,0 +1,12 @@+module Main where++import Test.Hspec++import Cpmonad.PrinterSpec qualified++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "Cpmonad.PrinterSpec" Cpmonad.PrinterSpec.spec