module Language.Piet.Compiler
(
imgFromFile
, compile
, 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
imgFromFile :: Maybe Int
-> FilePath
-> 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)
imageFromContext :: Int
-> IO (Image Colour)
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 .. width1 ], y <- [ 0 .. height1 ] ]
return $ imgNew width height pixels
imageGuessCodelLength :: IO Int
imageGuessCodelLength = do
width <- imageGetWidth
height <- imageGetHeight
rows <- mapM (\y -> mapM (\x -> imageQueryPixel x y)
[ 0 .. width1 ]) [ 0 .. height1 ]
cols <- mapM (\x -> mapM (\y -> imageQueryPixel x y)
[ 0 .. height1 ]) [ 0 .. width1 ]
return $ lastUntil (==1) $ scanl gcd (gcd width height)
$ fmap length (group rows) ++ fmap length (group cols)
where
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 :: Image Colour -> Program
compile image_ = let
(mask_, info_) = label4 image_
in
Program
{ image = image_
, mask = mask_
, info = info_
}
data LabellingStatus = LabellingStatus
{ _currentCoords :: (Int, Int)
, _nextKey :: LabelKey
, _mask :: Image LabelKey
, _infoMap :: IntMap LabelInfo
, _equivalences :: EquivalenceMap
} deriving (Show, Eq, Ord)
label4 :: Eq a => Image a -> (Image LabelKey, IntMap LabelInfo)
label4 = label4With (==)
label4With :: (a -> a -> Bool)
-> Image a
-> (Image LabelKey, IntMap 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)
label4With' :: (a -> a -> Bool) -> Image a -> 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) [ (x1, y), (x, y1) ]
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
type EquivalenceMap = IntMap LabelKey
equivClass :: LabelKey -> EquivalenceMap -> LabelKey
equivClass e = findWithDefault e e
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