{-# LANGUAGE BangPatterns
           , FlexibleContexts
           , CPP
           , GeneralizedNewtypeDeriving
           , ScopedTypeVariables
           , FlexibleInstances
           , MultiWayIf #-}
-- | Contour tracing of binary images (zero ~ background, nonzero ~ object).
--
-- Terminology:
--
-- A binary image is an image in which the pixel is boolean (represented
-- here  using 'Grey' and zero or non-zero pixel values).
--
-- All zero-value pixels are part of the "background".
--
-- An object is an connected group of non-zero pixels.
--
-- A 'Contour' is a trace of an objects' outer or inner edges.  Some
-- objects are solid, having no inner contours (consider a filled circle,
-- or letters such as 'h', 's', 'k' and 'l').  Other objects have "holes", also known as inner
-- contours.  The letters 'a' and 'e' have one hole while the letter 'B' has two.
--
-- After obtaining a 'Contours' structure (via the 'contours' function) the
-- raw traces ('Contour' type) can be used for further processing or the contours can be
-- filtered by aspects of interest and selectively re-drawn ('drawContour') , perhaps used to
-- mask the original image.
--
-- About Holes:
--
-- In cases where there is only one hole it is uniquely recorded in the
-- 'Contours' structure.  Objects with more than one hole record all inner
-- contours in one vector making them hard to extract separately - this is
-- due to the main data structure not being rich enough to record the holes
-- separately. As of writing, this is not seen as an issue because the
-- desired operation, drawContour, can still be achieved.  Changing this
-- behavior should be trivial if desired.
--
-- Use:
--
-- To use this library it is advised that you preprocess the image,
-- including thresholding (ex: 'otsu' on a grey scale image), to obtain a binary image then call:
--
-- @
-- cs = contours img
-- @
--
-- The 'Contours' structure can be accessed directly if desired.  It
-- includes an 'Map' of all contours (numbered counting from 1) and
-- a vector of the contour sizes (indexed by contour number, zero index is
-- unused/zero).
--
-- The algorithm implemented in this module follows the design laid out in
-- 'A Linear-Time Component-Labeling Algorithm Using Contour Tracing Technique' [1].
--
-- [1] http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.95.6330&rep=rep1&type=pdf
module Vision.Image.Contour (
    -- * Main Interface
      Contours(..), ContourId, OneContour, ContourValue, Contour(..), RowContour
    , contours
    -- * ADT style interface (hides 'Contours' internals)
    , allContourIds, lookupContour, rowContour, contourSize, contourPerimeter
    -- * Reconstructing Image Elements
    , ContourDrawStyle(..), drawContour, drawContours
    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif

import Control.Monad (when)
import Control.Monad.ST
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.Maybe (catMaybes)
import Data.List (groupBy,sort)
import Data.Function (on)
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Unboxed.Mutable as VM
import Foreign.Storable

import Vision.Image.Mutable (MutableManifest, new', write)
import qualified Vision.Image.Mutable as Mut
import Vision.Image.Grey (Grey,GreyPixel)
import Vision.Image.Type (Delayed)
import Vision.Image.Class (
      MaskedImage (..), Image (..), FromFunction (..), index
    )
import Vision.Primitive (
      Z (..), (:.) (..), Point, ix2, Size
    )

--------------------------------------------------------------------------------
--  Types and ADT-Style Interface

-- | Contours of an image include:
--    * A map from contour number to outer points and negative contour number of inner contour points.
--    * A vector of sizes for each contour for domain [1..size contourOutlines] (the zero index is meaningless)
data Contours =
        Contours { Contours -> Map ContourId Contour
contourOutlines :: Map ContourId Contour
                 , Contours -> Vector Int
contourSizes    :: !(VU.Vector Int)
                 }

allContourIds :: Contours -> [ContourId]
allContourIds :: Contours -> [ContourId]
allContourIds = forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contours -> Map ContourId Contour
contourOutlines

contourPerimeter :: Contours -> ContourId -> [Point]
contourPerimeter :: Contours -> ContourId -> [Point]
contourPerimeter Contours
m ContourId
i =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Unbox a => Vector a -> [a]
VU.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contour -> OneContour
outerContour) (Contours -> ContourId -> Maybe Contour
lookupContour Contours
m ContourId
i)

contourSize :: Contours -> ContourId -> Int
contourSize :: Contours -> ContourId -> Int
contourSize (Contours Map ContourId Contour
_ Vector Int
s) ContourId
i
    | ContourId -> Int
unCID ContourId
i forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| ContourId -> Int
unCID ContourId
i forall a. Ord a => a -> a -> Bool
>= forall a. Unbox a => Vector a -> Int
VU.length Vector Int
s = Int
0
    | Bool
otherwise                             = Vector Int
s forall a. Unbox a => Vector a -> Int -> a
VU.! ContourId -> Int
unCID ContourId
i

lookupContour :: Contours -> ContourId -> Maybe Contour
lookupContour :: Contours -> ContourId -> Maybe Contour
lookupContour Contours
m ContourId
i = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ContourId
i (Contours -> Map ContourId Contour
contourOutlines Contours
m)

-- |Contours are identified by a numeric ID number.
newtype ContourId = CID { ContourId -> Int
unCID :: Int } deriving (ContourId -> ContourId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContourId -> ContourId -> Bool
$c/= :: ContourId -> ContourId -> Bool
== :: ContourId -> ContourId -> Bool
$c== :: ContourId -> ContourId -> Bool
Eq, Eq ContourId
ContourId -> ContourId -> Bool
ContourId -> ContourId -> Ordering
ContourId -> ContourId -> ContourId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ContourId -> ContourId -> ContourId
$cmin :: ContourId -> ContourId -> ContourId
max :: ContourId -> ContourId -> ContourId
$cmax :: ContourId -> ContourId -> ContourId
>= :: ContourId -> ContourId -> Bool
$c>= :: ContourId -> ContourId -> Bool
> :: ContourId -> ContourId -> Bool
$c> :: ContourId -> ContourId -> Bool
<= :: ContourId -> ContourId -> Bool
$c<= :: ContourId -> ContourId -> Bool
< :: ContourId -> ContourId -> Bool
$c< :: ContourId -> ContourId -> Bool
compare :: ContourId -> ContourId -> Ordering
$ccompare :: ContourId -> ContourId -> Ordering
Ord, Ptr ContourId -> IO ContourId
Ptr ContourId -> Int -> IO ContourId
Ptr ContourId -> Int -> ContourId -> IO ()
Ptr ContourId -> ContourId -> IO ()
ContourId -> Int
forall b. Ptr b -> Int -> IO ContourId
forall b. Ptr b -> Int -> ContourId -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
poke :: Ptr ContourId -> ContourId -> IO ()
$cpoke :: Ptr ContourId -> ContourId -> IO ()
peek :: Ptr ContourId -> IO ContourId
$cpeek :: Ptr ContourId -> IO ContourId
pokeByteOff :: forall b. Ptr b -> Int -> ContourId -> IO ()
$cpokeByteOff :: forall b. Ptr b -> Int -> ContourId -> IO ()
peekByteOff :: forall b. Ptr b -> Int -> IO ContourId
$cpeekByteOff :: forall b. Ptr b -> Int -> IO ContourId
pokeElemOff :: Ptr ContourId -> Int -> ContourId -> IO ()
$cpokeElemOff :: Ptr ContourId -> Int -> ContourId -> IO ()
peekElemOff :: Ptr ContourId -> Int -> IO ContourId
$cpeekElemOff :: Ptr ContourId -> Int -> IO ContourId
alignment :: ContourId -> Int
$calignment :: ContourId -> Int
sizeOf :: ContourId -> Int
$csizeOf :: ContourId -> Int
Storable, Integer -> ContourId
ContourId -> ContourId
ContourId -> ContourId -> ContourId
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> ContourId
$cfromInteger :: Integer -> ContourId
signum :: ContourId -> ContourId
$csignum :: ContourId -> ContourId
abs :: ContourId -> ContourId
$cabs :: ContourId -> ContourId
negate :: ContourId -> ContourId
$cnegate :: ContourId -> ContourId
* :: ContourId -> ContourId -> ContourId
$c* :: ContourId -> ContourId -> ContourId
- :: ContourId -> ContourId -> ContourId
$c- :: ContourId -> ContourId -> ContourId
+ :: ContourId -> ContourId -> ContourId
$c+ :: ContourId -> ContourId -> ContourId
Num, Int -> ContourId -> ShowS
[ContourId] -> ShowS
ContourId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContourId] -> ShowS
$cshowList :: [ContourId] -> ShowS
show :: ContourId -> String
$cshow :: ContourId -> String
showsPrec :: Int -> ContourId -> ShowS
$cshowsPrec :: Int -> ContourId -> ShowS
Show)

-- |A contour is described by the points on the perimeter and a boolean
-- indicating if that point is "terminal" (next pixel to
-- the right is background iff the point is terminal).  The terminal
-- information allows for a slightly simpler 'drawContour' implementation.
type OneContour    = VU.Vector ContourValue
type ContourValue  = (Point,Bool)
data Contour = Contour { Contour -> OneContour
outerContour  :: OneContour
                       , Contour -> [OneContour]
innerContours :: [OneContour]
                       } -- Pair of outer and inner contours

insOuterContour :: ContourId -> OneContour -> Map ContourId Contour
                                           -> Map ContourId Contour
insOuterContour :: ContourId
-> OneContour -> Map ContourId Contour -> Map ContourId Contour
insOuterContour ContourId
cid OneContour
o Map ContourId Contour
mp =
    let c :: Contour
c = OneContour -> [OneContour] -> Contour
Contour OneContour
o []
    in forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ContourId
cid Contour
c Map ContourId Contour
mp

insInnerContour :: ContourId -> OneContour -> Map ContourId Contour
                                           -> Map ContourId Contour
insInnerContour :: ContourId
-> OneContour -> Map ContourId Contour -> Map ContourId Contour
insInnerContour ContourId
cid OneContour
i Map ContourId Contour
mp =
    let c :: Contour
c = OneContour -> [OneContour] -> Contour
Contour (forall a. HasCallStack => String -> a
error String
"Impossible: Inner contour with no outer!") [OneContour
i]
        f :: p -> Contour -> Contour
f p
_ (Contour OneContour
o [OneContour]
is) = OneContour -> [OneContour] -> Contour
Contour OneContour
o (OneContour
iforall a. a -> [a] -> [a]
:[OneContour]
is)
    in forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall {p}. p -> Contour -> Contour
f ContourId
cid Contour
c Map ContourId Contour
mp

-- |RowContour is a method of expressing contours by, for each row,
-- recording the start of an object and the end (due to reaching the other
-- side or a hole/inner contour) for each row.
type RowContour = VU.Vector (Point,Point)

--------------------------------------------------------------------------------
--  Image Reconstruction

-- | Outline: Just draw the edge.
--
-- OuterOutline: Outline the outer contours only, no hole contours
-- AllOutlines: Draw all contours
-- Fill: Draw the object but fill it in, ignoring holes.
-- FillWithHoles: Draw the object and do not fill in the holes.
data ContourDrawStyle = OuterOutline | AllOutlines | Fill | FillWithHoles
      deriving (ContourDrawStyle -> ContourDrawStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContourDrawStyle -> ContourDrawStyle -> Bool
$c/= :: ContourDrawStyle -> ContourDrawStyle -> Bool
== :: ContourDrawStyle -> ContourDrawStyle -> Bool
$c== :: ContourDrawStyle -> ContourDrawStyle -> Bool
Eq, Eq ContourDrawStyle
ContourDrawStyle -> ContourDrawStyle -> Bool
ContourDrawStyle -> ContourDrawStyle -> Ordering
ContourDrawStyle -> ContourDrawStyle -> ContourDrawStyle
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ContourDrawStyle -> ContourDrawStyle -> ContourDrawStyle
$cmin :: ContourDrawStyle -> ContourDrawStyle -> ContourDrawStyle
max :: ContourDrawStyle -> ContourDrawStyle -> ContourDrawStyle
$cmax :: ContourDrawStyle -> ContourDrawStyle -> ContourDrawStyle
>= :: ContourDrawStyle -> ContourDrawStyle -> Bool
$c>= :: ContourDrawStyle -> ContourDrawStyle -> Bool
> :: ContourDrawStyle -> ContourDrawStyle -> Bool
$c> :: ContourDrawStyle -> ContourDrawStyle -> Bool
<= :: ContourDrawStyle -> ContourDrawStyle -> Bool
$c<= :: ContourDrawStyle -> ContourDrawStyle -> Bool
< :: ContourDrawStyle -> ContourDrawStyle -> Bool
$c< :: ContourDrawStyle -> ContourDrawStyle -> Bool
compare :: ContourDrawStyle -> ContourDrawStyle -> Ordering
$ccompare :: ContourDrawStyle -> ContourDrawStyle -> Ordering
Ord, Int -> ContourDrawStyle -> ShowS
[ContourDrawStyle] -> ShowS
ContourDrawStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContourDrawStyle] -> ShowS
$cshowList :: [ContourDrawStyle] -> ShowS
show :: ContourDrawStyle -> String
$cshow :: ContourDrawStyle -> String
showsPrec :: Int -> ContourDrawStyle -> ShowS
$cshowsPrec :: Int -> ContourDrawStyle -> ShowS
Show, ReadPrec [ContourDrawStyle]
ReadPrec ContourDrawStyle
Int -> ReadS ContourDrawStyle
ReadS [ContourDrawStyle]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ContourDrawStyle]
$creadListPrec :: ReadPrec [ContourDrawStyle]
readPrec :: ReadPrec ContourDrawStyle
$creadPrec :: ReadPrec ContourDrawStyle
readList :: ReadS [ContourDrawStyle]
$creadList :: ReadS [ContourDrawStyle]
readsPrec :: Int -> ReadS ContourDrawStyle
$creadsPrec :: Int -> ReadS ContourDrawStyle
Read, Int -> ContourDrawStyle
ContourDrawStyle -> Int
ContourDrawStyle -> [ContourDrawStyle]
ContourDrawStyle -> ContourDrawStyle
ContourDrawStyle -> ContourDrawStyle -> [ContourDrawStyle]
ContourDrawStyle
-> ContourDrawStyle -> ContourDrawStyle -> [ContourDrawStyle]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ContourDrawStyle
-> ContourDrawStyle -> ContourDrawStyle -> [ContourDrawStyle]
$cenumFromThenTo :: ContourDrawStyle
-> ContourDrawStyle -> ContourDrawStyle -> [ContourDrawStyle]
enumFromTo :: ContourDrawStyle -> ContourDrawStyle -> [ContourDrawStyle]
$cenumFromTo :: ContourDrawStyle -> ContourDrawStyle -> [ContourDrawStyle]
enumFromThen :: ContourDrawStyle -> ContourDrawStyle -> [ContourDrawStyle]
$cenumFromThen :: ContourDrawStyle -> ContourDrawStyle -> [ContourDrawStyle]
enumFrom :: ContourDrawStyle -> [ContourDrawStyle]
$cenumFrom :: ContourDrawStyle -> [ContourDrawStyle]
fromEnum :: ContourDrawStyle -> Int
$cfromEnum :: ContourDrawStyle -> Int
toEnum :: Int -> ContourDrawStyle
$ctoEnum :: Int -> ContourDrawStyle
pred :: ContourDrawStyle -> ContourDrawStyle
$cpred :: ContourDrawStyle -> ContourDrawStyle
succ :: ContourDrawStyle -> ContourDrawStyle
$csucc :: ContourDrawStyle -> ContourDrawStyle
Enum, ContourDrawStyle
forall a. a -> a -> Bounded a
maxBound :: ContourDrawStyle
$cmaxBound :: ContourDrawStyle
minBound :: ContourDrawStyle
$cminBound :: ContourDrawStyle
Bounded)

