Update all new Tasks

Task/Zhang-Suen-thinning-algorithm/Haskell/zhang-suen-thinning-algorithm.hs

@@ -0,0 +1,122 @@
+import Data.Array
+import qualified Data.List as List
+
+data BW = Black | White
+        deriving (Eq, Show)
+
+type Index = (Int, Int)
+type BWArray = Array Index BW
+
+toBW :: Char -> BW
+toBW '0' = White
+toBW '1' = Black
+toBW ' ' = White
+toBW '#' = Black
+toBW _   = error "toBW: illegal char"
+
+toBWArray :: [String] -> BWArray
+toBWArray strings = arr
+  where
+    height = length strings
+    width  = minimum $ map length strings
+    arr    = listArray ((0, 0), (width - 1, height - 1))
+             . map toBW . concat . List.transpose $ map (take width) strings
+
+toChar :: BW -> Char
+toChar White = ' '
+toChar Black = '#'
+
+chunksOf :: Int -> [a] -> [[a]]
+chunksOf _ [] = []
+chunksOf n xs = take n xs : (chunksOf n $ drop n xs)
+
+showBWArray :: BWArray -> String
+showBWArray arr =
+  List.intercalate "\n" . List.transpose
+  . chunksOf (height + 1) . map toChar $ elems arr
+  where
+    (_, (_, height)) = bounds arr
+
+add :: Num a => (a, a) -> (a, a) -> (a, a)
+add (a, b) (x, y) = (a + x, b + y)
+
+within :: Ord a => ((a, a), (a, a)) -> (a, a) -> Bool
+within ((a, b), (c, d)) (x, y) =
+  a <= x && x <= c &&
+  b <= y && y <= d
+
+p2, p3, p4, p5, p6, p7, p8, p9 :: Index
+p2 = ( 0, -1)
+p3 = ( 1, -1)
+p4 = ( 1,  0)
+p5 = ( 1,  1)
+p6 = ( 0,  1)
+p7 = (-1,  1)
+p8 = (-1,  0)
+p9 = (-1, -1)
+
+ixamap :: Ix i => ((i, a) -> b) -> Array i a -> Array i b
+ixamap f a = listArray (bounds a) $ map f $ assocs a
+
+thin :: BWArray -> BWArray
+thin arr =
+  if pass2 == arr then pass2 else thin pass2
+  where
+    (low, high)     = bounds arr
+    lowB            = low `add` (1, 1)
+    highB           = high `add` (-1, -1)
+    isInner         = within (lowB, highB)
+    offs p          = map (add p) [p2, p3, p4, p5, p6, p7, p8, p9]
+    trans c (a, b)  = if a == White && b == Black then c + 1 else c
+    zipshift xs     = zip xs (drop 1 xs ++ xs)
+    transitions a   = (== (1 :: Int)) . foldl trans 0 . zipshift . map (a !) . offs
+    within2to6 n    = 2 <= n && n <= 6
+    blacks a p      = within2to6 . length . filter ((== Black) . (a !)) $ offs p
+    oneWhite xs a p = any ((== White) . (a !) . add p) xs
+    oneRight        = oneWhite [p2, p4, p6]
+    oneDown         = oneWhite [p4, p6, p8]
+    oneUp           = oneWhite [p2, p4, p8]
+    oneLeft         = oneWhite [p2, p6, p8]
+    precond a p     = (a ! p == Black) && isInner p && blacks a p && transitions a p
+    stage1 a p      = precond a p && oneRight a p && oneDown a p
+    stage2 a p      = precond a p && oneUp a p && oneLeft a p
+    stager f (p, d) = if f p then White else d
+    pass1           = ixamap (stager $ stage1 arr) arr
+    pass2           = ixamap (stager $ stage2 pass1) pass1
+
+sampleExA :: [String]
+sampleExA =
+  ["00000000000000000000000000000000"
+  ,"01111111110000000111111110000000"
+  ,"01110001111000001111001111000000"
+  ,"01110000111000001110000111000000"
+  ,"01110001111000001110000000000000"
+  ,"01111111110000001110000000000000"
+  ,"01110111100000001110000111000000"
+  ,"01110011110011101111001111011100"
+  ,"01110001111011100111111110011100"
+  ,"00000000000000000000000000000000"]
+
+sampleExB :: [String]
+sampleExB =
+  ["                                                          "
+  ," #################                   #############        "
+  ," ##################               ################        "
+  ," ###################            ##################        "
+  ," ########     #######          ###################        "
+  ,"   ######     #######         #######       ######        "
+  ,"   ######     #######        #######                      "
+  ,"   #################         #######                      "
+  ,"   ################          #######                      "
+  ,"   #################         #######                      "
+  ,"   ######     #######        #######                      "
+  ,"   ######     #######        #######                      "
+  ,"   ######     #######         #######       ######        "
+  ," ########     #######          ###################        "
+  ," ########     ####### ######    ################## ###### "
+  ," ########     ####### ######      ################ ###### "
+  ," ########     ####### ######         ############# ###### "
+  ,"                                                          "]
+
+main :: IO ()
+main = mapM_ (putStrLn . showBWArray . thin . toBWArray) [sampleExA, sampleExB]