brainfuck-monad 0.2.0 → 0.4.0

raw patch · 2 files changed

+188/−56 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Monad/BrainFuck.hs +187/−55
• brainfuck-monad.cabal +1/−1

@@ -2,6 +2,7 @@  import qualified Control.Monad as M import qualified Data.Char as Char+import Data.Word (Word8)  newtype BrainFuck a = BrainFuck (DataPointer -> ([Char], DataPointer, a)) @@ -40,6 +41,9 @@ -- | if byte at data pointer is nonzero, jump to optoce after matching open close = opcode ']' +-- | ignored if brainfuck machine does not support debugging+debug = opcode '#'+ -- | Adds an arbitrary character to the program. -- Should not be used directly. opcode :: Char -> BrainFuck ()@@ -53,12 +57,19 @@  -- | 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.+-- On entry, the loop body is run, and then it loops, until the address+-- the data pointer originally pointed at has a value of 0.+--+-- Any change that the loop body makes to the address of the data pointer+-- is reset each time through the loop (and at the end). This is necessary+-- to keep the BrainFuck monad's DataPointer consistent no matter what+-- happens when running the loop. loopUnless0 :: BrainFuck a -> BrainFuck a loopUnless0 a = do+	start <- addr 	open 	r <- a+	setAddr start 	close 	return r @@ -76,17 +87,27 @@ 			then next >> setAddr n 			else return () +-- | Runs an action with the data pointer temporarily set to an address,+-- then restores the data pointer.+withAddr :: Integer -> BrainFuck a -> BrainFuck a+withAddr n a = do+	old <- addr+	setAddr n+	r <- a+	setAddr old+	return r+ -- | Run an action multiple times. multi :: BrainFuck () -> Int -> BrainFuck () multi c n = do 	_ <- sequence (replicate n c) 	return () -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+add, sub :: Word8 -> BrainFuck ()+-- adds an byte to the byte at the data pointer (wraps on overflow)+add = multi incr . fromIntegral+-- subtracts an byte from the byte at the data pointer (wraps on underflow)+sub = multi decr . fromIntegral  -- | Zeros the current data cell. zero :: BrainFuck ()@@ -94,10 +115,10 @@  -- | Changes the current data cell to contain a specific value. -- (It can start at any value).-set :: Int -> BrainFuck ()+set :: Word8 -> BrainFuck () set n = do 	zero-	add n	+	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@@ -118,45 +139,98 @@ 	prev 	return r +alloc' :: (DataPointer -> BrainFuck a) -> BrainFuck a+alloc' a = alloc $ addr >>= a+ -- | 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)+	set $ fromIntegral $ Char.ord c 	a  -- | 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-		a i-		setAddr i+loopFrom :: Word8 -> (DataPointer -> BrainFuck ()) -> BrainFuck ()+loopFrom n a =+	alloc' $ \i -> do+		add n+		loopUnless0 $+			a i --- | Runs an action in an infinite loop. The action should avoid--- touching the current memory cell.+-- | Runs an action in an infinite loop. The action can modify its+-- current memory cell, or allocate and use new ones, and will not+-- exit the loop. forever :: BrainFuck a -> BrainFuck ()-forever a = loopFrom 1 $ \_ -> do-	_ <- a-	return ()+forever a = loopFrom 1 $ \i ->+	alloc' $ \scratch -> do+		a+		return () +-- | Copies the value of a cell.+copy :: DataPointer -> DataPointer -> BrainFuck ()+copy src dest = do+	withAddr dest zero+	alloc' $ \tmp -> do+		-- copy src to new and tmp, but this clobbers src+		setAddr src+		loopUnless0 $ do+			decr+			setAddr dest+			incr+			setAddr tmp+			incr+		-- put src back how it was+		setAddr tmp+		loopUnless0 $ do+			decr+			setAddr src+			incr++-- | Runs the action with a new cell that is logically NOT+-- the value of the passed pointer.+withNot :: DataPointer -> BrainFuck () -> BrainFuck ()+withNot p a = alloc' $ \tmp1 -> do+	copy p tmp1+	alloc' $ \tmp2 -> do+		incr+		setAddr tmp1+		loopUnless0 $ do+			zero+			setAddr tmp2+			decr+		setAddr tmp2+		a+ -- | Runs the action unless the data pointer points to 0.-unless0 :: BrainFuck () -> BrainFuck ()-unless0 a = do+unless0 :: DataPointer -> BrainFuck () -> BrainFuck ()+unless0 p a = do 	start <- addr-	loopUnless0 $ do-		a-		next-		zero-	prev+	alloc' $ \tmp -> do+		copy p tmp+		loopUnless0 $ do+			setAddr start+			a+			setAddr tmp+			zero -- don't loop +-- | Runs the action when the data pointer points to 0.+when0 :: DataPointer -> BrainFuck () -> BrainFuck ()+when0 p a = withNot p $+	addr >>= flip unless0 a++-- | Monadic if; the first action is run if the data pointer points to 0,+-- else the second action is run.+if0 :: DataPointer -> (BrainFuck (),  BrainFuck ()) -> BrainFuck ()+if0 p (y, n) = do+	when0 p y+	unless0 p n+ -- | 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+sumNext :: BrainFuck ()+sumNext = do 	next 	loopUnless0 $ do 		prev@@ -167,28 +241,24 @@  -- | Multiplies the current data cell by some value. Uses and zeros some -- of the following cells.-mult :: Int -> BrainFuck ()+mult :: Word8 -> BrainFuck () mult y = do 	x <- addr-	alloc $ do-		c1 <- addr-+	alloc' $ \c1 -> do 		-- Copy x to c1, and zero x. 		setAddr x 		loopUnless0 $ do+			decr 			setAddr c1 			incr-			setAddr x-			decr 	 		setAddr c1 		loopUnless0 $ do+			decr 			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@@ -210,33 +280,55 @@ 		| otherwise = do 			if abs delta < c 				then multi (if delta > 0 then incr else decr) (abs delta)-				else set c+				else set (fromIntegral c) 			output 			go False cs c 	  where 		delta = c - n --- | Prints out the alphabet, repeatedly.+-- | Prints out the alphabet, repeatedly, with some whitespace fun+-- to make it more interesting. demo :: String-demo = brainfuck $ forever $ do-	alloc $ do-		c <- addr-		set start+demo = brainfuck $ alloc' $ \tilt -> do+	settilt+	alloc' $ \tc -> do+		decr -- set to 255+		alloc' $ \wc -> do+			copy tilt wc+			forever $ alloc' $ \c -> do+				set (fromIntegral start)+				loopFrom (fromIntegral numchars) $ \i -> do+					decr 		-		loopFrom numchars $ \i -> do-			decr-			setAddr c-			output-			incr-		withChar ' ' output+					withAddr wc decr+					when0 wc $ do+						loopFrom 3 $ \_ -> do+							decr+							withChar ' ' output+						copy tilt wc+						withAddr tc decr+						when0 tc $ do+							withAddr tc decr+							withAddr tilt decr+							when0 tilt $ do+								withAddr tilt+									settilt+				+					setAddr c+					output+					incr   where 	start = Char.ord 'a' 	end = Char.ord 'z' 	numchars = end - start + 1 +	settilt = do+		set 4+		mult 5+ -- | Copy input to output. cat :: String-cat = brainfuck $ forever $ input >> output+cat = brainfuck $ forever $ alloc $ input >> output  -- | Simple hello world. helloworld :: String@@ -248,9 +340,36 @@ helloworld' :: String helloworld' = optimize $ brainfuck $ display "hello, world!" +{-+euler1 :: BrainFuck+euler1 = alloc' $ \result -> alloc' $ \scratch -> do+	let accum i = do+		setAddr scratch+		dup i+		setAddr result+		sumNext+		+	let checkmod i n = alloc $ do+		dup i+		mod n+		when0 $+			accum i++	loopFrom 1000 $ \i -> do+		decr+		alloc $ do+			checkmod i 5+			print0	+			unless0 $+				checkmod 1 3++	setAddr result+	decimalOutput+-}+ -- | Simple optimiser for brainfuck code. optimize :: String -> String-optimize s = go s [] s+optimize s = trimend $ go s [] s   where 	go orig r [] = 		let new = reverse r in@@ -262,6 +381,19 @@ 	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+	-- [-] before , is a noop, because the read overwrites the value+	go orig r ('[':'-':']':',':l) = go orig r (',':l)+	-- so is + or - before ,+	go orig r ('+':',':l) = go orig r (',':l)+	go orig r ('-':',':l) = go orig r (',':l)+	-- [-][-] is the same as [-]+	go orig r ('[':'-':']':'[':'-':']':l) = go orig r ('[':'-':']':l)+	-- [-] at start is noop, because memory starts empty+	go orig [] ('[':'-':']':l) = go orig [] l+	-- >[-] at start is generally a noop (for programs using alloc)+	go orig [] ('>':'[':'-':']':l) = go orig [] l 	go orig r (c:l) = go orig (c:r) l++	-- Any sequence of > and < at the end of a program is a noop.+	trimend = reverse . dropWhile (`elem` "><") . reverse+

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