fix[compressed]: FIRST BUG, the Num instance for Natural is broken

app/Main.hs

@@ -1,4 +1,33 @@
+{-# LANGUAGE LambdaCase #-}
 module Main (main) where
+import Control.Monad ((<$!>))
+
+import qualified System.Environment as Env
+
+import qualified Language.Brainfuck as Brainfuck
+import qualified Data.Text as Text
+import qualified Data.Text.IO as TextIO
+import qualified Data.Vector as Vector
+import qualified Language.Brainfuck.Instruction.Compressed as CompressedInstruction
+import qualified Language.Brainfuck.Instruction.Extended as ExtendedInstruction
+
+dumpVector :: Show a => FilePath -> Vector.Vector a -> IO ()
+dumpVector path = TextIO.writeFile path . Text.unlines . map (Text.pack . show) . Vector.toList
 
 main :: IO ()
-main = pure ()
+main = do
+  programFile <- Env.getArgs >>= \case
+    [x] -> pure x
+    _   -> error "usage: [program] source.bf"
+
+  instructions <- (Brainfuck.parse <$!> TextIO.readFile programFile) >>= \case
+    Left failure -> error $ show failure
+    Right x -> pure x
+
+  dumpVector "native.bf" instructions
+
+  let compressed = CompressedInstruction.compress instructions
+  dumpVector "compressed.bf" compressed
+
+  let extended = ExtendedInstruction.parse compressed
+  dumpVector "extended.bf" extended

bf-optimize.cabal

@@ -29,6 +29,8 @@ library
       Language.Brainfuck.Instruction
       Language.Brainfuck.Instruction.Compressed
       Language.Brainfuck.Instruction.Extended
+      Language.Brainfuck.Instruction.Extended.Interaction
+      Language.Brainfuck.Instruction.Extended.Operation
       Language.Brainfuck.Interpreter
   other-modules:
       Paths_bf_optimize

src/Language/Brainfuck.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE LambdaCase #-}
-module Language.Brainfuck (parse, ParseFailure, render) where
+
+-- | This module allows you to parse and manipulate brainfuck programs. Currently there are no re-exports here, you may need to look into submodules to find the operations you need.
+
+module Language.Brainfuck (parse, ParseFailure(..), render) where
 
 import Control.Monad.ST (runST, ST)
 
@@ -16,14 +19,32 @@ import Language.Brainfuck.Instruction ( Instruction(..) )
 import qualified Data.List as List
 import Numeric.Natural (Natural)
 
+-- | Brainfuck has only two types of syntax errors: either too many open brackets or too many closed brackets, this is the failure type.
+
 data ParseFailure
-  = UnexpectedClosingBracket Natural -- closing bracket position
+  = UnexpectedClosingBracket Natural 
-  | UnmatchedOpenBracket Natural -- opening bracket position
+  -- ^ closing bracket position
+  | UnmatchedOpenBracket Natural 
+  -- ^ opening bracket position
   deriving stock (Show, Eq)
 
 -- | Convert a Text to a list of instructions, discard all comments.
 --
 -- Recognized instructions are in the string "+-<>,.[]", they are represented as a Enum Type.
+--
+-- ==== __Examples__
+--
+-- >>> parse $ Text.pack "<<>>,,..<,.>"
+-- Right [MoveLeft,MoveLeft,MoveRight,MoveRight,ReadByte,ReadByte,PutByte,PutByte,MoveLeft,ReadByte,PutByte,MoveRight]
+--
+-- >>> parse $ Text.pack "[-]++<<<[>-[+-+-+]]>+"
+-- Right [Loop [Decrement],Increment,Increment,MoveLeft,MoveLeft,MoveLeft,Loop [MoveRight,Decrement,Loop [Increment,Decrement,Increment,Decrement,Increment]],MoveRight,Increment]
+--
+-- >>> parse $ Text.pack "["
+-- Left (UnmatchedOpenBracket 0)
+--
+-- >>> parse $ Text.pack "[]]"
+-- Left (UnexpectedClosingBracket 2)
 
 parse :: Text -> Either ParseFailure (Vector Instruction)
 parse text = runST $ do
@@ -75,18 +96,17 @@ parse text = runST $ do
                     _ -> pure innerResult
                 _   -> parseBlock cs instructions index
 
-
+-- | Render a series of instructions into a program text.
--- >>> parse $ Text.pack "<<>>,,..<,.>"
+--
--- Right [MoveLeft,MoveLeft,MoveRight,MoveRight,ReadByte,ReadByte,PutByte,PutByte,MoveLeft,ReadByte,PutByte,MoveRight]
+-- This is not exactly an inverse of 'parse' because parse will discard all comments and may fail with the 'Left' constructor.
-
+--
--- >>> parse $ Text.pack "[-]++<<<[>-[+-+-+]]>+"
+-- ==== __Examples__
--- Right [Loop [Decrement],Increment,Increment,MoveLeft,MoveLeft,MoveLeft,Loop [MoveRight,Decrement,Loop [Increment,Decrement,Increment,Decrement,Increment]],MoveRight,Increment]
+--
-
+-- >>> render $ Vector.fromList [Increment,Increment, Loop $ Vector.fromList [Decrement, MoveRight, Increment, MoveLeft]]
--- >>> parse $ Text.pack "["
+-- "++[->+<]"
--- Left (UnmatchedOpenBracket 0)
+--
-
+-- >>> fmap render . parse $ Text.pack "++ [ ->+< ] comment"
--- >>> parse $ Text.pack "[]]"
+-- Right "++[->+<]"
--- Left (UnexpectedClosingBracket 2)
 
 render :: Vector Instruction -> Text
 render = Text.concat . List.map renderSingle . Vector.toList

src/Language/Brainfuck/Instruction.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE InstanceSigs #-}
+
+-- | This is the native brainfuck instruction representation. They can be easily mapped to and from a program text.
+
 module Language.Brainfuck.Instruction (Instruction(..)) where
 
 import Data.Vector ( Vector )
@@ -9,6 +12,8 @@ import Test.QuickCheck.Instances.Vector ()
 
 import qualified Test.QuickCheck.Gen as Gen
 
+-- | The native brainfuck instruction. Does not allow comments, they must be discarded whilst parsing.
+
 data Instruction
   = Increment
   | Decrement
@@ -21,7 +26,7 @@ data Instruction
 
 instance Arbitrary Instruction where
   arbitrary :: Gen Instruction
-  arbitrary = Gen.oneof $
+  arbitrary = Gen.oneof 
     [ pure Increment
     , pure Decrement
     , pure MoveLeft

src/Language/Brainfuck/Instruction/Compressed.hs

@@ -1,5 +1,12 @@
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE InstanceSigs #-}
+
+-- | 
+-- Copyright: (c) Luca S. Jaekel
+-- License: AGPL3
+--
+-- Compressed Instructions are useful for brainfuck optimization, since they enable easier pattern-matching on common program patterns.
+
 module Language.Brainfuck.Instruction.Compressed ( CompressedInstruction(..), compress, uncompress ) where
 
 import Data.Bifunctor ( Bifunctor(first) )
@@ -17,16 +24,24 @@ import Test.QuickCheck.Gen qualified as Gen
 import Language.Brainfuck.Instruction ( Instruction )
 import Language.Brainfuck.Instruction qualified as Instruction 
 
+-- | Represents a single dense instruction, repeatable instructions have a effect count associated with them. They should not occur next to each other in data structures when they could be merged in any way.
+
 data CompressedInstruction
   = Add Word8
   | Subtract Word8
+  -- add and sub wrap when doing more than 255 because Brainfuck operates on u8-cells
   | MoveRight Natural
   | MoveLeft Natural
+  -- disallows moving a negative amount of steps in a direction
   | ReadByte
   | PutByte
   | Loop (Vector CompressedInstruction)
   deriving (Show, Eq)
 
+-- >>> fromInteger 300 :: Word8
+-- 44
+
+
 instance Arbitrary CompressedInstruction where
   arbitrary :: Gen CompressedInstruction
   arbitrary = Gen.oneof
@@ -41,6 +56,14 @@ instance Arbitrary CompressedInstruction where
     where
       resize f x = Gen.sized $ \ s -> Gen.resize (f s) x
 
+-- | Will count reoccuring instructions and associate the count with the repeatable instruction. This should reduce the size of the instruction vector for any useful program. 
+--
+-- >>> compress . Vector.fromList $ replicate 300 Instruction.Increment
+-- [Add 44]
+--
+-- >>> compress . Vector.fromList $ replicate 300 Instruction.MoveRight
+-- [MoveRight 300]
+
 compress :: Vector Instruction -> Vector CompressedInstruction
 compress instructions = Vector.fromList (go instructions)
   where
@@ -63,13 +86,13 @@ compress instructions = Vector.fromList (go instructions)
     spanLength :: Eq a => a -> Vector a -> (Int, Vector a)
     spanLength x xs = first Vector.length $ Vector.span (== x) xs
 
--- >>> fromInteger 300 :: Word8
+-- | Uncompress is not necessarily the exact inverse of compress, but it is a brainfuck program semantic-preserving function.
--- 44
+--
-
 -- >>> compress . Vector.fromList $ replicate 300 Instruction.Increment
 -- [Add 44]
--- >>> compress . Vector.fromList $ replicate 300 Instruction.MoveRight
+--
--- [MoveRight 300]
+-- >>> let source = Vector.replicate 300 Instruction.Increment in source == (uncompress . compress) source
+-- False
 
 uncompress :: Vector CompressedInstruction -> Vector Instruction
 uncompress = Vector.concatMap uncompressSingle

src/Language/Brainfuck/Instruction/Extended.hs

@@ -1,37 +1,63 @@
 {-# 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
+-- | Extended instructions are the representation I wish to use for the optimization techniques in these modules.
+-- They should be easy to extend, hence I factored the 'Operation' type out of 'Language.Brainfuck.CompressedInstruction.CompressedInstruction'.
+
+module Language.Brainfuck.Instruction.Extended (ExtendedInstruction(Modify, Move, Interact, Jump), pattern IfNonZero, pattern WithOffset, mkIfNonZero, mkWithOffset, translationSize, parse) where
 
 import Data.Word (Word8)
+
 import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
 import Numeric.Natural (Natural)
 
 import Language.Brainfuck.Instruction.Compressed (CompressedInstruction)
+import Language.Brainfuck.Instruction.Extended.Operation (Operation)
+import Language.Brainfuck.Instruction.Extended.Interaction (Interaction)
+
 
-import qualified Data.Vector as Vector
 import qualified Language.Brainfuck.Instruction.Compressed as CompressedInstruction
+import qualified Language.Brainfuck.Instruction.Extended.Operation as Operation
+import qualified Language.Brainfuck.Instruction.Extended.Interaction as Interaction
 
-data Operation
+-- | This pattern protects the invariant that 'WithOffset'-Instructions may not be nested
-  = Add
+--
-  | Subtract
+-- >>> WithOffset 5 (Interact Interaction.Write)
-  deriving (Show)
+-- AtOffset 5 (Interact Write)
-
+--
-data Interaction
+-- >>> WithOffset 5 (WithOffset (-2) (Modify Operation.Add 5))
-  = Read
+-- AtOffset 3 (Modify Add 5)
-  | Write
-  deriving (Show)
 
 pattern WithOffset :: Integer -> ExtendedInstruction -> ExtendedInstruction
 pattern WithOffset offset embedded <- AtOffset offset embedded
   where
     WithOffset offset embedded = mkWithOffset offset embedded
 
+-- | This pattern protects the invariant that 'IfNonZero'-Instructions may not be directly nested
+--
+-- >>> IfNonZero (Modify Operation.Add 5)
+-- WhenNonZero (Modify Add 5)
+--
+-- >>> IfNonZero (IfNonZero (Modify Operation.Subtract 2))
+-- WhenNonZero (Modify Subtract 2)
+
 pattern IfNonZero :: ExtendedInstruction -> ExtendedInstruction
 pattern IfNonZero instruction <- WhenNonZero instruction
   where
     IfNonZero instruction = mkIfNonZero instruction
 
+-- | The extended instruction set is defined by this enum.
+--
+-- Note: not all instruction types are exported since some of them hold invariants. 
+--
+-- You need to additionally consider these pattern exports when matching:
+--
+--   [@WithOffset@]: Will merge nested WithOffset instructions
+--
+--   [@IfNonZero@]: Will eliminate doubly conditional instructions
+
 data ExtendedInstruction
   = AtOffset Integer ExtendedInstruction -- invariant, WithOffset may not nest itself
   | WhenNonZero ExtendedInstruction -- invariant, IfNonZero may not nest itself
@@ -41,32 +67,50 @@ data ExtendedInstruction
   | Jump Integer
   deriving (Show)
 
+-- | Smart constructor alias for the pattern 'WithOffset'
+-- 
+-- >>> mkIfNonZero $ mkIfNonZero (Interact Interaction.Read)
+-- WhenNonZero (Interact Read)
+
 mkIfNonZero :: ExtendedInstruction -> ExtendedInstruction
 mkIfNonZero = \case
   WhenNonZero i -> WhenNonZero i
   instruction -> WhenNonZero instruction
 
+-- | Smart constructor alias for the pattern 'IfNonZero'
+--
+-- >>> mkWithOffset 15 $ mkWithOffset (-3) $ Interact Interaction.Read
+-- AtOffset 12 (Interact Read)
+
 mkWithOffset :: Integer -> ExtendedInstruction -> ExtendedInstruction
 mkWithOffset offset = \case
   AtOffset offset' i -> AtOffset (offset + offset') i
   instruction -> AtOffset offset instruction
 
--- >>> mkWithOffset 15 $ mkWithOffset (-3) $ Interact Read
+-- | Parsess the CompressedInstruction program into the ExtendedInstruction form, which e.g. does not contain 'CompressedInstruction.Loop' instructions anymore.
--- AtOffset 12 (Interact Read)
+--
+-- >>> :set -XOverloadedLists
+-- >>> parse [CompressedInstruction.Add 5]
+-- [Modify Add 5]
+--
+-- >>> 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))]
 
 parse :: Vector CompressedInstruction -> Vector ExtendedInstruction
 parse = Vector.fromList . Vector.foldr prependTranslation []
 