-- | Draws a given contour. The size specified must be large enough to
-- include the coordinate originally occupied by the contour being drawn,
-- no cropping or other transformation is done.
drawContour :: Contours -> Size -> ContourDrawStyle -> ContourId -> Grey
drawContour :: Contours -> Point -> ContourDrawStyle -> ContourId -> Grey
drawContour Contours
master Point
sz ContourDrawStyle
sty ContourId
c = Contours -> Point -> ContourDrawStyle -> [ContourId] -> Grey
drawContours Contours
master Point
sz ContourDrawStyle
sty [ContourId
c]

-- |Draws many contours.  See 'drawContour'.
drawContours :: Contours -> Size -> ContourDrawStyle -> [ContourId] -> Grey
drawContours :: Contours -> Point -> ContourDrawStyle -> [ContourId] -> Grey
drawContours Contours
m Point
sz ContourDrawStyle
AllOutlines [ContourId]
ids  = (Contour -> [OneContour])
-> Contours -> [ContourId] -> Point -> Grey
drawOutlines Contour -> [OneContour]
listOfUVec Contours
m [ContourId]
ids Point
sz
 where listOfUVec :: Contour -> [OneContour]
listOfUVec (Contour OneContour
o [OneContour]
is) = OneContour
oforall a. a -> [a] -> [a]
:[OneContour]
is
drawContours Contours
m Point
sz ContourDrawStyle
OuterOutline [ContourId]
ids = (Contour -> [OneContour])
-> Contours -> [ContourId] -> Point -> Grey
drawOutlines Contour -> [OneContour]
listOfUVec Contours
m [ContourId]
ids Point
sz
 where listOfUVec :: Contour -> [OneContour]
