Initial data commit

Task/Bitmap-Histogram/Haskell/bitmap-histogram-1.hs

@@ -0,0 +1,32 @@
+module Bitmap.BW(module Bitmap.BW) where
+
+import Bitmap
+import Control.Monad.ST
+
+newtype BW = BW Bool deriving (Eq, Ord)
+
+instance Color BW where
+    luminance (BW False) = 0
+    luminance _          = 255
+    black = BW False
+    white = BW True
+    toNetpbm [] = ""
+    toNetpbm l = init (concatMap f line) ++ "\n" ++ toNetpbm rest
+      where (line, rest) = splitAt 35 l
+            f (BW False) = "1 "
+            f _          = "0 "
+    fromNetpbm = map f
+      where f 1 = black
+            f _ = white
+    netpbmMagicNumber _ = "P1"
+    netpbmMaxval _ = ""
+
+toBWImage :: Color c => Image s c -> ST s (Image s BW)
+toBWImage = toBWImage' 128
+
+toBWImage' :: Color c => Int -> Image s c -> ST s (Image s BW)
+{- The first argument gives the darkest luminance assigned
+to white. -}
+toBWImage' darkestWhite = mapImage $ f . luminance
+  where f x | x < darkestWhite = black
+            | otherwise        = white

Task/Bitmap-Histogram/Haskell/bitmap-histogram-2.hs

@@ -0,0 +1,27 @@
+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)