+-- | This prepends the translation of the instruction to the given list, this was before I learned about List.concatMap being very efficient
+
 prependTranslation :: CompressedInstruction -> [ExtendedInstruction] -> [ExtendedInstruction]
 prependTranslation instruction rest = let
   addSingle = (:rest)
   in case instruction of
-    CompressedInstruction.Add       i    -> addSingle $ Modify Add i
+    CompressedInstruction.Add       i    -> addSingle $ Modify Operation.Add i
-    CompressedInstruction.Subtract  i    -> addSingle $ Modify Subtract i
+    CompressedInstruction.Subtract  i    -> addSingle $ Modify Operation.Subtract i
     CompressedInstruction.MoveRight n    -> addSingle $ Move $ toInteger n
-    CompressedInstruction.MoveLeft  n    -> addSingle $ Move $ toInteger (-n)
+    CompressedInstruction.MoveLeft  n    -> addSingle $ Move $ negate . toInteger $ n
-    CompressedInstruction.ReadByte       -> addSingle $ Interact Read
+    CompressedInstruction.ReadByte       -> addSingle $ Interact Interaction.Read
-    CompressedInstruction.PutByte        -> addSingle $ Interact Write
+    CompressedInstruction.PutByte        -> addSingle $ Interact Interaction.Write
     CompressedInstruction.Loop      body -> let
       bodySize = translationSize body
       backJump = IfNonZero $ Jump $ -(toInteger bodySize + 1)