listOfUVec (Contour OneContour
o [OneContour]
_) = [OneContour
o]
drawContours Contours
m Point
sz ContourDrawStyle
sty [ContourId]
ids = [[(Point, Bool)]] -> Point -> Grey
drawRows [[(Point, Bool)]]
pnts Point
sz
 where lk :: ContourId -> Maybe Contour
lk = Contours -> ContourId -> Maybe Contour
lookupContour Contours
m
       pnts :: [[(Point, Bool)]]
pnts = case ContourDrawStyle
sty of
                  ContourDrawStyle
Fill          -> forall a b. (a -> b) -> [a] -> [b]
map (forall a. Unbox a => Vector a -> [a]
VU.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contour -> OneContour
outerContour) forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ContourId -> Maybe Contour
lk [ContourId]
ids -- map (map (\(a,x) -> (a,not x)) . lk) innerIds ++ map lk outerIds
                  ContourDrawStyle
FillWithHoles -> forall a b. (a -> b) -> [a] -> [b]
map  (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Unbox a => Vector a -> [a]
VU.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Contour
x -> Contour -> OneContour
outerContour Contour
x forall a. a -> [a] -> [a]
: Contour -> [OneContour]
innerContours Contour
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContourId -> Maybe Contour
lk) [ContourId]
ids
                  ContourDrawStyle
