diff --git a/chain-codes.cabal b/chain-codes.cabal --- a/chain-codes.cabal +++ b/chain-codes.cabal @@ -1,5 +1,5 @@ name: chain-codes -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Library decoding chain codes from images description: Library decoding chain codes from images homepage: http://github.com/Fuuzetsu/chain-codes @@ -10,9 +10,33 @@ category: Data build-type: Simple cabal-version: >=1.10 +extra-source-files: test/res/*.gif + library exposed-modules: Data.ChainCodes build-depends: base >=4.6 && <5, JuicyPixels, containers hs-source-dirs: src default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Spec.hs + + hs-source-dirs: + test + , src + + other-modules: + Data.ChainCodes.ChainSpec + Data.ChainCodes.Blobs + + build-depends: + base + , hspec + , JuicyPixels + , containers + + build-depends: + chain-codes diff --git a/src/Data/ChainCodes.hs b/src/Data/ChainCodes.hs --- a/src/Data/ChainCodes.hs +++ b/src/Data/ChainCodes.hs @@ -39,29 +39,43 @@ Left err → Left err -- | Given an 'Image' parametrised by 'PixelRGB8' and given a --- 'Colour', we try to find the first pixel that matches the 'Colour'. +-- background 'Colour', we try to find the first pixel that doesn't match the +-- 'Colour'. -- -- We start checking at the top left corner of the image, checking each row --- fully before progressing a column: we check @(width, height)@ then --- @(width, height + 1)@ and so on where top left corner of the image is (0, 0) --- and positive height is towards the bottom. +-- fully before progressing a column: we check @(height, width)@ then +-- @(height, width + 1)@ and so on where top left corner of the image is (0, 0) +-- and positive height is towards the bottom. Uses colour 'average' for +-- comparison with a small leeway of 1. 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] ] + go [ (hi, wi) | 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 + 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 +-- | Averages each colour value and sees how close it is too fully-white. +intensity ∷ PixelRGB8 → Double +intensity p = fromIntegral (average p) / 255 + +-- | Takes the average of RGB values +average ∷ PixelRGB8 → Integer +average (PixelRGB8 r g b) = toInteger $ r `div` 3 + g `div` 3 + b `div` 3 + +-- | Specialised version of 'chainCodeWith' which uses a comparison function +-- which simply asserts that the shape colour is not the same as the background. +chainCode ∷ Image PixelRGB8 → Colour → Maybe ChainCode +chainCode i c = chainCodeWith i c (/= c) + -- | Given an 'Image' parametrised by 'PixelRGB8' and given a --- 'Colour', we try to find the chain code in the binary image which has --- the passed in colour. Note that this is the colour of your shape and any --- other colour is assumed to be the background: to process a black shape, pass --- in a black colour. +-- 'Colour' and a comparison function, we try to find the chain code in the +-- binary image which has the passed in colour. The comparison function's +-- purpose is to tell whether something is part of the shape. -- -- Note that only a single shape is accepted inside of the image. The -- starting positing is determined using 'findSpot'. @@ -69,10 +83,10 @@ -- The output list contains unique positions only: the beginning and -- end position are not treated the same. If 'findSpot' fails, we return -- 'Nothing'. -chainCode ∷ Image PixelRGB8 → Colour → Maybe ChainCode -chainCode img@(Image w h d) c = findSpot img c >>= \pos → +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 [0 ..] (fromList [(0, ppos)]) ppos + in Just $ go [1 ..] (fromList [(0, (-1, -1, 0)), (1, ppos)]) ppos where ns ∷ Map Int (Int, Int) ns = fromList $ zip [0 ..] @@ -80,25 +94,25 @@ , (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 + 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 == 0 || not (eqV positions count) = + | 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 ← [5 + fd .. fd + 13] + places = [ (mx, my, m) | i ← [fd + 5 .. fd + 13] , let m = i `mod` 8 (nx, ny) = ns ! m - o@(mx, my) = (fx + nx, fy + ny) + o@(mx, my) = (fx + ny, fy + nx) , inBounds o - , uncurry (pixelAt img) o == c + , f $ uncurry (pixelAt img) o ] in loop counts $ case places of [] → positions x:_ → insert (count + 1) x positions - | otherwise = delete 0 positions + | otherwise = delete 1 (delete 0 positions) eqV ∷ Map Int PixelPos → Int → Bool eqV p i = let (x, y, _) = p ! i diff --git a/test/Data/ChainCodes/Blobs.hs b/test/Data/ChainCodes/Blobs.hs new file mode 100644 --- /dev/null +++ b/test/Data/ChainCodes/Blobs.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE UnicodeSyntax #-} +-- | Module with some chaincode dumps +module Data.ChainCodes.Blobs where + +import Data.ChainCodes + +-- The values we're getting are from model MATLAB program which indexes images +-- from 1, so we use this helper to change lower our results. +reduce (x, y, z) = (x - 1, y - 1, z) + +-- a.gif chaincode +agifChain ∷ ChainCode +agifChain = map reduce + [ (69, 3, 1) + , (69, 4, 2) + , (69, 5, 2) + , (70, 6, 1) + , (70, 7, 2) + , (71, 8, 1) + , (71, 9, 2) + , (71, 10, 2) + , (72, 11, 1) + , (72, 12, 2) + , (72, 13, 2) + , (73, 14, 1) + , (73, 15, 2) + , (73, 16, 2) + , (74, 17, 1) + , (74, 18, 2) + , (74, 19, 2) + , (75, 20, 1) + , (75, 21, 2) + , (75, 22, 2) + , (75, 23, 2) + , (76, 24, 1) + , (76, 25, 2) + , (76, 26, 2) + , (77, 27, 1) + , (77, 28, 2) + , (77, 29, 2) + , (78, 30, 1) + , (78, 31, 2) + , (78, 32, 2) + , (79, 33, 1) + , (79, 34, 2) + , (80, 35, 1) + , (80, 36, 2) + , (80, 37, 2) + , (81, 38, 1) + , (81, 39, 2) + , (82, 40, 1) + , (83, 39, 7) + , (84, 38, 7) + , (85, 37, 7) + , (86, 37, 0) + , (87, 36, 7) + , (88, 35, 7) + , (89, 34, 7) + , (90, 33, 7) + , (91, 32, 7) + , (92, 32, 0) + , (93, 31, 7) + , (94, 30, 7) + , (95, 29, 7) + , (96, 28, 7) + , (97, 27, 7) + , (98, 27, 0) + , (99, 26, 7) + , (100, 25, 7) + , (101, 24, 7) + , (102, 23, 7) + , (103, 22, 7) + , (104, 22, 0) + , (105, 21, 7) + , (106, 20, 7) + , (107, 19, 7) + , (108, 18, 7) + , (109, 17, 7) + , (110, 17, 0) + , (111, 16, 7) + , (112, 15, 7) + , (113, 14, 7) + , (114, 13, 7) + , (115, 12, 7) + , (116, 12, 0) + , (117, 11, 7) + , (118, 10, 7) + , (119, 9, 7) + , (120, 9, 0) + , (120, 10, 2) + , (119, 11, 3) + , (119, 12, 2) + , (118, 13, 3) + , (117, 14, 3) + , (117, 15, 2) + , (116, 16, 3) + , (115, 17, 3) + , (115, 18, 2) + , (114, 19, 3) + , (113, 20, 3) + , (113, 21, 2) + , (112, 22, 3) + , (111, 23, 3) + , (111, 24, 2) + , (110, 25, 3) + , (109, 26, 3) + , (109, 27, 2) + , (108, 28, 3) + , (107, 29, 3) + , (107, 30, 2) + , (106, 31, 3) + , (105, 32, 3) + , (105, 33, 2) + , (104, 34, 3) + , (103, 35, 3) + , (103, 36, 2) + , (102, 37, 3) + , (101, 38, 3) + , (101, 39, 2) + , (100, 40, 3) + , (100, 41, 2) + , (99, 42, 3) + , (98, 43, 3) + , (98, 44, 2) + , (97, 45, 3) + , (96, 46, 3) + , (96, 47, 2) + , (95, 48, 3) + , (94, 49, 3) + , (93, 50, 3) + , (93, 51, 2) + , (92, 52, 3) + , (91, 53, 3) + , (91, 54, 2) + , (90, 55, 3) + , (89, 56, 3) + , (89, 57, 2) + , (88, 58, 3) + , (87, 59, 3) + , (87, 60, 2) + , (86, 61, 3) + , (85, 62, 3) + , (85, 63, 2) + , (84, 64, 3) + , (83, 65, 3) + , (83, 66, 2) + , (82, 67, 3) + , (81, 68, 3) + , (81, 69, 2) + , (80, 70, 3) + , (79, 71, 3) + , (79, 72, 2) + , (78, 73, 3) + , (77, 74, 3) + , (77, 75, 2) + , (76, 76, 3) + , (76, 77, 2) + , (75, 78, 3) + , (74, 79, 3) + , (73, 78, 5) + , (72, 77, 5) + , (72, 76, 6) + , (71, 75, 5) + , (70, 74, 5) + , (70, 73, 6) + , (69, 72, 5) + , (68, 71, 5) + , (68, 70, 6) + , (67, 69, 5) + , (66, 68, 5) + , (66, 67, 6) + , (65, 66, 5) + , (64, 65, 5) + , (64, 64, 6) + , (63, 63, 5) + , (62, 62, 5) + , (62, 61, 6) + , (61, 60, 5) + , (60, 59, 5) + , (60, 58, 6) + , (59, 57, 5) + , (58, 56, 5) + , (58, 55, 6) + , (57, 54, 5) + , (56, 53, 5) + , (56, 52, 6) + , (55, 51, 5) + , (54, 50, 5) + , (53, 49, 5) + , (53, 48, 6) + , (52, 47, 5) + , (51, 46, 5) + , (51, 45, 6) + , (50, 44, 5) + , (49, 43, 5) + , (49, 42, 6) + , (48, 41, 5) + , (47, 40, 5) + , (47, 39, 6) + , (46, 38, 5) + , (45, 37, 5) + , (45, 36, 6) + , (44, 35, 5) + , (43, 34, 5) + , (43, 33, 6) + , (42, 32, 5) + , (41, 31, 5) + , (41, 30, 6) + , (40, 29, 5) + , (39, 28, 5) + , (39, 27, 6) + , (38, 26, 5) + , (37, 25, 5) + , (37, 24, 6) + , (36, 23, 5) + , (35, 22, 5) + , (35, 21, 6) + , (34, 20, 5) + , (33, 19, 5) + , (33, 18, 6) + , (32, 17, 5) + , (31, 16, 5) + , (31, 15, 6) + , (30, 14, 5) + , (30, 13, 6) + , (31, 13, 0) + , (32, 13, 0) + , (33, 14, 1) + , (34, 15, 1) + , (35, 16, 1) + , (36, 17, 1) + , (37, 18, 1) + , (38, 18, 0) + , (39, 19, 1) + , (40, 20, 1) + , (41, 21, 1) + , (42, 22, 1) + , (43, 23, 1) + , (44, 23, 0) + , (45, 24, 1) + , (46, 25, 1) + , (47, 26, 1) + , (48, 27, 1) + , (49, 28, 1) + , (50, 28, 0) + , (51, 29, 1) + , (52, 30, 1) + , (53, 31, 1) + , (54, 32, 1) + , (55, 33, 1) + , (56, 33, 0) + , (57, 34, 1) + , (58, 35, 1) + , (59, 36, 1) + , (60, 37, 1) + , (61, 38, 1) + , (62, 38, 0) + , (63, 37, 7) + , (63, 36, 6) + , (63, 35, 6) + , (63, 34, 6) + , (63, 33, 6) + , (64, 32, 7) + , (64, 31, 6) + , (64, 30, 6) + , (64, 29, 6) + , (64, 28, 6) + , (64, 27, 6) + , (64, 26, 6) + , (65, 25, 7) + , (65, 24, 6) + , (65, 23, 6) + , (65, 22, 6) + , (65, 21, 6) + , (65, 20, 6) + , (65, 19, 6) + , (66, 18, 7) + , (66, 17, 6) + , (66, 16, 6) + , (66, 15, 6) + , (66, 14, 6) + , (66, 13, 6) + , (66, 12, 6) + , (67, 11, 7) + , (67, 10, 6) + , (67, 9, 6) + , (67, 8, 6) + , (67, 7, 6) + , (67, 6, 6) + , (68, 5, 7) + , (68, 4, 6) + , (68, 3, 6) + , (68, 2, 6) + ] diff --git a/test/Data/ChainCodes/ChainSpec.hs b/test/Data/ChainCodes/ChainSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/ChainCodes/ChainSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.ChainCodes.ChainSpec (main, spec) where + +import Data.ChainCodes +import Data.ChainCodes.Blobs +import Test.Hspec +import Codec.Picture + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "parseString" $ do + let img = "test/res/a.gif" + white = PixelRGB8 255 255 255 + black = PixelRGB8 0 0 0 + red = PixelRGB8 255 0 0 + readImg x = readRGB8 x >>= \case + Left _ → fail $ "Failed reading " ++ img + Right s → return s + + it "can find a spot" $ do + i ← readImg img + findSpot i black `shouldBe`Just (67, 1) + + it "fails with Nothing when it can't find a spot" $ do + i ← readImg "test/res/c.gif" + findSpot i red `shouldBe` Nothing + + it "can read in the correct chaincode" $ do + i ← readImg img + chainCode i black `shouldBe` Just agifChain diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/res/a.gif b/test/res/a.gif new file mode 100644 Binary files /dev/null and b/test/res/a.gif differ diff --git a/test/res/b.gif b/test/res/b.gif new file mode 100644 Binary files /dev/null and b/test/res/b.gif differ diff --git a/test/res/c.gif b/test/res/c.gif new file mode 100644 Binary files /dev/null and b/test/res/c.gif differ