@@ -74,6 +118,8 @@ prependTranslation instruction rest = let
 
       in forwardJump : Vector.foldr prependTranslation (backJump : rest) body
 
+-- | Calculates the required size for a instruction vector of ExtendedInstruction, since they may need more space.
+
 translationSize :: Vector CompressedInstruction -> Natural
 translationSize = Vector.sum . Vector.map instructionTranslationSize
   where
@@ -90,9 +136,3 @@ translationSize = Vector.sum . Vector.map instructionTranslationSize
       bodySize = translationSize body
       in skipLoopSize + repeatLoopSize + bodySize
 
--- >>> :set -XOverloadedLists
--- >>> parse [CompressedInstruction.Add 5]
--- [Modify Add 5]
---
--- >>> 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))]

src/Language/Brainfuck/Instruction/Extended/Interaction.hs

@@ -0,0 +1,13 @@
+
+-- | This module holds the 'Interaction' enum, this allows for nice qualified imports.
+--
+-- Also, it makes for smaller compilation units and easier changes, because I I just happen to know what's where.
+
+module Language.Brainfuck.Instruction.Extended.Interaction (Interaction(..)) where
+
+-- | All the Interactions with the outside world, I think it is safe to say that this is the final state of this module.
+
+data Interaction
+  = Read
+  | Write
+  deriving (Show)

src/Language/Brainfuck/Instruction/Extended/Operation.hs

@@ -0,0 +1,13 @@
+
+-- | This module holds the 'Operation' enum, this allows for nice qualified imports.
+--
+-- Also, it makes for smaller compilation units and easier changes, because I I just happen to know what's where.
+
+module Language.Brainfuck.Instruction.Extended.Operation (Operation(..)) where
+
+-- | All the Operations that are allowed on a Variable in the Extended Instruction format.
+
+data Operation
+  = Add
+  | Subtract
+  deriving (Show)