### move inverse to lecture/ and solutions/, created exercise

parent beb640fe
 %% Cell type:markdown id: tags: # Image deconvolution ## Task Given a blurred image $y$, find the original image $x$, where $$T x = y,$$ and $T$ is a blurring operator, e.g. an operator assigns to each pixel an average of all pixels in some neighbourhood. Depending on the blurring operator, it is not clear in general whether this problem has a solution at all. A frequent approach is to replace the problem by $$\text{Minimize } {\lVert T x - y \rVert}^2 \text{ with respect to } x,$$ or equivalently $$T^* T x = T^* y.$$ This equation can e.g. be solved using CG, but it turns out to be numerically unstable: if the blurred image $y$ is distorted with some noise, the reconstruction $x$ has significantly amplified noise. ## Regularization A simple way to stablilize the problem is Tikhonov regularization, which replaces the problem by $$\text{Minimize } {\lVert T x - y \rVert}^2 + \alpha {\lVert x \rVert}^2 \text{ with respect to } x,$$ for some *regularization parameter* $\alpha > 0$ or equivalently $$(T^* T + \alpha \mathbb{1}) x = T^* y.$$ $\alpha$ has to be chosen large enough to avoid the instabilities of the problem, but small enough in order not to change the problem too much. There are several ways to choose the parameter (semi-)automatically depending on the blurred and distorted image $y$ and the noise level. Mathematically, one is interested in the question under what circumstances and how fast the regularized reconstruction converge to the true solution. For this example, we will simply choose a regularization parameter manually. ## Imports and basics %% Cell type:code id: tags:  haskell {-# OPTIONS_GHC -O3 #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} import Control.Monad.Identity import Data.Array.Repa as R hiding ((++)) import Data.Array.Repa.Eval import Data.Array.Repa.Stencil import Data.Array.Repa.Stencil.Dim2 import Data.Array.Repa.Algorithms.Pixel (doubleLuminanceOfRGB8, rgb8OfGreyDouble) import Data.Array.Repa.IO.BMP (readImageFromBMP, writeImageToBMP) import Data.Random.Normal (normalsIO')  %% Cell type:markdown id: tags: Alias, for convenience. %% Cell type:code id: tags:  haskell type Image r = Array r DIM2 Double  %% Cell type:markdown id: tags: Loading and saving of images -- rather uninteresting. %% Cell type:code id: tags:  haskell loadImage :: FilePath -> IO (Image U) loadImage file = do loaded <- readImageFromBMP file case loaded of Left err -> error $show err Right img -> computeP$ R.map doubleLuminanceOfRGB8 img saveImage :: FilePath -> Image U -> IO () saveImage file img = do !m <- foldAllP max 0 img !img' <- computeP $R.map (rgb8OfGreyDouble . (/ m)) img writeImageToBMP file img'  %% Cell type:markdown id: tags: ## Operator type class We need functions for both the blurring operator and its adjoint. This can be done nicely using a typeclass. %% Cell type:code id: tags:  haskell class Operator a where evalOp :: a -> Image U -> Image D adjointOp :: a -> Image U -> Image D  %% Cell type:markdown id: tags: ## CG solver The Repa CG solver for the regularized normal equation $$(T^* T + \alpha \mathbb{1}) x = T^* y.$$ The code tries to use as few operator evaluations as possible. %% Cell type:code id: tags:  haskell data CGState = CGState { cgx :: Image U , cgp :: Image U , cgr :: Image U , cgr2 :: Double } cgreg :: Operator a => a -> Double -> Image U -> Image U -> [CGState] cgreg op reg rhs initial = runIdentity$ do (res :: Image U) <- computeP $rhs -^ evalOp op initial rInit <- computeP$ adjointOp op res r2Init <- normSquaredP rInit return $iterate cgStep (CGState initial rInit rInit r2Init) where normSquaredP = sumAllP . R.map (^(2::Int)) scale a = R.map (* a) cgStep :: CGState -> CGState cgStep (CGState x p r r2) = runIdentity$ do !(q :: Image U) <- computeP $evalOp op p !p2 <- normSquaredP p !q2 <- normSquaredP q let alpha = r2 / (q2 + reg*p2) !x' <- computeP$ x +^ scale alpha p !(s :: Image U) <- computeP $adjointOp op q !r' <- computeP$ r -^ scale alpha (s +^ scale reg p) !r2' <- normSquaredP r' let beta = r2' / r2 !p' <- computeP $r' +^ scale beta p return$ CGState x' p' r' r2'  %% Cell type:markdown id: tags: cgreg returns a lazy list of all iterates. takeUntil is uses to implement the stopping rule; it is similar to takeWhile, but also returns the final iterate. %% Cell type:code id: tags:  haskell takeUntil :: (a -> Bool) -> [a] -> [a] takeUntil _ [] = [] takeUntil predicate (x:xs) | predicate x = [x] | otherwise = x : takeUntil predicate xs  %% Cell type:markdown id: tags: We want to be able to output some information about the iterates, i.e. run an IO action over the list of iterates, before returning the final one. One option would be something like haskell fmap last . forM iterates $\it -> do [...]  However, this would perform the fmap last only *after* the IO actions are done, therfore retaining the entire list of iterates in memory. We want all but the final iterate to be garbage collected directly after printing information. This can be done using a monadic fold, where we do not actually accumulate a result but only return the last value. %% Cell type:code id: tags:  haskell process :: Monad m => [a] -> (a -> m ()) -> m a process xs f = foldM (\_ x -> f x >> return x) undefined xs  %% Cell type:markdown id: tags: runCG wrapper that calls cg, print information and implements the stopping rule based on relative residuals. %% Cell type:code id: tags:  haskell runCG :: Operator a => Double -> a -> Double -> Image U -> IO (Image U) runCG tol op reg rhs = do let initial = computeS$ fromFunction (extent rhs) (const 0) let steps' = cgreg op reg rhs initial let r20 = cgr2 $head steps' let steps = takeUntil (\x -> sqrt (cgr2 x / r20) < tol) steps' result <- process (zip [(1::Int)..] steps)$ \(n, cgs) -> putStrLn $show n ++ " " ++ show (sqrt$ cgr2 cgs / r20) return $cgx . snd$ result  %% Cell type:markdown id: tags: ## Blurring operator The implementation of the averaging operator uses repa stencils. %% Cell type:code id: tags:  haskell data StencilOp = StencilOp { getStencil :: Stencil DIM2 Double } instance Operator StencilOp where evalOp = (delay .) . mapStencil2 (BoundConst 0) . getStencil adjointOp = evalOp mkKernel :: Int -> StencilOp mkKernel n = StencilOp $makeStencil2 n n$ \(Z:.i:.j) -> if max (abs i) (abs j) <= n then Just x else Nothing where x = 1 / fromIntegral (n*n)  %% Cell type:markdown id: tags: ## Main The main function loads an image, blurs and distorts it, and performs regularized and unregularized reconstructions. %% Cell type:code id: tags: ` haskell main :: IO () main = do img <- loadImage "grumpy.bmp" saveImage "exact.bmp" img let sh = extent img -- Repa only supports stencils of size up to 7. Efficient implementations of -- more general blurring (or other convolution) operators can be done using e.g. -- FFTs. let kernel = mkKernel 7 blurry <- computeP \$ evalOp kernel img saveImage "blurry.bmp" blurry putStrLn "blurry reconstructed" runCG 1e-3 kernel 0 blurry >>= saveImage "blurry_reconstructed.bmp"