Initial version of Floyd Steinberg Dithering

.travis.yml

@@ -36,12 +36,6 @@ matrix:
   include:
   # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:
   # https://github.com/hvr/multi-ghc-travis
-  - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
-    compiler: ": #GHC 7.8.4"
-    addons:
-      apt:
-        packages: [cabal-install-1.24,ghc-7.8.4,happy-1.19.5,alex-3.1.7]
-        sources: [hvr-ghc]
 
   - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7
     compiler: ": #GHC 7.10.3"
@@ -76,22 +70,18 @@ matrix:
   # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS
   # variable, such as using --stack-yaml to point to a different file.
 
-  - env: BUILD=stack ARGS="--stack-yaml stack.lts-3.yaml"
-    compiler: ": #stack GHC-7.10.2 (lts-3.22)"
+  - env: BUILD=stack ARGS="--stack-yaml stack.lts-6.yaml"
+    compiler: ": #stack GHC-7.10.3 (lts-6.30)"
     addons:
       apt:
         packages: [libgmp-dev]
 
-  - env: BUILD=stack ARGS="--stack-yaml stack.lts-6.yaml"
-    compiler: ": #stack GHC-7.10.3 (lts-6.30)"
+  - env: BUILD=stack ARGS="--resolver lts-7"
+    compiler: ": #stack GHC-8.0.1 (lts-7.24)"
     addons:
       apt:
         packages: [libgmp-dev]
 
-  # - env: BUILD=stack ARGS="--resolver lts-7"
-  #   compiler: ": #stack GHC-8.0.1 (lts-7)"
-  #   addons: {apt: {packages: [libgmp-dev]}}
-
   - env: BUILD=stack ARGS="--resolver lts-8.24"
     compiler: ": #stack GHC-8.0.2 (lts-8.24)"
     addons:
@@ -111,17 +101,19 @@ matrix:
         packages: [libgmp-dev]
 
   # Nightly builds are allowed to fail
-  # - env: BUILD=stack ARGS="--resolver nightly"
-  #   compiler: ": #stack nightly"
-  #   addons: {apt: {packages: [libgmp-dev]}}
+  - env: BUILD=stack ARGS="--resolver nightly"
+    compiler: ": #stack nightly"
+    addons:
+      apt:
+        packages: [libgmp-dev]
 
   # - env: BUILD=stack ARGS="--resolver lts-8"
   #   compiler: ": #stack 8.0.2 osx"
   #   os: osx
 
   allow_failures:
   - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7
-  #- env: BUILD=stack ARGS="--resolver nightly"
+  - env: BUILD=stack ARGS="--resolver nightly"
 
 branches:
   except:
@@ -152,11 +144,6 @@ before_install:
       mkdir -p $HOME/.cabal
       echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config
       echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config
-
-      # if [ "$CABALVER" != "1.16" ]
-      # then
-      #   echo 'jobs: $ncpus' >> $HOME/.cabal/config
-      # fi
       ;;
   esac
 
@@ -177,7 +164,7 @@ install:
       cabal --version
       travis_retry cabal update
 
-      # Get the list of packages from the stack.yaml file
+      # Set the list of packages we will build
       PACKAGES="$TRAVIS_BUILD_DIR"
       echo $PACKAGES
 

hip.cabal

@@ -44,6 +44,7 @@ Library
                , repa            >= 3.2.1.1 && < 4
                , temporary       >= 1.1.1
                , vector          >= 0.10
+               , array
   Other-Extensions: BangPatterns
                   , ConstraintKinds
                   , CPP
@@ -67,6 +68,8 @@ Library
                  , Graphics.Image.Processing.Binary
                  , Graphics.Image.Processing.Complex
                  , Graphics.Image.Processing.Filter
+                 , Graphics.Image.Processing.Hough
+                 , Graphics.Image.Processing.Ahe
                  , Graphics.Image.Types
   Other-Modules:   Graphics.Image.ColorSpace.Binary
                  , Graphics.Image.ColorSpace.CMYK

