patch-image 0.3.3.1 → 0.3.3.2
raw patch · 8 files changed
+157/−158 lines, 8 filesdep +comfort-fftwdep +netlib-ffidep −carraydep −fftdep ~bytestringdep ~comfort-arraydep ~containers
Dependencies added: comfort-fftw, netlib-ffi
Dependencies removed: carray, fft
Dependency ranges changed: bytestring, comfort-array, containers, explicit-exception, filepath, knead, llvm-extra, llvm-tf, pqueue, unordered-containers, utility-ht, vector
Files
- Changes.md +4/−0
- patch-image.cabal +27/−24
- src/Knead.hs +45/−28
- src/Knead/CArray.hs +55/−85
- src/Knead/Color.hs +18/−14
- src/Knead/Shape.hs +6/−6
- src/MatchImageBorders.hs +1/−0
- src/State.hs +1/−1
Changes.md view
@@ -1,5 +1,9 @@ # Change log for the `patch-image` package +## 0.3.3.2:++ * Move from package `fft` to `comfort-fftw`.+ ## 0.3.2: * Use package `dsp` instead of `hmatrix`
patch-image.cabal view
@@ -1,10 +1,10 @@ Name: patch-image-Version: 0.3.3.1+Version: 0.3.3.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de> Maintainer: Henning Thielemann <haskell@henning-thielemann.de>-Homepage: http://hub.darcs.net/thielema/patch-image/+Homepage: https://hub.darcs.net/thielema/patch-image/ Category: Graphics Synopsis: Compose a big image from overlapping parts Description:@@ -34,20 +34,20 @@ . * May have problems with unstructured areas in the image. Tested-With: GHC==7.8.4, GHC==8.2.2-Cabal-Version: >=1.6+Cabal-Version: >=1.10 Build-Type: Simple Extra-Source-Files: Changes.md README.md Source-Repository this- Tag: 0.3.3.1+ Tag: 0.3.3.2 Type: darcs- Location: http://hub.darcs.net/thielema/patch-image/+ Location: https://hub.darcs.net/thielema/patch-image/ Source-Repository head Type: darcs- Location: http://hub.darcs.net/thielema/patch-image/+ Location: https://hub.darcs.net/thielema/patch-image/ Flag llvm Description: Build program version base on knead@@ -79,37 +79,38 @@ Option Hs-Source-Dirs: src + Default-Language: Haskell98 GHC-Options: -Wall -threaded -fwarn-tabs -fwarn-incomplete-record-updates GHC-Prof-Options: -fprof-auto -rtsopts If flag(llvm) Build-Depends:- knead >=0.4 && <0.6,- llvm-extra >=0.10 && <0.11,- llvm-tf >=9.2 && <9.3,+ knead >=1.0 && <1.1,+ llvm-extra >=0.11 && <0.12,+ llvm-tf >=9.2 && <13.0, tfp >=1.0 && <1.1,- comfort-array >=0.3 && <0.5,+ comfort-fftw >=0.0 && <0.1,+ comfort-array >=0.5 && <0.6,+ netlib-ffi >=0.1.1 && <0.2, JuicyPixels >=2.0 && <3.4, dsp >=0.2.4 && <0.3,- vector >=0.10 && <0.13,+ vector >=0.10 && <0.14, pqueue >=1.2 && <1.5,- enumset >=0.0.5 && <0.1,+ enumset >=0.0.5 && <0.2, 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-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.6,- unordered-containers >=0.2.5 && <0.2.11,- bytestring >=0.9.2 && <0.11,- explicit-exception >=0.1.7 && <0.2,+ unordered-containers >=0.2.5 && <0.2.20,+ bytestring >=0.9.2 && <0.13,+ explicit-exception >=0.1.7 && <0.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,+ utility-ht >=0.0.16 && <0.1, prelude-compat ==0.0.*, base >=4 && <5 Else@@ -126,6 +127,7 @@ Option Hs-Source-Dirs: src + Default-Language: Haskell98 GHC-Options: -Wall -threaded -fwarn-tabs -fwarn-incomplete-record-updates GHC-Prof-Options: -fprof-auto -rtsopts @@ -144,15 +146,15 @@ 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.11,- bytestring >=0.9.2 && <0.11,- enumset >=0.0.5 && <0.1,- explicit-exception >=0.1.7 && <0.2,+ vector >=0.10 && <0.14,+ unordered-containers >=0.2.5 && <0.2.20,+ bytestring >=0.9.2 && <0.13,+ enumset >=0.0.5 && <0.2,+ explicit-exception >=0.1.7 && <0.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,+ utility-ht >=0.0.16 && <0.1, base >=4 && <5 Else Buildable: False@@ -161,6 +163,7 @@ Main-Is: Draft.hs Hs-Source-Dirs: src + Default-Language: Haskell98 GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates If flag(buildDraft)
src/Knead.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Main where import qualified Option@@ -16,23 +17,23 @@ absolutePositionsFromPairDisplacements, fixAtLeastOnePosition, layoutFromPairDisplacements, fixAtLeastOneAnglePosition, )-import Knead.CArray (liftCArray) 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-import Math.FFT.Base (FFTWReal)+import qualified Numeric.FFTW.Rank2 as Trafo2+import qualified Numeric.FFTW.Shape as Spectrum+import qualified Numeric.Netlib.Class as Class -import qualified Data.Array.Knead.Parameterized.Render as RenderP-import qualified Data.Array.Knead.Simple.Physical as Phys-import qualified Data.Array.Knead.Simple.ShapeDependent as ShapeDep-import qualified Data.Array.Knead.Simple.Symbolic as Symb+import qualified Data.Array.Knead.Symbolic.Render as RenderP+import qualified Data.Array.Knead.Symbolic.Physical as Phys+import qualified Data.Array.Knead.Symbolic.ShapeDependent as ShapeDep+import qualified Data.Array.Knead.Symbolic as Symb import qualified Data.Array.Knead.Shape as Shape import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Simple.Symbolic ((!))+import Data.Array.Knead.Symbolic ((!)) import Data.Array.Knead.Expression (Exp, (==*), (<*), (<=*), (>=*), (||*), (&&*)) @@ -40,11 +41,10 @@ import qualified Data.Array.Comfort.Storable.Unchecked as ComfortArray import qualified Data.Array.Comfort.Shape as ComfortShape +import qualified LLVM.Extra.Multi.Value.Storable as Storable 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.Storable as Storable-import qualified LLVM.Extra.Tuple as Tuple import LLVM.Extra.Multi.Value (Atom, atom) import qualified LLVM.Core as LLVM@@ -309,13 +309,13 @@ vecYUV :: (MultiValue.PseudoRing a, LLVM.IsArithmetic a,- LLVM.IsPrimitive a, LLVM.IsConst a, Tuple.ValueOf a ~ LLVM.Value a) =>+ LLVM.IsPrimitive a, LLVM.IsConst a, MultiValue.Repr a ~ LLVM.Value a) => VecExp a (YUV a) vecYUV = Arith.Vec { Arith.vecZero = Expr.zero,- Arith.vecAdd = Expr.liftTupleM2 LLVMArith.add,- Arith.vecScale = Expr.liftTupleM2 SoV.scale+ Arith.vecAdd = Expr.liftReprM2 LLVMArith.add,+ Arith.vecScale = Expr.liftReprM2 SoV.scale } {-@@ -498,13 +498,13 @@ brightnessPlane :: (Symb.C array, Shape.C size) =>- (LLVM.IsPrimitive a, Tuple.ValueOf a ~ LLVM.Value a) =>+ (LLVM.IsPrimitive a, MultiValue.Repr a ~ LLVM.Value a) => array size (YUV a) -> array size a brightnessPlane = Symb.map Color.brightness rowHistogram :: (Symb.C array, MultiValue.Additive a) =>- (LLVM.IsPrimitive a, Tuple.ValueOf a ~ LLVM.Value a) =>+ (LLVM.IsPrimitive a, MultiValue.Repr a ~ LLVM.Value a) => array Dim2 (YUV a) -> array Dim1 a rowHistogram = Symb.fold1 Expr.add .@@ -587,6 +587,14 @@ let Vec2 y x = Expr.decompose atomIx2 p in Expr.ifThenElse (y<*height &&* x<*width) (img ! p) a +pad_ :: (MultiValue.C a, sh ~ (dim,dim), dim ~ Shape.Cyclic Size) =>+ Exp a -> Exp sh -> SymbPlane a -> Symb.Array sh a+pad_ a sh img =+ let Vec2 height width = decomposeDim2 $ Symb.shape img+ in generate sh $ \p ->+ let (y,x) = Expr.decompose (atom,atom) p+ in Expr.ifThenElse (y<*height &&* x<*width) (img ! ix2 y x) a+ cyclicReverse2d :: (MultiValue.C a) => SymbPlane a -> SymbPlane a cyclicReverse2d spec = let (Vec2 height width) = decomposeDim2 $ Symb.shape spec@@ -610,27 +618,32 @@ spec (cyclicReverse2d spec) correlatePadded ::- (FFTWReal a, MultiValue.Real a, Storable.C a,+ (Class.Real a, MultiValue.Real a, Storable.C a, MultiValue.Field a, MultiValue.RationalConstant a) => Dim2 -> IO (Plane a -> Plane a -> IO (Plane a)) correlatePadded- padExtent@(Vec2 (Shape.ZeroBased height) (Shape.ZeroBased width)) = do- let sh = Expr.cons padExtent+ shape@(Vec2 (Shape.ZeroBased height) (Shape.ZeroBased width)) = do+ let sh = Expr.cons (Shape.Cyclic height, Shape.Cyclic width) mergePlanes <- RenderP.run $ \a b ->- Symb.zipWith Expr.consComplex (pad 0 sh a) (pad 0 sh b)- let (halfWidth,parity) = divMod width 2+ Symb.zipWith Expr.consComplex (pad_ 0 sh a) (pad_ 0 sh b) let exprFromInt = Expr.cons . fromIntegral mulSpecs <- RenderP.run $- clip (0,0) (exprFromInt $ halfWidth+1, exprFromInt height) .+ clip (0,0) (exprFromInt $ div width 2 + 1, exprFromInt height) . Symb.map (Expr.modify (atomComplex, atomComplex) $ uncurry Komplex.mulConj) . untangleSpectra2d return $ \ a b ->- liftCArray (if parity==0 then FFT.dftCRN [0,1] else FFT.dftCRON [0,1]) =<<- mulSpecs =<< liftCArray (FFT.dftN [0,1]) =<< mergePlanes a b+ return .+ ComfortArray.reshape shape .+ Trafo2.fourierCR .+ ComfortArray.reshape (Shape.Cyclic height, Spectrum.Half width) =<<+ mulSpecs .+ ComfortArray.reshape shape .+ Trafo2.fourier Trafo2.Forward =<<+ mergePlanes a b prepareOverlapMatching ::@@ -1406,10 +1419,10 @@ pow ::- (Tuple.ValueOf a ~ LLVM.Value ar,+ (MultiValue.Repr a ~ LLVM.Value ar, LLVM.IsFloating ar, SoV.TranscendentalConstant ar) => Exp a -> Exp a -> Exp a-pow = flip $ Expr.liftTupleM2 LLVMArith.pow+pow = flip $ Expr.liftReprM2 LLVMArith.pow distanceMapGamma :: (MultiValue.Algebraic a, MultiValue.Real a,@@ -1736,6 +1749,7 @@ notice "write fft" let pic0 : pic1 : _ = map snd rotated size = Vec2 (Shape.ZeroBased 1024) (Shape.ZeroBased 768)+ size_ = (Shape.Cyclic 1024, Shape.Cyclic 768) makeByteImage <- RenderP.run $ \k -> imageByteFromFloat . Symb.map (k*) . Symb.fix runPad <- RenderP.run pad@@ -1743,11 +1757,14 @@ (makeByteImage 1 =<< runPad 0 size pic0) runMagnitude <- RenderP.run $- Symb.map (Expr.modify atomComplex $ \(r:+i) -> Expr.sqrt$ r*r+i*i)+ Symb.map (Expr.modify atomComplex $ \(r:+i) -> Expr.sqrt $ r*r+i*i) . Symb.fix+ runPad_ <- RenderP.run pad_ writeGrey (Option.quality opt) "/tmp/spectrum.jpeg" =<<- (makeByteImage 0.1 =<< runMagnitude =<<- liftCArray (FFT.dftRCN [0,1]) =<< runPad 0 size pic0)+ (makeByteImage 0.1 =<< runMagnitude .+ ComfortArray.mapShape (\(Shape.Cyclic height, halfWidth) -> Vec2 (Shape.ZeroBased height) (Shape.ZeroBased $ fromIntegral $ ComfortShape.size halfWidth)) .+ Trafo2.fourierRC+ =<< runPad_ 0 size_ pic0) correlate <- correlatePadded size writeGrey (Option.quality opt) "/tmp/convolution.jpeg" =<< (makeByteImage 0.1 =<< correlate pic0 pic1)
src/Knead/CArray.hs view
@@ -1,84 +1,61 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Knead.CArray where -import Knead.Shape (Vec2(Vec2), Dim2)- import qualified Complex as Komplex -import qualified Math.FFT as FFT-import Math.FFT.Base (FFTWReal)+import qualified Numeric.FFTW.Rank2 as Trafo2+import qualified Numeric.FFTW.Shape as Spectrum+import qualified Numeric.Netlib.Class as Class import Foreign.Storable.Record.Tuple (Tuple(Tuple)) import Foreign.Storable (Storable) -import qualified Data.Array.Comfort.Shape as ComfortShape-import Data.Array.Comfort.Storable.Unchecked (Array(Array))--import qualified Data.Array.CArray.Base as CArrayPriv-import qualified Data.Array.CArray as CArray-import Data.Array.IArray (Ix, amap, bounds, rangeSize)-import Data.Array.CArray (CArray)--import Control.Applicative ((<$>))+import qualified Data.Array.Comfort.Storable as Array+import qualified Data.Array.Comfort.Shape as Shape+import Data.Array.Comfort.Storable.Unchecked (Array)+import Data.Array.Comfort.Storable ((!)) import Data.Complex (Complex((:+)), realPart) -import Data.Tuple.HT (mapPair)+import Data.Maybe (fromMaybe) -arrayCFromKnead :: Array Dim2 a -> IO (CArray (Int,Int) a)-arrayCFromKnead- (Array- (Vec2 (ComfortShape.ZeroBased height) (ComfortShape.ZeroBased width))- fptr) =- CArrayPriv.unsafeForeignPtrToCArray fptr- ((0,0), (fromIntegral height - 1, fromIntegral width - 1))--arrayKneadFromC ::- (Storable a) => CArray (Int,Int) a -> Array Dim2 a-arrayKneadFromC carray =- case bounds carray of- ((ly,lx), (uy,ux)) ->- Array- (Vec2- (ComfortShape.ZeroBased $ fromIntegral $ rangeSize (ly,uy))- (ComfortShape.ZeroBased $ fromIntegral $ rangeSize (lx,ux)))- (snd $ CArrayPriv.toForeignPtr carray)--liftCArray ::- (Storable a, Storable b) =>- (CArray (Int,Int) a -> CArray (Int,Int) b) ->- Array Dim2 a -> IO (Array Dim2 b)-liftCArray f a = arrayKneadFromC . f <$> arrayCFromKnead a+type Plane = Array (Shape.ZeroBased Int, Shape.ZeroBased Int)+type Cyclic = Array (Shape.Cyclic Int, Shape.Cyclic Int) -pad ::- (Storable a) => a -> (Int,Int) -> CArray (Int,Int) a -> CArray (Int,Int) a+pad :: (Storable a) => a -> (Int,Int) -> Plane a -> Cyclic a pad a (height, width) img =- CArray.listArray ((0,0), (height-1, width-1)) (repeat a)- CArray.//- CArray.assocs img+ Array.sample (Shape.Cyclic height, Shape.Cyclic width) $ \ix ->+ fromMaybe a $ Array.accessMaybe img ix -clip :: (Storable a) => (Int,Int) -> CArray (Int,Int) a -> CArray (Int,Int) a-clip (height, width) = CArray.ixmap ((0,0), (height-1, width-1)) id+uncycle :: Cyclic a -> Plane a+uncycle =+ Array.mapShape+ (\(Shape.Cyclic height, Shape.Cyclic width) ->+ (Shape.ZeroBased height, Shape.ZeroBased width)) +clip ::+ (Storable a, Shape.Indexed sh0, Shape.Indexed sh1) =>+ (Shape.Index sh0 ~ Shape.Index sh1) =>+ sh1 -> Array sh0 a -> Array sh1 a+clip sh img = Array.sample sh (img!)+ correlatePaddedSimple ::- (FFTWReal a) =>- (Int,Int) ->- CArray (Int,Int) a ->- CArray (Int,Int) a ->- CArray (Int,Int) a+ (Class.Real a) => (Int,Int) -> Plane a -> Plane a -> Plane a correlatePaddedSimple sh =- let forward = FFT.dftRCN [0,1] . pad 0 sh- inverse = FFT.dftCRN [0,1]- in \ a b ->- inverse $ CArray.liftArray2 Komplex.mulConj (forward a) (forward b)+ let forward = Trafo2.fourierRC . pad 0 sh+ inverse = Trafo2.fourierCR+ in \a b ->+ uncycle $ Array.map (/ fromIntegral (uncurry (*) sh)) $+ inverse $+ Array.zipWith Komplex.mulConj (forward a) (forward b) --- expects zero-based arrays-cyclicReverse2d :: (Storable a) => CArray (Int,Int) a -> CArray (Int,Int) a+cyclicReverse2d :: (Storable a) => Cyclic a -> Cyclic a cyclicReverse2d spec =- let (height, width) = mapPair ((1+), (1+)) $ snd $ CArray.bounds spec- in CArray.ixmap (CArray.bounds spec)- (\(y,x) -> (mod (-y) height, mod (-x) width)) spec+ let shape@(Shape.Cyclic height, Shape.Cyclic width) = Array.shape spec+ in Array.sample shape (\(y,x) -> spec ! (mod (-y) height, mod (-x) width)) untangleCoefficient :: (Fractional a) => Complex a -> Complex a -> (Complex a, Complex a)@@ -96,10 +73,10 @@ -- ToDo: could be moved to fft package untangleSpectra2d :: (Fractional a, Storable a) =>- CArray (Int,Int) (Complex a) ->- CArray (Int,Int) (Tuple (Complex a, Complex a))+ Cyclic (Complex a) ->+ Cyclic (Tuple (Complex a, Complex a)) untangleSpectra2d spec =- CArray.liftArray2+ Array.zipWith ((Tuple.) . untangleCoefficient) spec (cyclicReverse2d spec) @@ -110,17 +87,17 @@ -} mulConjUntangledSpectra2d :: (Fractional a, Storable a) =>- CArray (Int,Int) (Complex a) -> CArray (Int,Int) (Complex a)+ Cyclic (Complex a) -> Cyclic (Complex a) mulConjUntangledSpectra2d spec =- CArray.liftArray2+ Array.zipWith ((uncurry Komplex.mulConj .) . untangleCoefficient) spec (cyclicReverse2d spec) {--This is more efficient than 'correlatePaddedSimpleCArray'+This is more efficient than 'correlatePaddedSimple' since it needs only one complex forward Fourier transform,-where 'correlatePaddedSimpleCArray' needs two real transforms.+where 'correlatePaddedSimple' needs two real transforms. Especially for odd sizes two real transforms are slower than a complex transform. For the analysis part,@@ -128,29 +105,22 @@ Afterwards we untangle the superposed spectra. -} correlatePaddedComplex ::- (FFTWReal a) =>- (Int,Int) ->- CArray (Int,Int) a ->- CArray (Int,Int) a ->- CArray (Int,Int) a+ (Class.Real a) => (Int,Int) -> Plane a -> Plane a -> Plane a correlatePaddedComplex sh a b =- amap realPart $ FFT.idftN [0,1] $- mulConjUntangledSpectra2d $ FFT.dftN [0,1] $- CArray.liftArray2 (:+) (pad 0 sh a) (pad 0 sh b)+ uncycle $ Array.map ((/ fromIntegral (uncurry (*) sh)) . realPart) $+ Trafo2.fourier Trafo2.Backward $+ mulConjUntangledSpectra2d $ Trafo2.fourier Trafo2.Forward $+ Array.zipWith (:+) (pad 0 sh a) (pad 0 sh b) {- |-Should be yet a little bit more efficient than 'correlatePaddedComplexCArray'+Should be yet a little bit more efficient than 'correlatePaddedComplex' since it uses a real back transform. -} correlatePadded ::- (FFTWReal a) =>- (Int,Int) ->- CArray (Int,Int) a ->- CArray (Int,Int) a ->- CArray (Int,Int) a+ (Class.Real a) => (Int,Int) -> Plane a -> Plane a -> Plane a correlatePadded sh@(height,width) a b =- (case divMod width 2 of- (halfWidth,0) -> FFT.dftCRN [0,1] . clip (height,halfWidth+1)- (halfWidth,_) -> FFT.dftCRON [0,1] . clip (height,halfWidth+1)) $- mulConjUntangledSpectra2d $ FFT.dftN [0,1] $- CArray.liftArray2 (:+) (pad 0 sh a) (pad 0 sh b)+ uncycle $ Array.map (/ fromIntegral (height*width)) $+ Trafo2.fourierCR $+ clip (Shape.Cyclic height, Spectrum.Half width) $+ mulConjUntangledSpectra2d $ Trafo2.fourier Trafo2.Forward $+ Array.zipWith (:+) (pad 0 sh a) (pad 0 sh b)
src/Knead/Color.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}@@ -7,7 +8,8 @@ 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.Storable as Storable+import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Tuple as Tuple@@ -56,11 +58,11 @@ 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)) =>+ MultiVector.C a,+ MultiVector.Repr 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+ load = fmap MultiValue.cast . Storable.load <=< castVectorPtr+ store x = Storable.store (MultiValue.cast x) <=< castVectorPtr castVectorPtr :: LLVM.Value (Ptr (YUV a)) ->@@ -77,7 +79,9 @@ instance (LLVM.IsPrimitive a, LLVM.IsConst a) => MultiValue.C (YUV a) where- cons = MultiValue.consTuple+ type Repr (YUV a) = LLVM.Value (LLVM.Vector TypeNum.D3 a)+ cons (YUV a0 a1 a2) =+ MultiValue.Cons $ LLVM.valueOf $ LLVM.consVector a0 a1 a2 undef = MultiValue.undefTuple zero = MultiValue.zeroTuple phi = MultiValue.phiTuple@@ -85,35 +89,35 @@ yuv ::- (LLVM.IsPrimitive a, Tuple.ValueOf a ~ LLVM.Value a) =>+ (LLVM.IsPrimitive a, MultiValue.Repr a ~ LLVM.Value a) => Exp a -> Exp a -> Exp a -> Exp (YUV a) yuv =- Expr.liftTupleM3+ 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 ::- (LLVM.IsPrimitive a, Tuple.ValueOf a ~ LLVM.Value a) =>+ (LLVM.IsPrimitive a, MultiValue.Repr a ~ LLVM.Value a) => Exp (YUV a) -> Exp a brightness =- Expr.liftTupleM (flip LLVM.extractelement (LLVM.valueOf 0))+ Expr.liftReprM (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)+mapPlain f = Expr.liftReprM (Vector.map f) exprUnliftM1 ::- (Tuple.ValueOf a ~ al, Tuple.ValueOf b ~ bl) =>+ (MultiValue.Repr a ~ al, MultiValue.Repr 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) =>+ (LLVM.IsPrimitive a, MultiValue.Repr a ~ LLVM.Value a,+ LLVM.IsPrimitive b, MultiValue.Repr b ~ LLVM.Value b) => (Exp a -> Exp b) -> Exp (YUV a) -> Exp (YUV b) map f = mapPlain (exprUnliftM1 f)
src/Knead/Shape.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE EmptyDataDecls #-} module Knead.Shape where @@ -7,9 +8,9 @@ import qualified Data.Array.Comfort.Shape as ComfortShape -import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Iterator as Iter import qualified LLVM.Extra.Arithmetic as A@@ -98,6 +99,7 @@ valueOf (Vec2 n m) = Vec2 (Tuple.valueOf n) (Tuple.valueOf m) instance (MultiValue.C n) => MultiValue.C (Vec2 tag n) where+ type Repr (Vec2 tag n) = Vec2 tag (MultiValue.Repr n) cons (Vec2 n m) = MultiValue.compose $ Vec2 (MultiValue.cons n) (MultiValue.cons m) undef = MultiValue.compose $ squareShape MultiValue.undef@@ -152,9 +154,7 @@ 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) unzipShape = MultiValue.decompose (squareShape atom) @@ -169,8 +169,8 @@ ComfortShape.Indexed (Vec2 tag i) where type Index (Vec2 tag i) = Index2 (Shape.Index i) indices (Vec2 n m) = map (uncurry Vec2) $ ComfortShape.indices (n,m)- sizeOffset (Vec2 n m) =- mapSnd (. (\(Vec2 i j) -> (i,j))) $ ComfortShape.sizeOffset (n,m)+ unifiedSizeOffset (Vec2 n m) =+ mapSnd (. (\(Vec2 i j) -> (i,j))) $ ComfortShape.unifiedSizeOffset (n,m) inBounds (Vec2 n m) (Vec2 i j) = ComfortShape.inBounds (n,m) (i,j) instance (tag ~ ShapeTag, Shape.C i) => Shape.C (Vec2 tag i) where
src/MatchImageBorders.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {- | This is an approach for stitching images at narrow bands along lines of small image differences.
src/State.hs view
@@ -212,7 +212,7 @@ catMaybes $ mrot0 : map (\(Rotated _ mrot) -> mrot) rots))) blocks)) .- ListHT.segmentBeforeMaybe+ ListHT.segmentBeforeJust (\(Rotated mPathRel mrot) -> (,) mrot <$> mPathRel) imagePairMap ::