diff --git a/Changes.md b/Changes.md --- a/Changes.md +++ b/Changes.md @@ -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` diff --git a/patch-image.cabal b/patch-image.cabal --- a/patch-image.cabal +++ b/patch-image.cabal @@ -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 Maintainer: Henning Thielemann -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) diff --git a/src/Knead.hs b/src/Knead.hs --- a/src/Knead.hs +++ b/src/Knead.hs @@ -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) diff --git a/src/Knead/CArray.hs b/src/Knead/CArray.hs --- a/src/Knead/CArray.hs +++ b/src/Knead/CArray.hs @@ -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) diff --git a/src/Knead/Color.hs b/src/Knead/Color.hs --- a/src/Knead/Color.hs +++ b/src/Knead/Color.hs @@ -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) diff --git a/src/Knead/Shape.hs b/src/Knead/Shape.hs --- a/src/Knead/Shape.hs +++ b/src/Knead/Shape.hs @@ -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 diff --git a/src/MatchImageBorders.hs b/src/MatchImageBorders.hs --- a/src/MatchImageBorders.hs +++ b/src/MatchImageBorders.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {- | This is an approach for stitching images at narrow bands along lines of small image differences. diff --git a/src/State.hs b/src/State.hs --- a/src/State.hs +++ b/src/State.hs @@ -212,7 +212,7 @@ catMaybes $ mrot0 : map (\(Rotated _ mrot) -> mrot) rots))) blocks)) . - ListHT.segmentBeforeMaybe + ListHT.segmentBeforeJust (\(Rotated mPathRel mrot) -> (,) mrot <$> mPathRel) imagePairMap ::