_             -> forall a. HasCallStack => String -> a
error String
"Impossible: Style is not Fill, FillWithHoles"

drawOutlines :: (Contour -> [VU.Vector ContourValue]) -> Contours -> [ContourId] -> Size -> Grey
drawOutlines :: (Contour -> [OneContour])
-> Contours -> [ContourId] -> Point -> Grey
drawOutlines Contour -> [OneContour]
oper Contours
m [ContourId]
ids Point
sz = forall a. (forall s. ST s a) -> a
runST forall {s}. ST s Grey
f
 where
  f :: ST s Grey
f = do
    MutableManifest GreyPixel s
i <- forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
Point -> ImagePixel (Freezed i) -> m (i (PrimState m))
new' Point
sz GreyPixel
0 :: ST s (MutableManifest GreyPixel s)
    let vs :: [Point]
vs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Contour -> [OneContour]
oper forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Contours -> ContourId -> Maybe Contour
lookupContour Contours
m) [ContourId]
ids
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Point
p -> forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
i (PrimState m) -> Point -> ImagePixel (Freezed i) -> m ()
write MutableManifest GreyPixel s
i Point
p GreyPixel
255) [Point]
vs
    forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
i (PrimState m) -> m (Freezed i)
Mut.unsafeFreeze MutableManifest GreyPixel s
i


-- | Draws rows, throwing an exception when the size is too small for the
-- coordinates.
drawRows :: [[ContourValue]] -> Size -> Grey
drawRows :: [[(Point, Bool)]] -> Point -> Grey
drawRows [[(Point, Bool)]]
vs Point
sz = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    MutableManifest GreyPixel s
i <- forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
Point -> ImagePixel (Freezed i) -> m (i (PrimState m))
new' Point
sz GreyPixel
0
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall s. MutableManifest GreyPixel s -> [(Point, Bool)] -> ST s ()
drawMutable MutableManifest GreyPixel s
i) [[(Point, Bool)]]
vs
    forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
i (PrimState m) -> m (Freezed i)
Mut.unsafeFreeze MutableManifest GreyPixel s
i

drawMutable :: MutableManifest GreyPixel s -> [ContourValue] -> ST s ()
drawMutable :: forall s. MutableManifest GreyPixel s -> [(Point, Bool)] -> ST s ()
drawMutable MutableManifest GreyPixel s
i [(Point, Bool)]
cs = forall (m :: * -> *) a b.
(Monad m, Unbox a) =>
(a -> m b) -> Vector a -> m ()
VU.mapM_ (forall {m :: * -> *} {i :: * -> *}.
(MutableImage i, PrimMonad m, Num (ImagePixel (Freezed i))) =>
i (PrimState m) -> (Point, Point) -> m ()
f MutableManifest GreyPixel s
i) RowContour
rs
 where
     rs :: RowContour
rs = [(Point, Bool)] -> RowContour
rowContour [(Point, Bool)]
cs
     f :: i (PrimState m) -> (Point, Point) -> m ()
f i (PrimState m)
img (Point
start,Point
stop) = (Point, Point) -> m ()
go (Point
start, Point
stop)
       where go :: (Point, Point) -> m ()
go (s :: Point
s@(DIM0
Z:.Int
row:.Int
col),Point
t) = do
                forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
i (PrimState m) -> Point -> ImagePixel (Freezed i) -> m ()
write i (PrimState m)
img Point
s ImagePixel (Freezed i)
255
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Point
s forall a. Eq a => a -> a -> Bool
/= Point
t) forall a b. (a -> b) -> a -> b
$ (Point, Point) -> m ()
go (DIM0
Z forall tail head. tail -> head -> tail :. head
:. Int
row forall tail head. tail -> head -> tail :. head
:. (Int
colforall a. Num a => a -> a -> a
+Int
1),Point
t)

-- |Given a vector including outer (and optionally inner) contour points,
-- make 'row contour' from which is easier to transform back into a binary
-- image.  By not including the inner contour points the row will be filled, making
-- traces of objects with holes appear solid.
rowContour :: [ContourValue] -> RowContour
rowContour :: [(Point, Bool)] -> RowContour
rowContour [(Point, Bool)]
cs =
    let rows :: [[(Point,Bool)]]
        rows :: [[(Point, Bool)]]
rows = forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((\(DIM0
Z:.Int
r:.Int
_) -> Int
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [(Point, Bool)]
cs -- XXX consider vector quick/tim sort
    in forall a. Unbox a => [a] -> Vector a
VU.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(Point, Bool)] -> [(Point, Point)]
walkM [[(Point, Bool)]]
rows
 where
  walkM :: [(Point,Bool)] -> [(Point,Point)]
  walkM :: [(Point, Bool)] -> [(Point, Point)]
walkM [(Point, Bool)
x] = [(forall a b. (a, b) -> a
fst (Point, Bool)
x,forall a b. (a, b) -> a
fst (Point, Bool)
x)]
  walkM [(Point, Bool)]
x   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible: No terminal when walking contour: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ([(Point, Bool)]
x,[(Point, Bool)]
cs)) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ [(Point, Bool)] -> Maybe [(Point, Point)]
walk [(Point, Bool)]
x
  walk :: [(Point,Bool)] -> Maybe [(Point,Point)]
  walk :: [(Point, Bool)] -> Maybe [(Point, Point)]
walk [] = forall a. a -> Maybe a
Just []
  walk xs :: [(Point, Bool)]
xs@((Point, Bool)
x:[(Point, Bool)]
_) = case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Point, Bool)]
xs of
                      []     -> forall a. Maybe a
Nothing
                      ((Point, Bool)
t:[(Point, Bool)]
ys) -> ((forall a b. (a, b) -> a
fst (Point, Bool)
x,forall a b. (a, b) -> a
fst (Point, Bool)
t) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Point, Bool)] -> Maybe [(Point, Point)]
walk [(Point, Bool)]
ys

-- |The meat of this module is the 'contours' function, which extracts
-- the contours (outer and inner outlines) of a binary image.
-- Zero-valued pixels are the background and non-zero are active/objects to
-- trace.  The output, 'Contours', contains enough information to determine
-- the number of contours, their traces, the size in pixels (filled size
-- and perimeter), number of holes, etc.
contours :: (Image src, Num (ImagePixel src), Eq (ImagePixel src)) => src -> Contours
contours :: forall src.
(Image src, Num (ImagePixel src), Eq (ImagePixel src)) =>
src -> Contours
contours src
src = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
     let bsrc :: Delayed (ImagePixel src)
