diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -133,10 +133,10 @@ Options: * `--output`: - Path of the output JPEG image with the weighted collage. + Path of the output image with the weighted collage. * `--output-hard`: - Alternative output of a JPEG collage + Alternative output of a collage where the image parts are simply averaged. You will certainly see bumps in brightness at the borders of the image parts. @@ -175,7 +175,7 @@ Options: * `--output-shaped`: - Path of the output JPEG image with smoothly blended image parts + Path of the output image with smoothly blended image parts along curves of low image difference. * `--output-shaped-hard`: @@ -196,7 +196,7 @@ General options: * `--quality`: - JPEG quality percentage for writing the images. + Quality percentage for writing images in JPEG format. # Semi-Automatic mode: inspection and correction diff --git a/patch-image.cabal b/patch-image.cabal --- a/patch-image.cabal +++ b/patch-image.cabal @@ -1,5 +1,5 @@ Name: patch-image -Version: 0.3.3.3 +Version: 0.3.4 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -28,7 +28,8 @@ . Restrictions: . - * Only supports JPEG format. + * Requires that all input pictures use the same color space + and that color channel depth is 8 bit. . * Images must be approximately correctly oriented. . @@ -41,7 +42,7 @@ README.md Source-Repository this - Tag: 0.3.3.3 + Tag: 0.3.4 Type: darcs Location: https://hub.darcs.net/thielema/patch-image/ diff --git a/src/Knead.hs b/src/Knead.hs --- a/src/Knead.hs +++ b/src/Knead.hs @@ -20,7 +20,7 @@ import Knead.Shape (Size, Vec2(Vec2), Dim1, Dim2, Shape2, Shape2ZB, Index2, Ix2, Factor2, verticalSize, verticalVal, horizontalVal) -import Knead.Color (YUV) +import Knead.Color (YUV, RGB) import Degree (Degree(Degree), getDegree) import qualified Numeric.FFTW.Rank2 as Trafo2 @@ -75,6 +75,7 @@ import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Bool8 as Bool8 +import qualified Data.Char as Char import Data.Monoid ((<>)) import Data.Maybe.HT (toMaybe) import Data.Maybe (mapMaybe, isJust, isNothing) @@ -98,10 +99,23 @@ type Plane = Phys.Array Dim2 type Planes tuple = Plane (Tuple tuple) type SymbPlane = Symb.Array Dim2 -type ColorImage a = Phys.Array Dim2 (YUV a) -type ColorImage8 = ColorImage Word8 +type Image = Phys.Array Dim2 +type GreyImage a = Image a +type GreyImage8 = GreyImage Word8 +type YUVImage a = Image (YUV a) +type YUVImage8 = YUVImage Word8 +type RGBImage a = Image (RGB a) +type RGBImage8 = RGBImage Word8 +data InColorSpace f a = + InGreySpace (f a) + | InYUVSpace (f (YUV a)) + | InRGBSpace (f (RGB a)) +type ColorImage = InColorSpace (Phys.Array Dim2) + + + shape2 :: (Integral i) => i -> i -> Dim2 shape2 height width = Vec2 @@ -109,25 +123,101 @@ (Shape.ZeroBased $ fromIntegral width) -readImage :: Verbosity -> FilePath -> IO ColorImage8 +pixelFormatName :: Pic.DynamicImage -> String +pixelFormatName pic = + case pic of + Pic.ImageY8 _ -> "Greyscale 8-bit" + Pic.ImageY16 _ -> "Greyscale 16-bit" + Pic.ImageY32 _ -> "Greyscale 32-bit" + Pic.ImageYF _ -> "Greyscale Floating Point" + Pic.ImageYA8 _ -> "Luminance + Alpha 8-bit" + Pic.ImageYA16 _ -> "Luminance + Alpha 16-bit" + Pic.ImageRGB8 _ -> "RGB 8-bit" + Pic.ImageRGB16 _ -> "RGB 16-bit" + Pic.ImageRGBA8 _ -> "RGBA 8-bit" + Pic.ImageRGBA16 _ -> "RGBA 16-bit" + Pic.ImageYCbCr8 _ -> "YCbCr 8-bit" + Pic.ImageCMYK8 _ -> "CMYK 8-bit" + Pic.ImageCMYK16 _ -> "CMYK 16-bit" + Pic.ImageRGBF _ -> "RGB Floating Point" + +noImage :: Pic.Image a +noImage = error "no image" + +failFormatMismatch :: Pic.DynamicImage -> Pic.DynamicImage -> IO a +failFormatMismatch expected got = + fail $ + "Inconsistent input pixel formats: " + ++ + printf + "Expected pixel format '%s' but got '%s'." + (pixelFormatName expected) + (pixelFormatName got) + +castImage :: + (Pic.PixelBaseComponent a ~ abase, SV.Storable abase) => + Verbosity -> String -> Pic.Image a -> IO (ComfortArray.Array Dim2 b) +castImage verbosity typ pic = do + let dat = Pic.imageData pic + CmdLine.info verbosity $ + printf "%s %dx%d, size %d\n" + typ + (Pic.imageWidth pic) + (Pic.imageHeight pic) + (SV.length dat) + return $ + ComfortArray.Array + (shape2 (Pic.imageHeight pic) (Pic.imageWidth pic)) + (castForeignPtr $ fst $ SV.unsafeToForeignPtr0 dat) + +readGreyImage :: Verbosity -> FilePath -> IO GreyImage8 +readGreyImage verbosity path = do + epic <- Pic.readImage path + case epic of + Left msg -> fail msg + Right dynpic -> + case dynpic of + Pic.ImageY8 pic -> castImage verbosity "grey" pic + _ -> failFormatMismatch (Pic.ImageY8 noImage) dynpic + +readYUVImage :: Verbosity -> FilePath -> IO YUVImage8 +readYUVImage verbosity path = do + epic <- Pic.readImage path + case epic of + Left msg -> fail msg + Right dynpic -> + case dynpic of + Pic.ImageYCbCr8 pic -> castImage verbosity "yuv" pic + _ -> failFormatMismatch (Pic.ImageYCbCr8 noImage) dynpic + +readRGBImage :: Verbosity -> FilePath -> IO RGBImage8 +readRGBImage verbosity path = do + epic <- Pic.readImage path + case epic of + Left msg -> fail msg + Right dynpic -> + case dynpic of + Pic.ImageRGB8 pic -> castImage verbosity "rgb" pic + _ -> failFormatMismatch (Pic.ImageRGB8 noImage) dynpic + +readImage :: Verbosity -> FilePath -> IO (ColorImage Word8) readImage verbosity path = do epic <- Pic.readImage path case epic of - Left msg -> ioError $ userError msg + Left msg -> fail msg Right dynpic -> case dynpic of - Pic.ImageYCbCr8 pic -> do - let dat = Pic.imageData pic - CmdLine.info verbosity $ - printf "yuv %dx%d, size %d\n" - (Pic.imageWidth pic) - (Pic.imageHeight pic) - (SV.length dat) - return $ - ComfortArray.Array - (shape2 (Pic.imageHeight pic) (Pic.imageWidth pic)) - (castForeignPtr $ fst $ SV.unsafeToForeignPtr0 dat) - _ -> ioError $ userError "unsupported image type" + Pic.ImageY8 pic -> + fmap InGreySpace $ castImage verbosity "grey" pic + Pic.ImageYCbCr8 pic -> + fmap InYUVSpace $ castImage verbosity "yuv" pic + Pic.ImageRGB8 pic -> + fmap InRGBSpace $ castImage verbosity "rgb" pic + _ -> + fail $ + printf + "color space '%s' unsupported or more than 8 bit" + (pixelFormatName dynpic) vectorStorableFrom :: @@ -150,17 +240,35 @@ Pic.imageData = vectorStorableFrom castArray img } -writeImage :: Int -> FilePath -> ColorImage8 -> IO () -writeImage quality path img = - Pic.saveJpgImage quality path $ Pic.ImageYCbCr8 $ +saveImage :: Int -> FilePath -> Pic.DynamicImage -> IO () +saveImage quality path img = + case map Char.toLower $ FilePath.takeExtension path of + ".png" -> Pic.savePngImage path img + ".jpg" -> Pic.saveJpgImage quality path img + ".jpeg" -> Pic.saveJpgImage quality path img + ".bmp" -> Pic.saveBmpImage path img + ".gif" -> either fail id $ Pic.saveGifImage path img + ".tiff" -> Pic.saveTiffImage path img + ".tif" -> Pic.saveTiffImage path img + ".hdr" -> Pic.saveRadianceImage path img + ext -> fail $ "Unknown file name extension: " ++ ext + +writeYUVImage :: Int -> FilePath -> YUVImage8 -> IO () +writeYUVImage quality path img = + saveImage quality path $ Pic.ImageYCbCr8 $ imageFromArray castForeignPtr img +writeRGBImage :: Int -> FilePath -> RGBImage8 -> IO () +writeRGBImage quality path img = + Pic.saveJpgImage quality path $ Pic.ImageRGB8 $ + imageFromArray castForeignPtr img + writeGrey :: Int -> FilePath -> Plane Word8 -> IO () writeGrey quality path img = - Pic.saveJpgImage quality path $ Pic.ImageY8 $ imageFromArray id img + saveImage quality path $ Pic.ImageY8 $ imageFromArray id img -colorImageExtent :: ColorImage8 -> (Size, Size) +colorImageExtent :: Image a -> (Size, Size) colorImageExtent pic = case Phys.shape pic of Vec2 (Shape.ZeroBased height) (Shape.ZeroBased width) -> (width, height) @@ -203,6 +311,15 @@ imageByteFromFloat = Symb.map byteFromFloat +yuvImageFloatFromByte :: + (Symb.C array, Shape.C sh, + NiceValue.NativeFloating a ar, a ~ ar, + NiceValue.PseudoRing a, NiceValue.Real a, + NiceValue.RationalConstant a) => + array sh (YUV Word8) -> array sh (YUV a) +yuvImageFloatFromByte = Symb.map $ Color.map floatFromByte + + yuvByteFromFloat :: (NiceValue.NativeFloating a ar, a ~ ar, NiceValue.Field a, NiceValue.Real a, @@ -210,23 +327,75 @@ Exp (YUV a) -> Exp (YUV Word8) yuvByteFromFloat = Color.map byteFromFloat -colorImageFloatFromByte :: - (Symb.C array, Shape.C sh, - NiceValue.NativeFloating a ar, a ~ ar, - NiceValue.PseudoRing a, NiceValue.Real a, - NiceValue.RationalConstant a) => - array sh (YUV Word8) -> array sh (YUV a) -colorImageFloatFromByte = Symb.map $ Color.map floatFromByte - -colorImageByteFromFloat :: +yuvImageByteFromFloat :: (Symb.C array, Shape.C sh, NiceValue.NativeFloating a ar, a ~ ar, NiceValue.Field a, NiceValue.Real a, NiceValue.RationalConstant a) => array sh (YUV a) -> array sh (YUV Word8) -colorImageByteFromFloat = Symb.map yuvByteFromFloat +yuvImageByteFromFloat = Symb.map yuvByteFromFloat +yuvBrightnessFromByte :: Exp (YUV Word8) -> Exp Float +yuvBrightnessFromByte = floatFromByte . Color.luma + +rgbBrightnessFromByte :: Exp (RGB Word8) -> Exp Float +rgbBrightnessFromByte = Color.brightness . Color.map floatFromByte + + + +data ColorSpaceDict v8 a v = + ColorSpaceDict { + csFloatFromByte :: Exp v8 -> Exp v, + csByteFromFloat :: Exp v -> Exp v8, + csBrightness :: Exp v -> Exp a, + csBrightnessFromByte :: Exp v8 -> Exp a, + csVectorSpace :: VecExp a v + } + +csImageFloatFromByte :: + (Shape.C sh) => + ColorSpaceDict v8 a v -> Symb.Array sh v8 -> Symb.Array sh v +csImageFloatFromByte cs = Symb.map (csFloatFromByte cs) + +csImageByteFromFloat :: + (Shape.C sh) => + ColorSpaceDict v8 a v -> Symb.Array sh v -> Symb.Array sh v8 +csImageByteFromFloat cs = Symb.map (csByteFromFloat cs) + + +greyColorSpaceDict :: ColorSpaceDict Word8 Float Float +greyColorSpaceDict = + ColorSpaceDict { + csFloatFromByte = floatFromByte, + csByteFromFloat = byteFromFloat, + csBrightness = id, + csBrightnessFromByte = floatFromByte, + csVectorSpace = vecGrey + } + +yuvColorSpaceDict :: ColorSpaceDict (YUV Word8) Float (YUV Float) +yuvColorSpaceDict = + ColorSpaceDict { + csFloatFromByte = Color.map floatFromByte, + csByteFromFloat = yuvByteFromFloat, + csBrightness = Color.brightness, + csBrightnessFromByte = yuvBrightnessFromByte, + csVectorSpace = vecC3 + } + +rgbColorSpaceDict :: ColorSpaceDict (RGB Word8) Float (RGB Float) +rgbColorSpaceDict = + ColorSpaceDict { + csFloatFromByte = Color.map floatFromByte, + csByteFromFloat = Color.map byteFromFloat, + csBrightness = Color.brightness, + csBrightnessFromByte = rgbBrightnessFromByte, + csVectorSpace = vecC3 + } + + + fastRound :: (NiceValue.NativeInteger i ir, NiceValue.NativeFloating a ar) => Exp a -> Exp i @@ -307,11 +476,19 @@ type VecExp a v = Arith.Vec (Exp a) (Exp v) -vecYUV :: +vecGrey :: (NiceValue.PseudoRing a) => VecExp a a +vecGrey = + Arith.Vec { + Arith.vecZero = Expr.zero, + Arith.vecAdd = Expr.add, + Arith.vecScale = Expr.mul + } + +vecC3 :: (NiceValue.PseudoRing a, LLVM.IsArithmetic a, LLVM.IsPrimitive a, LLVM.IsConst a, NiceValue.Repr a ~ LLVM.Value a) => - VecExp a (YUV a) -vecYUV = + VecExp a (Color.C3 space a) +vecC3 = Arith.Vec { Arith.vecZero = Expr.zero, Arith.vecAdd = Expr.liftReprM2 LLVMArith.add, @@ -488,30 +665,23 @@ img -runRotate :: IO (Degree Float -> ColorImage8 -> IO ColorImage8) +runRotate :: IO (Degree Float -> YUVImage8 -> IO YUVImage8) runRotate = do rot <- RenderP.run $ \rot -> - colorImageByteFromFloat . rotate vecYUV rot . colorImageFloatFromByte + yuvImageByteFromFloat . rotate vecC3 rot . yuvImageFloatFromByte return $ \ angle img -> rot (Degree.cis angle) img -brightnessPlane :: - (Symb.C array, Shape.C size) => - (LLVM.IsPrimitive a, NiceValue.Repr a ~ LLVM.Value a) => - array size (YUV a) -> array size a -brightnessPlane = Symb.map Color.brightness - rowHistogram :: (Symb.C array, NiceValue.Additive a) => (LLVM.IsPrimitive a, NiceValue.Repr a ~ LLVM.Value a) => - array Dim2 (YUV a) -> array Dim1 a + array Dim2 a -> array Dim1 a rowHistogram = Symb.fold1 Expr.add . ShapeDep.backpermute (Expr.modify atomDim2 $ \(Vec2 h w) -> (h,w)) - (Expr.modify (atom,atom) $ \(y,x) -> Vec2 y x) . - brightnessPlane + (Expr.modify (atom,atom) $ \(y,x) -> Vec2 y x) tailArr :: (Symb.C array) => array Dim1 a -> array Dim1 a @@ -529,17 +699,23 @@ scoreHistogram = Symb.fold1All Expr.add . Symb.map Expr.sqr . differentiate -runScoreRotation :: IO (Degree Float -> ColorImage8 -> IO Float) -runScoreRotation = do +runScoreRotation :: + (Storable.C v) => + (Exp v -> Exp Float) -> + IO (Degree Float -> Image v -> IO Float) +runScoreRotation brightness = do rot <- RenderP.run $ \rot -> - rowHistogram . rotate vecYUV rot . colorImageFloatFromByte + rowHistogram . rotate vecGrey rot . Symb.map brightness score <- RenderP.run scoreHistogram return $ \ angle img -> score =<< rot (Degree.cis angle) img -findOptimalRotation :: IO ([Degree Float] -> ColorImage8 -> IO (Degree Float)) -findOptimalRotation = do - scoreRotation <- runScoreRotation +findOptimalRotation :: + (Storable.C v) => + (Exp v -> Exp Float) -> + IO ([Degree Float] -> Image v -> IO (Degree Float)) +findOptimalRotation brightness = do + scoreRotation <- runScoreRotation brightness return $ \angles pic -> fmap (fst . List.maximumBy (comparing snd)) $ forM angles $ \angle -> (,) angle <$> scoreRotation angle pic @@ -647,9 +823,11 @@ prepareOverlapMatching :: - IO (Int -> (Degree Float, ColorImage8) -> IO ((Float, Float), Plane Float)) -prepareOverlapMatching = do - bright <- RenderP.run $ brightnessPlane . colorImageFloatFromByte . Symb.fix + (Storable.C v8) => + (Exp v8 -> Exp Float) -> + IO (Int -> (Degree Float, Image v8) -> IO ((Float, Float), Plane Float)) +prepareOverlapMatching brightness = do + bright <- RenderP.run $ Symb.map brightness . Symb.fix hp <- highpassMulti rotat <- RenderP.run $ rotate Arith.vecScalar return $ \radius (angle, img) -> @@ -1037,28 +1215,34 @@ (Expr.ifThenElse inPicB (b!pb) (Arith.vecZero vec)) composeOverlap :: + (Storable.C v8, Storable.C v) => + ColorSpaceDict v8 Float v -> IO ((Size, Size) -> - ((Degree Float, ColorImage8), (Degree Float, ColorImage8)) -> - IO ColorImage8) -composeOverlap = do + ((Degree Float, Image v8), (Degree Float, Image v8)) -> + IO (Image v8)) +composeOverlap cs = do + let vec = csVectorSpace cs over <- RenderP.run $ \displacement (ra, picA) (rb, picB) -> - colorImageByteFromFloat $ - overlap2 vecYUV displacement - (rotate vecYUV ra $ colorImageFloatFromByte picA, - rotate vecYUV rb $ colorImageFloatFromByte picB) + csImageByteFromFloat cs $ + overlap2 vec displacement + (rotate vec ra $ csImageFloatFromByte cs picA, + rotate vec rb $ csImageFloatFromByte cs picB) return $ \displacement ((angleA,picA), (angleB,picB)) -> over displacement (Degree.cis angleA, picA) (Degree.cis angleB, picB) -emptyCountCanvas :: IO (Dim2 -> IO (Planes (Word32, YUV Float))) -emptyCountCanvas = - RenderP.run $ \sh -> Symb.fill sh (Expr.tuple $ Expr.zip 0 $ Color.yuv 0 0 0) +emptyCountCanvas :: + (Storable.C v) => + VecExp a v -> IO (Dim2 -> IO (Planes (Word32, v))) +emptyCountCanvas vec = + RenderP.run $ \sh -> + Symb.fill sh (Expr.tuple $ Expr.zip 0 $ Arith.vecZero vec) -type RotatedImage = ((Float,Float), (Float,Float), ColorImage8) +type RotatedImage v8 = ((Float,Float), (Float,Float), Image v8) addToCountCanvas :: (NiceValue.PseudoRing a, NiceValue.NativeFloating a ar) => @@ -1074,23 +1258,29 @@ Arith.vecScale vec (Expr.floatFromBool8 mask) pic)) updateCountCanvas :: - IO (RotatedImage -> Planes (Word32, YUV Float) -> - IO (Planes (Word32, YUV Float))) -updateCountCanvas = + (Storable.C v8, Storable.C v) => + ColorSpaceDict v8 Float v -> + IO (RotatedImage v8 -> Planes (Word32, v) -> + IO (Planes (Word32, v))) +updateCountCanvas cs = RenderP.run $ \(rot, mov, pic) countCanvas -> Symb.map Expr.tuple $ - addToCountCanvas vecYUV - (rotateStretchMove vecYUV rot mov (Symb.shape countCanvas) $ - colorImageFloatFromByte pic) + addToCountCanvas (csVectorSpace cs) + (rotateStretchMove (csVectorSpace cs) rot mov (Symb.shape countCanvas) + $ + csImageFloatFromByte cs pic) (Symb.map Expr.untuple countCanvas) -finalizeCountCanvas :: IO (Planes (Word32, YUV Float) -> IO ColorImage8) -finalizeCountCanvas = +finalizeCountCanvas :: + (Storable.C v8, Storable.C v) => + ColorSpaceDict v8 Float v -> + IO (Planes (Word32, v) -> IO (Image v8)) +finalizeCountCanvas cs = RenderP.run $ - colorImageByteFromFloat . + csImageByteFromFloat cs . Symb.map (Expr.modify (Tuple (atom,atom)) $ \(Tuple (count, pixel)) -> - Arith.vecScale vecYUV (recip $ fromInt count) pixel) . + Arith.vecScale (csVectorSpace cs) (recip $ fromInt count) pixel) . Symb.fix @@ -1098,58 +1288,70 @@ diffAbs = Expr.liftM2 $ \x y -> NiceValue.abs =<< NiceValue.sub x y diffWithCanvas :: - IO (RotatedImage -> Plane (YUV Float) -> IO (Planes (Bool8, Float))) -diffWithCanvas = + (Storable.C v8, Storable.C v) => + ColorSpaceDict v8 Float v -> + IO (RotatedImage v8 -> Plane v -> IO (Planes (Bool8, Float))) +diffWithCanvas cs = RenderP.run $ \(rot, mov, pic) avg -> Symb.zipWith (Expr.modify2 (atom,atom) atom $ \(b,x) y -> - Tuple (b, diffAbs (Color.brightness x) (Color.brightness y))) - (rotateStretchMove vecYUV rot mov (Symb.shape avg) $ - colorImageFloatFromByte pic) + Tuple (b, diffAbs (csBrightness cs x) (csBrightness cs y))) + (rotateStretchMove (csVectorSpace cs) rot mov (Symb.shape avg) $ + csImageFloatFromByte cs pic) avg finalizeCountCanvasFloat :: - IO ((Planes (Word32, YUV Float)) -> IO (Plane (YUV Float))) -finalizeCountCanvasFloat = + (Storable.C v) => + VecExp Float v -> IO ((Planes (Word32, v)) -> IO (Plane v)) +finalizeCountCanvasFloat vec = RenderP.run $ Symb.map (Expr.modify (Tuple (atom,atom)) $ \(Tuple (count, pixel)) -> - Arith.vecScale vecYUV (recip $ fromInt count) pixel) + Arith.vecScale vec (recip $ fromInt count) pixel) . Symb.fix -emptyCanvas :: IO (Dim2 -> IO ColorImage8) -emptyCanvas = RenderP.run $ \sh -> Symb.fill sh (Color.yuv 0 0 0) +emptyCanvas :: + (Storable.C v8, Storable.C v) => + ColorSpaceDict v8 Float v -> + IO (Dim2 -> IO (Image v8)) +emptyCanvas cs = RenderP.run $ \sh -> + Symb.fill sh $ csByteFromFloat cs $ Arith.vecZero $ csVectorSpace cs addMaskedToCanvas :: - IO (RotatedImage -> + (Storable.C v8, Storable.C v) => + ColorSpaceDict v8 Float v -> + IO (RotatedImage v8 -> Plane Bool8 -> - ColorImage8 -> - IO ColorImage8) -addMaskedToCanvas = + Image v8 -> + IO (Image v8)) +addMaskedToCanvas cs = RenderP.run $ \(rot, mov, pic) mask canvas -> Symb.zipWith3 Expr.ifThenElse (Symb.map Expr.boolPFrom8 mask) - (Symb.map (yuvByteFromFloat . Expr.snd) $ - rotateStretchMove vecYUV rot mov (Symb.shape canvas) $ - colorImageFloatFromByte pic) + (Symb.map (csByteFromFloat cs . Expr.snd) $ + rotateStretchMove (csVectorSpace cs) rot mov (Symb.shape canvas) $ + csImageFloatFromByte cs pic) canvas updateShapedCanvas :: - IO (RotatedImage -> + (Storable.C v8, Storable.C v) => + ColorSpaceDict v8 Float v -> + IO (RotatedImage v8 -> Plane Float -> - Planes (Float, YUV Float) -> - IO (Planes (Float, YUV Float))) -updateShapedCanvas = + Planes (Float, v) -> + IO (Planes (Float, v))) +updateShapedCanvas cs = RenderP.run $ \(rot, mov, pic) shape weightCanvas -> Symb.map Expr.tuple $ - addToWeightedCanvas vecYUV + addToWeightedCanvas (csVectorSpace cs) (Symb.zipWith (Expr.modify2 atom (atom,atom) $ \s (b,x) -> (Expr.floatFromBool8 b * s, x)) shape $ - rotateStretchMove vecYUV rot mov (Symb.shape weightCanvas) $ - colorImageFloatFromByte pic) + rotateStretchMove (csVectorSpace cs) rot mov (Symb.shape weightCanvas) + $ + csImageFloatFromByte cs pic) (Symb.map Expr.untuple weightCanvas) @@ -1439,10 +1641,12 @@ Symb.map (pow gamma) $ distanceMap sh this others points -emptyWeightedCanvas :: IO (Dim2 -> IO (Planes (Float, YUV Float))) -emptyWeightedCanvas = +emptyWeightedCanvas :: + (Storable.C v) => + VecExp Float v -> IO (Dim2 -> IO (Planes (Float, v))) +emptyWeightedCanvas vec = RenderP.run $ \sh -> - Symb.fill sh $ Expr.tuple $ Expr.zip 0 $ Color.yuv 0 0 0 + Symb.fill sh $ Expr.tuple $ Expr.zip 0 $ Arith.vecZero vec addToWeightedCanvas :: (NiceValue.PseudoRing a, NiceValue.NativeFloating a ar) => @@ -1458,14 +1662,16 @@ Arith.vecAdd vec canvas $ Arith.vecScale vec weight pic)) updateWeightedCanvas :: + (Storable.C v8, Storable.C v) => + ColorSpaceDict v8 Float v -> IO (Float -> Geometry Float -> [Geometry Float] -> [Arith.Point2 Float] -> - ColorImage8 -> - Planes (Float, YUV Float) -> - IO (Planes (Float, YUV Float))) -updateWeightedCanvas = do + Image v8 -> + Planes (Float, v) -> + IO (Planes (Float, v))) +updateWeightedCanvas cs = do distances <- RenderP.run $ \gamma shape this -> @@ -1476,12 +1682,12 @@ RenderP.run $ \this pic dist weightSumCanvas -> let (rot, mov, _) = Expr.unzip3 this in Symb.map Expr.tuple $ - addToWeightedCanvas vecYUV + addToWeightedCanvas (csVectorSpace cs) (Symb.zip dist $ Symb.map Expr.snd $ - rotateStretchMove vecYUV rot mov + rotateStretchMove (csVectorSpace cs) rot mov (Symb.shape weightSumCanvas) $ - colorImageFloatFromByte pic) + csImageFloatFromByte cs pic) (Symb.map Expr.untuple weightSumCanvas) return $ \gamma this others points pic weightSumCanvas -> do @@ -1493,40 +1699,46 @@ update this pic dists weightSumCanvas -finalizeWeightedCanvas :: IO (Planes (Float, YUV Float) -> IO ColorImage8) -finalizeWeightedCanvas = +finalizeWeightedCanvas :: + (Storable.C v8, Storable.C v) => + ColorSpaceDict v8 Float v -> + IO (Planes (Float, v) -> IO (Image v8)) +finalizeWeightedCanvas cs = RenderP.run $ - colorImageByteFromFloat . + csImageByteFromFloat cs . Symb.map (Expr.modify (Tuple (atom,atom)) $ \(Tuple (weightSum, pixel)) -> - Arith.vecScale vecYUV (recip weightSum) pixel) . + Arith.vecScale (csVectorSpace cs) (recip weightSum) pixel) . Symb.fix data - Picture param = + Picture param v8 = Picture { picPath :: FilePath, picParam :: param, - picColored :: (Degree Float, ColorImage8), + picColored :: (Degree Float, Image v8), picPlane :: ((Float, Float), Plane Float) } -mapPicParam :: (a -> b) -> Picture a -> Picture b +mapPicParam :: (a -> b) -> Picture a v8 -> Picture b v8 mapPicParam f pic = pic{picParam = f $ picParam pic} processOverlap :: + (Storable.C v8, Storable.C v) => Option.Args -> - IO ([FilePath], [(Degree Float, ColorImage8)], + ColorSpaceDict v8 Float v -> + (Int -> FilePath -> Image v8 -> IO ()) -> + PictureList (State.NoAngleCorrection, (Maybe Float, Maybe Float)) v8 -> + IO ([FilePath], [(Degree Float, Image v8)], [((Float, Float), Complex Float)]) -processOverlap args = do +processOverlap args cs writeImage (PictureList rotPics) = do let opt = Option.option args let info = CmdLine.info (Option.verbosity opt) - pics <- - map (mapPicParam (\(State.NoAngleCorrection, pos) -> pos)) <$> - processRotation args + let pics = + map (mapPicParam (\(State.NoAngleCorrection, pos) -> pos)) rotPics let padSize = Shape.ZeroBased $ fromIntegral $ Option.padSize opt (maybeAllOverlapsShared, optimalOverlapShared) <- case Just $ Vec2 padSize padSize of @@ -1550,7 +1762,7 @@ (State.readDisplacement (map picPath pics)) (Option.relations opt) - composeOver <- composeOverlap + composeOver <- composeOverlap cs overlapDiff <- overlapDifferenceRun let open = map ((\(mx,my) -> isNothing mx || isNothing my) . picParam) pics displacements <- @@ -1624,16 +1836,15 @@ processOverlapRotate :: Option.Args -> - IO ([FilePath], [(Degree Float, ColorImage8)], + PictureList (State.AngleCorrection, (Maybe Float, Maybe Float)) v8 -> + IO ([FilePath], [(Degree Float, Image v8)], [((Float, Float), Complex Float)]) -processOverlapRotate args = do +processOverlapRotate args (PictureList rotPics) = do let opt = Option.option args let info = CmdLine.info (Option.verbosity opt) let infoPlain = when (Option.verbosity opt >= Verbosity.verbose) . putStr - pics <- - map (mapPicParam (mapFst State.getAngleCorrection)) <$> - processRotation args + let pics = map (mapPicParam (mapFst State.getAngleCorrection)) rotPics let padSize = Option.padSize opt let stampSize = Option.stampSize opt optimalOverlapShared <- @@ -1713,36 +1924,117 @@ return (map picPath pics, map picColored pics, posRots) +runRotater :: + (angleCorr ~ Degree Float) => + Option.Option -> + ([angleCorr] -> pic -> IO angleCorr) -> + FilePath -> + Maybe angleCorr -> pic -> IO (angleCorr, pic) +runRotater opt findOptRot path maybeAngle pic = do + let info = CmdLine.info (Option.verbosity opt) + let maxAngle = Option.maximumAbsoluteAngle opt + let angles = Degree.linearScale (Option.numberAngleSteps opt) maxAngle + angle <- + case maybeAngle of + Just angle -> return angle + Nothing -> findOptRot angles pic + info $ printf "%s %f\176\n" path (getDegree angle) + return (angle, pic) + +-- alternatively we could use Functor.Compose DecoratedList Plane +newtype ImageList a v8 = ImageList [(a, ComfortArray.Array Dim2 v8)] + +imageListMetadata :: InColorSpace (ImageList a) v8 -> [a] +imageListMetadata x = + case x of + InGreySpace (ImageList xs) -> map fst xs + InYUVSpace (ImageList xs) -> map fst xs + InRGBSpace (ImageList xs) -> map fst xs + +newtype PictureList a v8 = PictureList [Picture a v8] + processRotation :: (State.AngleCorrected angleCorr) => - Option.Args -> IO [Picture (angleCorr, (Maybe Float, Maybe Float))] + Option.Args -> + IO (InColorSpace (PictureList (angleCorr, (Maybe Float, Maybe Float))) Word8) processRotation args = do let opt = Option.option args let notice = CmdLine.notice (Option.verbosity opt) - let info = CmdLine.info (Option.verbosity opt) inputs <- Option.images args notice "\nfind rotation angles\n" - findOptRot <- findOptimalRotation picAngles <- - forM inputs $ \(State.Proposed path (maybeAngle, _) _) -> do - pic <- readImage (Option.verbosity opt) path - let maxAngle = Option.maximumAbsoluteAngle opt - let angles = Degree.linearScale (Option.numberAngleSteps opt) maxAngle - angle <- - case maybeAngle of - Just angle -> return angle - Nothing -> findOptRot angles pic - info $ printf "%s %f\176\n" path (getDegree angle) - return (angle, pic) + case inputs of + [] -> do + return $ InGreySpace $ ImageList [] + State.Proposed path0 (maybeAngle0, _) _ : inputs0 -> do + let retrieveImagesAndRotationInColorSpace :: + (Storable.C v8) => + (Exp v8 -> Exp Float) -> + (Verbosity -> FilePath -> IO (Image v8)) -> + Image v8 -> IO (ImageList (Degree Float) v8) + retrieveImagesAndRotationInColorSpace + brightnessFromByte readSpecImage pic0 = do + findOptRot <- findOptimalRotation brightnessFromByte + fmap ImageList $ + liftA2 (:) + (runRotater opt findOptRot path0 maybeAngle0 pic0) + (forM inputs0 $ + \(State.Proposed path (maybeAngle, _) _) -> do + pic <- readSpecImage (Option.verbosity opt) path + runRotater opt findOptRot path maybeAngle pic) + + dynpic0 <- readImage (Option.verbosity opt) path0 + case dynpic0 of + InGreySpace pic0 -> + fmap InGreySpace $ + retrieveImagesAndRotationInColorSpace + floatFromByte readGreyImage pic0 + InYUVSpace pic0 -> + fmap InYUVSpace $ + retrieveImagesAndRotationInColorSpace + yuvBrightnessFromByte readYUVImage pic0 + InRGBSpace pic0 -> + fmap InRGBSpace $ + retrieveImagesAndRotationInColorSpace + rgbBrightnessFromByte readRGBImage pic0 + forM_ (Option.outputState opt) $ \format -> State.write (printf format "angle") $ - zipWith State.Angle (map State.propPath inputs) (map fst picAngles) + zipWith State.Angle + (map State.propPath inputs) + (imageListMetadata picAngles) + case picAngles of + InGreySpace picAnglesGrey -> + fmap InGreySpace $ + processRotationInColorSpace args + inputs picAnglesGrey floatFromByte + InYUVSpace picAnglesYUV -> + fmap InYUVSpace $ + processRotationInColorSpace args + inputs picAnglesYUV yuvBrightnessFromByte + InRGBSpace picAnglesRGB -> + fmap InRGBSpace $ + processRotationInColorSpace args + inputs picAnglesRGB rgbBrightnessFromByte + +processRotationInColorSpace :: + (Storable.C v8) => + Option.Args -> + [State.Proposed a] -> + ImageList (Degree Float) v8 -> + (Exp v8 -> Exp Float) -> + IO (PictureList (a, (Maybe Float, Maybe Float)) v8) +processRotationInColorSpace args + inputs (ImageList picAngles) brightnessFromByte = do + let opt = Option.option args + let notice = CmdLine.notice (Option.verbosity opt) + notice "\nfind relative placements\n" - prepOverlapMatching <- prepareOverlapMatching + prepOverlapMatching <- prepareOverlapMatching brightnessFromByte rotated <- mapM (prepOverlapMatching (Option.smooth opt)) picAngles when False $ do @@ -1769,7 +2061,7 @@ writeGrey (Option.quality opt) "/tmp/convolution.jpeg" =<< (makeByteImage 0.1 =<< correlate pic0 pic1) - return $ + return $ PictureList $ zipWith3 (\(State.Proposed path (_,angleCorr) maybePos) colored plane -> Picture path (angleCorr, maybePos) colored plane) @@ -1780,15 +2072,46 @@ IO.hSetBuffering IO.stdout IO.LineBuffering IO.hSetBuffering IO.stderr IO.LineBuffering + if Option.finetuneRotate (Option.option args) + then do + picsCS <- processRotation args + case picsCS of + InGreySpace pics -> + processInColorSpace args greyColorSpaceDict writeGrey + =<< processOverlapRotate args pics + InYUVSpace pics -> + processInColorSpace args yuvColorSpaceDict writeYUVImage + =<< processOverlapRotate args pics + InRGBSpace pics -> + processInColorSpace args rgbColorSpaceDict writeRGBImage + =<< processOverlapRotate args pics + else do + picsCS <- processRotation args + case picsCS of + InGreySpace pics -> + processInColorSpace args greyColorSpaceDict writeGrey + =<< processOverlap args greyColorSpaceDict writeGrey pics + InYUVSpace pics -> + processInColorSpace args yuvColorSpaceDict writeYUVImage + =<< processOverlap args yuvColorSpaceDict writeYUVImage pics + InRGBSpace pics -> + processInColorSpace args rgbColorSpaceDict writeRGBImage + =<< processOverlap args rgbColorSpaceDict writeRGBImage pics + +processInColorSpace :: + (Storable.C v8, Storable.C v) => + Option.Args -> + ColorSpaceDict v8 Float v -> + (Int -> FilePath -> Image v8 -> IO ()) -> + ([FilePath], + [(Degree Float, Image v8)], + [((Float, Float), Complex Float)]) -> + IO () +processInColorSpace args cs writeImage (paths, picAngles, posRots) = do let opt = Option.option args let notice = CmdLine.notice (Option.verbosity opt) let info = CmdLine.info (Option.verbosity opt) - (paths, picAngles, posRots) <- - if Option.finetuneRotate opt - then processOverlapRotate args - else processOverlap args - forM_ (Option.outputState opt) $ \format -> State.write (printf format "position") $ zipWith3 @@ -1804,10 +2127,11 @@ let canvasShape = shape2 canvasHeight canvasWidth mapM_ info canvasMsgs + let vec = csVectorSpace cs forM_ (Option.outputHard opt) $ \path -> do - emptyCanv <- emptyCountCanvas - updateCanv <- updateCountCanvas - finalizeCanv <- finalizeCountCanvas + emptyCanv <- emptyCountCanvas vec + updateCanv <- updateCountCanvas cs + finalizeCanv <- finalizeCountCanvas cs empty <- emptyCanv canvasShape writeImage (Option.quality opt) path =<< finalizeCanv =<< @@ -1850,9 +2174,9 @@ forM_ (Option.output opt) $ \path -> do notice "\nweighted composition\n" - emptyCanv <- emptyWeightedCanvas - updateCanv <- updateWeightedCanvas - finalizeCanv <- finalizeWeightedCanvas + emptyCanv <- emptyWeightedCanvas vec + updateCanv <- updateWeightedCanvas cs + finalizeCanv <- finalizeWeightedCanvas cs empty <- emptyCanv canvasShape writeImage (Option.quality opt) path =<< finalizeCanv =<< @@ -1864,15 +2188,15 @@ when (isJust (Option.outputShaped opt) || isJust (Option.outputShapedHard opt)) $ do notice "\nmatch shapes\n" - emptyCanv <- emptyCountCanvas - updateCanv <- updateCountCanvas - finalizeCanv <- finalizeCountCanvasFloat + emptyCanv <- emptyCountCanvas vec + updateCanv <- updateCountCanvas cs + finalizeCanv <- finalizeCountCanvasFloat vec empty <- emptyCanv canvasShape sumImg <- foldM (flip updateCanv) empty rotMovPics avg <- finalizeCanv sumImg - diff <- diffWithCanvas + diff <- diffWithCanvas cs picDiffs <- mapM (flip diff avg) rotMovPics getSnd <- RenderP.run $ Symb.map (Expr.snd . Expr.untuple) . Symb.fix lp <- lowpassMulti @@ -1896,8 +2220,8 @@ arrayVecFromPair $ ComfortArray.map (\b -> if Bool8.toBool b then 255 else 0) shape - emptyPlainCanv <- emptyCanvas - addMasked <- addMaskedToCanvas + emptyPlainCanv <- emptyCanvas cs + addMasked <- addMaskedToCanvas cs emptyPlain <- emptyPlainCanv canvasShape writeImage (Option.quality opt) path =<< foldM @@ -1917,9 +2241,9 @@ writeGrey (Option.quality opt) (printf format name) =<< makeByteImage shape - emptyWeightedCanv <- emptyWeightedCanvas - updateWeightedCanv <- updateShapedCanvas - finalizeWeightedCanv <- finalizeWeightedCanvas + emptyWeightedCanv <- emptyWeightedCanvas vec + updateWeightedCanv <- updateShapedCanvas cs + finalizeWeightedCanv <- finalizeWeightedCanvas cs emptyWeighted <- emptyWeightedCanv canvasShape writeImage (Option.quality opt) path =<< finalizeWeightedCanv =<< @@ -1932,16 +2256,16 @@ rotateTest :: IO () rotateTest = do rot <- runRotate - img <- readImage Verbosity.normal "/tmp/bild/artikel0005.jpeg" + img <- readYUVImage Verbosity.normal "/tmp/bild/artikel0005.jpeg" forM_ [0..11] $ \k -> do let path = printf "/tmp/rotated/%04d.jpeg" k putStrLn path - writeImage 100 path =<< rot (Degree $ fromInteger k * 30) img + writeYUVImage 100 path =<< rot (Degree $ fromInteger k * 30) img scoreTest :: IO () scoreTest = do - score <- runScoreRotation - img <- readImage Verbosity.normal "/tmp/bild/artikel0005.jpeg" + score <- runScoreRotation yuvBrightnessFromByte + img <- readYUVImage Verbosity.normal "/tmp/bild/artikel0005.jpeg" forM_ [-10..10] $ \k -> do print =<< score (Degree $ fromInteger k / 10) img diff --git a/src/Knead/Color.hs b/src/Knead/Color.hs --- a/src/Knead/Color.hs +++ b/src/Knead/Color.hs @@ -3,6 +3,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE EmptyDataDecls #-} module Knead.Color where import qualified Data.Array.Knead.Expression as Expr @@ -31,56 +32,59 @@ -data YUV a = YUV a a a +data C3 space a = C3 a a a -instance Functor YUV where - fmap f (YUV y u v) = YUV (f y) (f u) (f v) +type YUV = C3 SpaceYUV; data SpaceYUV +type RGB = C3 SpaceRGB; data SpaceRGB -instance Foldable YUV where - foldMap f (YUV y u v) = f y <> f u <> f v +instance Functor (C3 space) where + fmap f (C3 y u v) = C3 (f y) (f u) (f v) -instance Traversable YUV where - traverse f (YUV y u v) = liftA3 YUV (f y) (f u) (f v) +instance Foldable (C3 space) where + foldMap f (C3 y u v) = f y <> f u <> f v -instance Applicative YUV where - pure a = YUV a a a - YUV fy fu fv <*> YUV y u v = YUV (fy y) (fu u) (fv v) +instance Traversable (C3 space) where + traverse f (C3 y u v) = liftA3 C3 (f y) (f u) (f v) +instance Applicative (C3 space) where + pure a = C3 a a a + C3 fy fu fv <*> C3 y u v = C3 (fy y) (fu u) (fv v) -instance (Storable a) => Storable (YUV a) where + +instance (Storable a) => Storable (C3 space a) where sizeOf = StoreTrav.sizeOf . lazyElements alignment = StoreTrav.alignment peek = StoreTrav.peekApplicative poke = StoreTrav.poke -lazyElements :: YUV a -> YUV a -lazyElements ~(YUV y u v) = YUV y u v +lazyElements :: C3 space a -> C3 space a +lazyElements ~(C3 y u v) = C3 y u v instance (Storable.Vector a, LLVM.IsPrimitive a, LLVM.IsConst a, NiceVector.C a, NiceVector.Repr TypeNum.D3 a ~ LLVM.Value (LLVM.Vector TypeNum.D3 a)) => - Storable.C (YUV a) where + Storable.C (C3 space a) where load = fmap NiceValue.cast . Storable.load <=< castVectorPtr store x = Storable.store (NiceValue.cast x) <=< castVectorPtr castVectorPtr :: - LLVM.Value (Ptr (YUV a)) -> + LLVM.Value (Ptr (C3 space a)) -> LLVM.CodeGenFunction r (LLVM.Value (Ptr (LLVM.Vector TypeNum.D3 a))) castVectorPtr = LLVM.bitcast instance (LLVM.IsPrimitive a, LLVM.IsConst a) => - Tuple.Value (YUV a) where - type ValueOf (YUV a) = LLVM.Value (LLVM.Vector TypeNum.D3 a) - valueOf (YUV a0 a1 a2) = LLVM.valueOf $ LLVM.consVector a0 a1 a2 + Tuple.Value (C3 space a) where + type ValueOf (C3 space a) = LLVM.Value (LLVM.Vector TypeNum.D3 a) + valueOf (C3 a0 a1 a2) = LLVM.valueOf $ LLVM.consVector a0 a1 a2 instance (LLVM.IsPrimitive a, LLVM.IsConst a) => - NiceValue.C (YUV a) where - type Repr (YUV a) = LLVM.Value (LLVM.Vector TypeNum.D3 a) - cons (YUV a0 a1 a2) = + NiceValue.C (C3 space a) where + type Repr (C3 space a) = LLVM.Value (LLVM.Vector TypeNum.D3 a) + cons (C3 a0 a1 a2) = NiceValue.Cons $ LLVM.valueOf $ LLVM.consVector a0 a1 a2 undef = NiceValue.undefTuple zero = NiceValue.zeroTuple @@ -88,26 +92,55 @@ addPhi = NiceValue.addPhiTuple -yuv :: +cons :: (LLVM.IsPrimitive a, NiceValue.Repr a ~ LLVM.Value a) => - Exp a -> Exp a -> Exp a -> Exp (YUV a) -yuv = + Exp a -> Exp a -> Exp a -> Exp (C3 space a) +cons = Expr.liftReprM3 (\y u v -> do arr0 <- LLVM.insertelement Tuple.undef y (LLVM.valueOf 0) arr1 <- LLVM.insertelement arr0 u (LLVM.valueOf 1) LLVM.insertelement arr1 v (LLVM.valueOf 2)) -brightness :: +yuv :: (LLVM.IsPrimitive a, NiceValue.Repr a ~ LLVM.Value a) => + Exp a -> Exp a -> Exp a -> Exp (YUV a) +yuv = cons + +rgb :: + (LLVM.IsPrimitive a, NiceValue.Repr a ~ LLVM.Value a) => + Exp a -> Exp a -> Exp a -> Exp (RGB a) +rgb = cons + +class Space space where + brightness :: + (NiceValue.Field a, NiceValue.RationalConstant a, NiceValue.Real a, + LLVM.IsPrimitive a, NiceValue.Repr a ~ LLVM.Value a) => + Exp (C3 space a) -> Exp a + +luma :: + (LLVM.IsPrimitive a, NiceValue.Repr a ~ LLVM.Value a) => Exp (YUV a) -> Exp a -brightness = - Expr.liftReprM (flip LLVM.extractelement (LLVM.valueOf 0)) +luma = Expr.liftReprM (flip LLVM.extractelement (LLVM.valueOf 0)) +instance Space SpaceYUV where + brightness = luma + +red, green, blue :: + (LLVM.IsPrimitive a, NiceValue.Repr a ~ LLVM.Value a) => + Exp (RGB a) -> Exp a +red = Expr.liftReprM (flip LLVM.extractelement (LLVM.valueOf 0)) +green = Expr.liftReprM (flip LLVM.extractelement (LLVM.valueOf 1)) +blue = Expr.liftReprM (flip LLVM.extractelement (LLVM.valueOf 2)) + +instance Space SpaceRGB where + brightness c = 0.299 * red c + 0.587 * green c + 0.114 * blue c + + mapPlain :: (LLVM.IsPrimitive a, LLVM.IsPrimitive b) => (forall r. LLVM.Value a -> LLVM.CodeGenFunction r (LLVM.Value b)) -> - Exp (YUV a) -> Exp (YUV b) + Exp (C3 space a) -> Exp (C3 space b) mapPlain f = Expr.liftReprM (Vector.map f) exprUnliftM1 :: @@ -119,5 +152,5 @@ map :: (LLVM.IsPrimitive a, NiceValue.Repr a ~ LLVM.Value a, LLVM.IsPrimitive b, NiceValue.Repr b ~ LLVM.Value b) => - (Exp a -> Exp b) -> Exp (YUV a) -> Exp (YUV b) + (Exp a -> Exp b) -> Exp (C3 space a) -> Exp (C3 space b) map f = mapPlain (exprUnliftM1 f)