src/Graphics/Image/Processing/Ahe.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-} 
+
+-- | Adaptive histogram equalization is used to improve contrast in images.
+-- It adjusts image intensity in small regions (neighborhood) in the image.
+module Graphics.Image.Processing.Ahe where
+
+import Control.Monad (forM_, when)
+import Control.Monad.ST
+import Data.STRef 
+import Debug.Trace (trace)
+
+import Prelude as P hiding (subtract)
+import Graphics.Image.Processing.Filter
+import Graphics.Image.Interface as I
+import Graphics.Image
+import Graphics.Image.Types as IP
+import Graphics.Image.ColorSpace (X)
+
+-- | Supplementary function for applying border resolution and a general mask.
+simpleFilter :: (Array arr cs e, Array arr X e) => Direction -> Border (Pixel cs e) -> Filter arr cs e
+simpleFilter dir !border =
+  Filter (correlate border kernel)
+  where
+    !kernel =
+      case dir of
+        Vertical   -> fromLists $ [ [ 0, -1, 0 ], [  -1,  4,  -1 ], [  0,  -1,  0 ] ]
+        Horizontal -> fromLists $ [ [ 0, -1, 0 ], [ -1, 4, -1 ], [ 0, -1, 0 ] ]
+
+-- | 'ahe' operates on small 'contextual' regions of the image. It enhances the contrast of each
+-- region and this technique works well when the distribution of pixel values is similar throughout
+-- the image. 
+--
+-- The idea is to perform contrast enhancement in 'neighborhood region' of each pixel and the size
+-- of the region is a parameter of the method. It constitutes a characteristic length scale: contrast 
+-- at smaller scales is enhanced, while contrast at larger scales is reduced (For general purposes, a size
+-- factor of 5 tends to give pretty good results).
+--
+-- <<images/yield.jpg>>   <<images/yield_ahe.png>>
+--
+-- Usage : 
+--	
+-- >>> img <- readImageY VU "images/yield.jpg"
+-- >>> input1 <- getLine
+-- >>> input2 <- getLine
+-- >>> let thetaSz = (P.read input1 :: Int)
+-- >>> let distSz = (P.read input2 :: Int) 
+-- >>> let neighborhoodFactor = (P.read input2 :: Int) 
+-- >>> let aheImage :: Image VU RGB Double
+-- >>>     aheImage = ahe img thetaSz distSz neighborhoodFactor
+-- >>> writeImage "images/yield_ahe.png" (toImageRGB aheImage)
+--
+ahe
+  :: forall arr e cs . ( MArray arr Y Double, IP.Array arr Y Double, IP.Array arr Y Word16, MArray arr Y Word16, Array arr X Double)
+  => Image arr Y Double
+  -> Int  -- ^ width of output image
+  -> Int  -- ^ height of output image 
+  -> Int  -- ^ neighborhood size factor
+  -> Image arr Y Word16
+ahe image thetaSz distSz neighborhoodFactor = I.map (fmap toWord16) accBin
+ where
+   ip = applyFilter (simpleFilter Horizontal Edge) image  -- Pre-processing (Border resolution) 
+   widthMax, var1, heightMax, var2 :: Int
+   var1 = ((rows ip) - 1)
+   widthMax = ((rows ip) - 1)
+   var2 = ((cols ip) - 1)
+   heightMax = ((cols ip) - 1)
+
+   accBin :: Image arr Y Word16
+   accBin = runST $                -- Core part of the Algo begins here.
+     do arr <- I.new (thetaSz, distSz)   -- Create a mutable image with the given dimensions.
+        forM_ [0 .. var1] $ \x -> do
+          forM_ [0 .. var2] $ \y -> do
+            rankRef <- newSTRef (0 :: Int)
+            let neighborhood a maxValue = filter (\a -> a >= 0 && a < maxValue) [a-5 .. a+5] 
+            forM_ (neighborhood x var1) $ \i -> do
+              forM_ (neighborhood y var2) $ \j -> do  
+                 when (I.index ip (x, y) > I.index ip (i, j)) $ modifySTRef' rankRef (+1)
+            rank <- readSTRef rankRef
+            let px = ((rank * 255))  
+            I.write arr (x, y) (PixelY (fromIntegral px))
+        freeze arr   
+

src/Graphics/Image/Processing/Dithering.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-} 
+
+-- | Adaptive histogram equalization is used to improve contrast in images.
+-- It adjusts image intensity in small regions (neighborhood) in the image.
+module Graphics.Image.Processing.Dithering where
+
+import Control.Monad (forM_, when)
+import Control.Monad.ST
+import Data.STRef 
+
+
+import Prelude as P hiding (subtract)
+import Graphics.Image.Processing.Filter
+import Graphics.Image.Interface as I
+import Graphics.Image
+import Graphics.Image.Types as IP
+import Graphics.Image.ColorSpace (X)
+
+
+applyThreshold :: RealFrac x => x -> x
+applyThreshold x = 255 * fromIntegral (floor(x/128))
+
+dithering
+  :: forall arr e cs . ( MArray arr Y Double, IP.Array arr Y Double, IP.Array arr Y Double, IP.Array arr Y Word8)
+  => Image arr Y Double
+  -> Image arr Y Word8
+dithering image = I.map (fmap toWord8) accBin
+ where
+   widthMax, heightMax :: Int
+   widthMax = ((rows image) - 1)
+   heightMax = ((cols image) - 1)
+
+   accBin :: Image arr Y Double
+   accBin = runST $                
+     do arr <- I.new (widthMax + 1, heightMax + 1) 
+        forM_ [0 .. widthMax] $ \x -> do
+          forM_ [0 .. heightMax] $ \y -> do
+            let m = (I.index image (x, y))
+{-            if (m > 0.5)
+               then do let we = 1 - m
+                       I.write arr (x, y) m
+               else if (m <= 0.5)
+                       then do let be = m - 0
+                               I.write arr (x, y) m
+               else do let we = 1 - m
+                       I.write arr (x, y) m -}
+            if (x < widthMax) 
+               then do let px = ( (1-m) * 7/16)
+                       I.write arr (x+1, y) px 
+               else if (x > 1 && y < heightMax)
+                       then do let px = ((m-0) * 3/16)
+                               I.write arr (x-1, y+1) px
+               else if (x > 1 && y < heightMax)
+                       then do let px = ((1-m) * 5/16)
+                               I.write arr (x, y+1) px
+               else if (x > 1 && y < heightMax)
+                       then do let px = ((m-0) * 1/16)
+                               I.write arr (x-1, y+1) px
+               else do let px = I.index image (x, y)
+                       I.write arr (x, y) px 
+        freeze arr 
+
+test :: IO ()
+test = do
+      frog <- readImageY VU "yield.jpg"
+      writeImage "input.png" frog
+      let ditherImage :: Image VU Y Word8
+          ditherImage = dithering frog
+      writeImage "dither2.png" (toImageRGB ditherImage)  
+