bsrc = forall i.
FromFunction i =>
Point -> (Point -> FromFunctionPixel i) -> i
fromFunction (DIM0
Z forall tail head. tail -> head -> tail :. head
:. Int
yforall a. Num a => a -> a -> a
+Int
2 forall tail head. tail -> head -> tail :. head
:. Int
xforall a. Num a => a -> a -> a
+Int
2) Point -> ImagePixel src
mkBorder
     MutableManifest ContourId s
mutImg   <- forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
Point -> ImagePixel (Freezed i) -> m (i (PrimState m))
new' (forall i. MaskedImage i => i -> Point
shape Delayed (ImagePixel src)
bsrc) ContourId
zid
     (Map ContourId Contour
outlines,BlobSizes s
sz) <- forall s p.
(Storable p, Num p, Eq p) =>
Delayed p
-> MutableManifest ContourId s
-> ST s (Map ContourId Contour, BlobSizes s)
doLabeling Delayed (ImagePixel src)
bsrc MutableManifest ContourId s
mutImg
     Vector Int
sizes <- forall s. BlobSizes s -> ST s (Vector Int)
freezeBlobSizes BlobSizes s
sz
     forall (m :: * -> *) a. Monad m => a -> m a
return (Map ContourId Contour -> Vector Int -> Contours
Contours Map ContourId Contour
outlines Vector Int
sizes)
 where
 (DIM0
Z :. Int
y :. Int
x) = forall i. MaskedImage i => i -> Point
shape src
src

 mkBorder :: Point -> ImagePixel src
mkBorder (DIM0
Z :. Int
j :. Int
i)
   | Int
j forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
j forall a. Eq a => a -> a -> Bool
== (Int
yforall a. Num a => a -> a -> a
+Int
1) Bool -> Bool -> Bool
|| Int
i forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
i forall a. Eq a => a -> a -> Bool
== (Int
xforall a. Num a => a -> a -> a
+Int
1) = forall a. Num a => a
background
   | Bool
otherwise                                    = forall i. Image i => i -> Point -> ImagePixel i
index src
src (DIM0
Z forall tail head. tail -> head -> tail :. head
:. Int
jforall a. Num a => a -> a -> a
-Int
1 forall tail head. tail -> head -> tail :. head
:. Int
iforall a. Num a => a -> a -> a
-Int
1)

-- The image is assumed to be binary and should have values of either 0 (black) or... nonzero (white)
-- here we assume the background is black.  Nonzero would require more
-- change elsewhere!
background :: Num a => a
background :: forall a. Num a => a
background = a
0

zid :: ContourId
zid :: ContourId
zid = Int -> ContourId
CID Int
0

data BlobSizes s = BS (VM.MVector s Int)

freezeBlobSizes :: BlobSizes s -> ST s (VU.Vector Int)
freezeBlobSizes :: forall s. BlobSizes s -> ST s (Vector Int)
freezeBlobSizes (BS MVector s Int
v) = forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VU.unsafeFreeze MVector s Int
v

incBlobSizes :: ContourId -> BlobSizes s -> ST s (BlobSizes s)
incBlobSizes :: forall s. ContourId -> BlobSizes s -> ST s (BlobSizes s)
incBlobSizes (CID Int
i) s :: BlobSizes s
s@(BS MVector s Int
v)
  | Int
i forall a. Ord a => a -> a -> Bool
> Int
0 =
     if forall a s. Unbox a => MVector s a -> Int
VM.length MVector s Int
v forall a. Ord a => a -> a -> Bool
<= Int
i
         then do MVector s Int
nv <- forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a)
VM.unsafeGrow MVector s Int
v (Int
iforall a. Num a => a -> a -> a
*Int
2)
                 forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Int
ix -> forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite MVector s Int
nv Int
ix Int
0) [Int
i..Int
iforall a. Num a => a -> a -> a
*Int
2forall a. Num a => a -> a -> a
-Int
1]
                 forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite MVector s Int
nv Int
i Int
1
                 forall (m :: * -> *) a. Monad m => a -> m a
return (forall s. MVector s Int -> BlobSizes s
BS MVector s Int
nv)
         else do Int
p <- forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
VM.unsafeRead MVector s Int
v Int
i
                 forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite MVector s Int
v Int
i (Int
pforall a. Num a => a -> a -> a
+Int
1)
                 forall (m :: * -> *) a. Monad m => a -> m a
return BlobSizes s
s
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return BlobSizes s
s

zeroBlobSizes :: ST s (BlobSizes s)
zeroBlobSizes :: forall s. ST s (BlobSizes s)
zeroBlobSizes = forall s. MVector s Int -> BlobSizes s
BS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> a -> m (MVector (PrimState m) a)
VM.replicate Int
1024 Int
0

-- Make a contour image of the same dimension but with ContourIDs instead
-- of pixels.
doLabeling :: forall s p. (Storable p, Num p, Eq p) => Delayed p -> MutableManifest ContourId s -> ST s (Map ContourId Contour,BlobSizes s)
doLabeling :: forall s p.
(Storable p, Num p, Eq p) =>
Delayed p
-> MutableManifest ContourId s
-> ST s (Map ContourId Contour, BlobSizes s)
doLabeling Delayed p
src MutableManifest ContourId s
mutImg = forall s. ST s (BlobSizes s)
zeroBlobSizes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Point
-> ContourId
-> ContourId
-> Map ContourId Contour
-> BlobSizes s
-> ST s (Map ContourId Contour, BlobSizes s)
go (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Int -> Point
ix2 Int
1 Int
1) (Int -> ContourId
CID Int
0) (Int -> ContourId
CID Int
1) forall a. Monoid a => a
mempty
 where
 getCID    :: Point -> ST s ContourId
 getCID :: Point -> ST s ContourId
getCID     = forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
i (PrimState m) -> Point -> m (ImagePixel (Freezed i))
Mut.read MutableManifest ContourId s
mutImg
 setCID :: Point -> ContourId -> ST s ()
