simple symbolic execution for straight-line bf

bf.hs

import Data.Int
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM

data CellUpdate = CellUpdate
	{ inputID :: Maybe Int
	, offset :: Int8
	} deriving (Eq, Ord, Read, Show)

instance Monoid CellUpdate where mempty = CellUpdate Nothing 0
instance Semigroup CellUpdate where
	u <> u' = case inputID u' of
		Nothing -> u { offset = offset u + offset u' }
		Just{}  -> u'

bumpInputs :: Int -> CellUpdate -> CellUpdate
bumpInputs n u = u { inputID = (n+) <$> inputID u }

data TapeUpdate = TapeUpdate
	{ pointerMotion :: Int
	, inputCount :: Int
	, outputs :: [(Int, CellUpdate)]
	, writes :: IntMap CellUpdate
	} deriving (Eq, Ord, Read, Show)

instance Monoid TapeUpdate where mempty = TapeUpdate 0 0 [] mempty
instance Semigroup TapeUpdate where
	u <> u' = TapeUpdate
		{ pointerMotion = pointerMotion u + pointerMotion u'
		, inputCount = inputCount u + inputCount u'
		, outputs = outputs u ++
			[ (ptr, IM.findWithDefault mempty ptr (writes u) <> o)
			| (ptr, o) <- bumpPointers u (outputs u')
			]
		, writes = IM.unionWith (<>) (writes u)
		         . IM.fromDistinctAscList . bumpPointers u . IM.toAscList
		         $ writes u'
		}

bumpPointers :: TapeUpdate -> [(Int, CellUpdate)] -> [(Int, CellUpdate)]
bumpPointers u = map $ \(ptr, u') -> (ptr+pointerMotion u, bumpInputs (inputCount u) u')

data Op
	= IncCell
	| DecCell
	| IncPtr
	| DecPtr
	| In
	| Out
	deriving (Bounded, Enum, Eq, Ord, Read, Show)

compileOp :: Op -> TapeUpdate
compileOp IncCell = mempty { writes = IM.singleton 0 mempty { offset =  1 } }
compileOp DecCell = mempty { writes = IM.singleton 0 mempty { offset = -1 } }
compileOp IncPtr  = mempty { pointerMotion =  1 }
compileOp DecPtr  = mempty { pointerMotion = -1 }
compileOp In      = mempty { inputCount = 1, writes = IM.singleton 0 (CellUpdate (Just 0) 0) }
compileOp Out     = mempty { outputs = [(0, mempty)] }

compileOps :: [Op] -> TapeUpdate
compileOps = foldMap compileOp

-- Now, if we have a TapeUpdate u and
--
--     pointerMotion u = 0
--     writes u IM.! 0 = CellUpdate Nothing n
--
-- where n is odd, we can emit a very short instruction sequence that does a
-- tiny bit of arithmetic and captures the entire contents of the loop in just
-- a few hardware instructions. This will capture the common patterns of "set
-- this cell to 0", "add these two cells and store the result in this other
-- cell", "copy this cell to that one", and so forth.
--
-- If you wanted to capture more patterns, you could make CellUpdate more
-- complicated; currently it can only represent overwriting with input and
-- additions of constants, but you could imagine making a more complicated
-- expression type which could capture reads from old memory cells,
-- multiplications, and more, to handle common patterns that require nested
-- loops in bf.