Zhang-Suen thinning algorithm: Difference between revisions
Content added Content deleted
(Add Haskell - Zhang-Suen Thinning Algorithm) |
|||
Line 748: | Line 748: | ||
........................................................... |
........................................................... |
||
...........................................................</pre> |
...........................................................</pre> |
||
=={{header|Haskell}}== |
|||
<lang Haskell>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]</lang> |
|||
{{out}} |
|||
<pre> ####### ###### |
|||
# # ## |
|||
# # # |
|||
# # # |
|||
##### # # |
|||
## # |
|||
# # ## ## # |
|||
# #### |
|||
# ########## ####### |
|||
## # #### # |
|||
# # ## |
|||
# # # |
|||
# # # |
|||
# # # |
|||
############ # |
|||
# # # |
|||
# # # |
|||
# # # |
|||
# # # |
|||
# ## |
|||
# ############ |
|||
### ### |
|||
</pre> |
|||
=={{header|J}}== |
=={{header|J}}== |