brainfuck-monad 0.1.0 → 0.2.0

raw patch · 2 files changed

+182/−70 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Monad/BrainFuck.hs +181/−69
• brainfuck-monad.cabal +1/−1

@@ -35,15 +35,11 @@ output = opcode '.' -- | input byte, storing at data pointer input = opcode ','--- | if byte at data pointer is zero, jump to command after close+-- | if byte at data pointer is zero, jump to opcode after close open = opcode '['--- | if byte at data pointer is nonzero, jump to command after matching open+-- | if byte at data pointer is nonzero, jump to optoce after matching open close = opcode ']' -add, sub :: Int -> BrainFuck ()-add = multi incr-sub = multi decr- -- | Adds an arbitrary character to the program. -- Should not be used directly. opcode :: Char -> BrainFuck ()@@ -55,27 +51,15 @@ opcode' :: (DataPointer -> DataPointer) -> Char -> BrainFuck () opcode' f x =  BrainFuck $ \loc -> ([x], f loc, ()) --- | Run an action multiple times.-multi :: BrainFuck () -> Int -> BrainFuck ()-multi c n = do-	_ <- sequence (replicate n c)-	return ()---- | Assuming that the data pointer points to a 0, changes--- it to the value of a Char.-char :: Char.Char -> BrainFuck ()-char = multi incr . Char.ord---- | Undoes `char`-unchar :: Char.Char -> BrainFuck ()-unchar = multi decr . Char.ord---- | Runs an action with the data pointer pointing at a Char.-withChar :: Char.Char -> BrainFuck a -> BrainFuck a-withChar c a = do-	char c+-- | The loop is only run if the data pointer doesn't point to 0.+--+-- On entry, the loop body is run, and then it loops, until the data+-- pointer points to 0.+loopUnless0 :: BrainFuck a -> BrainFuck a+loopUnless0 a = do+	open 	r <- a-	unchar c+	close 	return r  -- | Gets the current address of the data pointer.@@ -92,64 +76,192 @@ 			then next >> setAddr n 			else return () --- | The loop is only run if the data pointer doesn't point to 0.------ On entry, the loop body is run, and then it loops, until the data--- pointer points to 0.-loopUnless0 :: BrainFuck () -> BrainFuck ()-loopUnless0 a = do-	open-	a-	close+-- | Run an action multiple times.+multi :: BrainFuck () -> Int -> BrainFuck ()+multi c n = do+	_ <- sequence (replicate n c)+	return () -data Constants = Constants NumConstants Integer+add, sub :: Int -> BrainFuck ()+-- adds an Int to the byte at the data pointer+add = multi incr+-- subtracts an Int from the byte at the data pointer+sub = multi decr -type NumConstants = Int+-- | Zeros the current data cell.+zero :: BrainFuck ()+zero = loopUnless0 decr --- | Let's run programs with data addresses 0..n reserved to always contain--- the numbers n..0+-- | Changes the current data cell to contain a specific value.+-- (It can start at any value).+set :: Int -> BrainFuck ()+set n = do+	zero+	add n	++-- | For higher-level programming in brainfuck, it's useful to have a way+-- to run a function, while allocating a memory cell, which is initialized+-- to contain 0. ----- These constants will make brainfuck quite a bit easier to use!-brainfuckConstants :: NumConstants -> (Constants -> BrainFuck a) -> String-brainfuckConstants numconstants a = brainfuck $ do-	M.forM_ [0..numconstants] $ \n -> do-		add (numconstants - n)-		next-	a (Constants numconstants 0)+-- This and many of the functions below assume that+-- cells to the left are in use, while cells to the right+-- are unused and may contain any data. Higher-level functions should+-- generally avoid changing the current cell, and should instead alloc+-- a new one to use.+alloc :: BrainFuck a -> BrainFuck a+alloc a = do+	next+	zero+	cell <- addr+	r <- a+	setAddr cell+	prev+	return r --- | Sets data pointer to point to one of the Constants.-pointAt :: Constants -> Integer -> BrainFuck ()-pointAt (Constants numconstants c) i = setAddr (c + fromIntegral numconstants - i)+-- | Allocates a new memory cell, populates it with a Char, and runs+-- the action.+withChar :: Char.Char -> BrainFuck a -> BrainFuck a+withChar c a = alloc $ do+	set (Char.ord c)+	a --- | Run an action in a loop, until the data pointer points to 0.-loop :: Constants -> BrainFuck () -> BrainFuck ()-loop constants a = do-	here <- addr-	pointAt constants 1+-- | Allocates a cell and uses it as the loop counter, starting from +-- the provided value. The action will continue running in a loop until+-- it decrements the counter to 0.+loopFrom :: Int -> (DataPointer -> BrainFuck ()) -> BrainFuck ()+loopFrom n a = alloc $ do+	i <- addr+	add n 	loopUnless0 $ do-		setAddr here+		a i+		setAddr i++-- | Runs an action in an infinite loop. The action should avoid+-- touching the current memory cell.+forever :: BrainFuck a -> BrainFuck ()+forever a = loopFrom 1 $ \_ -> do+	_ <- a+	return ()++-- | Runs the action unless the data pointer points to 0.+unless0 :: BrainFuck () -> BrainFuck ()+unless0 a = do+	start <- addr+	loopUnless0 $ do 		a+		next+		zero+	prev --- | Runs an action in an infinite loop.-forever :: Constants -> BrainFuck () -> BrainFuck ()-forever constants a = loop constants $ do-	a-	pointAt constants 1+-- | Adds the current and next data cells. The next cell is zeroed+-- and the sum is left in the current cell.+sum :: BrainFuck ()+sum = do+	next+	loopUnless0 $ do+		prev+		incr+		next+		decr+	prev --- | Prints out the ASCII characters, starting with space, repeatedly.--- --- TODO: Only print printable characters.+-- | Multiplies the current data cell by some value. Uses and zeros some+-- of the following cells.+mult :: Int -> BrainFuck ()+mult y = do+	x <- addr+	alloc $ do+		c1 <- addr++		-- Copy x to c1, and zero x.+		setAddr x+		loopUnless0 $ do+			setAddr c1+			incr+			setAddr x+			decr+	+		setAddr c1+		loopUnless0 $ do+			loopFrom y $ \c2 -> do+				decr+				setAddr x+				incr+			setAddr c1+			decr++-- | Displays a string. Tries to generate a fairly small brainfuck program,+-- using a few encoding tricks. The current cell is modified, and not+-- cleaned up at the end, so run using alloc if necessary.+display :: String -> BrainFuck ()+display s = start >>= go True (map Char.ord s)+  where+	-- Get to letter 104 ('a' is 97) quickly by multiplication.+	start = do+		zero+		x <- addr+		add 13+		mult 8+		return (13 * 8)+	+	go _ [] _ = return ()+	go started (c:cs) n+		| not started && delta > 13 = start >>= go True (c:cs)+		| otherwise = do+			if abs delta < c+				then multi (if delta > 0 then incr else decr) (abs delta)+				else set c+			output+			go False cs c+	  where+		delta = c - n++-- | Prints out the alphabet, repeatedly. demo :: String-demo = brainfuckConstants 1 $ \constants -> do-	add $ Char.ord ' '-	forever constants $ do-		add 1-		output+demo = brainfuck $ forever $ do+	alloc $ do+		c <- addr+		set start+		+		loopFrom numchars $ \i -> do+			decr+			setAddr c+			output+			incr+		withChar ' ' output+  where+	start = Char.ord 'a'+	end = Char.ord 'z'+	numchars = end - start + 1 +-- | Copy input to output. cat :: String-cat = brainfuckConstants 1 $ flip forever $ input >> output+cat = brainfuck $ forever $ input >> output +-- | Simple hello world. helloworld :: String helloworld = brainfuck $ 	M.forM_ "hello, world!" $ 		flip withChar output++-- | Optimized to use less space.+helloworld' :: String+helloworld' = optimize $ brainfuck $ display "hello, world!"++-- | Simple optimiser for brainfuck code.+optimize :: String -> String+optimize s = go s [] s+  where+	go orig r [] =+		let new = reverse r in+		if new /= orig+			then go new [] new+			else new+	go orig r ('>':'<':l) = go orig r l -- <> is a noop+	go orig r ('<':'>':l) = go orig r l -- >< is a noop+	go orig r ('+':'-':l) = go orig r l -- +- is a noop+	go orig r ('-':'+':l) = go orig r l -- -+ is a noop+	go orig r ('[':']':l) = go orig r l -- [] is a noop+	go orig [] ('[':'-':']':l) = go orig [] l -- [-] at start is noop+	go orig [] ('>':'[':'-':']':l) = go orig [] l -- >[-] at start is noop+	go orig r (c:l) = go orig (c:r) l

@@ -1,5 +1,5 @@ Name: brainfuck-monad-Version: 0.1.0+Version: 0.2.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>