28 lines
884 B
Haskell
28 lines
884 B
Haskell
import Bitmap
|
|
import Bitmap.RGB
|
|
import Bitmap.BW
|
|
import Bitmap.Netpbm
|
|
import Control.Monad.ST
|
|
import Data.Array
|
|
|
|
main = do
|
|
i <- readNetpbm "original.ppm" :: IO (Image RealWorld RGB)
|
|
writeNetpbm "bw.pbm" =<< stToIO (do
|
|
h <- histogram i
|
|
toBWImage' (medianIndex h) i)
|
|
|
|
histogram :: Color c => Image s c -> ST s [Int]
|
|
histogram = liftM f . getPixels where
|
|
f = elems . accumArray (+) 0 (0, 255) . map (\i -> (luminance i, 1))
|
|
|
|
medianIndex :: [Int] -> Int
|
|
{- Given a list l, finds the index i that minimizes
|
|
abs $ sum (take i l) - sum (drop i l) -}
|
|
medianIndex l = result
|
|
where (result, _, _, _, _) =
|
|
iterate f (0, 0, 0, l, reverse l) !! (length l - 1)
|
|
f (n, left, right, lL@(l : ls), rL@(r : rs)) =
|
|
if left < right
|
|
then (n + 1, left + l, right, ls, rL)
|
|
else (n, left, right + r, lL, rs)
|