setCID Point
i ContourId
c = forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
i (PrimState m) -> Point -> ImagePixel (Freezed i) -> m ()
write MutableManifest ContourId s
mutImg Point
i ContourId
c
 getPixel :: Point -> ImagePixel (Delayed p)
 getPixel :: Point -> ImagePixel (Delayed p)
getPixel   = forall i. Image i => i -> Point -> ImagePixel i
index Delayed p
src

 incIx :: Point -> Maybe Point
 incIx :: Point -> Maybe Point
incIx !(DIM0
Z :. (!Int
y) :. (!Int
x))
    | Int
x forall a. Ord a => a -> a -> Bool
< Int
xMaxforall a. Num a => a -> a -> a
-Int
1  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DIM0
Z forall tail head. tail -> head -> tail :. head
:. Int
y     forall tail head. tail -> head -> tail :. head
:. (Int
xforall a. Num a => a -> a -> a
+Int
1)
    | Int
y forall a. Ord a => a -> a -> Bool
< Int
yMaxforall a. Num a => a -> a -> a
-Int
1  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DIM0
Z forall tail head. tail -> head -> tail :. head
:. (Int
yforall a. Num a => a -> a -> a
+Int
1) forall tail head. tail -> head -> tail :. head
:. Int
1
    | Bool
otherwise = forall a. Maybe a
Nothing

 (DIM0
Z :. Int
yMax :. Int
xMax) = forall i. MaskedImage i => i -> Point
shape Delayed p
src

 -- Traverse the source image top to bottom, left to right.  If the pixel
 -- has an ID then propagate that ID to all the following active pixels in
 -- the row.  If the pixel is active and has no ID then trace either an
 -- inner or outer contour.  If the pixel is inactive then skip it.
 go :: Maybe Point
-> ContourId
-> ContourId
-> Map ContourId Contour
-> BlobSizes s
-> ST s (Map ContourId Contour, BlobSizes s)
go Maybe Point
Nothing   ContourId
_ ContourId
_ !Map ContourId Contour
mp BlobSizes s
v              = forall (m :: * -> *) a. Monad m => a -> m a
return (Map ContourId Contour
mp,BlobSizes s
v)
 go (Just Point
idx) ContourId
leftCID !ContourId
newCID !Map ContourId Contour
mp BlobSizes s
v =
   do ContourId
thisCID <- Point -> ST s ContourId
getCID Point
idx
      if | p
val forall a. Eq a => a -> a -> Bool
== forall a. Num a => a
background                     -> ST s (Map ContourId Contour, BlobSizes s)
skipForward -- this step doesn't appear in the paper! D'oh
         | ContourId
thisCID forall a. Eq a => a -> a -> Bool
== ContourId
zid Bool -> Bool -> Bool
&& p
above forall a. Eq a => a -> a -> Bool
== forall a. Num a => a
background ->
                         do -- Step 1: Outer contour trace (active pixel with id=0 and above is background)
                            OneContour
newContour <- forall p s.
(Storable p, Num p, Eq p) =>
Delayed p
-> MutableManifest ContourId s
-> ContourType
-> Point
-> ContourId
-> ST s OneContour
traceContour Delayed p
src MutableManifest ContourId s
mutImg ContourType
ExternalContour Point
idx ContourId
newCID
                            Maybe Point
-> ContourId
-> ContourId
-> Map ContourId Contour
-> BlobSizes s
-> ST s (Map ContourId Contour, BlobSizes s)
go (forall a. a -> Maybe a
Just Point
idx) ContourId
newCID (ContourId
newCID forall a. Num a => a -> a -> a
+ ContourId
1) (ContourId
-> OneContour -> Map ContourId Contour -> Map ContourId Contour
insOuterContour ContourId
newCID OneContour
newContour Map ContourId Contour
mp) BlobSizes s
v
         | p
below forall a. Eq a => a -> a -> Bool
== forall a. Num a => a
background ->               -- Step 2: P is an              white pixel
             do ContourId
belowCID <- Point -> ST s ContourId
getCID Point
belowIdx     --                 ^          ^
                if | ContourId
belowCID forall a. Eq a => a -> a -> Bool
== ContourId
zid ->         --                 ^ unmarked ^
                         do -- Step 2a: Inner contour trace, below pixel was unmarked
                            let innerCID :: ContourId
innerCID = if ContourId
zid forall a. Eq a => a -> a -> Bool
== ContourId
thisCID then ContourId
leftCID else ContourId
thisCID
                            OneContour
inner <- forall p s.
(Storable p, Num p, Eq p) =>
Delayed p
-> MutableManifest ContourId s
-> ContourType
-> Point
-> ContourId
-> ST s OneContour
traceContour Delayed p
src MutableManifest ContourId s
mutImg ContourType
InternalContour Point
idx ContourId
innerCID
                            Maybe Point
-> ContourId
-> ContourId
-> Map ContourId Contour
-> BlobSizes s
-> ST s (Map ContourId Contour, BlobSizes s)
go (Point -> Maybe Point
incIx Point
idx) ContourId
innerCID ContourId
newCID (ContourId
-> OneContour -> Map ContourId Contour -> Map ContourId Contour
insInnerContour ContourId
innerCID OneContour
inner Map ContourId Contour
mp) BlobSizes s
v
                            -- there can be more than one inner contour, make a richer container structure than IntMap?
                            -- Notice this isn't entirely necessary, one
                            -- CID can contain all inner contours and they can be redrawn correctly.
                   | Bool
otherwise -> ST s (Map ContourId Contour, BlobSizes s)
stepForward -- Step 2b: Previously-observed contour
         | Bool
otherwise                             -> ST s (Map ContourId Contour, BlobSizes s)
stepForward -- Active pixel not on a contour
   where val :: ImagePixel (Delayed p)
val         = Point -> ImagePixel (Delayed p)
getPixel Point
idx
         above :: ImagePixel (Delayed p)
above       = Point -> ImagePixel (Delayed p)
getPixel (DIM0
Z forall tail head. tail -> head -> tail :. head
:. Int
yforall a. Num a => a -> a -> a
-Int
1 forall tail head. tail -> head -> tail :. head
:. Int
x)
         below :: ImagePixel (Delayed p)
below       = Point -> ImagePixel (Delayed p)
getPixel Point
belowIdx
         belowIdx :: Point
