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 [ (hi, wi) | wi ← [0 .. w 1], hi ← [0 .. h 1] ]
where
go ∷ [(Int, Int)] → Maybe Position
go [] = Nothing
go (x:xs) = let ac = average c
ap = average $ uncurry (pixelAt img) x
in if 1 < abs (ac ap) then Just x else go xs
intensity ∷ PixelRGB8 → Double
intensity p = fromIntegral (average p) / 255
average ∷ PixelRGB8 → Integer
average (PixelRGB8 r g b) = toInteger $ r `div` 3 + g `div` 3 + b `div` 3
chainCode ∷ Image PixelRGB8 → Colour → Maybe ChainCode
chainCode i c = chainCodeWith i c (/= c)
chainCodeWith ∷ Image PixelRGB8 → Colour → (Colour → Bool) → Maybe ChainCode
chainCodeWith img@(Image w h d) c f = findSpot img c >>= \pos →
let ppos = (fst pos, snd pos, 0)
in Just $ go [1 ..] (fromList [(0, (1, 1, 0)), (1, 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 cs positions p@(sx, sy, _) =
map snd . toList $ loop cs positions
where
loop ∷ [Int] → Map Int PixelPos → Map Int PixelPos
loop (count:counts) positions
| count == 1 || 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 ← [fd + 5 .. fd + 13]
, let m = i `mod` 8
(nx, ny) = ns ! m
o@(mx, my) = (fx + ny, fy + nx)
, inBounds o
, f $ uncurry (pixelAt img) o
]
in loop counts $ case places of
[] → positions
x:_ → insert (count + 1) x positions
| otherwise = delete 1 (delete 0 positions)
eqV ∷ Map Int PixelPos → Int → Bool
eqV p i = let (x, y, _) = p ! i
in (x, y) == (sx, sy)