packages feed

piet (empty) → 0.1

raw patch · 11 files changed

+1493/−0 lines, 11 filesdep +Imlibdep +arraydep +basebuild-type:Customsetup-changed

Dependencies added: Imlib, array, base, containers, mtl

Files

+ LICENSE view
@@ -0,0 +1,21 @@+Copyright (c) 2008, Stephan Friedrichs+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ''AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#! /usr/bin/env runhaskell++> module Main where+>+> import Distribution.Simple+>+> main = defaultMain+
+ piet.cabal view
@@ -0,0 +1,45 @@++Name:               piet+Version:            0.1+Stability:          beta++Category:           Compilers/Interpreters+Synopsis:           A Piet interpreter+Description:        An interpreter for the Piet programming language,+                    see <http://www.dangermouse.net/esoteric/piet.html>.++License:            BSD3+License-File:       LICENSE+Copyright:          (c) 2008, Stephan Friedrichs++Author:             Stephan Friedrichs+Maintainer:         Stephan Friedrichs (deduktionstheorem at web dot de)++Build-Type:         Custom+Cabal-Version:      >= 1.2++Library+  Build-Depends:+      array >= 0.1+    , base >= 3.0+    , containers >= 0.1+    , Imlib >= 0.1+    , mtl >= 1.1+  Exposed-Modules:+      Data.RollStack+    , Language.Piet+    , Language.Piet.Commands+    , Language.Piet.Compiler+    , Language.Piet.Interpreter+    , Language.Piet.PietMonad+    , Language.Piet.Types+  Hs-Source-Dirs:   sources+  GHC-Options:      -threaded -Wall -O2+  Extensions:       CPP++Executable          piet+  Main-Is:          Main.hs+  Hs-Source-Dirs:   sources+  GHC-Options:      -threaded -Wall -O2+  Extensions:       CPP+
+ sources/Data/RollStack.hs view
@@ -0,0 +1,115 @@++-- | This module implements a customized stack for the Piet programming+-- language.+--+-- In addition to the common 'push', 'pop' and 'top' operations, the+-- a 'RollStack' provides a 'roll' (see below) command, which is the+-- reason for using a 'Seq'uence and not a list as underlying data+-- structure.+--+-- Whenever the /O/-notation is used, /n/ describes the number of elements+-- within the stack.+module Data.RollStack+	(+	-- * Stack type+	  RollStack+	+	-- * Query+	, isEmpty+	, top+	+	-- * Construction+	, Data.RollStack.empty+	, Data.RollStack.singleton+	+	-- * Insert delete and roll operations+	, push+	, pop+	, roll++	-- * List conversion+	, Data.RollStack.fromList+	, Data.RollStack.toList+	) where++import Data.Foldable as Foldable+import Data.Maybe+import Data.Sequence  as Seq+import Prelude hiding (foldl, foldr)++-- | The 'RollStack' type.+newtype RollStack a+	= Stack (Seq a)++instance (Show a) => Show (RollStack a) where+	show (Stack xs) = show xs++instance (Eq a) => Eq (RollStack a) where+	(Stack xs) == (Stack ys) = xs == ys++instance (Ord a) => Ord (RollStack a) where+	compare (Stack xs) (Stack ys) = compare xs ys++instance Functor RollStack where+	fmap f (Stack xs) = Stack $ fmap f xs++instance Foldable RollStack where+	fold      (Stack xs) = fold      xs+	foldMap f (Stack xs) = foldMap f xs+	foldr f z (Stack xs) = foldr f z xs+	foldl f z (Stack xs) = foldl f z xs++-- | /O(1)/. Tests, if a 'RollStack' is empty.+isEmpty :: RollStack a -> Bool+isEmpty = isNothing . top++-- | /O(1)/. Looks at the top element of the 'RollStack'. Returns+-- 'Nothing' if the stack is empty.+top :: RollStack a -> Maybe a+top stack = fst `fmap` pop stack++-- | /O(1)/. Construct an empty 'Stack'.+empty :: RollStack a+empty = Stack Seq.empty++-- | /O(1)/. Construct a 'RollStack' containing a single element.+singleton :: a -> RollStack a+singleton = Stack . Seq.singleton++-- | /O(1)/. Push an element on the 'RollStack'.+push :: a -> RollStack a -> RollStack a+push x (Stack xs) = Stack (x <| xs)++-- | /O(1)/. Pop the top element from the 'RollStack' if it is not empty.+pop :: RollStack a -> Maybe (a, RollStack a)+pop (Stack xs) = case viewl xs of+	EmptyL   -> fail "empty RollStack"+	y :< ys -> return (y, Stack ys)++-- | /O(log(n))/. A single roll to depth /n/ is defined as burying the top+-- value on the stack /n/ deep and bringing all values above it up by 1+-- place. A negative number of rolls rolls in the opposite direction. A+-- negative depth results in an 'error'.+roll :: Int		-- ^ Number of rolls+	-> Int		-- ^ Depth+	-> RollStack a	-- ^ Original 'RollStack'+	-> RollStack a	-- ^ Rotated 'RollStack'+roll rolls depth unmodified@(Stack xs)+	| depth < 0                = error $ "negative depth in Data.RollStack.roll: " ++ show depth+	| rolls == 0 || depth == 0 = unmodified+	| otherwise                = let+		(xs1, xs2)   = Seq.splitAt depth xs+		(xs1a, xs1b) = Seq.splitAt (rolls `mod` depth) xs1+		in+		Stack (xs1b >< xs1a >< xs2)++-- | /O(n)/. Convert a list into a 'Stack'. The list's head will be+-- the first element of the 'Stack'+fromList :: [a] -> RollStack a+fromList = Stack . Seq.fromList++-- | /O(n)/. Convert a 'RollStack' to a list. The 'top' of the 'RollStack'+-- will be the list's head.+toList :: RollStack a -> [a]+toList (Stack xs) = Foldable.toList xs+
+ sources/Language/Piet.hs view
@@ -0,0 +1,17 @@++-- | Comprehensive module of the Piet interpreter. See+-- <http://www.dangermouse.net/esoteric/piet.html>.+module Language.Piet+	( module Language.Piet.Commands+	, module Language.Piet.Compiler+	, module Language.Piet.Interpreter+	, module Language.Piet.PietMonad+	, module Language.Piet.Types+	) where++import Language.Piet.Commands+import Language.Piet.Compiler+import Language.Piet.Interpreter+import Language.Piet.PietMonad+import Language.Piet.Types+
+ sources/Language/Piet/Commands.hs view
@@ -0,0 +1,218 @@++-- | This module contains the implementation of the Piet language+-- constructs. Most of the documentation is copied from the+-- Piet specification at <http://www.dangermouse.net/esoteric/piet.html>.+module Language.Piet.Commands+	(+	-- * Stack access+	  piet_push+	, piet_pop+	+	-- * Arithmetic operators+	, piet_add+	, piet_subtract+	, piet_multiply+	, piet_divide+	, piet_mod+	+	-- * Boolean operations+	, piet_not+	, piet_greater+	+	-- * Movement+	, piet_pointer+	, piet_switch+	+	-- * Stack modification+	, piet_duplicate+	, piet_roll+	+	-- * I/O+	, piet_in_number, piet_in_char+	, piet_out_number, piet_out_char+	) where++import Control.Monad+import Language.Piet.PietMonad+import Language.Piet.Types++-- | Pushes the value of the colour block just exited on to the stack.+-- Note that values of colour blocks are not automatically pushed on+-- to the stack - this push operation must be explicitly carried out.+piet_push :: Int -> PietMonad ()+piet_push n = do+	logWithPosition $ "push " ++ show n+	stackPush n++-- | Pops the top value off the stack and discards it.+piet_pop :: PietMonad ()+piet_pop = do+	logWithPosition "pop"+	forcePopFail "pop"+	return ()++-- | Pops the top two values off the stack, adds them, and pushes the+-- result back on the stack.+piet_add :: PietMonad ()+piet_add = do+	logWithPosition "add"+	onStack2 "add" (+)++-- | Pops the top two values off the stack, subtracts the top value from+-- the second top value, and pushes the result back on the stack.+piet_subtract :: PietMonad ()+piet_subtract = do+	logWithPosition "subtract"+	onStack2 "subtract" (flip (-))++-- | Pops the top two values off the stack, multiplies them, and pushes the+-- result back on the stack. +piet_multiply :: PietMonad ()+piet_multiply = do+	logWithPosition "multiply"+	onStack2 "multiply" (*)++-- | Pops the top two values off the stack, calculates the integer division+-- of the second top value by the top value, and pushes the result back on+-- the stack.+piet_divide :: PietMonad ()+piet_divide = do+	logWithPosition "divide"+	onStack2 "divide" (flip div)++-- | Pops the top two values off the stack, calculates the second top value+-- modulo the top value, and pushes the result back on the stack.+piet_mod :: PietMonad ()+piet_mod = do+	logWithPosition "mod"+	onStack2 "mod" (flip Prelude.mod)++-- | Replaces the top value of the stack with 0 if it is non-zero, and 1 if+-- it is zero.+piet_not :: PietMonad ()+piet_not = do+	logWithPosition "not"+	onStack1 "not" not'+	where+	not' 0 = 1+	not' _ = 0++-- | Pops the top two values off the stack, and pushes 1 on to the stack if+-- the second top value is greater than the top value, and pushes 0 if it+-- is not greater.+piet_greater :: PietMonad ()+piet_greater = do+	logWithPosition "greater"+	onStack2 "greater" greater'+	where+	greater' a b+		| a < b     = 1+		| otherwise = 0++-- | Pops the top value off the stack and rotates the DP clockwise that many+-- steps (anticlockwise if negative).+piet_pointer :: PietMonad ()+piet_pointer = do+	n	<- forcePopFail "pointer"+	dp	<- getDP+	let dp'	= (rotate n dp)+	setDP dp'+	logWithPosition $ "pointer " ++ show dp'++-- | Pops the top value off the stack and toggles the CC that many times.+piet_switch :: PietMonad ()+piet_switch = do+	n	<- forcePopFail "switch"+	cc	<- getCC+	let cc'	= toggle n cc+	setCC cc'+	logWithPosition $ "switch " ++ show cc'++-- | Pushes a copy of the top value on the stack on to the stack.+piet_duplicate :: PietMonad ()+piet_duplicate = do+	logWithPosition "duplicate"+	x <- forcePopFail "duplicate"+	stackPush x+	stackPush x++-- | Pops the top two values off the stack and \"rolls\" the remaining stack+-- entries to a depth equal to the second value popped, by a number of+-- rolls equal to the first value popped. A single roll to depth /n/ is+-- defined as burying the top value on the stack /n/ deep and bringing all+-- values above it up by 1 place. A negative number of rolls rolls in the+-- opposite direction. A negative depth is an error and the command is+-- ignored.+--+-- In this implementation, \"ignored\" means that the top two values+-- remain pushed off the stack, while the rest of the stack remains+-- unmodified.+piet_roll :: PietMonad ()+piet_roll = do+	logWithPosition "roll"+	rolls <- forcePopFail "roll"+	depth <- forcePopFail "roll"+	when (depth > 0 && rolls /= 0) $ stackRoll rolls depth++-- | Reads a number from STDIN and pushes it on to the stack. +piet_in_number :: PietMonad ()+piet_in_number = do+	logWithPosition "in_number"+	n <- readNumber+	stackPush n++-- | Reads a char from STDIN and pushes it on to the stack.+piet_in_char :: PietMonad ()+piet_in_char = do+	logWithPosition "in_char"+	n <- readChar+	stackPush n++-- | Pops the top value off the stack and prints it to STDOUT+-- as a number.+piet_out_number :: PietMonad ()+piet_out_number = do+	n <- forcePopFail "out_number"+	logWithPosition $ "out_number " ++ show n+	printNumber n++-- | Pops the top value off the stack and prints it to STDOUT+-- as a char.+piet_out_char :: PietMonad ()+piet_out_char = do+	n <- forcePopFail "out_char"+	logWithPosition $ "out_char " ++ show n+	printChar n++-- | Pops the top element of the stack, applies a function to it+-- and pushes the result back on the stack. The 'String' describes+-- the calling Piet function for possible errors.+onStack1 :: String -> (Int -> Int) -> PietMonad ()+onStack1 location f = liftM f (forcePopFail location) >>= stackPush++-- | Pops the top two elements of the stack, applies a function to+-- them (the first argument will be the first element popped from+-- the stack, the 2nd will be the 2nd) and pushes the result back+-- on the stack. The 'String' describes the calling Piet function+-- and might be needed to give error messages.+onStack2 :: String -> (Int -> Int -> Int) -> PietMonad ()+onStack2 location f = liftM2 f (forcePopFail location) (forcePopFail location) >>= stackPush++-- | Pops the top element from the stack and 'fail's if none is+-- available (with the given 'String' as location).+forcePopFail :: String -> PietMonad Int+forcePopFail location = forcePop (fail $ "Empty stack at " ++ location)++-- | Tries to pop the top element from the stack and returns it.+-- If the stack is empty, the alternative action is performed.+forcePop :: PietMonad Int -- ^ Will be executed if the stack is empty.+	-> PietMonad Int  -- ^ Returns the top stack entry otherwise.+forcePop errorAction = stackPop >>= maybe errorAction return++-- | Helper that issues a 'Verbosed' log message and prefixes+-- it with the current position.+logWithPosition :: String -> PietMonad ()+logWithPosition msg = do+	pos	<- getPosition+	logMessage Verbosed $ show pos ++ ' ' : msg+
+ sources/Language/Piet/Compiler.hs view
@@ -0,0 +1,210 @@++-- |+-- This module implements the image processing part of this library. It+-- is able to do basic image I/O and provides funcions for labelling+-- images and extracting Piet-relevant information at the same time.+module Language.Piet.Compiler+	(+	-- * I/O+	  imgFromFile+	+	-- * The \"compiler\"+	, compile+	+	-- * Labelling+	, label4, label4With+	) where++import Control.Exception+import Control.Monad+import Data.IntMap hiding (filter)+import Data.List hiding (insert)+import Data.Monoid+import Graphics.Imlib+import Language.Piet.Types++-- | Load an 'Image' holding Piet 'Colour's from a given file.+-- If the codel length is known, it should be passed as 'Just'+-- argument, otherwise, it is guessed from the file. Note that+-- \"codel length\" means the edge length of the codels and+-- not their size.+--+-- /This function is not thread safe due to imlib2!/+imgFromFile :: Maybe Int	-- ^ Codel length or 'Nothing' if unknown+	-> FilePath		-- ^ The image file location+	-> IO (Either ImlibLoadError (Image Colour))+imgFromFile codelInfo file = do+	(img, err)	<- loadImageWithErrorReturn file+	case err of+		ImlibLoadErrorNone	-> bracket+				(contextSetImage img)+				(const freeImageAndDecache)+				$ const $ do+			codelLength	<- maybe imageGuessCodelLength return codelInfo+			img'		<- imageFromContext (max 1 codelLength)+			return (Right img')+		_			-> return (Left err)++-- | Build an @'Image' 'Colour'@ from the current imlib2 context.+imageFromContext :: Int		-- ^ Codel length (not size)+	-> IO (Image Colour)	-- ^ The image data+imageFromContext codelLength = do+	width	<- (`div` codelLength) `liftM` imageGetWidth+	height	<- (`div` codelLength) `liftM` imageGetHeight+	alpha	<- imageHasAlpha++	pixels	<- mapM (\xy@(x, y) -> do+			ImlibColor a r g b <- imageQueryPixel+				(x * codelLength)+				(y * codelLength)+			return (xy, if alpha then rgba2Colour r g b a else rgb2Colour  r g b)+		) [ (x, y) | x <- [ 0 .. width-1 ], y <- [ 0 .. height-1 ] ]++	return $ imgNew width height pixels++-- | Guess the codel length from the image that is currently loaded in+-- the imlib2 buffer. The guess simply is the the gcd of the image+-- width, length and the length of all equally coloured subrows and+-- -cols.+imageGuessCodelLength :: IO Int+imageGuessCodelLength = do+	width	<- imageGetWidth+	height	<- imageGetHeight++	rows	<- mapM (\y -> mapM (\x -> imageQueryPixel x y)+		[ 0 .. width-1 ]) [ 0 .. height-1 ]+	cols	<- mapM (\x -> mapM (\y -> imageQueryPixel x y)+		[ 0 .. height-1 ]) [ 0 .. width-1 ]+	+	return $ lastUntil (==1) $ scanl gcd (gcd width height)+		$ fmap length (group rows) ++ fmap length (group cols)+	+	where++	-- Get the first item of a list that fulfills @p@ or its+	-- last element.+	lastUntil :: Ord a => (a -> Bool) -> [a] -> a+	lastUntil _ [x]    = x+	lastUntil p (x:xs) = if p x then x else lastUntil p xs+	lastUntil _ _      = error "empty list in lastUntil helper (imageGuessCodelLength)"++-- | Compile an @'Image' 'Colour'@ to a Piet 'Program'.+compile :: Image Colour -> Program+compile image_ = let+	(mask_, info_)	= label4 image_+	in+	Program+		{ image	= image_+		, mask	= mask_+		, info	= info_+		}++-- | Status of the labelling algorithm.+data LabellingStatus = LabellingStatus+	{ _currentCoords	:: (Int, Int)		-- ^ Current pixel to investigate+	, _nextKey		:: LabelKey		-- ^ Next unused 'LabelKey'+	, _mask			:: Image LabelKey	-- ^ Each pixel contains a label key+	, _infoMap		:: IntMap LabelInfo	-- ^ Mapping from 'LabelKey's to 'LabelInfo's+	, _equivalences		:: EquivalenceMap	-- ^ Holds information about label equivalences+	} deriving (Show, Eq, Ord)++-- | Label an image with 4-neighbourship and equivalence as neighbouring+-- condition, which is @'label4With' (==)@.+label4 :: Eq a => Image a -> (Image LabelKey, IntMap LabelInfo)+label4 = label4With (==)++-- | Labels an image with 4-neighbourship.+label4With :: (a -> a -> Bool)	-- ^ Decides whether two neighbouring pixels are adjacent.+	-> Image a		-- ^ The 'Image' to be labelled.+	-> (Image LabelKey, IntMap LabelInfo)+				-- ^ A mask 'Image' (containing a key for every pixel)+				-- and a mapping from these keys to 'LabelInfo'.+label4With neighbours img = let+	status	= label4With' neighbours img LabellingStatus+		{ _currentCoords	= (0, 0)+		, _nextKey		= 0+		, _mask			= imgNew (imgWidth img) (imgHeight img) []+		, _infoMap		= mempty+		, _equivalences		= mempty+		}+	img'	= fmap ((flip equivClass) (_equivalences status)) $ _mask status+	inf	= foldWithKey+		(\label labelInfo mergedMap -> let+			label'	= equivClass label $ _equivalences status+			in+			alter (maybe (Just labelInfo) (Just . (mappend labelInfo))) label' mergedMap+		) mempty+		$ _infoMap status+	in (img', inf)++-- | Labelling algorithm expressed in terms of a 'LabellingStatus', see+-- 'label4With'.+label4With' :: (a -> a -> Bool) -> Image a -> LabellingStatus -> LabellingStatus+{-# SPECIALISE+    label4With' :: (Colour -> Colour -> Bool) -> Image Colour -> LabellingStatus -> LabellingStatus+    #-}++label4With' neighbours img status = let+	xy@(x, y)	= _currentCoords status+	pixel		= imgPixel x y img++	mergeLabels	= fmap (\(x', y', _) -> imgPixel x' y' (_mask status))+		$ filter (\(_, _, e) -> neighbours pixel e)+		$ fmap (\(x', y') -> (x', y', imgPixel x' y' img))+		$ previousNeighbours (_currentCoords status)+	+	status'		= case mergeLabels of+		[]		-> let label = _nextKey status in status+			{ _nextKey	= succ label+			, _mask		= imgSetPixel x y label (_mask status)+			, _infoMap	= insert label (addPixel x y mempty) (_infoMap status)+			}+		[label]		-> status+			{ _mask		= imgSetPixel x y label (_mask status)+			, _infoMap	= adjust (addPixel x y) label (_infoMap status)+			}+		[l1, l2]	-> let+			label	= max l1 l2+			in status+				{ _mask		= imgSetPixel x y label (_mask status)+				, _infoMap	= adjust (addPixel x y) label (_infoMap status)+				, _equivalences	= equivInsert l1 l2 (_equivalences status)+				}+		_		-> error+			"too many neighbours in Language.Piet.Compiler.ImageProcessor.label4With'"+	in case nextCoords xy of+		Just xy' -> label4With' neighbours img $ status' { _currentCoords = xy' }+		Nothing  -> status'++	where+	previousNeighbours :: (Int, Int) -> [(Int, Int)]+	previousNeighbours (x, y) = filter (\(x', y') -> x' >= 0 && y' >= 0) [ (x-1, y), (x, y-1) ]++	nextCoords :: (Int, Int) -> Maybe (Int, Int)+	nextCoords (x, y)+		| x < imgWidth img - 1	= Just (x + 1, y)+		| y < imgHeight img - 1	= Just (0, y + 1)+		| otherwise		= Nothing++-- | Detects equivalence classes. Invariant: Every element is mapped to the+-- minimum of it's equivalence class.+type EquivalenceMap = IntMap LabelKey++-- | Find the equivalence class of a given element.+equivClass :: LabelKey -> EquivalenceMap -> LabelKey+equivClass e = findWithDefault e e++-- | Insert a new equivalence.+equivInsert :: LabelKey -> LabelKey -> EquivalenceMap -> EquivalenceMap+equivInsert x y mp = let+	class1		= equivClass x mp+	class2		= equivClass y mp+	classes		= [x, y, class1, class2]+	newClass	= minimum classes+	in+	if x /= y+		then fmap (\eqClass -> if or (fmap (== eqClass) classes) then newClass else eqClass)+			$ insert x newClass+			$ insert y newClass mp+		else mp+
+ sources/Language/Piet/Interpreter.hs view
@@ -0,0 +1,170 @@++-- | This module implements an interpreter for the Piet programming+-- language.+module Language.Piet.Interpreter+	(+	-- * Interpreter implementation+	  interpret+	+	-- * Helper functions+	-- ** Movement+	, interpretWhite+	, nonBlackSucc+	, succCoordinates+	-- ** Colour difference handling+	, colours2Command+	, colourDiff2Command+	) where++import Control.Monad+import Data.IntMap hiding (filter)+import Data.Maybe+import Language.Piet.Commands+import Language.Piet.PietMonad+import Language.Piet.Types++-- | Interpret a Piet 'Program'.+interpret :: Program -> PietMonad ()+interpret = interpret' Nothing++-- | Interpret a Piet 'Program'+interpret' :: Maybe (Lightness, HueColour, Int)	-- ^ Previous' block colour and size if it was a hue-block+	-> Program				-- ^ Program+	-> PietMonad ()+interpret' previous program = do+	(x, y)	<- getPosition+	case imgPixel x y (image program) of+		Hue l c	-> do+			maybe (return ())+				(\(oldL, oldC, oldS) -> colours2Command oldL oldC l c oldS)+				previous+			+			dp		<- getDP+			cc		<- getCC+			let key		= imgPixel x y (mask program)+			let label	= findWithDefault EmptyInfo key (info program)+			+			case nonBlackSucc program label dp cc of+				Just (x', y', dp', cc')	-> do+					setPosition x' y'+					setDP dp'+					setCC cc'+					interpret' (Just (l, c, labelSize label)) program+				Nothing			-> do+					terminate+		White	-> interpretWhite program+		Black	-> do+			logMessage Fatal "Entered black block, terminate"+			terminate++-- | Find a way out of the current 'White' block. 'terminate' if there+-- is no way out.+interpretWhite :: Program -> PietMonad ()+interpretWhite program = do+	(x, y)		<- getPosition+	let key		= imgPixel x y (mask program)+	let codels	= labelSize $ findWithDefault EmptyInfo key (info program)+	+	-- The Maximum steps without loop:+	--   every DP/CC combination * size of white block+	-- Is there a better way without actually tracking coordinate/DP/CC tuples?+	+	when (White == imgPixel x y (image program))+		$ interpretWhite' (8 * codels) program++-- | See 'interpretWhite'. The 'Int' determines the maximum remaining+-- moves by one codel and DP/CC changes.+interpretWhite' :: Int -> Program -> PietMonad ()+interpretWhite' limit program+	| limit <= 0	= terminate+	| otherwise	= do+		(x, y)	<- getPosition+		case imgPixel x y (image program) of+			White	-> do+				dp		<- getDP+				let (x', y')	= addCoordinates dp x y+				if isBlocked x' y' program+					then do+						cc	<- getCC+						setDP $ rotate 1 dp+						setCC $ toggle 1 cc+						interpretWhite' (limit - 1) program+					else do+						setPosition x' y'+						interpretWhite' (limit - 1) program+			_	-> interpret' Nothing program -- found a way out++-- | Find coordinates and resulting DP/CC of the successing non-black block,+-- if it exists, 'Nothing' otherwise.+nonBlackSucc :: Program		-- ^ Program+	-> LabelInfo		-- ^ Current block+	-> DirectionPointer	-- ^ DP+	-> CodelChooser		-- ^ CC+	-> Maybe (Int, Int, DirectionPointer, CodelChooser)+				-- ^ Next coordinates, DP and CC (if available)+nonBlackSucc program label dp cc = let+	directions	= fmap (\(r, t) -> (rotate r dp, toggle t cc))+		$ zip [ 0, 0, 1, 1, 2, 2, 3, 3 ] (0 : cycle [ 1, 1, 0, 0 ])+	in+	fmap (\((x, y), (d, c)) -> (x, y, d, c)) $ listToMaybe+		$ filter (\((x, y), _) -> not (isBlocked x y program))+		$ zip (fmap (uncurry (succCoordinates label)) directions) directions++-- | Given a label, a 'DirectionPointer' and a 'CodelChooser', this+-- function finds the coordinates of the next block to enter. These+-- coordinates are not guaranteed to be valid, they might be out of+-- range or point to a 'Black' or 'White' block.+succCoordinates :: LabelInfo	-- ^ Current label+	-> DirectionPointer	-- ^ DP+	-> CodelChooser		-- ^ CC+	-> (Int, Int)		-- ^ Where to enter the next block+succCoordinates label dp cc = let+	(getX, getY) = case (dp, cc) of+		(DPRight, CCLeft)  -> (borderCoord . labelRight, borderMin . labelRight)+		(DPRight, CCRight) -> (borderCoord . labelRight, borderMax . labelRight)+		(DPDown,  CCLeft)  -> (borderMax . labelBottom,  borderCoord . labelBottom)+		(DPDown,  CCRight) -> (borderMin . labelBottom,  borderCoord . labelBottom)+		(DPLeft,  CCLeft)  -> (borderCoord . labelLeft,  borderMax . labelLeft)+		(DPLeft,  CCRight) -> (borderCoord . labelLeft,  borderMin . labelLeft)+		(DPUp,    CCLeft)  -> (borderMin . labelTop,     borderCoord . labelTop)+		(DPUp,    CCRight) -> (borderMax . labelTop,     borderCoord . labelTop)+	in+	addCoordinates dp (getX label) (getY label)++-- | Piet's commands are issued by a colour change, see+-- <http://www.dangermouse.net/esoteric/piet.html>. This function+-- takes two neighbouring colours and returns the resulting Piet+-- command, which is a function consuming (or more likely,+-- ignoring) an 'Int' (the size of the colour block that is being+-- left) and returning a @'PietMonad' ()@.+colours2Command :: Lightness	-- ^ 'Lightness' of the \"from\"-block+	-> HueColour		-- ^ 'HueColour' of the \"from\"-block+	-> Lightness		-- ^ 'Lightness' of the \"to\"-block+	-> HueColour		-- ^ 'HueColour' of the \"to\"-block+	-> Int			-- ^ The size of the \"from\"-block+	-> PietMonad ()		-- ^ Resulting Piet operation+colours2Command fromLight fromColour toLight toColour = colourDiff2Command+	(lightnessChange fromLight toLight) (hueChange fromColour toColour)++-- | Converts a colour difference calculated by 'Language.Piet.Types.colourChange' and+-- 'lightnessChange' to a @'PietMonad' ()@, compare 'colours2Command'.+colourDiff2Command :: Lightness -> HueColour -> Int -> PietMonad ()+colourDiff2Command Light  Red     _ = return ()+colourDiff2Command Normal Red     n = piet_push n+colourDiff2Command Dark   Red     _ = piet_pop+colourDiff2Command Light  Yellow  _ = piet_add+colourDiff2Command Normal Yellow  _ = piet_subtract+colourDiff2Command Dark   Yellow  _ = piet_multiply+colourDiff2Command Light  Green   _ = piet_divide+colourDiff2Command Normal Green   _ = piet_mod+colourDiff2Command Dark   Green   _ = piet_not+colourDiff2Command Light  Cyan    _ = piet_greater+colourDiff2Command Normal Cyan    _ = piet_pointer+colourDiff2Command Dark   Cyan    _ = piet_switch+colourDiff2Command Light  Blue    _ = piet_duplicate+colourDiff2Command Normal Blue    _ = piet_roll+colourDiff2Command Dark   Blue    _ = piet_in_number+colourDiff2Command Light  Magenta _ = piet_in_char+colourDiff2Command Normal Magenta _ = piet_out_number+colourDiff2Command Dark   Magenta _ = piet_out_char+
+ sources/Language/Piet/PietMonad.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE MultiParamTypeClasses #-}++-- | A module implementing the Piet interpreter as a monad. The monad+-- encapsulates the interpreter's status, i. e. the side-effects of+-- Piet programs.+module Language.Piet.PietMonad+	(+	-- * The Piet interpreter monad+	  PietMonad+	, InterpreterStatus+	, LogLevel(..)+	+	-- * Status access+	-- ** Direction Pointer, Codel Chooser and position+	, getDP, setDP+	, getCC, setCC+	, getPosition, setPosition+	-- ** Stack primitives+	, stackPush, stackPop, stackRoll+	+	-- * I/O+	, printNumber, printChar+	, readNumber, readChar+	, logMessage+	+	-- * Termination+	, terminate+	+	-- * Execution+	, runPietMonad+	) where++import Control.Concurrent+import Control.Monad.Error ()+import Control.Monad.State+import Data.RollStack+import Language.Piet.Types++-- | The status of a Piet interpreter.+data InterpreterStatus = InterpreterStatus+	{ dp		:: DirectionPointer	-- ^ Direction Pointer+	, cc		:: CodelChooser		-- ^ Codel Chooser+	, position	:: (Int, Int)		-- ^ Position+	, stack		:: RollStack Int	-- ^ Stack+	}++-- | A request a Piet interpreter may send to it's environment.+data PietRequest+	= Read  PietType	-- ^ The interpreter wants to read from STDIN.+	| Print PietType Int	-- ^ The interpreter wants to print something to STDOUT.+	| Log LogLevel String	-- ^ A log message has been issued.+	| Terminate		-- ^ The Program has terminated.+	deriving (Show, Eq, Ord)++-- | Describes the importance of a log message.+data LogLevel+	= Verbosed	-- ^ Rather verbosed output.+	| Info		-- ^ Usual log level.+	| Error		-- ^ A recoverable error has occured.+	| Fatal		-- ^ A fatal error has occured.+	deriving (Eq, Ord)++instance Show LogLevel where+	show Verbosed	= "VERBOSED"+	show Info	= "INFO    "+	show Error	= "ERROR   "+	show Fatal	= "FATAL   "++-- | A monad encapsulating the status of a Piet interpreter.+newtype PietMonad a = PietMonad (InterpreterStatus+	-> Chan PietRequest+	-> Chan Int+	-> IO (Either String (a, InterpreterStatus)))++instance Monad PietMonad where+	return x = PietMonad (\status _ _ -> return (return (x, status)))+	+	(PietMonad m01) >>= f = PietMonad (\status0 requestChan inputChan -> do+			either1	<- m01 status0 requestChan inputChan+			case either1 of+				Left msg		-> return (fail msg)+				Right (x1, status1)	-> do+					let (PietMonad m12) = f x1+					m12 status1 requestChan inputChan+		)+	+	fail msg = do+		logMessage Fatal msg+		PietMonad (\_ _ _ -> return (fail msg))++instance MonadState InterpreterStatus PietMonad where+	get        = PietMonad $ \status _ _ -> return (return (status, status))+	put status = PietMonad $ \_      _ _ -> return (return ((),     status))++-- | Returns the current Direction Pointer.+getDP :: PietMonad DirectionPointer+getDP = gets dp++-- | Sets the Direction Pointer.+setDP :: DirectionPointer -> PietMonad ()+setDP newDP = modify (\status -> status { dp = newDP })++-- | Returns the current Codel Chooser.+getCC :: PietMonad CodelChooser+getCC = gets cc++-- | Sets the current Codel Chooser.+setCC :: CodelChooser -> PietMonad ()+setCC newCC = modify (\status -> status { cc = newCC })++-- | Returns the current position.+getPosition :: PietMonad (Int, Int)+getPosition = gets position++-- | Sets the current position.+setPosition :: Int -> Int -> PietMonad ()+setPosition x y = modify (\status -> status { position = (x, y) })++-- | Pushes a given 'Int' value on the stack.+stackPush :: Int -> PietMonad ()+stackPush n = modify (\status -> status { stack = push n (stack status) })++-- | Pops the top value from the stack. If the stack was empty,+-- 'Nothing' is returned, 'Just' the top value otherise.+stackPop :: PietMonad (Maybe Int)+stackPop = do+	response <- gets (pop . stack)+	case response of+		Nothing      -> return Nothing+		Just (x, xs) -> do+			modify (\status -> status { stack = xs })+			return (Just x)++-- | Performs the 'roll' operation on the stack.+stackRoll :: Int	-- ^ Roll number+	-> Int		-- ^ Depth+	-> PietMonad ()+stackRoll rolls depth = modify (\status -> status { stack = roll rolls depth (stack status) })++-- | Reads the given 'PietType' from STDIN.+readType :: PietType -> PietMonad Int+readType pType = PietMonad $ \status requestChan inputChan -> do+	writeChan requestChan (Read pType)+	response <- readChan inputChan+	return $ return (response, status)++-- | Reads a number from STDIN.+readNumber :: PietMonad  Int+readNumber = readType PietNumber++-- | Reads a character from STDIN. Note that it is returned as an 'Int'.+readChar :: PietMonad Int+readChar = readType PietChar++-- | Issue log message with given priority.+logMessage :: LogLevel -> String -> PietMonad ()+logMessage level msg = PietMonad $ \status requestChan _ -> do+	writeChan requestChan (Log level msg)+	return $ return ((), status)++-- | Prints a representation of a given 'PietType' to STDOUT.+printType :: PietType -> Int -> PietMonad ()+printType pType n = PietMonad $ \status requestChan _ -> do+	writeChan requestChan (Print pType n)+	return $ return ((), status)++-- | Prints a number to STDOUT.+printNumber :: Int -> PietMonad ()+printNumber = printType PietNumber++-- | Converts a given number to a character and prints it to STDOUT.+printChar :: Int -> PietMonad ()+printChar = printType PietChar++-- | Quit a program. Any command following this one will be ignored.+terminate :: PietMonad ()+terminate = PietMonad $ \status requestChan _ -> do+	writeChan requestChan Terminate+	return $ return ((), status)++-- | Executes a program represented by a 'PietMonad'. I/O operations+-- (reading and writing numbers or characters) is delegated to+-- callback functions.+runPietMonad :: (PietType -> IO Int)		-- ^ Callback to read from STDIN+	-> (PietType -> Int -> IO ())		-- ^ Print callback+	-> (LogLevel -> String -> IO ())	-- ^ Logging callback+	-> PietMonad a				-- ^ The program to be executed+	-> IO (Either String a)			-- ^ Result of the 'PietMonad' or an error message+runPietMonad readCallback printCallback logCallback program = do+	requestChannel	<- newChan+	responseChannel	<- newChan+	lock		<- newEmptyMVar++	-- Fork the actual monadic calculation.++	forkIO $ do+		let PietMonad piet = do+			x <- program++			-- This guarantees, that the service routine (see+			-- below) terminates iff the Piet program terminates,+			-- no matter how broken the program text is+			terminate++			return x++		x <- piet InterpreterStatus+				{ dp		= DPRight+				, cc		= CCLeft+				, position	= (0, 0)+				, stack		= empty+				}+			requestChannel+			responseChannel+		+		putMVar lock x+	+	-- Run the IO part in the current thread. Thus the caller does+	-- not have to worry about thread-safe callbacks as all the IO+	-- stays in the same thread, which is the invoking thread.++	let serviceRoutine = do+		request <- readChan requestChannel+		case request of+			Read pType	-> do+				n <- readCallback pType+				writeChan responseChannel n+				serviceRoutine+			Print pType n	-> do+				printCallback pType n+				serviceRoutine+			Log level msg	-> do+				logCallback level msg+				serviceRoutine+			Terminate	-> return ()++	serviceRoutine+	+	-- Block until the monadic calculation is completed and+	-- return its result.+	+	(liftM fst) `liftM` takeMVar lock +
+ sources/Language/Piet/Types.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE CPP #-}++-- | A module providing a couple of Piet-specific types+-- and simple associated functions needed throughout the library.+module Language.Piet.Types+	(+	-- * Piet Interpreter+	-- ** Direction Pointer and Codel Chooser+	  DirectionPointer(..), addCoordinates, rotate+	, CodelChooser(..), toggle+	-- ** Piet's type system+	, PietType(..)+	-- ** Runtime program representation+	, Program(..), isBlocked++	-- * Colour system+	, Colour(..), rgba2Colour, rgb2Colour+	, HueColour(..), hueChange+	, Lightness(..), lightnessChange++	-- * Images+	, Image, imgWidth, imgHeight, imgInRange, imgNew, imgPixel, imgSetPixel+	, LabelKey, LabelInfo(..), labelSize, addPixel, LabelBorder(..)+	) where++import Data.Array.IArray+import Data.IntMap hiding ((!))+import Data.Monoid+import Data.Ord++-- | The Direction Pointer (DP).+data DirectionPointer+	= DPRight+	| DPDown+	| DPLeft+	| DPUp+	deriving (Show, Read, Eq, Ord, Enum)++-- | Move coordinates by one in the direction of the 'DirectionPointer'.+addCoordinates :: DirectionPointer	-- ^ Direction to move to+	-> Int				-- ^ x-coordinate+	-> Int				-- ^ y-coordinate+	-> (Int, Int)			-- ^ New x-/y-coordinates+addCoordinates DPRight	x y = (x + 1, y)+addCoordinates DPDown	x y = (x, y + 1)+addCoordinates DPLeft	x y = (x - 1, y)+addCoordinates DPUp	x y = (x, y - 1)++-- | Rotate a 'DirectionPointer' clockwise (counter clockwise if the 'Int' is+-- negative) a given number of times. +rotate :: Int -> DirectionPointer -> DirectionPointer+rotate n dp = let n' = (n + fromEnum dp) `rem` 4+	in toEnum $ if n' < 0 then n' + 4 else n'++-- | The Codel Chooser (CC).+data CodelChooser+	= CCLeft+	| CCRight+	deriving (Show, Read, Eq, Ord, Enum)++-- | Toggle a 'CodelChooser' a given number of times.+toggle :: Int -> CodelChooser -> CodelChooser+toggle n cc = let n' = (n + fromEnum cc) `rem` 2+	in toEnum $ if n' < 0 then n' + 2 else n'++-- | Piet types. Relevant to distinguish in-/output strategies.+data PietType+	= PietNumber+	| PietChar+	deriving (Show, Read, Eq, Ord)++-- | Runtime program representation.+data Program = Program+	{ image	:: Image Colour		-- ^ Original image+	, mask	:: Image LabelKey	-- ^ Labelled image+	, info	:: IntMap LabelInfo	-- ^ Information about the labels+	}++-- | Returns if a given codel in a program is blocked in the Piet+-- sense (which is the case when it is out of the image's range or+-- 'Black').+isBlocked :: Int -> Int -> Program -> Bool+isBlocked x y program = (not (imgInRange x y (image program)))+	|| (Black == imgPixel x y (image program))++-- | The colours that make up a Piet program text.+data Colour+	= Black+	| White+	| Hue {-# UNPACK #-} !Lightness {-# UNPACK #-} !HueColour+	deriving (Show, Read, Eq, Ord)++-- | Converts red\/green\/blue\/alpha values to a 'Colour'. The alpha channel+-- is ignored for now, but may be used in future implementations or+-- dialects, so please use this function instead of 'rgb2Colour' whenever+-- an alpha channel is available.+rgba2Colour :: Num w => w	-- ^ red+	-> w			-- ^ green+	-> w			-- ^ blue+	-> w			-- ^ alpha+	-> Colour+rgba2Colour r g b _ = rgb2Colour r g b++-- | Converts red\/green\/blue values to a 'Colour'. If the supplied+-- arguments do not form a proper Piet 'Colour', 'White' is returned.+rgb2Colour :: Num w => w	-- ^ red+	-> w		-- ^ green+	-> w		-- ^ blue+	-> Colour+rgb2Colour 0x00 0x00 0x00 = Black+rgb2Colour 0xff 0xff 0xff = White+rgb2Colour 0xff 0xc0 0xc0 = Hue Light  Red+rgb2Colour 0xff 0x00 0x00 = Hue Normal Red+rgb2Colour 0xc0 0x00 0x00 = Hue Dark   Red+rgb2Colour 0xff 0xff 0xc0 = Hue Light  Yellow+rgb2Colour 0xff 0xff 0x00 = Hue Normal Yellow+rgb2Colour 0xc0 0xc0 0x00 = Hue Dark   Yellow+rgb2Colour 0xc0 0xff 0xc0 = Hue Light  Green+rgb2Colour 0x00 0xff 0x00 = Hue Normal Green+rgb2Colour 0x00 0xc0 0x00 = Hue Dark   Green+rgb2Colour 0xc0 0xff 0xff = Hue Light  Cyan+rgb2Colour 0x00 0xff 0xff = Hue Normal Cyan+rgb2Colour 0x00 0xc0 0xc0 = Hue Dark   Cyan+rgb2Colour 0xc0 0xc0 0xff = Hue Light  Blue+rgb2Colour 0x00 0x00 0xff = Hue Normal Blue+rgb2Colour 0x00 0x00 0xc0 = Hue Dark   Blue+rgb2Colour 0xff 0xc0 0xff = Hue Light  Magenta+rgb2Colour 0xff 0x00 0xff = Hue Normal Magenta+rgb2Colour 0xc0 0x00 0xc0 = Hue Dark   Magenta+rgb2Colour _    _    _    = White++-- | Piet colours in the hue cycle.+data HueColour+	= Red+	| Yellow+	| Green+	| Cyan+	| Blue+	| Magenta+	deriving (Show, Read, Eq, Ord, Enum)++-- | Hue difference between two 'HueColour's. 'Red' means no change,+-- 'Yellow' one step and so forth.+hueChange :: HueColour -> HueColour -> HueColour+hueChange c1 c2 = toEnum $ (fromEnum c2 - fromEnum c1) `mod` 6++-- | Hue lightness values supported by Piet.+data Lightness+	= Light+	| Normal+	| Dark+	deriving (Show, Read, Eq, Ord, Enum)++-- | Lightness difference between Piet lightness values. 'Light'+-- represents no change, 'Normal' one step darker and 'Dark'+-- two steps darker.+lightnessChange :: Lightness -> Lightness -> Lightness+lightnessChange l1 l2 = toEnum $ (fromEnum l2 - fromEnum l1) `mod` 3++-- | An image. Its coordinates will be @(0, 0) .. (width-1, height-1)@+data Image a = Image+	{ imgWidth	:: {-# UNPACK #-} !Int		-- ^ Width of an 'Image' in pixels.+	, imgHeight	:: {-# UNPACK #-} !Int		-- ^ Height of an 'Image' in pixels.+	, imgPixels	:: !(Array (Int, Int) a)	-- ^ An 'Array' storing the pixels of an 'Image'.+	}+#ifndef __HADDOCK__+	deriving (Show, Eq, Ord)+#else+instance (Show a) => Show (Image a)+instance (Eq a) => Eq (Image a)+instance (Ord a) => Ord (Image a)+#endif++instance Functor Image where+	fmap f img = img { imgPixels = amap f (imgPixels img) }++-- | Build a new image.+imgNew :: Int			-- ^ Width+	-> Int			-- ^ Height+	-> [((Int, Int), a)]	-- ^ Coordinate-value list+	-> Image a+imgNew width height entries = Image+	{ imgWidth	= width+	, imgHeight	= height+	, imgPixels	= array ((0, 0), (width - 1, height - 1)) entries+	}++-- | Find out, if the given coordinates are within the 'Image'+-- borders (which are @ (0, 0) .. (width-1, height-1)@).+imgInRange :: Int	-- ^ x-coordinate+	-> Int		-- ^ y-coordinate+	-> Image a	-- ^ An 'Image'+	-> Bool		-- ^ If @(x, y)@ is within the 'Image'+imgInRange x y img = 0 <= x && x < imgWidth img && 0 <= y && y < imgHeight img++-- | Access a pixel at given x/y-coordinates.+imgPixel :: Int	-- ^ x-coordinate+	-> Int	-- ^ y-coordinate+	-> Image a -> a+imgPixel x y img = (imgPixels img) ! (x, y)++-- | Set a pixel at given x/y-coordinates.+imgSetPixel :: Int -> Int -> a -> Image a -> Image a+imgSetPixel x y pixel img = img { imgPixels = (imgPixels img) // [((x, y), pixel)] }++-- | We'll just use 'Int's to identifiy labels.+type LabelKey = Int++-- | Stores compiler-relevant information about a label. This type+-- implements an instance of 'Monoid' to merge labels.+data LabelInfo+	= EmptyInfo	-- ^ The empty label+	| LabelInfo+		{ _labelSize	:: {-# UNPACK #-} !Int		-- ^ Number of pixels+		, labelTop	:: {-# UNPACK #-} !LabelBorder	-- ^ Top border+		, labelLeft	:: {-# UNPACK #-} !LabelBorder	-- ^ left border+		, labelBottom	:: {-# UNPACK #-} !LabelBorder	-- ^ Bottom border+		, labelRight	:: {-# UNPACK #-} !LabelBorder	-- ^ Right border+		}	-- ^ Label with a size and four borders+	deriving (Show, Eq, Ord)++-- | Number of pixels in a label. This function is defined for all+-- constructors of 'LabelInfo' so, in contrast to '_labelSize', it+-- won't fail on 'EmptyInfo' .+labelSize :: LabelInfo -> Int+labelSize EmptyInfo		= 0+labelSize _info@(LabelInfo { })	= _labelSize _info++instance Monoid LabelInfo where+	mempty = EmptyInfo++	mappend EmptyInfo i = i+	mappend i EmptyInfo = i+	mappend i1 i2 = LabelInfo+		{ _labelSize	= labelSize i1 + labelSize i2+		, labelTop	= mergeMin (labelTop i1) (labelTop i2)+		, labelLeft	= mergeMin (labelLeft i1) (labelLeft i2)+		, labelBottom	= mergeMax (labelBottom i1) (labelBottom i2)+		, labelRight	= mergeMax (labelRight i1) (labelRight i2)+		}++-- | Holds information of a label (coloured area) relevant for the Piet+-- language, i. e. information about where the program flow will be+-- directed regarding a Direction Pointer.+--+-- Holds a border position (e. g. an x-coordinate) and the minimum+-- or maximum associated \"other\" coordinates (e. g. y-coordinates).+data LabelBorder = LabelBorder+	{ borderCoord	:: {-# UNPACK #-} !Int	-- ^ Where the border is located+	, borderMin	:: {-# UNPACK #-} !Int	-- ^ Minimum \"other\" coordinate of the border+	, borderMax	:: {-# UNPACK #-} !Int	-- ^ Maximum \"other\" coordinate of the border+	} deriving (Show, Eq, Ord)++-- | Merge two 'LabelBorder's holding a /maximum/ coordinate.+mergeMin :: LabelBorder -> LabelBorder -> LabelBorder+mergeMin = merge (comparing borderCoord)++-- | Merge two 'LabelBorder's holding a /minimum/ coordinate.+mergeMax :: LabelBorder -> LabelBorder -> LabelBorder+mergeMax = merge (comparing (negate . borderCoord))++-- | General merge, see 'mergeMin' and 'mergeMax'+merge :: (LabelBorder -> LabelBorder -> Ordering) -> LabelBorder -> LabelBorder -> LabelBorder+merge comp b1 b2 = case comp b1 b2 of+	EQ -> b1+		{ borderMin	= min (borderMin b1) (borderMin b2)+		, borderMax	= max (borderMax b1) (borderMax b2)+		}+	LT -> b1+	GT -> b2++-- | Add a pixel to a 'LabelInfo'.+addPixel :: Int -> Int -> LabelInfo -> LabelInfo+addPixel x y EmptyInfo = LabelInfo+	{ _labelSize	= 1+	, labelTop	= LabelBorder y x x+	, labelLeft	= LabelBorder x y y+	, labelBottom	= LabelBorder y x x+	, labelRight	= LabelBorder x y y+	}+addPixel x y nonEmpty = nonEmpty+	{ _labelSize	= 1 + labelSize nonEmpty+	, labelTop	= mergeMin (labelTop nonEmpty) (LabelBorder y x x)+	, labelLeft	= mergeMin (labelLeft nonEmpty) (LabelBorder x y y)+	, labelBottom	= mergeMax (labelBottom nonEmpty) (LabelBorder y x x)+	, labelRight	= mergeMax (labelRight nonEmpty) (LabelBorder x y y)+	}+
+ sources/Main.hs view
@@ -0,0 +1,158 @@+module Main+	( main+	) where++import Control.Monad.Error+import Data.List+import Data.Version (showVersion)+import Language.Piet+import qualified Paths_piet as Paths (version)+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO++-- | Main function.+main :: IO ()+main = do+	args	<- getArgs+	case parseArguments args of+		Left err	-> do+			putStrLn err+			printUsage+			exitWith $ ExitFailure 1+		Right opts	-> do+			actualMain opts+			exitWith ExitSuccess++-- | Main function without the option-parsing part.+actualMain :: Options -> IO ()+actualMain Help		= printUsage+actualMain Version	= printVersion+actualMain opts@Run { }	= case program opts of+	Nothing		-> do+		putStrLn "No program given"+		printUsage+	Just file	-> do+		loadresult	<- imgFromFile (codelSize opts) file+		case loadresult of+			Left err	-> do+				putStr "Unable to load image, imlib2 issued this error: "+				print err+				exitWith $ ExitFailure 2+			Right img	-> do+				let prog	= compile img++				hSetBuffering stdin  NoBuffering+				hSetBuffering stdout NoBuffering+				hFlush stdout+				+				response	<- runPietMonad readCallback+					printCallback+					(logCallback (verbosity opts))+					(interpret prog)++				case response of+					Left err	-> do+						putStrLn err+						exitWith $ ExitFailure 3+					Right _		-> return ()++-- | Print program usage to STDOUT.+printUsage :: IO ()+printUsage = getProgName >>= putStrLn . ((flip usageInfo) options) . versionise++-- | Print program name and version to STDOUT.+printVersion :: IO ()+printVersion = getProgName >>= putStrLn . versionise++-- | Append /-version/ to a program name, where /version/ is+-- the actual version of this cabal package.+versionise :: String -> String+versionise = (++ "-" ++ showVersion Paths.version)++-- | Callback function to read a 'PietNumber' (i. e. a parsed line) or a+-- 'PietChar' from STDIN.+readCallback :: PietType -> IO Int+readCallback PietNumber = getLine >>= maybe (readCallback PietNumber) return . readMaybe+readCallback PietChar   = fromEnum `liftM` getChar++-- | Callback to print a 'PietType'.+printCallback :: PietType -> Int -> IO ()+printCallback PietNumber = putStr . show+printCallback PietChar   = putChar . toEnum++-- | Callback to manage log messages.+logCallback :: LogLevel -> LogLevel -> String -> IO ()+logCallback threshold level msg = when (level >= threshold) $ do+	let prefixedMsg = show level ++ ' ' : msg+	putStrLn prefixedMsg++-- | Build 'Options' and - if specified - a program file to execute+-- from a list of 'String's (the arguments).+parseArguments :: [String] -> Either String Options+parseArguments args = do+	let (optCBs, remaining, errors)	= getOpt Permute options args++	unless (null errors) $ fail (unlines errors)+	opts	<- foldM (flip ($)) defaultOptions optCBs+	+	case remaining of+		[]	-> return opts+		[prog]	-> case opts of+			Run { }	-> return (opts { program = Just prog } )+			_	-> return opts+		_	-> fail "please specify exactly one program"++-- | Type bundling command line options.+data Options+	= Help		-- ^ Don't run anything, just print a help text+	| Version	-- ^ Don't run anything, print program name and version+	| Run+		{ program	:: Maybe FilePath	-- ^ Program to run+		, codelSize	:: Maybe Int		-- ^ Explicitly specify codel size+		, verbosity	:: LogLevel+		}	-- ^ Run a given program+	deriving (Show, Eq, Ord)++-- | The default 'Options'.+defaultOptions :: Options+defaultOptions = Run+	{ program	= Nothing+	, codelSize	= Nothing+	, verbosity	= Info+	}++-- | List of command line options accepted by this interpreter.+options :: [OptDescr (Options -> (Either String Options))]+options =+	[ Option ['h', '?'] ["help"]+		(NoArg (const (Right Help)))+		"print usage information and exit"+	, Option [] ["version"]+		(NoArg (const (Right Version)))+		"print version information and exit"+	, Option ['c'] ["codels"]+		(ReqArg (\arg opt -> maybe+			(Left "codel size must be a number")+			(\x -> case opt of+				Run { }	-> Right (opt { codelSize = Just x })+				_	-> Right opt)+			(readMaybe arg)) "LENGTH")+		"codel length (the codel size will be LENGTH^2)"+	, Option ['v'] ["verbose"]+		(NoArg (\opt -> case opt of+			Run { }	-> Right (opt { verbosity = Verbosed } )+			_	-> Right opt))+		"give verbosed output"+	, Option ['q'] ["quiet"]+		(NoArg (\opt -> case opt of+			Run { }	-> Right (opt { verbosity = Error } )+			_	-> Right opt))+		"suppress all but error messages"+	]++-- | Like 'read', but returns 'Nothing' instead of raising an 'error' on failure.+readMaybe :: Read a => String -> Maybe a+readMaybe str = find ((== "") . snd) (reads str) >>= return . fst+