belowIdx    = DIM0
Z forall tail head. tail -> head -> tail :. head
:. Int
yforall a. Num a => a -> a -> a
+Int
1 forall tail head. tail -> head -> tail :. head
:. Int
x
         DIM0
Z :. Int
y :. Int
x = Point
idx
         stepForward :: ST s (Map ContourId Contour, BlobSizes s)
stepForward = do ContourId
xId <- if ContourId
leftCID forall a. Ord a => a -> a -> Bool
<= ContourId
zid
                                  then Point -> ST s ContourId
getCID Point
idx
                                  else forall (m :: * -> *) a. Monad m => a -> m a
return ContourId
leftCID
                          Point -> ContourId -> ST s ()
setCID Point
idx ContourId
xId
                          BlobSizes s
nv <- forall s. ContourId -> BlobSizes s -> ST s (BlobSizes s)
incBlobSizes ContourId
xId BlobSizes s
v
                          Maybe Point
-> ContourId
-> ContourId
-> Map ContourId Contour
-> BlobSizes s
-> ST s (Map ContourId Contour, BlobSizes s)
go (Point -> Maybe Point
incIx Point
idx) ContourId
xId ContourId
newCID Map ContourId Contour
mp BlobSizes s
nv
         skipForward :: ST s (Map ContourId Contour, BlobSizes s)
skipForward = Maybe Point
-> ContourId
-> ContourId
-> Map ContourId Contour
-> BlobSizes s
-> ST s (Map ContourId Contour, BlobSizes s)
go (Point -> Maybe Point
incIx Point
idx) (-ContourId
2) ContourId
newCID Map ContourId Contour
mp BlobSizes s
v

-- Mark surrounding background pixels
-- label non-background pixels with CID
--
-- Unroll the loop one step to account for the lone-pixel case.  Without
-- lone pixels the tight inner loop can save a check (See 'Impossible')
--
-- TODO: optimize later, duplicate tracer and remove the p==pos, after a benchmarking method is setup.
traceContour :: forall p s. (Storable p, Num p, Eq p) => Delayed p -> MutableManifest ContourId s -> ContourType -> Point -> ContourId -> ST s OneContour
traceContour :: forall p s.
(Storable p, Num p, Eq p) =>
Delayed p
-> MutableManifest ContourId s
-> ContourType
-> Point
-> ContourId
-> ST s OneContour
traceContour Delayed p
src MutableManifest ContourId s
mutImg ContourType
contourTy Point
origPnt ContourId
assignedCID =
  do Maybe (Point, ContourPos)
next <- Point -> ContourPos -> ST s (Maybe (Point, ContourPos))
tracer Point
origPnt ContourPos
startPos
     case Maybe (Point, ContourPos)
next of
         Maybe (Point, ContourPos)
Nothing              -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Unbox a => [a] -> Vector a
VU.fromList forall a b. (a -> b) -> a -> b
$ forall {head} {head} {b}.
(Num head, Num head) =>
[((DIM0 :. head) :. head, b)] -> [((DIM0 :. head) :. head, b)]
fixList [(Point
origPnt,Bool
True)])
         Just (Point
sndPnt,ContourPos
sndPos) -> do
            let f :: Point -> ContourPos -> ST s [(Point, Bool)]
f Point
pnt ContourPos
pos = do (Point
nPnt,ContourPos
nPos) <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"Impossible: Nothing in inner") forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> ContourPos -> ST s (Maybe (Point, ContourPos))
tracer Point
pnt ContourPos
pos
                               if Point
pnt forall a. Eq a => a -> a -> Bool
== Point
origPnt Bool -> Bool -> Bool
&& Point
nPnt forall a. Eq a => a -> a -> Bool
== Point
sndPnt
                                   then forall (m :: * -> *) a. Monad m => a -> m a
return [] -- XXX some algorithms duplicate the start point, pnt, as the last point `return [pnt]`.  Should we?
                                   else ((Point
pnt,Point -> Bool
terminal Point
pnt) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> ContourPos -> ST s [(Point, Bool)]
f Point
nPnt ContourPos
nPos
            forall a. Unbox a => [a] -> Vector a
VU.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {head} {head} {b}.
(Num head, Num head) =>
[((DIM0 :. head) :. head, b)] -> [((DIM0 :. head) :. head, b)]
fixList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point
origPnt, Point -> Bool
terminal Point
origPnt)forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> ContourPos -> ST s [(Point, Bool)]
f Point
sndPnt ContourPos
sndPos

 where
   terminal :: Point -> Bool
terminal (DIM0
Z :. Int
row :. Int
col) = p
0 forall a. Eq a => a -> a -> Bool
== Point -> ImagePixel (Delayed p)
getPixel (DIM0
Z forall tail head. tail -> head -> tail :. head
:. Int
row forall tail head. tail -> head -> tail :. head
:. (Int
colforall a. Num a => a -> a -> a
+Int
1))
   -- Translate between indexes in our border-added image and the original
   fixList :: [((DIM0 :. head) :. head, b)] -> [((DIM0 :. head) :. head, b)]
fixList [((DIM0 :. head) :. head, b)]
xs = let f :: ((DIM0 :. head) :. head, b) -> ((DIM0 :. head) :. head, b)
f (DIM0
Z :. head
a :. head
b, b
t) = (DIM0
Z forall tail head. tail -> head -> tail :. head
:. head
aforall a. Num a => a -> a -> a
-head
1 forall tail head. tail -> head -> tail :. head
:. head
bforall a. Num a => a -> a -> a
-head
1,b
t) in forall a b. (a -> b) -> [a] -> [b]
map forall {head} {head} {b}.
(Num head, Num head) =>
((DIM0 :. head) :. head, b) -> ((DIM0 :. head) :. head, b)
f [((DIM0 :. head) :. head, b)]
xs
   startPos :: ContourPos
startPos   = case ContourType
contourTy of { ContourType
ExternalContour -> ContourPos
UR ; ContourType
InternalContour -> ContourPos
LL  }
   setCID :: Point -> ContourId -> ST s ()
setCID Point
i ContourId
c = forall (i :: * -> *) (m :: * -> *).
(MutableImage i, PrimMonad m) =>
i (PrimState m) -> Point -> ImagePixel (Freezed i) -> m ()
write MutableManifest ContourId s
mutImg Point
i ContourId
c
   getPixel :: Point -> ImagePixel (Delayed p)
   getPixel :: Point -> ImagePixel (Delayed p)
