module Data.ChainCodes where
import Codec.Picture
import Codec.Picture.Types
import Data.Function
import Control.Monad
import Data.Word
import Data.Map hiding (map)
type Colour = PixelRGB8
type PixelPos = (Int, Int, Int)
type Position = (Int, Int)
type ChainCode = [PixelPos]
readRGB8 ∷ FilePath → IO (Either String (Image PixelRGB8))
readRGB8 = readImage >=> return . \case
Right (ImageRGB8 i) → Right i
Right _ → Left "Unsuported image format. RGB8 images only please."
Left err → Left err
findSpot ∷ Image PixelRGB8 → Colour → Maybe Position
findSpot img@(Image w h d) c
| w <= 0 || h <= 0 = Nothing
| otherwise =
go [ (wi, hi) | wi ← [0 .. w 1], hi ← [0 .. h 1] ]
where
go ∷ [(Int, Int)] → Maybe Position
go [] = Nothing
go (x:xs) = if uncurry (pixelAt img) x == c
then Just x
else go xs
chainCode ∷ Image PixelRGB8 → Colour → Maybe ChainCode
chainCode img@(Image w h d) c = findSpot img c >>= \pos →
let ppos = (fst pos, snd pos, 0)
in Just $ go [0 ..] (fromList [(0, ppos)]) ppos
where
ns ∷ Map Int (Int, Int)
ns = fromList $ zip [0 ..]
[ (0, 1), (1, 1), (1, 0), (1, 1)
, (0, 1), (1, 1), (1, 0), (1, 1)]
go ∷ [Int] → Map Int PixelPos → PixelPos → ChainCode
go (count:counts) positions p@(sx, sy, _) =
map snd . toList $ loop (count:counts) positions
where
loop ∷ [Int] → Map Int PixelPos → Map Int PixelPos
loop (count:counts) positions
| count == 0 || not (eqV positions count) =
let current@(fx, fy, fd) = positions ! count
inBounds (x, y) = x >= 0 && y >= 0 && x < w && y < h
places = [ (mx, my, m) | i ← [5 + fd .. fd + 13]
, let m = i `mod` 8
(nx, ny) = ns ! m
o@(mx, my) = (fx + nx, fy + ny)
, inBounds o
, uncurry (pixelAt img) o == c
]
in loop counts $ case places of
[] → positions
x:_ → insert (count + 1) x positions
| otherwise = delete 0 positions
eqV ∷ Map Int PixelPos → Int → Bool
eqV p i = let (x, y, _) = p ! i
in (x, y) == (sx, sy)