From 95f86c86606b0c41f810a0a18bc5e5d2512a2e3b Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Thu, 19 Jun 2025 21:51:34 +0200 Subject: [PATCH 1/6] feat: QuickCheck testing --- bf-optimize.cabal | 5 ++- package.yaml | 1 + test/Arbitrary/InvalidBrainfuckProgram.hs | 26 +++++++++++++ test/Arbitrary/ValidBrainfuckProgram.hs | 47 +++++++++++++++++++++++ test/Spec.hs | 24 +++++++++++- 5 files changed, 101 insertions(+), 2 deletions(-) create mode 100644 test/Arbitrary/InvalidBrainfuckProgram.hs create mode 100644 test/Arbitrary/ValidBrainfuckProgram.hs diff --git a/bf-optimize.cabal b/bf-optimize.cabal index cd815da..5bae42a 100644 --- a/bf-optimize.cabal +++ b/bf-optimize.cabal @@ -62,6 +62,8 @@ test-suite bf-optimize-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Arbitrary.InvalidBrainfuckProgram + Arbitrary.ValidBrainfuckProgram Paths_bf_optimize autogen-modules: Paths_bf_optimize @@ -69,7 +71,8 @@ test-suite bf-optimize-test test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 , bf-optimize , text , vector diff --git a/package.yaml b/package.yaml index 8aebee4..257b77d 100644 --- a/package.yaml +++ b/package.yaml @@ -59,3 +59,4 @@ tests: - -with-rtsopts=-N dependencies: - bf-optimize + - QuickCheck diff --git a/test/Arbitrary/InvalidBrainfuckProgram.hs b/test/Arbitrary/InvalidBrainfuckProgram.hs new file mode 100644 index 0000000..f51c591 --- /dev/null +++ b/test/Arbitrary/InvalidBrainfuckProgram.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingStrategies #-} +module Arbitrary.InvalidBrainfuckProgram (InvalidBrainfuckProgram(..)) where + +import Data.Text (Text) +import Test.QuickCheck.Gen (Gen) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) + +import qualified Data.Text as Text +import qualified Test.QuickCheck.Gen as Gen +import qualified Arbitrary.ValidBrainfuckProgram as ValidBrainfuckProgram + +newtype InvalidBrainfuckProgram = InvalidBrainfuckProgram { get :: Text } + deriving stock Show + +instance Arbitrary InvalidBrainfuckProgram where + arbitrary :: Gen InvalidBrainfuckProgram + arbitrary = do + validProgram <- ValidBrainfuckProgram.get <$> arbitrary + + index <- Gen.choose (0, Text.length validProgram) + badBrace <- Gen.oneof $ map pure "[]" + let (prefix, suffix) = Text.splitAt index validProgram + + pure . InvalidBrainfuckProgram $ Text.concat [prefix, Text.singleton badBrace, suffix] + diff --git a/test/Arbitrary/ValidBrainfuckProgram.hs b/test/Arbitrary/ValidBrainfuckProgram.hs new file mode 100644 index 0000000..a8d350e --- /dev/null +++ b/test/Arbitrary/ValidBrainfuckProgram.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingStrategies #-} +module Arbitrary.ValidBrainfuckProgram (ValidBrainfuckProgram(..)) where +import Data.Text (Text) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) +import Test.QuickCheck.Gen (Gen, sized, frequency, oneof, resize) +import Data.Coerce (coerce) + +import qualified Data.Text as Text + +newtype ValidBrainfuckProgram = ValidBrainfuckProgram { get :: Text } + deriving stock Show + +instance Arbitrary ValidBrainfuckProgram where + arbitrary :: Gen ValidBrainfuckProgram + arbitrary = coerce . fmap Text.pack $ character [] + where + character rest = do + body <- frequency + [ (1, comment) + , (9, operator) + ] + + sized $ \ size -> frequency + [ (1 , pure body) + , (size, character body) + ] + + where + operator = let + + simpleOperator = oneof $ map (pure . (:rest)) "+-<>,." + loopOperator = fmap ('[':) . sized $ \ s -> resize (s `div` 8) (character (']':rest)) + + in frequency + [ (3, simpleOperator) + , (1, loopOperator) + ] + + comment = do + commentChar <- oneof $ map pure "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + pure $ commentChar : rest + +-- >>> import Test.QuickCheck.Gen (generate) +-- >>> generate $ (arbitrary :: Gen ValidBrainfuckProgram) +-- ValidBrainfuckProgram {get = "<-"} + diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..51237ef 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} +import Test.QuickCheck.All (quickCheckAll) +import System.Exit (exitFailure, exitSuccess) + +import qualified Data.Either as Either +import qualified Language.Brainfuck as Brainfuck +import qualified Arbitrary.ValidBrainfuckProgram as ValidBrainfuckProgram +import qualified Arbitrary.InvalidBrainfuckProgram as InValidBrainfuckProgram + +prop_acceptValidPrograms :: ValidBrainfuckProgram.ValidBrainfuckProgram -> Bool +prop_acceptValidPrograms = Either.isRight . Brainfuck.parse . ValidBrainfuckProgram.get + +prop_rejectInvalidPrograms :: InValidBrainfuckProgram.InvalidBrainfuckProgram -> Bool +prop_rejectInvalidPrograms = Either.isLeft . Brainfuck.parse . InValidBrainfuckProgram.get + +return [] -- template haskell guard +runQuickCheck :: IO Bool +runQuickCheck = $quickCheckAll + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = do + quickCheckGood <- runQuickCheck + + if quickCheckGood then exitSuccess else exitFailure From 9484d097d4b148e82f8d256097459b0ea284b85e Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Thu, 19 Jun 2025 21:51:45 +0200 Subject: [PATCH 2/6] feat: StrictData + Unbounded Integer types --- src/Language/Brainfuck/Instruction/Extended.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Language/Brainfuck/Instruction/Extended.hs b/src/Language/Brainfuck/Instruction/Extended.hs index e3b8d9d..8bd5a79 100644 --- a/src/Language/Brainfuck/Instruction/Extended.hs +++ b/src/Language/Brainfuck/Instruction/Extended.hs @@ -1,12 +1,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StrictData #-} module Language.Brainfuck.Instruction.Extended (Operation(..), Interaction(..), ExtendedInstruction(Modify, Move, Interact, Jump), pattern IfNonZero, pattern WithOffset, mkIfNonZero, mkWithOffset, translationSize, parse) where + import Data.Word (Word8) -import Language.Brainfuck.Instruction.Compressed (CompressedInstruction) import Data.Vector (Vector) +import Numeric.Natural (Natural) + +import Language.Brainfuck.Instruction.Compressed (CompressedInstruction) + import qualified Data.Vector as Vector import qualified Language.Brainfuck.Instruction.Compressed as CompressedInstruction -import Numeric.Natural (Natural) data Operation = Add @@ -18,7 +22,7 @@ data Interaction | Write deriving (Show) -pattern WithOffset :: Int -> ExtendedInstruction -> ExtendedInstruction +pattern WithOffset :: Integer -> ExtendedInstruction -> ExtendedInstruction pattern WithOffset offset embedded <- AtOffset offset embedded where WithOffset offset embedded = mkWithOffset offset embedded @@ -29,7 +33,7 @@ pattern IfNonZero instruction <- WhenNonZero instruction IfNonZero instruction = mkIfNonZero instruction data ExtendedInstruction - = AtOffset Int ExtendedInstruction -- invariant, WithOffset may not nest itself + = AtOffset Integer ExtendedInstruction -- invariant, WithOffset may not nest itself | WhenNonZero ExtendedInstruction -- invariant, IfNonZero may not nest itself | Modify Operation Word8 | Move Integer @@ -42,7 +46,7 @@ mkIfNonZero = \case WhenNonZero i -> WhenNonZero i instruction -> WhenNonZero instruction -mkWithOffset :: Int -> ExtendedInstruction -> ExtendedInstruction +mkWithOffset :: Integer -> ExtendedInstruction -> ExtendedInstruction mkWithOffset offset = \case AtOffset offset' i -> AtOffset (offset + offset') i instruction -> AtOffset offset instruction From d012307d196c30d0f06819fedd6e61ced38f5960 Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Fri, 20 Jun 2025 09:26:11 +0200 Subject: [PATCH 3/6] feat: tests for the rendering/parsing --- bf-optimize.cabal | 14 +++++++--- package.yaml | 3 ++- src/Language/Brainfuck.hs | 24 +++++++++++++++-- src/Language/Brainfuck/Instruction.hs | 23 ++++++++++++++++ test/Arbitrary/InvalidBrainfuckProgram.hs | 26 ------------------- test/Arbitrary/InvalidBrainfuckText.hs | 26 +++++++++++++++++++ ...infuckProgram.hs => ValidBrainfuckText.hs} | 13 +++++----- test/Spec.hs | 20 +++++++++----- 8 files changed, 104 insertions(+), 45 deletions(-) delete mode 100644 test/Arbitrary/InvalidBrainfuckProgram.hs create mode 100644 test/Arbitrary/InvalidBrainfuckText.hs rename test/Arbitrary/{ValidBrainfuckProgram.hs => ValidBrainfuckText.hs} (74%) diff --git a/bf-optimize.cabal b/bf-optimize.cabal index 5bae42a..ca802e7 100644 --- a/bf-optimize.cabal +++ b/bf-optimize.cabal @@ -29,6 +29,7 @@ library Language.Brainfuck.Instruction Language.Brainfuck.Instruction.Compressed Language.Brainfuck.Instruction.Extended + Language.Brainfuck.Interpreter other-modules: Paths_bf_optimize autogen-modules: @@ -37,7 +38,9 @@ library src ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 + , quickcheck-instances , text , vector default-language: Haskell2010 @@ -52,8 +55,10 @@ executable bf-optimize-exe app ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 , bf-optimize + , quickcheck-instances , text , vector default-language: Haskell2010 @@ -62,8 +67,8 @@ test-suite bf-optimize-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Arbitrary.InvalidBrainfuckProgram - Arbitrary.ValidBrainfuckProgram + Arbitrary.InvalidBrainfuckText + Arbitrary.ValidBrainfuckText Paths_bf_optimize autogen-modules: Paths_bf_optimize @@ -74,6 +79,7 @@ test-suite bf-optimize-test QuickCheck , base >=4.7 && <5 , bf-optimize + , quickcheck-instances , text , vector default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 257b77d..3b9462d 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,8 @@ dependencies: - base >= 4.7 && < 5 - text - vector +- QuickCheck +- quickcheck-instances ghc-options: - -Wall @@ -59,4 +61,3 @@ tests: - -with-rtsopts=-N dependencies: - bf-optimize - - QuickCheck diff --git a/src/Language/Brainfuck.hs b/src/Language/Brainfuck.hs index 0d0e320..c348315 100644 --- a/src/Language/Brainfuck.hs +++ b/src/Language/Brainfuck.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingStrategies #-} -module Language.Brainfuck (parse, ParseFailure) where +{-# LANGUAGE LambdaCase #-} +module Language.Brainfuck (parse, ParseFailure, render) where import Control.Monad ((<$!>)) import Control.Monad.ST (runST, ST) @@ -14,11 +15,12 @@ import Data.Vector qualified as Vector import Data.Vector.Mutable qualified as MutableVector import Language.Brainfuck.Instruction ( Instruction(..) ) +import qualified Data.List as List data ParseFailure = UnexpectedClosingBracket Int -- closing bracket position | UnmatchedOpenBracket Int -- opening bracket position - deriving stock (Show) + deriving stock (Show, Eq) -- | Convert a Text to a list of instructions, discard all comments. -- @@ -83,3 +85,21 @@ parse text = runST $ do -- >>> parse $ Text.pack "[]]" -- Left (UnexpectedClosingBracket 2) + +render :: Vector Instruction -> Text +render = Text.concat . List.map renderSingle . Vector.toList + where + renderSingle = \case + Increment -> Text.singleton '+' + Decrement -> Text.singleton '-' + MoveLeft -> Text.singleton '<' + MoveRight -> Text.singleton '>' + ReadByte -> Text.singleton ',' + PutByte -> Text.singleton '.' + Loop body -> Text.concat [Text.singleton '[', render body, Text.singleton ']'] + +-- >>> import Test.QuickCheck.Instances.Vector () +-- >>> import Test.QuickCheck.Arbitrary (arbitrary) +-- >>> render <$> Gen.generate arbitrary +-- "<,<>,<,." + diff --git a/src/Language/Brainfuck/Instruction.hs b/src/Language/Brainfuck/Instruction.hs index a1a6a70..80a52aa 100644 --- a/src/Language/Brainfuck/Instruction.hs +++ b/src/Language/Brainfuck/Instruction.hs @@ -1,7 +1,13 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE InstanceSigs #-} module Language.Brainfuck.Instruction (Instruction(..)) where import Data.Vector ( Vector ) +import Test.QuickCheck.Gen (Gen) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) +import Test.QuickCheck.Instances.Vector () + +import qualified Test.QuickCheck.Gen as Gen data Instruction = Increment @@ -12,3 +18,20 @@ data Instruction | PutByte | Loop (Vector Instruction) deriving stock (Show, Eq) + +instance Arbitrary Instruction where + arbitrary :: Gen Instruction + arbitrary = Gen.oneof $ + [ pure Increment + , pure Decrement + , pure MoveLeft + , pure MoveRight + , pure ReadByte + , pure PutByte + , Loop <$> reduceSize 8 arbitrary + ] + where + reduceSize d g = Gen.sized $ \ s -> Gen.resize (s `div` d) g + +-- >>> Gen.generate (Gen.resize 30 arbitrary) :: IO [Instruction] +-- [MoveLeft,Decrement,PutByte,Decrement,Decrement,Increment,ReadByte,MoveLeft,Increment,Loop [],MoveRight,Increment,Increment,Loop [],MoveLeft,Loop [],MoveRight,ReadByte,ReadByte,MoveLeft,Decrement,MoveRight,MoveLeft,Loop [PutByte,Increment,Loop []],Decrement] diff --git a/test/Arbitrary/InvalidBrainfuckProgram.hs b/test/Arbitrary/InvalidBrainfuckProgram.hs deleted file mode 100644 index f51c591..0000000 --- a/test/Arbitrary/InvalidBrainfuckProgram.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE DerivingStrategies #-} -module Arbitrary.InvalidBrainfuckProgram (InvalidBrainfuckProgram(..)) where - -import Data.Text (Text) -import Test.QuickCheck.Gen (Gen) -import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) - -import qualified Data.Text as Text -import qualified Test.QuickCheck.Gen as Gen -import qualified Arbitrary.ValidBrainfuckProgram as ValidBrainfuckProgram - -newtype InvalidBrainfuckProgram = InvalidBrainfuckProgram { get :: Text } - deriving stock Show - -instance Arbitrary InvalidBrainfuckProgram where - arbitrary :: Gen InvalidBrainfuckProgram - arbitrary = do - validProgram <- ValidBrainfuckProgram.get <$> arbitrary - - index <- Gen.choose (0, Text.length validProgram) - badBrace <- Gen.oneof $ map pure "[]" - let (prefix, suffix) = Text.splitAt index validProgram - - pure . InvalidBrainfuckProgram $ Text.concat [prefix, Text.singleton badBrace, suffix] - diff --git a/test/Arbitrary/InvalidBrainfuckText.hs b/test/Arbitrary/InvalidBrainfuckText.hs new file mode 100644 index 0000000..42b97f1 --- /dev/null +++ b/test/Arbitrary/InvalidBrainfuckText.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingStrategies #-} +module Arbitrary.InvalidBrainfuckText (InvalidBrainfuckText(..)) where + +import Data.Text (Text) +import Test.QuickCheck.Gen (Gen) +import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) + +import qualified Data.Text as Text +import qualified Test.QuickCheck.Gen as Gen +import qualified Arbitrary.ValidBrainfuckText as ValidBrainfuckText + +newtype InvalidBrainfuckText = InvalidBrainfuckText { get :: Text } + deriving stock Show + +instance Arbitrary InvalidBrainfuckText where + arbitrary :: Gen InvalidBrainfuckText + arbitrary = do + validText <- ValidBrainfuckText.get <$> arbitrary + + index <- Gen.choose (0, Text.length validText) + badBrace <- Gen.oneof $ map pure "[]" + let (prefix, suffix) = Text.splitAt index validText + + pure . InvalidBrainfuckText $ Text.concat [prefix, Text.singleton badBrace, suffix] + diff --git a/test/Arbitrary/ValidBrainfuckProgram.hs b/test/Arbitrary/ValidBrainfuckText.hs similarity index 74% rename from test/Arbitrary/ValidBrainfuckProgram.hs rename to test/Arbitrary/ValidBrainfuckText.hs index a8d350e..c5a0505 100644 --- a/test/Arbitrary/ValidBrainfuckProgram.hs +++ b/test/Arbitrary/ValidBrainfuckText.hs @@ -1,6 +1,6 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE DerivingStrategies #-} -module Arbitrary.ValidBrainfuckProgram (ValidBrainfuckProgram(..)) where +module Arbitrary.ValidBrainfuckText (ValidBrainfuckText(..)) where import Data.Text (Text) import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) import Test.QuickCheck.Gen (Gen, sized, frequency, oneof, resize) @@ -8,11 +8,11 @@ import Data.Coerce (coerce) import qualified Data.Text as Text -newtype ValidBrainfuckProgram = ValidBrainfuckProgram { get :: Text } +newtype ValidBrainfuckText = ValidBrainfuckText { get :: Text } deriving stock Show -instance Arbitrary ValidBrainfuckProgram where - arbitrary :: Gen ValidBrainfuckProgram +instance Arbitrary ValidBrainfuckText where + arbitrary :: Gen ValidBrainfuckText arbitrary = coerce . fmap Text.pack $ character [] where character rest = do @@ -42,6 +42,7 @@ instance Arbitrary ValidBrainfuckProgram where pure $ commentChar : rest -- >>> import Test.QuickCheck.Gen (generate) --- >>> generate $ (arbitrary :: Gen ValidBrainfuckProgram) --- ValidBrainfuckProgram {get = "<-"} +-- >>> generate $ (arbitrary :: Gen ValidBrainfuckText) +-- ValidBrainfuckText {get = "<[><]>[>],>+,[.-K.]+.>[<],z[p[[<]]+<],<[+]+[P[+][[e]]+,]+,.[-][[<],>>++]+"} + diff --git a/test/Spec.hs b/test/Spec.hs index 51237ef..238a797 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,17 +1,25 @@ {-# LANGUAGE TemplateHaskell #-} + +import Data.Vector (Vector) + import Test.QuickCheck.All (quickCheckAll) import System.Exit (exitFailure, exitSuccess) +import Language.Brainfuck.Instruction (Instruction) + import qualified Data.Either as Either import qualified Language.Brainfuck as Brainfuck -import qualified Arbitrary.ValidBrainfuckProgram as ValidBrainfuckProgram -import qualified Arbitrary.InvalidBrainfuckProgram as InValidBrainfuckProgram +import qualified Arbitrary.ValidBrainfuckText as ValidBrainfuckText +import qualified Arbitrary.InvalidBrainfuckText as InValidBrainfuckText -prop_acceptValidPrograms :: ValidBrainfuckProgram.ValidBrainfuckProgram -> Bool -prop_acceptValidPrograms = Either.isRight . Brainfuck.parse . ValidBrainfuckProgram.get +prop_acceptValidTexts :: ValidBrainfuckText.ValidBrainfuckText -> Bool +prop_acceptValidTexts = Either.isRight . Brainfuck.parse . ValidBrainfuckText.get -prop_rejectInvalidPrograms :: InValidBrainfuckProgram.InvalidBrainfuckProgram -> Bool -prop_rejectInvalidPrograms = Either.isLeft . Brainfuck.parse . InValidBrainfuckProgram.get +prop_rejectInvalidTexts :: InValidBrainfuckText.InvalidBrainfuckText -> Bool +prop_rejectInvalidTexts = Either.isLeft . Brainfuck.parse . InValidBrainfuckText.get + +prop_renderParseInverse :: Vector Instruction -> Bool +prop_renderParseInverse source = Right source == (Brainfuck.parse . Brainfuck.render $ source) return [] -- template haskell guard runQuickCheck :: IO Bool From f05da30c8aa994f326fd035e9209c285027543a6 Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Fri, 20 Jun 2025 10:37:55 +0200 Subject: [PATCH 4/6] feat: documentation --- test/Spec.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 238a797..2d96419 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,12 +12,15 @@ import qualified Language.Brainfuck as Brainfuck import qualified Arbitrary.ValidBrainfuckText as ValidBrainfuckText import qualified Arbitrary.InvalidBrainfuckText as InValidBrainfuckText -prop_acceptValidTexts :: ValidBrainfuckText.ValidBrainfuckText -> Bool -prop_acceptValidTexts = Either.isRight . Brainfuck.parse . ValidBrainfuckText.get +-- | ValidBrainfuckText will produce a text with comments, it must be parsed correctly +prop_acceptValidTexts :: ValidBrainfuckText.ValidBrainfuckText -> Bool +prop_acceptValidTexts = Either.isRight . Brainfuck.parse . ValidBrainfuckText.get +-- | InvalidBrainfuckText will insert unbalanced brackets, they must be rejected prop_rejectInvalidTexts :: InValidBrainfuckText.InvalidBrainfuckText -> Bool prop_rejectInvalidTexts = Either.isLeft . Brainfuck.parse . InValidBrainfuckText.get +-- | Does rendering and parsing a vector of instructions yield the exact same result? prop_renderParseInverse :: Vector Instruction -> Bool prop_renderParseInverse source = Right source == (Brainfuck.parse . Brainfuck.render $ source) From 40ce94ab7bcf02f2f839d41fd4b9883322b3cc1a Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Mon, 23 Jun 2025 14:00:21 +0200 Subject: [PATCH 5/6] feat[compressed]: ability to uncompress --- .../Brainfuck/Instruction/Compressed.hs | 37 ++++++++++++++++++- .../Brainfuck/Instruction/Extended.hs | 1 - test/Spec.hs | 5 +++ 3 files changed, 41 insertions(+), 2 deletions(-) diff --git a/src/Language/Brainfuck/Instruction/Compressed.hs b/src/Language/Brainfuck/Instruction/Compressed.hs index c57224f..bf28a1d 100644 --- a/src/Language/Brainfuck/Instruction/Compressed.hs +++ b/src/Language/Brainfuck/Instruction/Compressed.hs @@ -1,13 +1,19 @@ {-# LANGUAGE ImportQualifiedPost #-} -module Language.Brainfuck.Instruction.Compressed ( CompressedInstruction(..), compress ) where +{-# LANGUAGE InstanceSigs #-} +module Language.Brainfuck.Instruction.Compressed ( CompressedInstruction(..), compress, uncompress ) where import Data.Bifunctor ( Bifunctor(first) ) import Data.Vector ( Vector ) import Data.Word ( Word8 ) import Numeric.Natural ( Natural ) +import Test.QuickCheck.Gen (Gen) +import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary)) +import Test.QuickCheck.Instances.Natural () import Data.Vector qualified as Vector +import Test.QuickCheck.Gen qualified as Gen + import Language.Brainfuck.Instruction ( Instruction ) import Language.Brainfuck.Instruction qualified as Instruction @@ -21,6 +27,20 @@ data CompressedInstruction | Loop (Vector CompressedInstruction) deriving (Show, Eq) +instance Arbitrary CompressedInstruction where + arbitrary :: Gen CompressedInstruction + arbitrary = Gen.oneof + [ Add <$> arbitrary + , Subtract <$> arbitrary + , MoveRight <$> arbitrary + , MoveLeft <$> arbitrary + , pure ReadByte + , pure PutByte + , Loop <$> resize (`div` 8) arbitrary + ] + where + resize f x = Gen.sized $ \ s -> Gen.resize (f s) x + compress :: Vector Instruction -> Vector CompressedInstruction compress instructions = Vector.fromList (go instructions) where @@ -51,3 +71,18 @@ compress instructions = Vector.fromList (go instructions) -- >>> compress . Vector.fromList $ replicate 300 Instruction.MoveRight -- [MoveRight 300] +uncompress :: Vector CompressedInstruction -> Vector Instruction +uncompress = Vector.concatMap uncompressSingle + where + uncompressSingle instruction = let + repeated x times = Vector.replicate (fromIntegral times) x + + in case instruction of + Add times -> repeated Instruction.Increment times + Subtract times -> repeated Instruction.Decrement times + MoveRight times -> repeated Instruction.MoveRight times + MoveLeft times -> repeated Instruction.MoveLeft times + PutByte -> Vector.singleton Instruction.PutByte + ReadByte -> Vector.singleton Instruction.ReadByte + Loop body -> Vector.singleton $ Instruction.Loop (uncompress body) + diff --git a/src/Language/Brainfuck/Instruction/Extended.hs b/src/Language/Brainfuck/Instruction/Extended.hs index 8bd5a79..5fb434c 100644 --- a/src/Language/Brainfuck/Instruction/Extended.hs +++ b/src/Language/Brainfuck/Instruction/Extended.hs @@ -96,4 +96,3 @@ translationSize = Vector.sum . Vector.map instructionTranslationSize -- -- >>> parse [CompressedInstruction.Add 5, CompressedInstruction.Loop [CompressedInstruction.Loop [CompressedInstruction.ReadByte], CompressedInstruction.PutByte]] -- [Modify Add 5,Jump 4,Jump 1,Interact Read,WhenNonZero (Jump (-2)),Interact Write,WhenNonZero (Jump (-5))] - diff --git a/test/Spec.hs b/test/Spec.hs index 2d96419..986fa09 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -11,6 +11,7 @@ import qualified Data.Either as Either import qualified Language.Brainfuck as Brainfuck import qualified Arbitrary.ValidBrainfuckText as ValidBrainfuckText import qualified Arbitrary.InvalidBrainfuckText as InValidBrainfuckText +import qualified Language.Brainfuck.Instruction.Compressed as CompressedInstruction -- | ValidBrainfuckText will produce a text with comments, it must be parsed correctly prop_acceptValidTexts :: ValidBrainfuckText.ValidBrainfuckText -> Bool @@ -24,6 +25,10 @@ prop_rejectInvalidTexts = Either.isLeft . Brainfuck.parse . InValidBrainfuckText prop_renderParseInverse :: Vector Instruction -> Bool prop_renderParseInverse source = Right source == (Brainfuck.parse . Brainfuck.render $ source) +-- | Compressing and Uncompressing should be inverse +prop_CompressUncompressInverse :: Vector Instruction -> Bool +prop_CompressUncompressInverse source = source == CompressedInstruction.uncompress . CompressedInstruction.compress + return [] -- template haskell guard runQuickCheck :: IO Bool runQuickCheck = $quickCheckAll From 1b20f4ef717370626b89cfecfb57dc24fc5524fb Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Mon, 23 Jun 2025 14:01:39 +0200 Subject: [PATCH 6/6] fix[test]: missing argument to function --- test/Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 986fa09..449530c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -25,9 +25,9 @@ prop_rejectInvalidTexts = Either.isLeft . Brainfuck.parse . InValidBrainfuckText prop_renderParseInverse :: Vector Instruction -> Bool prop_renderParseInverse source = Right source == (Brainfuck.parse . Brainfuck.render $ source) --- | Compressing and Uncompressing should be inverse +-- | Compressing and Uncompressing should be inverse. The opposite must not be true, since `compress $ replicate 300 Increment` is `Add 44` prop_CompressUncompressInverse :: Vector Instruction -> Bool -prop_CompressUncompressInverse source = source == CompressedInstruction.uncompress . CompressedInstruction.compress +prop_CompressUncompressInverse source = source == (CompressedInstruction.uncompress . CompressedInstruction.compress) source return [] -- template haskell guard runQuickCheck :: IO Bool