Anonymous user
Zhang-Suen thinning algorithm: Difference between revisions
Add Haskell - Zhang-Suen Thinning Algorithm
(Add Haskell - Zhang-Suen Thinning Algorithm) |
|||
Line 748:
...........................................................
...........................................................</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}}==
| |||