getPixel   = forall i. Image i => i -> Point -> ImagePixel i
index Delayed p
src

   {-# INLINE tracer #-}
   tracer :: Point -> ContourPos -> ST s (Maybe (Point, ContourPos))
tracer Point
pnt ContourPos
pos =
       let tracer' :: Bool -> ContourPos -> ST s (Maybe (Point, ContourPos))
tracer' Bool
True ContourPos
p | ContourPos
p forall a. Eq a => a -> a -> Bool
== ContourPos
pos = Point -> ContourId -> ST s ()
setCID Point
pnt ContourId
assignedCID forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
           tracer' Bool
_ ContourPos
p = do let rpnt :: Point
rpnt = Point -> ContourPos -> Point
relPoint Point
pnt ContourPos
p
                                v :: ImagePixel (Delayed p)
v    = Point -> ImagePixel (Delayed p)
getPixel Point
rpnt
                            if | p
v forall a. Eq a => a -> a -> Bool
== forall a. Num a => a
background -> do Point -> ContourId -> ST s ()
setCID Point
rpnt (-ContourId
1)
                                                       Bool -> ContourPos -> ST s (Maybe (Point, ContourPos))
tracer' Bool
True (ContourPos -> ContourPos
incCP ContourPos
p)
                               | Bool
otherwise       -> do Point -> ContourId -> ST s ()
setCID Point
pnt ContourId
assignedCID
                                                       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Point
rpnt, ContourPos -> ContourPos
decCP2 ContourPos
p))
       in Bool -> ContourPos -> ST s (Maybe (Point, ContourPos))
tracer' Bool
False ContourPos
pos


--------------------------------------------------------------------------------
--  Internal Types and Utilities

data ContourType = ExternalContour | InternalContour deriving (ContourType -> ContourType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContourType -> ContourType -> Bool
$c/= :: ContourType -> ContourType -> Bool
== :: ContourType -> ContourType -> Bool
$c== :: ContourType -> ContourType -> Bool
Eq)

-- A contour position is Upper/Lower/Middle Left/Center/Right pixel
-- relative to the current.  Because we add a border to the image prior
-- to processing, all original pixels `cross` contours positions are
-- a valid point.
data ContourPos  = MR | LR | LC | LL
                 | ML | UL | UC | UR
            deriving (Int -> ContourPos
ContourPos -> Int
ContourPos -> [ContourPos]
ContourPos -> ContourPos
ContourPos -> ContourPos -> [ContourPos]
ContourPos -> ContourPos -> ContourPos -> [ContourPos]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ContourPos -> ContourPos -> ContourPos -> [ContourPos]
$cenumFromThenTo :: ContourPos -> ContourPos -> ContourPos -> [ContourPos]
enumFromTo :: ContourPos -> ContourPos -> [ContourPos]
$cenumFromTo :: ContourPos -> ContourPos -> [ContourPos]
enumFromThen :: ContourPos -> ContourPos -> [ContourPos]
$cenumFromThen :: ContourPos -> ContourPos -> [ContourPos]
enumFrom :: ContourPos -> [ContourPos]
$cenumFrom :: ContourPos -> [ContourPos]
fromEnum :: ContourPos -> Int
$cfromEnum :: ContourPos -> Int
toEnum :: Int -> ContourPos
$ctoEnum :: Int -> ContourPos
pred :: ContourPos -> ContourPos
$cpred :: ContourPos -> ContourPos
succ :: ContourPos -> ContourPos
$csucc :: ContourPos -> ContourPos
Enum, ContourPos
forall a. a -> a -> Bounded a
maxBound :: ContourPos
$cmaxBound :: ContourPos
minBound :: ContourPos
$cminBound :: ContourPos
Bounded, ContourPos -> ContourPos -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContourPos -> ContourPos -> Bool
$c/= :: ContourPos -> ContourPos -> Bool
== :: ContourPos -> ContourPos -> Bool
$c== :: ContourPos -> ContourPos -> Bool
Eq, Int -> ContourPos -> ShowS
[ContourPos] -> ShowS
ContourPos -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContourPos] -> ShowS
$cshowList :: [ContourPos] -> ShowS
show :: ContourPos -> String
$cshow :: ContourPos -> String
showsPrec :: Int -> ContourPos -> ShowS
$cshowsPrec :: Int -> ContourPos -> ShowS
Show)

relPoint :: Point -> ContourPos -> Point
relPoint :: Point -> ContourPos -> Point
relPoint (DIM0
Z :. Int
row :. Int
col) ContourPos
pos = DIM0
Z forall tail head. tail -> head -> tail :. head
:. Int
row' forall tail head. tail -> head -> tail :. head
:. Int
col'
 where !row' :: Int
row' = Int
row forall a. Num a => a -> a -> a
+ Int
y
       !col' :: Int
col' = Int
col forall a. Num a => a -> a -> a
+ Int
x
       x :: Int
x = Vector Int
colOffset forall a. Unbox a => Vector a -> Int -> a
VU.! forall a. Enum a => a -> Int
fromEnum ContourPos
pos
       y :: Int
y = Vector Int
rowOffset forall a. Unbox a => Vector a -> Int -> a
VU.! forall a. Enum a => a -> Int
fromEnum ContourPos
pos

-- Rather than have branching (and expected poor performance),
-- use a table of x/y offsets for the relative pixel position.
colOffset,rowOffset :: VU.Vector Int
rowOffset :: Vector Int
rowOffset = forall a. Unbox a => [a] -> Vector a
VU.fromList [Int
0,Int
1,Int
1,Int
1,Int
0,-Int
1,-Int
1,-Int
1]
colOffset :: Vector Int
colOffset = forall a. Unbox a => [a] -> Vector a
VU.fromList [Int
1,Int
1,Int
0,-Int
1,-Int
1,-Int
1,Int
0,Int
1]

-- Position clockwise by one tick
incCP :: ContourPos -> ContourPos
incCP :: ContourPos -> ContourPos
incCP  = forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. Integral a => a -> a -> a
`rem` Int
8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Int
1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum

-- Position counter-clockwise by two ticks
decCP2 :: ContourPos -> ContourPos
decCP2 :: ContourPos -> ContourPos
decCP2 = forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. Integral a => a -> a -> a
`rem` Int
8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Int
6)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum