patch-image 0.3.3 → 0.3.3.1
raw patch · 8 files changed
+336/−196 lines, 8 filesdep +shell-utilitydep +storable-recorddep −Cabaldep −storable-tupledep ~cassavadep ~enumsetdep ~knead
Dependencies added: shell-utility, storable-record
Dependencies removed: Cabal, storable-tuple
Dependency ranges changed: cassava, enumset, knead, llvm-extra, llvm-tf, unordered-containers
Files
- patch-image.cabal +17/−17
- src/Accelerate.hs +15/−15
- src/Knead.hs +131/−98
- src/Knead/CArray.hs +6/−3
- src/Knead/Color.hs +119/−0
- src/Knead/Shape.hs +39/−19
- src/Option.hs +9/−10
- src/Option/Utility.hs +0/−34
patch-image.cabal view
@@ -1,5 +1,5 @@ Name: patch-image-Version: 0.3.3+Version: 0.3.3.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -33,7 +33,7 @@ * Images must be approximately correctly oriented. . * May have problems with unstructured areas in the image.-Tested-With: GHC==7.8.3+Tested-With: GHC==7.8.4, GHC==8.2.2 Cabal-Version: >=1.6 Build-Type: Simple Extra-Source-Files:@@ -41,7 +41,7 @@ README.md Source-Repository this- Tag: 0.3.3+ Tag: 0.3.3.1 Type: darcs Location: http://hub.darcs.net/thielema/patch-image/ @@ -56,6 +56,7 @@ Flag cuda Description: Build program version base on accelerate-cuda+ Default: False Manual: True Flag buildDraft@@ -69,12 +70,12 @@ MatchImageBorders Knead.CArray Knead.Shape+ Knead.Color Complex State LinearAlgebra Arithmetic Degree- Option.Utility Option Hs-Source-Dirs: src @@ -83,29 +84,29 @@ If flag(llvm) Build-Depends:- knead >=0.4 && <0.5,- llvm-extra >=0.8 && <0.9,- llvm-tf >=3.1 && <3.2,+ knead >=0.4 && <0.6,+ llvm-extra >=0.10 && <0.11,+ llvm-tf >=9.2 && <9.3, tfp >=1.0 && <1.1, comfort-array >=0.3 && <0.5, JuicyPixels >=2.0 && <3.4, dsp >=0.2.4 && <0.3, vector >=0.10 && <0.13, pqueue >=1.2 && <1.5,- enumset >=0.0.4 && <0.1,+ enumset >=0.0.5 && <0.1, containers >=0.4.2 && <0.7, semigroups >=0.1 && <1.0, fft >=0.1.7 && <0.2, storable-complex >=0.2.2 && <0.3,- storable-tuple >=0.0.3 && <0.1,+ storable-record >=0.0.5 && <0.1, bool8 >=0.0 && <0.1, carray >=0.1.5 && <0.2, array >=0.4 && <0.6,- cassava >=0.4.5 && <0.5.2,- unordered-containers >=0.2.5 && <0.2.10,+ cassava >=0.4.5 && <0.6,+ unordered-containers >=0.2.5 && <0.2.11, bytestring >=0.9.2 && <0.11, explicit-exception >=0.1.7 && <0.2,- Cabal >=1.18 && <3,+ shell-utility >=0.1 && <0.2, filepath >=1.3 && <1.5, non-empty >=0.2 && <0.4, utility-ht >=0.0.13 && <0.1,@@ -122,7 +123,6 @@ Arithmetic Complex Degree- Option.Utility Option Hs-Source-Dirs: src @@ -139,17 +139,17 @@ accelerate-io >=1.0 && <1.1, accelerate >=1.1 && <1.2, JuicyPixels >=2.0 && <3.4,- cassava >=0.4.5 && <0.5.2,+ cassava >=0.4.5 && <0.6, dsp >=0.2.4 && <0.3, gnuplot >=0.5 && <0.6, containers >=0.4.2 && <0.7, array >=0.4 && <0.6, vector >=0.10 && <0.13,- unordered-containers >=0.2.5 && <0.2.10,+ unordered-containers >=0.2.5 && <0.2.11, bytestring >=0.9.2 && <0.11,- enumset >=0.0.4 && <0.1,+ enumset >=0.0.5 && <0.1, explicit-exception >=0.1.7 && <0.2,- Cabal >=1.18 && <3,+ shell-utility >=0.1 && <0.2, filepath >=1.3 && <1.5, non-empty >=0.2 && <0.4, utility-ht >=0.0.1 && <0.1,
src/Accelerate.hs view
@@ -63,9 +63,9 @@ import qualified System.FilePath as FilePath import qualified System.IO as IO -import qualified Distribution.Simple.Utils as CmdLine-import qualified Distribution.Verbosity as Verbosity-import Distribution.Verbosity (Verbosity)+import qualified Shell.Utility.Log as CmdLine+import qualified Shell.Utility.Verbosity as Verbosity+import Shell.Utility.Verbosity (Verbosity) import Text.Printf (printf) import Control.Monad.HT (void)@@ -1493,10 +1493,10 @@ let (poss, dps) = absolutePositionsFromPairDisplacements (fixAtLeastOnePosition (0,0) $ map picParam pics) overlaps- info "\nabsolute positions"+ info "\nabsolute positions\n" info $ unlines $ map show poss - info "\ncompare position differences with pair displacements"+ info "\ncompare position differences with pair displacements\n" info $ unlines $ zipWith (\(dpx,dpy) (dx,dy) ->@@ -1569,11 +1569,11 @@ (\(score,pa,pb) -> (score, (add pa leftTopA, add pb leftTopB))) $ optimalOverlapShared mMaxDiff picA picB- info $ printf "left-top: %s, %s" (show leftTopA) (show leftTopB)- info $ printf "%s - %s" pathA pathB+ info $ printf "left-top: %s, %s\n" (show leftTopA) (show leftTopB)+ info $ printf "%s - %s\n" pathA pathB forM_ corrs $ \(score, (pa@(xa,ya),pb@(xb,yb))) -> info $- printf "%s ~ %s, (%f,%f), %f"+ printf "%s ~ %s, (%f,%f), %f\n" (show pa) (show pb) (xb-xa) (yb-ya) score return $ map snd corrs return ((ia,ib), (pathA,pathB), correspondences)@@ -1588,7 +1588,7 @@ fixAtLeastOneAnglePosition (Degree 0, (0,0)) $ map picParam pics) overlaps- info "\nabsolute positions and rotations: place, rotation (magnitude, phase)"+ info "\nabsolute positions and rotations: place, rotation (magnitude, phase)\n" infoPlain $ unlines $ map (\((dx,dy),r) ->@@ -1598,7 +1598,7 @@ (getDegree $ Degree.fromRadian $ Complex.phase r)) posRots - info "\ncompare position differences with pair displacements"+ info "\ncompare position differences with pair displacements\n" infoPlain $ unlines $ zipWith (\(dpx,dpy) (_i, ((xa,ya),(xb,yb))) ->@@ -1619,7 +1619,7 @@ inputs <- Option.images args - notice "\nfind rotation angles"+ notice "\nfind rotation angles\n" picAngles <- forM inputs $ \(State.Proposed path (maybeAngle, _) _) -> do pic <- readImage (Option.verbosity opt) path@@ -1641,7 +1641,7 @@ State.write (printf format "angle") $ zipWith State.Angle (map State.propPath inputs) (map fst picAngles) - notice "\nfind relative placements"+ notice "\nfind relative placements\n" let rotated = map (prepareOverlapMatching (Option.smooth opt)) picAngles when False $ do@@ -1687,7 +1687,7 @@ (angle <> Degree.fromRadian (Complex.phase rot)) pos) paths picAngles posRots - notice "\ncompose all parts"+ notice "\ncompose all parts\n" let ((canvasWidth, canvasHeight), rotMovPics, canvasMsgs) = Arith.canvasShape colorImageExtent (map (mapFst Degree.toRadian) picAngles) posRots@@ -1701,7 +1701,7 @@ (emptyCountCanvas (Z :. 3 :. canvasHeight :. canvasWidth)) rotMovPics - notice "\ndistance maps"+ notice "\ndistance maps\n" let geometryRelations = Arith.geometryRelations $ map (Arith.geometryFeatures . mapThd3 colorImageExtent) rotMovPics@@ -1729,7 +1729,7 @@ distanceMapRun canvasShape thisGeom otherGeoms allPoints forM_ (Option.output opt) $ \path -> do- notice "\nweighted composition"+ notice "\nweighted composition\n" writeImage (Option.quality opt) path $ finalizeWeightedCanvas $ foldl
src/Knead.hs view
@@ -7,6 +7,7 @@ import qualified MatchImageBorders import qualified Arithmetic as Arith import qualified Knead.CArray as KneadCArray+import qualified Knead.Color as Color import qualified Complex as Komplex import qualified Degree import MatchImageBorders (arrayPairFromVec, arrayVecFromPair)@@ -19,6 +20,7 @@ import Knead.Shape (Size, Vec2(Vec2), Dim1, Dim2, Shape2, Shape2ZB, Index2, Ix2, Factor2, verticalSize, verticalVal, horizontalVal)+import Knead.Color (YUV) import Degree (Degree(Degree), getDegree) import qualified Math.FFT as FFT@@ -38,10 +40,11 @@ import qualified Data.Array.Comfort.Storable.Unchecked as ComfortArray import qualified Data.Array.Comfort.Shape as ComfortShape +import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as LLVMArith-import qualified LLVM.Extra.Multi.Value.Memory as MultiMem-import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Tuple as Tuple import LLVM.Extra.Multi.Value (Atom, atom) import qualified LLVM.Core as LLVM@@ -53,19 +56,20 @@ import qualified Data.Vector.Storable as SV import Foreign.ForeignPtr (ForeignPtr, castForeignPtr)+import Foreign.Storable.Record.Tuple (Tuple(Tuple, getTuple)) import Foreign.Storable.Complex () import qualified System.FilePath as FilePath import qualified System.IO as IO -import qualified Distribution.Simple.Utils as CmdLine-import qualified Distribution.Verbosity as Verbosity-import Distribution.Verbosity (Verbosity)+import qualified Shell.Utility.Log as CmdLine+import qualified Shell.Utility.Verbosity as Verbosity+import Shell.Utility.Verbosity (Verbosity) import Text.Printf (printf) import qualified Control.Monad.HT as MonadHT import Control.Monad (when, join, foldM, (<=<))-import Control.Applicative (pure, (<$>), (<*>))+import Control.Applicative (liftA2, pure, (<$>), (<*>)) import qualified Data.Foldable as Fold import qualified Data.List as List@@ -79,7 +83,7 @@ import Data.Foldable (forM_) import Data.Ord.HT (comparing) import Data.Tuple.HT- (mapPair, mapFst, mapSnd, mapTriple, swap, mapThd3, fst3, uncurry3)+ (mapPair, mapFst, mapSnd, mapTriple, swap, mapThd3, uncurry3) import Data.Word (Word8, Word32) import Data.Bool8 (Bool8) @@ -92,11 +96,11 @@ type SmallDim = Shape.ZeroBased SmallSize 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 YUV a = (a,a,a) shape2 :: (Integral i) => i -> i -> Dim2 shape2 height width =@@ -200,27 +204,23 @@ yuvByteFromFloat ::- (MultiValue.NativeFloating a ar,+ (MultiValue.NativeFloating a ar, a ~ ar, MultiValue.Field a, MultiValue.Real a, MultiValue.RationalConstant a) => Exp (YUV a) -> Exp (YUV Word8)-yuvByteFromFloat =- Expr.modify (atom,atom,atom) $- mapTriple (byteFromFloat, byteFromFloat, byteFromFloat)+yuvByteFromFloat = Color.map byteFromFloat colorImageFloatFromByte :: (Symb.C array, Shape.C sh,- MultiValue.NativeFloating a ar,+ MultiValue.NativeFloating a ar, a ~ ar, MultiValue.PseudoRing a, MultiValue.Real a, MultiValue.RationalConstant a) => array sh (YUV Word8) -> array sh (YUV a)-colorImageFloatFromByte =- Symb.map $ Expr.modify (atom,atom,atom) $- mapTriple (floatFromByte, floatFromByte, floatFromByte)+colorImageFloatFromByte = Symb.map $ Color.map floatFromByte colorImageByteFromFloat :: (Symb.C array, Shape.C sh,- MultiValue.NativeFloating a ar,+ MultiValue.NativeFloating a ar, a ~ ar, MultiValue.Field a, MultiValue.Real a, MultiValue.RationalConstant a) => array sh (YUV a) -> array sh (YUV Word8)@@ -307,17 +307,15 @@ type VecExp a v = Arith.Vec (Exp a) (Exp v) -vecYUV :: (MultiValue.PseudoRing a) => VecExp a (YUV a)+vecYUV ::+ (MultiValue.PseudoRing a, LLVM.IsArithmetic a,+ LLVM.IsPrimitive a, LLVM.IsConst a, Tuple.ValueOf a ~ LLVM.Value a) =>+ VecExp a (YUV a) vecYUV = Arith.Vec {- Arith.vecZero = Expr.compose (Expr.zero, Expr.zero, Expr.zero),- Arith.vecAdd =- Expr.modify2 (atom,atom,atom) (atom,atom,atom) $- \(ay,au,av) (by,bu,bv) ->- (Expr.add ay by, Expr.add au bu, Expr.add av bv),- Arith.vecScale =- Expr.modify2 atom (atom,atom,atom) $- \a (by,bu,bv) -> (Expr.mul a by, Expr.mul a bu, Expr.mul a bv)+ Arith.vecZero = Expr.zero,+ Arith.vecAdd = Expr.liftTupleM2 LLVMArith.add,+ Arith.vecScale = Expr.liftTupleM2 SoV.scale } {-@@ -405,7 +403,7 @@ rotateStretchMoveCoords ::- (SV.Storable a, MultiMem.C a,+ (SV.Storable a, Storable.C a, MultiValue.Real a, MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.NativeFloating a ar) => Exp (a, a) ->@@ -452,7 +450,7 @@ and then moves the picture. -} rotateStretchMove ::- (SV.Storable a, MultiMem.C a,+ (SV.Storable a, Storable.C a, MultiValue.Real a, MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.NativeFloating a ar, MultiValue.C v) =>@@ -471,7 +469,7 @@ Symb.map (Expr.modify (atom,atom) $ \(x,y) -> ix2 y x) coords) rotate ::- (SV.Storable a, MultiMem.C a,+ (SV.Storable a, Storable.C a, MultiValue.Real a, MultiValue.Field a, MultiValue.RationalConstant a, MultiValue.NativeFloating a ar, MultiValue.C v) =>@@ -498,16 +496,15 @@ return $ \ angle img -> rot (Degree.cis angle) img -brightnessValue :: Exp (YUV a) -> Exp a-brightnessValue = Expr.modify (atom,atom,atom) fst3- brightnessPlane :: (Symb.C array, Shape.C size) =>+ (LLVM.IsPrimitive a, Tuple.ValueOf a ~ LLVM.Value a) => array size (YUV a) -> array size a-brightnessPlane = Symb.map brightnessValue+brightnessPlane = Symb.map Color.brightness rowHistogram :: (Symb.C array, MultiValue.Additive a) =>+ (LLVM.IsPrimitive a, Tuple.ValueOf a ~ LLVM.Value a) => array Dim2 (YUV a) -> array Dim1 a rowHistogram = Symb.fold1 Expr.add .@@ -613,7 +610,7 @@ spec (cyclicReverse2d spec) correlatePadded ::- (FFTWReal a, MultiValue.Real a, MultiMem.C a,+ (FFTWReal a, MultiValue.Real a, Storable.C a, MultiValue.Field a, MultiValue.RationalConstant a) => Dim2 -> IO (Plane a -> Plane a -> IO (Plane a)) correlatePadded@@ -755,7 +752,7 @@ optimalOverlap padExtent = do run <- RenderP.run $ \minOverlapPortion (sha, shb) img ->- argmaximum $+ RenderP.MarshalExp $ argmaximum $ allOverlapsFromCorrelation padExtent minOverlapPortion sha shb img correlate <- correlatePadded padExtent @@ -1043,9 +1040,9 @@ -emptyCountCanvas :: IO (Dim2 -> IO (Plane (Word32, YUV Float)))+emptyCountCanvas :: IO (Dim2 -> IO (Planes (Word32, YUV Float))) emptyCountCanvas =- RenderP.run $ \sh -> Symb.fill sh (Expr.zip 0 $ Expr.zip3 0 0 0)+ RenderP.run $ \sh -> Symb.fill sh (Expr.tuple $ Expr.zip 0 $ Color.yuv 0 0 0) type RotatedImage = ((Float,Float), (Float,Float), ColorImage8)@@ -1064,21 +1061,22 @@ Arith.vecScale vec (Expr.floatFromBool8 mask) pic)) updateCountCanvas ::- IO (RotatedImage -> Plane (Word32, YUV Float) ->- IO (Plane (Word32, YUV Float)))+ IO (RotatedImage -> Planes (Word32, YUV Float) ->+ IO (Planes (Word32, YUV Float))) updateCountCanvas = RenderP.run $ \(rot, mov, pic) countCanvas ->+ Symb.map Expr.tuple $ addToCountCanvas vecYUV (rotateStretchMove vecYUV rot mov (Symb.shape countCanvas) $ colorImageFloatFromByte pic)- countCanvas+ (Symb.map Expr.untuple countCanvas) -finalizeCountCanvas :: IO ((Plane (Word32, YUV Float)) -> IO ColorImage8)+finalizeCountCanvas :: IO (Planes (Word32, YUV Float) -> IO ColorImage8) finalizeCountCanvas = RenderP.run $ colorImageByteFromFloat . Symb.map- (Expr.modify (atom,atom) $ \(count, pixel) ->+ (Expr.modify (Tuple (atom,atom)) $ \(Tuple (count, pixel)) -> Arith.vecScale vecYUV (recip $ fromInt count) pixel) . Symb.fix @@ -1087,34 +1085,34 @@ diffAbs = Expr.liftM2 $ \x y -> MultiValue.abs =<< MultiValue.sub x y diffWithCanvas ::- IO (RotatedImage -> Plane (YUV Float) -> IO (Plane (Bool8, Float)))+ IO (RotatedImage -> Plane (YUV Float) -> IO (Planes (Bool8, Float))) diffWithCanvas = RenderP.run $ \(rot, mov, pic) avg -> Symb.zipWith (Expr.modify2 (atom,atom) atom $ \(b,x) y ->- (b, diffAbs (brightnessValue x) (brightnessValue y)))+ Tuple (b, diffAbs (Color.brightness x) (Color.brightness y))) (rotateStretchMove vecYUV rot mov (Symb.shape avg) $ colorImageFloatFromByte pic) avg finalizeCountCanvasFloat ::- IO ((Plane (Word32, YUV Float)) -> IO (Plane (YUV Float)))+ IO ((Planes (Word32, YUV Float)) -> IO (Plane (YUV Float))) finalizeCountCanvasFloat = RenderP.run $ Symb.map- (Expr.modify (atom,atom) $ \(count, pixel) ->+ (Expr.modify (Tuple (atom,atom)) $ \(Tuple (count, pixel)) -> Arith.vecScale vecYUV (recip $ fromInt count) pixel) . Symb.fix emptyCanvas :: IO (Dim2 -> IO ColorImage8)-emptyCanvas = RenderP.run $ \sh -> Symb.fill sh (Expr.zip3 0 0 0)+emptyCanvas = RenderP.run $ \sh -> Symb.fill sh (Color.yuv 0 0 0) addMaskedToCanvas :: IO (RotatedImage -> Plane Bool8 ->- Plane (YUV Word8) ->- IO (Plane (YUV Word8)))+ ColorImage8 ->+ IO ColorImage8) addMaskedToCanvas = RenderP.run $ \(rot, mov, pic) mask canvas -> Symb.zipWith3 Expr.ifThenElse@@ -1127,10 +1125,11 @@ updateShapedCanvas :: IO (RotatedImage -> Plane Float ->- Plane (Float, YUV Float) ->- IO (Plane (Float, YUV Float)))+ Planes (Float, YUV Float) ->+ IO (Planes (Float, YUV Float))) updateShapedCanvas = RenderP.run $ \(rot, mov, pic) shape weightCanvas ->+ Symb.map Expr.tuple $ addToWeightedCanvas vecYUV (Symb.zipWith (Expr.modify2 atom (atom,atom) $ \s (b,x) ->@@ -1138,7 +1137,7 @@ shape $ rotateStretchMove vecYUV rot mov (Symb.shape weightCanvas) $ colorImageFloatFromByte pic)- weightCanvas+ (Symb.map Expr.untuple weightCanvas) maybePlus ::@@ -1229,8 +1228,7 @@ array (Symb.lift0 $ Symb.id $ Expr.compose $ Shape.ZeroBased (4 :: Exp SmallSize)) -distanceMapBoxRun ::- IO (Dim2 -> Geometry Float -> IO (Plane Word8))+distanceMapBoxRun :: IO (Dim2 -> Geometry Float -> IO (Plane Word8)) distanceMapBoxRun = RenderP.run $ \sh geom -> scaleDistanceMapGeom geom $@@ -1284,8 +1282,10 @@ distanceMapContainedRun = do distances <- RenderP.run $- \sh this -> scaleDistanceMapGeom this . distanceMapContained sh this- return $ \sh this others -> distances sh this =<< Phys.vectorFromList others+ \sh this ->+ scaleDistanceMapGeom this .+ distanceMapContained sh this . geometryArray+ return $ \sh this others -> distances sh this =<< geometryVector others scaleDistanceMapGeom :: (MultiValue.Field a, MultiValue.Real a, MultiValue.RationalConstant a,@@ -1296,6 +1296,32 @@ in imageByteFromFloat $ Symb.map (scale*) img +pointsVector ::+ [Arith.Point2 Float] ->+ IO (ComfortArray.Array SmallDim (Tuple (Arith.Point2 Float)))+pointsVector = Phys.vectorFromList . map Tuple++pointsArray ::+ Symb.Array SmallDim (Tuple (Arith.Point2 a)) ->+ Symb.Array SmallDim (Arith.Point2 a)+pointsArray = Symb.map Expr.untuple++type TupledGeometry a = Tuple (Tuple (a,a), Tuple (a,a), Tuple (Size,Size))++geometryVector ::+ (SV.Storable a) =>+ [Geometry a] -> IO (ComfortArray.Array SmallDim (TupledGeometry a))+geometryVector =+ Phys.vectorFromList . map (Tuple . mapTriple (Tuple, Tuple, Tuple))++geometryArray ::+ Symb.Array SmallDim (TupledGeometry a) ->+ Symb.Array SmallDim (Geometry a)+geometryArray =+ Symb.map+ (Expr.mapTriple (Expr.untuple, Expr.untuple, Expr.untuple) . Expr.untuple)++ pixelCoordinates :: (MultiValue.NativeFloating a ar) => Exp Dim2 -> SymbPlane (a,a) pixelCoordinates sh =@@ -1316,8 +1342,10 @@ distanceMapPointsRun = do distances <- RenderP.run $- \sh -> scaleDistanceMap . distanceMapPoints (pixelCoordinates sh)- return $ \sh points -> distances sh =<< Phys.vectorFromList points+ \sh ->+ scaleDistanceMap .+ distanceMapPoints (pixelCoordinates sh) . pointsArray+ return $ \sh points -> distances sh =<< pointsVector points scaleDistanceMap ::@@ -1369,20 +1397,19 @@ distanceMapRun = do distances <- RenderP.run $- \sh this others -> scaleDistanceMap . distanceMap sh this others- return $ \sh this others points -> do- othersVec <- Phys.vectorFromList others- pointsVec <- Phys.vectorFromList points- distances sh this othersVec pointsVec+ \sh this ->+ scaleDistanceMap .+ uncurry (distanceMap sh this) . mapPair (geometryArray, pointsArray)+ return $ \sh this others points ->+ distances sh this =<<+ liftA2 (,) (geometryVector others) (pointsVector points) pow ::- (MultiValue.Repr LLVM.Value a ~ LLVM.Value ar,+ (Tuple.ValueOf a ~ LLVM.Value ar, LLVM.IsFloating ar, SoV.TranscendentalConstant ar) => Exp a -> Exp a -> Exp a-pow =- flip $ Expr.liftM2 $ \(MultiValue.Cons x) (MultiValue.Cons y) ->- fmap MultiValue.Cons $ LLVMArith.pow x y+pow = flip $ Expr.liftTupleM2 LLVMArith.pow distanceMapGamma :: (MultiValue.Algebraic a, MultiValue.Real a,@@ -1393,15 +1420,16 @@ Exp Dim2 -> Exp (Geometry a) -> Symb.Array SmallDim (Geometry a) ->- Symb.Array SmallDim (a, a) ->+ Symb.Array SmallDim (Arith.Point2 a) -> SymbPlane a distanceMapGamma gamma sh this others points = Symb.map (pow gamma) $ distanceMap sh this others points -emptyWeightedCanvas :: IO (Dim2 -> IO (Plane (Float, YUV Float)))+emptyWeightedCanvas :: IO (Dim2 -> IO (Planes (Float, YUV Float))) emptyWeightedCanvas =- RenderP.run $ \sh -> Symb.fill sh (Expr.zip 0 $ Expr.zip3 0 0 0)+ RenderP.run $ \sh ->+ Symb.fill sh $ Expr.tuple $ Expr.zip 0 $ Color.yuv 0 0 0 addToWeightedCanvas :: (MultiValue.PseudoRing a, MultiValue.NativeFloating a ar) =>@@ -1422,38 +1450,42 @@ [Geometry Float] -> [Arith.Point2 Float] -> ColorImage8 ->- Plane (Float, YUV Float) ->- IO (Plane (Float, YUV Float)))+ Planes (Float, YUV Float) ->+ IO (Planes (Float, YUV Float))) updateWeightedCanvas = do- distances <- RenderP.run distanceMapGamma+ distances <-+ RenderP.run $+ \gamma shape this ->+ uncurry (distanceMapGamma gamma shape this) .+ mapPair (geometryArray, pointsArray) update <- RenderP.run $ \this pic dist weightSumCanvas -> let (rot, mov, _) = Expr.unzip3 this- in addToWeightedCanvas vecYUV+ in Symb.map Expr.tuple $+ addToWeightedCanvas vecYUV (Symb.zip dist $ Symb.map Expr.snd $ rotateStretchMove vecYUV rot mov (Symb.shape weightSumCanvas) $ colorImageFloatFromByte pic)- weightSumCanvas+ (Symb.map Expr.untuple weightSumCanvas) return $ \gamma this others points pic weightSumCanvas -> do- othersVec <- Phys.vectorFromList others- pointsVec <- Phys.vectorFromList points dists <-- distances- gamma (Phys.shape weightSumCanvas) this- othersVec pointsVec+ distances gamma (Phys.shape weightSumCanvas) this+ =<<+ liftA2 (,) (geometryVector others) (pointsVector points)+ update this pic dists weightSumCanvas -finalizeWeightedCanvas :: IO (Plane (Float, YUV Float) -> IO ColorImage8)+finalizeWeightedCanvas :: IO (Planes (Float, YUV Float) -> IO ColorImage8) finalizeWeightedCanvas = RenderP.run $ colorImageByteFromFloat . Symb.map- (Expr.modify (atom,atom) $ \(weightSum, pixel) ->+ (Expr.modify (Tuple (atom,atom)) $ \(Tuple (weightSum, pixel)) -> Arith.vecScale vecYUV (recip weightSum) pixel) . Symb.fix @@ -1552,10 +1584,10 @@ let (poss, dps) = absolutePositionsFromPairDisplacements (fixAtLeastOnePosition (0,0) $ map picParam pics) overlaps- info "\nabsolute positions"+ info "\nabsolute positions\n" info $ unlines $ map show poss - info "\ncompare position differences with pair displacements"+ info "\ncompare position differences with pair displacements\n" info $ unlines $ zipWith (\(dpx,dpy) (dx,dy) ->@@ -1628,11 +1660,11 @@ (\(score,pa,pb) -> (score, (add pa leftTopA, add pb leftTopB))) <$> optimalOverlapShared mMaxDiff picA picB- info $ printf "left-top: %s, %s" (show leftTopA) (show leftTopB)- info $ printf "%s - %s" pathA pathB+ info $ printf "left-top: %s, %s\n" (show leftTopA) (show leftTopB)+ info $ printf "%s - %s\n" pathA pathB forM_ corrs $ \(score, (pa@(xa,ya),pb@(xb,yb))) -> info $- printf "%s ~ %s, (%f,%f), %f"+ printf "%s ~ %s, (%f,%f), %f\n" (show pa) (show pb) (xb-xa) (yb-ya) score return $ map snd corrs return ((ia,ib), (pathA,pathB), correspondences)@@ -1647,7 +1679,7 @@ fixAtLeastOneAnglePosition (Degree 0, (0,0)) $ map picParam pics) overlaps- info "\nabsolute positions and rotations: place, rotation (magnitude, phase)"+ info "\nabsolute positions and rotations: place, rotation (magnitude, phase)\n" infoPlain $ unlines $ map (\((dx,dy),r) ->@@ -1657,7 +1689,7 @@ (getDegree $ Degree.fromRadian $ Complex.phase r)) posRots - info "\ncompare position differences with pair displacements"+ info "\ncompare position differences with pair displacements\n" infoPlain $ unlines $ zipWith (\(dpx,dpy) (_i, ((xa,ya),(xb,yb))) ->@@ -1678,7 +1710,7 @@ inputs <- Option.images args - notice "\nfind rotation angles"+ notice "\nfind rotation angles\n" findOptRot <- findOptimalRotation picAngles <- forM inputs $ \(State.Proposed path (maybeAngle, _) _) -> do@@ -1696,7 +1728,7 @@ State.write (printf format "angle") $ zipWith State.Angle (map State.propPath inputs) (map fst picAngles) - notice "\nfind relative placements"+ notice "\nfind relative placements\n" prepOverlapMatching <- prepareOverlapMatching rotated <- mapM (prepOverlapMatching (Option.smooth opt)) picAngles @@ -1748,7 +1780,7 @@ (angle <> Degree.fromRadian (Complex.phase rot)) pos) paths picAngles posRots - notice "\ncompose all parts"+ notice "\ncompose all parts\n" let ((canvasWidth, canvasHeight), rotMovPics, canvasMsgs) = Arith.canvasShape colorImageExtent (map (mapFst Degree.toRadian) picAngles) posRots@@ -1765,7 +1797,7 @@ foldM (flip updateCanv) empty rotMovPics - notice "\ndistance maps"+ notice "\ndistance maps\n" let geometryRelations = Arith.geometryRelations $ map (Arith.geometryFeatures . mapThd3 colorImageExtent) rotMovPics@@ -1800,7 +1832,7 @@ uncurry3 (distMap canvasShape) geoms forM_ (Option.output opt) $ \path -> do- notice "\nweighted composition"+ notice "\nweighted composition\n" emptyCanv <- emptyWeightedCanvas updateCanv <- updateWeightedCanvas finalizeCanv <- finalizeWeightedCanvas@@ -1814,7 +1846,7 @@ empty (zip geometryRelations picAngles) when (isJust (Option.outputShaped opt) || isJust (Option.outputShapedHard opt)) $ do- notice "\nmatch shapes"+ notice "\nmatch shapes\n" emptyCanv <- emptyCountCanvas updateCanv <- updateCountCanvas finalizeCanv <- finalizeCountCanvasFloat@@ -1825,16 +1857,17 @@ avg <- finalizeCanv sumImg diff <- diffWithCanvas picDiffs <- mapM (flip diff avg) rotMovPics- getSnd <- RenderP.run $ Symb.map Expr.snd . Symb.fix+ getSnd <- RenderP.run $ Symb.map (Expr.snd . Expr.untuple) . Symb.fix lp <- lowpassMulti- let masks = map (ComfortArray.map fst . arrayPairFromVec) picDiffs+ let masks =+ map (ComfortArray.map (fst.getTuple) . arrayPairFromVec) picDiffs let smoothRadius = Option.shapeSmooth opt smoothPicDiffs <- mapM (fmap arrayPairFromVec . lp smoothRadius <=< getSnd) picDiffs (locs, pqueue) <- MatchImageBorders.prepareShaping $ zip masks smoothPicDiffs counts <-- MutArray.thaw . ComfortArray.map (fromIntegral . fst) $+ MutArray.thaw . ComfortArray.map (fromIntegral . fst . getTuple) $ arrayPairFromVec sumImg shapes <- MatchImageBorders.shapeParts counts locs pqueue
src/Knead/CArray.hs view
@@ -7,8 +7,8 @@ import qualified Math.FFT as FFT import Math.FFT.Base (FFTWReal) +import Foreign.Storable.Record.Tuple (Tuple(Tuple)) import Foreign.Storable (Storable)-import Foreign.Storable.Tuple () import qualified Data.Array.Comfort.Shape as ComfortShape import Data.Array.Comfort.Storable.Unchecked (Array(Array))@@ -96,9 +96,12 @@ -- ToDo: could be moved to fft package untangleSpectra2d :: (Fractional a, Storable a) =>- CArray (Int,Int) (Complex a) -> CArray (Int,Int) (Complex a, Complex a)+ CArray (Int,Int) (Complex a) ->+ CArray (Int,Int) (Tuple (Complex a, Complex a)) untangleSpectra2d spec =- CArray.liftArray2 untangleCoefficient spec (cyclicReverse2d spec)+ CArray.liftArray2+ ((Tuple.) . untangleCoefficient)+ spec (cyclicReverse2d spec) {- | Equivalent to @amap (uncurry Komplex.mulConj) . untangleSpectra2d@
+ src/Knead/Color.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module Knead.Color where++import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Expression (Exp)++import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Foreign.Storable.Traversable as StoreTrav+import Foreign.Storable (Storable, sizeOf, alignment, poke, peek)+import Foreign.Ptr (Ptr)++import Control.Monad ((<=<))+import Control.Applicative (Applicative, liftA3, pure, (<*>))++import Data.Traversable (Traversable, traverse)+import Data.Foldable (Foldable, foldMap)+import Data.Monoid ((<>))++++data YUV a = YUV a a a++instance Functor YUV where+ fmap f (YUV y u v) = YUV (f y) (f u) (f v)++instance Foldable YUV where+ foldMap f (YUV y u v) = 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 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 (Storable a) => Storable (YUV 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++instance+ (Storable.Vector a, LLVM.IsPrimitive a, LLVM.IsConst a,+ Tuple.VectorValue TypeNum.D3 a,+ Tuple.VectorValueOf TypeNum.D3 a ~ LLVM.Value (LLVM.Vector TypeNum.D3 a)) =>+ Storable.C (YUV a) where+ load = Storable.load <=< castVectorPtr+ store x = Storable.store x <=< castVectorPtr++castVectorPtr ::+ LLVM.Value (Ptr (YUV 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++instance+ (LLVM.IsPrimitive a, LLVM.IsConst a) =>+ MultiValue.C (YUV a) where+ cons = MultiValue.consTuple+ undef = MultiValue.undefTuple+ zero = MultiValue.zeroTuple+ phi = MultiValue.phiTuple+ addPhi = MultiValue.addPhiTuple+++yuv ::+ (LLVM.IsPrimitive a, Tuple.ValueOf a ~ LLVM.Value a) =>+ Exp a -> Exp a -> Exp a -> Exp (YUV a)+yuv =+ Expr.liftTupleM3+ (\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 ::+ (LLVM.IsPrimitive a, Tuple.ValueOf a ~ LLVM.Value a) =>+ Exp (YUV a) -> Exp a+brightness =+ Expr.liftTupleM (flip LLVM.extractelement (LLVM.valueOf 0))++mapPlain ::+ (LLVM.IsPrimitive a, LLVM.IsPrimitive b) =>+ (forall r. LLVM.Value a -> LLVM.CodeGenFunction r (LLVM.Value b)) ->+ Exp (YUV a) -> Exp (YUV b)+mapPlain f = Expr.liftTupleM (Vector.map f)++exprUnliftM1 ::+ (Tuple.ValueOf a ~ al, Tuple.ValueOf b ~ bl) =>+ (Exp a -> Exp b) -> al -> LLVM.CodeGenFunction r bl+exprUnliftM1 f a =+ fmap (\(MultiValue.Cons b) -> b) $ Expr.unliftM1 f $ MultiValue.Cons a++map ::+ (LLVM.IsPrimitive a, Tuple.ValueOf a ~ LLVM.Value a,+ LLVM.IsPrimitive b, Tuple.ValueOf b ~ LLVM.Value b) =>+ (Exp a -> Exp b) -> Exp (YUV a) -> Exp (YUV b)+map f = mapPlain (exprUnliftM1 f)
src/Knead/Shape.hs view
@@ -7,8 +7,10 @@ import qualified Data.Array.Comfort.Shape as ComfortShape -import qualified LLVM.Extra.Multi.Value.Memory as MultiMem+import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Iterator as Iter import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Multi.Value (atom)@@ -81,23 +83,36 @@ let q = castToElemPtr p in Monad.lift2 Vec2 (peek q) (peekElemOff q 1) +instance (Tuple.Undefined n) => Tuple.Undefined (Vec2 tag n) where+ undef = Vec2 Tuple.undef Tuple.undef++instance (Tuple.Phi n) => Tuple.Phi (Vec2 tag n) where+ phi bb (Vec2 a0 a1) =+ Monad.lift2 Vec2 (Tuple.phi bb a0) (Tuple.phi bb a1)+ addPhi bb (Vec2 a0 a1) (Vec2 b0 b1) =+ Tuple.addPhi bb a0 b0 >>+ Tuple.addPhi bb a1 b1++instance (Tuple.Value n) => Tuple.Value (Vec2 tag n) where+ type ValueOf (Vec2 tag n) = Vec2 tag (Tuple.ValueOf n)+ valueOf (Vec2 n m) = Vec2 (Tuple.valueOf n) (Tuple.valueOf m)+ instance (MultiValue.C n) => MultiValue.C (Vec2 tag n) where- type Repr f (Vec2 tag n) = Vec2 tag (MultiValue.Repr f n) cons (Vec2 n m) = MultiValue.compose $ Vec2 (MultiValue.cons n) (MultiValue.cons m) undef = MultiValue.compose $ squareShape MultiValue.undef zero = MultiValue.compose $ squareShape MultiValue.zero- phis bb a =+ phi bb a = case MultiValue.decompose (squareShape atom) a of Vec2 a0 a1 -> fmap MultiValue.compose $- Monad.lift2 Vec2 (MultiValue.phis bb a0) (MultiValue.phis bb a1)- addPhis bb a b =+ Monad.lift2 Vec2 (MultiValue.phi bb a0) (MultiValue.phi bb a1)+ addPhi bb a b = case (MultiValue.decompose (squareShape atom) a, MultiValue.decompose (squareShape atom) b) of (Vec2 a0 a1, Vec2 b0 b1) ->- MultiValue.addPhis bb a0 b0 >>- MultiValue.addPhis bb a1 b1+ MultiValue.addPhi bb a0 b0 >>+ MultiValue.addPhi bb a1 b1 type instance MultiValue.Decomposed f (Vec2 tag pat) =@@ -119,20 +134,25 @@ (MultiValue.decompose pn (MultiValue.Cons n)) (MultiValue.decompose pm (MultiValue.Cons m)) -instance (MultiMem.C i) => MultiMem.C (Vec2 tag i) where+instance (Memory.C i) => Memory.C (Vec2 tag i) where type Struct (Vec2 tag i) =- LLVM.Struct (MultiMem.Struct i, (MultiMem.Struct i, ()))+ LLVM.Struct (Memory.Struct i, (Memory.Struct i, ())) decompose nm =- Monad.lift2 zipShape- (MultiMem.decompose =<< LLVM.extractvalue nm TypeNum.d0)- (MultiMem.decompose =<< LLVM.extractvalue nm TypeNum.d1)- compose nm =- case unzipShape nm of- Vec2 n m -> do- sn <- MultiMem.compose n- sm <- MultiMem.compose m- rn <- LLVM.insertvalue (LLVM.value LLVM.undef) sn TypeNum.d0- LLVM.insertvalue rn sm TypeNum.d1+ Monad.lift2 Vec2+ (Memory.decompose =<< LLVM.extractvalue nm TypeNum.d0)+ (Memory.decompose =<< LLVM.extractvalue nm TypeNum.d1)+ compose (Vec2 n m) = do+ sn <- Memory.compose n+ sm <- Memory.compose m+ rn <- LLVM.insertvalue (LLVM.value LLVM.undef) sn TypeNum.d0+ LLVM.insertvalue rn sm TypeNum.d1++instance (Marshal.C i) => Marshal.C (Vec2 tag i) where+ pack (Vec2 n m) = LLVM.consStruct (Marshal.pack n) (Marshal.pack m)+ unpack =+ LLVM.uncurryStruct $ \n m -> Vec2 (Marshal.unpack n) (Marshal.unpack m)++instance (Marshal.C i, MultiValue.C i) => Marshal.MV (Vec2 tag i) where unzipShape :: MultiValue.T (Vec2 tag n) -> Vec2 tag (MultiValue.T n)
src/Option.hs view
@@ -1,9 +1,14 @@ module Option where import qualified State-import Option.Utility (exitFailureMsg, parseNumber, fmapOptDescr) import Degree (Degree(Degree, getDegree)) +import qualified Shell.Utility.Verbosity as Verbosity+import Shell.Utility.Verbosity (Verbosity)+import Shell.Utility.ParseArgument (parseNumber)+import Shell.Utility.Exit (exitFailureMsg)+import Shell.Utility.GetOpt (fmapOptDescr)+ import qualified System.Console.GetOpt as Opt import qualified System.Environment as Env import System.Console.GetOpt (ArgDescr(NoArg, ReqArg), getOpt, usageInfo)@@ -13,7 +18,7 @@ import Control.Monad (when) -import qualified Data.EnumSet as EnumSet+import qualified Data.EnumBitSet as EnumSet import qualified Data.Vector as Vector import qualified Data.Map as Map import qualified Data.List.HT as ListHT@@ -22,10 +27,6 @@ import Data.Monoid ((<>)) import Data.Word (Word8) -import qualified Distribution.Verbosity as Verbosity-import qualified Distribution.ReadE as ReadE-import Distribution.Verbosity (Verbosity)- import Text.Printf (printf) @@ -153,10 +154,8 @@ "show options" : opt generic ['v'] ["verbose"]- (flip ReqArg "N" $ \str flags -> do- case ReadE.runReadE Verbosity.flagToVerbosity str of- Right n -> return (flags{verbosity = n})- Left msg -> exitFailureMsg msg)+ (flip ReqArg "N" $ \str flags ->+ fmap (\verb -> flags{verbosity = verb}) $ Verbosity.parse str) (printf "verbosity level: 0..3, default: %d" (fromEnum $ verbosity defltOption)) :
− src/Option/Utility.hs
@@ -1,34 +0,0 @@-module Option.Utility where--import qualified System.Console.GetOpt as G-import qualified System.Exit as Exit-import qualified System.IO as IO---parseNumber ::- (Read a) =>- String -> (a -> Bool) -> String -> String -> IO a-parseNumber name constraint constraintName str =- case reads str of- [(n, "")] ->- if constraint n- then return n- else exitFailureMsg $ name ++ " must be a " ++ constraintName ++ " number"- _ ->- exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'"--exitFailureMsg :: String -> IO a-exitFailureMsg msg = do- IO.hPutStrLn IO.stderr msg- Exit.exitFailure--fmapArgDescr :: (a -> b) -> (G.ArgDescr a -> G.ArgDescr b)-fmapArgDescr f d =- case d of- G.NoArg a -> G.NoArg $ f a- G.ReqArg g str -> G.ReqArg (f.g) str- G.OptArg g str -> G.OptArg (f.g) str--fmapOptDescr :: (a -> b) -> (G.OptDescr a -> G.OptDescr b)-fmapOptDescr f (G.Option short long arg help) =- G.Option short long (fmapArgDescr f arg) help