horde-ad-0.3.0.0: src/HordeAd/Core/Conversion.hs
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
-- | Conversion constructors.
module HordeAd.Core.Conversion
( TKConversion(..), convCmp, lemTKAllNumConvert, lemTKAllNumBackConvert
, convertSTK, convertFTK, buildTKConversion, transposeTKConversion
) where
import Prelude hiding ((.))
import Control.Category
import Data.Proxy (Proxy (Proxy))
import Data.Type.Equality (TestEquality (..), gcastWith, (:~:) (Refl))
import GHC.TypeLits (type (+))
import Data.Array.Nested (MapJust, Replicate, type (++))
import Data.Array.Nested.Convert
(shrFromShXAnyShape, shsFromSSX, shsFromShX, shxFromShR, shxFromShS)
import Data.Array.Nested.Lemmas
import Data.Array.Nested.Mixed.Shape
import Data.Array.Nested.Shaped.Shape
import Data.Array.Nested.Types (unsafeCoerceRefl)
import HordeAd.Core.TensorKind
import HordeAd.Core.Types
-- | This is copied, with modifications, from ox-arrays.
--
-- This is a recipe for converting arrays, not always followed,
-- and a proof a conversion is possible, with some proof obligations
-- delayed to runtime (in ConvXS' and ConvXX', where not only the ranks
-- of the shapes need to agree, but also the dimensions of the input
-- array and of the output shape, which is not all captured in the type).
-- As in ox-arrays, conversions only change the meta-data, not the underlying
-- vector representation of the array.
type role TKConversion nominal nominal
data TKConversion (a :: TK) (b :: TK) where
ConvId :: TKConversion a a
ConvCmp :: TKConversion b c -> TKConversion a b -> TKConversion a c
ConvRX :: TKConversion (TKR2 n a) (TKX2 (Replicate n Nothing) a)
ConvSX :: TKConversion (TKS2 sh a) (TKX2 (MapJust sh) a)
ConvXR :: SingletonTK a -> TKConversion (TKX2 sh a) (TKR2 (Rank sh) a)
ConvXS :: TKConversion (TKX2 (MapJust sh) a) (TKS2 sh a)
ConvXS' :: Rank sh ~ Rank sh'
=> FullShapeTK (TKS2 sh' a)
-> TKConversion (TKX2 sh a) (TKS2 sh' a)
ConvXX' :: Rank sh ~ Rank sh'
=> FullShapeTK (TKX2 sh' a)
-> TKConversion (TKX2 sh a) (TKX2 sh' a)
ConvRR :: TKConversion a b -> TKConversion (TKR2 n a) (TKR2 n b)
ConvSS :: TKConversion a b -> TKConversion (TKS2 sh a) (TKS2 sh b)
ConvXX :: TKConversion a b -> TKConversion (TKX2 sh a) (TKX2 sh b)
ConvT2 :: TKConversion a a'
-> TKConversion b b'
-> TKConversion (TKProduct a b) (TKProduct a' b')
Conv0X :: SingletonTK a -> TKConversion a (TKX2 '[] a)
ConvX0 :: TKConversion (TKX2 '[] a) a
ConvNest :: SingletonTK (TKX2 sh a)
-> TKConversion (TKX2 (sh ++ sh') a) (TKX2 sh (TKX2 sh' a))
ConvUnnest :: TKConversion (TKX2 sh (TKX2 sh' a)) (TKX2 (sh ++ sh') a)
ConvZip :: SingletonTK a -> SingletonTK b
-> TKConversion (TKProduct (TKX2 sh a) (TKX2 sh b))
(TKX2 sh (TKProduct a b))
ConvUnzip :: SingletonTK a -> SingletonTK b
-> TKConversion (TKX2 sh (TKProduct a b))
(TKProduct (TKX2 sh a) (TKX2 sh b))
deriving instance Show (TKConversion a b)
instance Category TKConversion where
id = ConvId
(.) = convCmp
instance TestEquality (TKConversion a) where
testEquality = \cases
ConvId ConvId -> Just Refl
(ConvCmp c1 d1) (ConvCmp c2 d2)
| Just Refl <- testEquality d1 d2
, Just Refl <- testEquality c1 c2 -> Just Refl
ConvRX ConvRX -> Just Refl
ConvSX ConvSX -> Just Refl
(ConvXR stk1) (ConvXR stk2)
| Just Refl <- sameSTK stk1 stk2 -> Just Refl
ConvXS ConvXS -> Just unsafeCoerceRefl
-- equality with MapJust implies equality without
(ConvXS' ftk1) (ConvXS' ftk2)
| Just Refl <- matchingFTK ftk1 ftk2 -> Just Refl
(ConvXX' ftk1) (ConvXX' ftk2)
| Just Refl <- matchingFTK ftk1 ftk2 -> Just Refl
(ConvRR c1) (ConvRR c2)
| Just Refl <- testEquality c1 c2 -> Just Refl
(ConvSS c1) (ConvSS c2)
| Just Refl <- testEquality c1 c2 -> Just Refl
(ConvXX c1) (ConvXX c2)
| Just Refl <- testEquality c1 c2 -> Just Refl
(ConvT2 c1 d1) (ConvT2 c2 d2)
| Just Refl <- testEquality c1 c2
, Just Refl <- testEquality d1 d2 -> Just Refl
(Conv0X stk1) (Conv0X stk2)
| Just Refl <- sameSTK stk1 stk2 -> Just Refl
ConvX0 ConvX0 -> Just Refl
(ConvNest stk1) (ConvNest stk2)
| Just Refl <- sameSTK stk1 stk2 -> Just unsafeCoerceRefl
-- (sh ++) is morally injective
ConvUnnest ConvUnnest -> Just Refl
(ConvZip stk1 stk'1) (ConvZip stk2 stk'2)
| Just Refl <- sameSTK stk1 stk2
, Just Refl <- sameSTK stk'1 stk'2 -> Just Refl
(ConvUnzip stk1 stk'1) (ConvUnzip stk2 stk'2)
| Just Refl <- sameSTK stk1 stk2
, Just Refl <- sameSTK stk'1 stk'2 -> Just Refl
_ _ -> Nothing
-- TODO: expand
convCmp :: TKConversion b c -> TKConversion a b -> TKConversion a c
convCmp a b = case (a, b) of
(_, ConvId) -> a
(_, ConvCmp ConvId c) -> convCmp a c
(ConvId, _) -> b
(ConvCmp a1 a2, _) -> a1 . (a2 . b)
(ConvSX, ConvXS) -> ConvId
(ConvSX, ConvCmp ConvXS c) -> c
(ConvXR{}, ConvRX @n) | Refl <- lemRankReplicate (Proxy @n) -> ConvId
(ConvXR{}, ConvCmp (ConvRX @n) c) | Refl <- lemRankReplicate (Proxy @n) -> c
(ConvXR stk, ConvXX'{}) -> ConvXR stk
(ConvXR stk, ConvCmp ConvXX'{} c) -> convCmp (ConvXR stk) c
(ConvXS @sh, ConvSX @sh') ->
gcastWith (unsafeCoerceRefl :: sh :~: sh')
ConvId
(ConvXS @sh, ConvCmp (ConvSX @sh') c) ->
gcastWith (unsafeCoerceRefl :: sh :~: sh')
c
(ConvXS, ConvXX' (FTKX sh x)) | Refl <- lemRankMapJust (shsFromShX sh) ->
ConvXS' (FTKS (shsFromShX sh) x)
(ConvXS, ConvCmp (ConvXX' (FTKX sh x)) c)
| Refl <- lemRankMapJust (shsFromShX sh) ->
convCmp (ConvXS' (FTKS (shsFromShX sh) x)) c
(ConvXS' @_ @sh' _, ConvSX @sh) ->
gcastWith (unsafeCoerceRefl :: sh :~: sh')
ConvId
(ConvXS' @_ @sh' _, ConvCmp (ConvSX @sh) c) ->
gcastWith (unsafeCoerceRefl :: sh :~: sh')
c
(ConvXS' ftk, ConvXX'{}) -> ConvXS' ftk
(ConvXS' ftk, ConvCmp ConvXX'{} c) -> convCmp (ConvXS' ftk) c
(ConvXS' (FTKS ZSS _), Conv0X stk) -> convCmp ConvXS (Conv0X stk)
(ConvXS' (FTKS ZSS _), ConvCmp (Conv0X stk) c) ->
convCmp (convCmp ConvXS (Conv0X stk)) c
(ConvXX' ftk, ConvXX'{}) -> ConvXX' ftk
(ConvXX' ftk, ConvCmp ConvXX'{} c) -> convCmp (ConvXX' ftk) c
(ConvXX' (FTKX ZSX _), Conv0X stk) -> Conv0X stk
(ConvXX' (FTKX ZSX _), ConvCmp (Conv0X stk) c) -> convCmp (Conv0X stk) c
(ConvRR a', ConvRR b') -> ConvRR (convCmp a' b')
(ConvRR a', ConvCmp (ConvRR b') c) -> convCmp (ConvRR (convCmp a' b')) c
(ConvSS a', ConvSS b') -> ConvSS (convCmp a' b')
(ConvSS a', ConvCmp (ConvSS b') c) -> convCmp (ConvSS (convCmp a' b')) c
(ConvXX a', ConvXX b') -> convXX (convCmp a' b')
(ConvXX a', ConvCmp (ConvXX b') c) -> convCmp (convXX (convCmp a' b')) c
(Conv0X{}, ConvX0) -> ConvId
(Conv0X{}, ConvCmp ConvX0 c) -> c
(ConvX0, ConvXX' @sh (FTKX ZSX _)) ->
gcastWith (unsafeCoerceRefl :: sh :~: '[])
ConvX0
(ConvX0, ConvCmp (ConvXX' @sh (FTKX ZSX _)) c) ->
gcastWith (unsafeCoerceRefl :: sh :~: '[]) $
convCmp ConvX0 c
(ConvX0, Conv0X{}) -> ConvId
(ConvX0, ConvCmp Conv0X{} c) -> c
(ConvT2 a1 a2, ConvT2 b1 b2) -> convT2 (convCmp a1 b1) (convCmp a2 b2)
(ConvT2 a1 a2, ConvCmp (ConvT2 b1 b2) c) ->
convCmp (convT2 (convCmp a1 b1) (convCmp a2 b2)) c
{- Not enough singletons to decide the equality here:
(ConvNest @sh @_ @sh' _, ConvUnnest @sh2 @sh2')
| Just Refl <- testEquality sh :~: sh2) ->
gcastWith (unsafeCoerceRefl :: sh' :~: sh2') $
ConvId
(ConvNest @sh @_ @sh' _, ConvCmp (ConvUnnest @sh2 @sh2') c)
| Just Refl <- testEquality sh :~: sh2) ->
gcastWith (unsafeCoerceRefl :: sh' :~: sh2') $
c -}
-- not enough type info in the AST:
-- (ConvNest (STKX sh x), ConvXX d) ->
-- convCmp (ConvXX (ConvXX d)) (ConvNest (STKX sh (convertSTKBack d x)))
(ConvUnnest, ConvNest{}) -> ConvId
(ConvUnnest, ConvCmp ConvNest{} c) -> c
(ConvXX d, ConvUnnest) ->
convCmp ConvUnnest (convXX (convXX d))
(ConvXX d, ConvCmp ConvUnnest c) ->
convCmp ConvUnnest (convCmp (convXX (convXX d)) c)
(ConvZip{}, ConvUnzip{}) -> ConvId
(ConvZip{}, ConvCmp (ConvUnzip{}) c) -> c
(ConvXX' (FTKX sh (FTKProduct c1 c2)), ConvZip stk1 stk2) ->
convCmp (ConvZip stk1 stk2)
(convT2 (ConvXX' (FTKX sh c1)) (ConvXX' (FTKX sh c2)))
(ConvXX' (FTKX sh (FTKProduct c1 c2)), ConvCmp (ConvZip stk1 stk2) c) ->
convCmp (ConvZip stk1 stk2)
(convCmp (convT2 (ConvXX' (FTKX sh c1)) (ConvXX' (FTKX sh c2))) c)
(ConvUnzip{}, ConvZip{}) -> ConvId
(ConvUnzip{}, ConvCmp (ConvZip{}) c) -> c
(ConvUnzip stk1 stk2, ConvXX' (FTKX sh (FTKProduct c1 c2))) ->
convCmp (convT2 (ConvXX' (FTKX sh c1)) (ConvXX' (FTKX sh c2)))
(ConvUnzip stk1 stk2)
(ConvUnzip stk1 stk2, ConvCmp (ConvXX' (FTKX sh (FTKProduct c1 c2))) c) ->
convCmp (convT2 (ConvXX' (FTKX sh c1)) (ConvXX' (FTKX sh c2)))
(convCmp (ConvUnzip stk1 stk2) c)
_ -> ConvCmp a b
convT2 :: TKConversion a a'
-> TKConversion b b'
-> TKConversion (TKProduct a b) (TKProduct a' b')
convT2 ConvId ConvId = ConvId
convT2 a b = ConvT2 a b
convXX :: TKConversion a b -> TKConversion (TKX2 sh a) (TKX2 sh b)
convXX ConvId = ConvId
convXX a = ConvXX a
lemTKAllNumConvert :: TKAllNum a
=> TKConversion a b -> Dict0 (TKAllNum b)
lemTKAllNumConvert = \case
ConvId -> Dict0
ConvCmp c1 c2 | Dict0 <- lemTKAllNumConvert c2 ->
lemTKAllNumConvert c1
ConvRX -> Dict0
ConvSX -> Dict0
ConvXR{} -> Dict0
ConvXS -> Dict0
ConvXS'{} -> Dict0
ConvXX'{} -> Dict0
ConvRR c | Dict0 <- lemTKAllNumConvert c -> Dict0
ConvSS c | Dict0 <- lemTKAllNumConvert c -> Dict0
ConvXX c | Dict0 <- lemTKAllNumConvert c -> Dict0
ConvT2 c1 c2 | Dict0 <- lemTKAllNumConvert c1
, Dict0 <- lemTKAllNumConvert c2 -> Dict0
Conv0X{} -> Dict0
ConvX0 -> Dict0
ConvNest{} -> Dict0
ConvUnnest -> Dict0
ConvZip{} -> Dict0
ConvUnzip{} -> Dict0
lemTKAllNumBackConvert :: TKAllNum b
=> TKConversion a b -> Dict0 (TKAllNum a)
lemTKAllNumBackConvert = \case
ConvId -> Dict0
ConvCmp c1 c2 | Dict0 <- lemTKAllNumBackConvert c1 ->
lemTKAllNumBackConvert c2
ConvRX -> Dict0
ConvSX -> Dict0
ConvXR{} -> Dict0
ConvXS -> Dict0
ConvXS'{} -> Dict0
ConvXX'{} -> Dict0
ConvRR c | Dict0 <- lemTKAllNumBackConvert c -> Dict0
ConvSS c | Dict0 <- lemTKAllNumBackConvert c -> Dict0
ConvXX c | Dict0 <- lemTKAllNumBackConvert c -> Dict0
ConvT2 c1 c2 | Dict0 <- lemTKAllNumBackConvert c1
, Dict0 <- lemTKAllNumBackConvert c2 -> Dict0
Conv0X{} -> Dict0
ConvX0 -> Dict0
ConvNest{} -> Dict0
ConvUnnest -> Dict0
ConvZip{} -> Dict0
ConvUnzip{} -> Dict0
convertSTK :: TKConversion a b -> SingletonTK a -> SingletonTK b
convertSTK = \cases
ConvId astk -> astk
(ConvCmp c1 c2) astk -> convertSTK c1 (convertSTK c2 astk)
ConvRX (STKR n a) -> STKX (ssxReplicate n) a
ConvSX (STKS sh a) -> STKX (ssxFromShX $ shxFromShS sh) a
(ConvXR _stk) (STKX ssx a) -> STKR (ssxRank ssx) a
ConvXS (STKX ssx a) -> STKS (shsFromSSX ssx) a
(ConvXS' (FTKS sh _x)) (STKX _ssx2 a) -> STKS sh a
(ConvXX' (FTKX shx _x)) (STKX _ssx2 a) -> STKX (ssxFromShX shx) a
(ConvRR c) (STKR n a) -> STKR n (convertSTK c a)
(ConvSS c) (STKS sh a) -> STKS sh (convertSTK c a)
(ConvXX c) (STKX ssx a) -> STKX ssx (convertSTK c a)
(ConvT2 c1 c2) (STKProduct stk1 stk2) ->
STKProduct (convertSTK c1 stk1) (convertSTK c2 stk2)
(Conv0X _stk) stk -> STKX ZKX stk
ConvX0 (STKX ZKX stk) -> stk
(ConvNest (STKX ssx x)) (STKX shsh' _x) ->
STKX ssx (STKX (ssxDropSSX ssx shsh') x)
ConvUnnest (STKX sh (STKX sh' x)) -> STKX (sh `ssxAppend` sh') x
(ConvZip _ _) (STKProduct (STKX sh a1) (STKX _sh a2)) ->
STKX sh (STKProduct a1 a2)
(ConvUnzip _ _) (STKX sh (STKProduct a1 a2)) ->
STKProduct (STKX sh a1) (STKX sh a2)
convertFTK :: TKConversion a b -> FullShapeTK a -> FullShapeTK b
convertFTK = \cases
ConvId aftk -> aftk
(ConvCmp c1 c2) aftk -> convertFTK c1 (convertFTK c2 aftk)
ConvRX (FTKR shr a) -> FTKX (shxFromShR shr) a
ConvSX (FTKS sh a) -> FTKX (shxFromShS sh) a
(ConvXR _stk) (FTKX shx a) -> FTKR (shrFromShXAnyShape shx) a
ConvXS (FTKX shx a) -> FTKS (shsFromShX shx) a
(ConvXS' ftk) _ -> ftk
(ConvXX' ftk) _ -> ftk
(ConvRR c) (FTKR shr a) -> FTKR shr (convertFTK c a)
(ConvSS c) (FTKS sh a) -> FTKS sh (convertFTK c a)
(ConvXX c) (FTKX shx a) -> FTKX shx (convertFTK c a)
(ConvT2 c1 c2) (FTKProduct ftk1 ftk2) ->
FTKProduct (convertFTK c1 ftk1) (convertFTK c2 ftk2)
(Conv0X _stk) ftk -> FTKX ZSX ftk
ConvX0 (FTKX ZSX ftk) -> ftk
(ConvNest @_ @_ @sh' (STKX ssx _x)) (FTKX shsh' x) ->
let (t, d) = shxSplitApp (Proxy @sh') ssx shsh'
in FTKX t (FTKX d x)
ConvUnnest (FTKX sh (FTKX sh' x)) -> FTKX (sh `shxAppend` sh') x
(ConvZip _ _) (FTKProduct (FTKX sh a1) (FTKX _sh a2)) ->
FTKX sh (FTKProduct a1 a2)
(ConvUnzip _ _) (FTKX sh (FTKProduct a1 a2)) ->
FTKProduct (FTKX sh a1) (FTKX sh a2)
buildTKConversion :: SNat k -> FullShapeTK a
-> TKConversion a b
-> TKConversion (BuildTensorKind k a) (BuildTensorKind k b)
buildTKConversion k aftk c0 = case c0 of
ConvId -> ConvId
ConvCmp c1 c2 -> convCmp (buildTKConversion k (convertFTK c2 aftk) c1)
(buildTKConversion k aftk c2)
ConvRX | FTKR @n shr xstk <- aftk
, Refl <- lemRankReplicate (Proxy @n)
, Refl <- lemRankReplicate (Proxy @(1 + n)) ->
convCmp (ConvXX' (FTKX (SKnown k :$% shxFromShR shr) xstk)) ConvRX
ConvSX -> ConvSX
ConvXR stk -> ConvXR stk
ConvXS -> ConvXS
ConvXS' ftk -> ConvXS' (buildFTK k ftk)
ConvXX' ftk -> ConvXX' (buildFTK k ftk)
ConvRR c -> ConvRR c
ConvSS c -> ConvSS c
ConvXX c -> ConvXX c
ConvT2 c1 c2 | FTKProduct ftk1 ftk2 <- aftk ->
ConvT2 (buildTKConversion k ftk1 c1) (buildTKConversion k ftk2 c2)
Conv0X _astk -> case aftk of
FTKScalar -> ConvSX
FTKR @n shr x | Refl <- lemRankReplicate (Proxy @n)
, Refl <- lemRankReplicate (Proxy @(1 + n)) ->
convCmp (ConvXX (ConvXR (ftkToSTK x)))
(convCmp (ConvNest (STKX (SKnown k :!% ZKX) (ftkToSTK x)))
(convCmp
(ConvXX' (FTKX (SKnown k :$% shxFromShR shr) x))
ConvRX))
FTKS _sh x ->
convCmp (ConvXX ConvXS)
(convCmp (ConvNest (STKX (SKnown k :!% ZKX) (ftkToSTK x)))
ConvSX)
FTKX _ssx x -> ConvNest (STKX (SKnown k :!% ZKX) (ftkToSTK x))
FTKProduct aftk1 aftk2 ->
buildTKConversion
k aftk (convCmp (ConvZip (ftkToSTK aftk1) (ftkToSTK aftk2))
(ConvT2 (Conv0X (ftkToSTK aftk1))
(Conv0X (ftkToSTK aftk2))))
ConvX0 -> case aftk of
FTKX ZSX FTKScalar -> ConvXS
FTKX ZSX (FTKR @n _n x) | Refl <- lemRankReplicate (Proxy @n) ->
convCmp (ConvXR (ftkToSTK x))
(convCmp ConvUnnest (ConvXX ConvRX))
FTKX ZSX FTKS{} ->
convCmp ConvXS
(convCmp ConvUnnest (ConvXX ConvSX))
FTKX ZSX FTKX{} -> ConvUnnest
FTKX ZSX (FTKProduct aftk1 aftk2) ->
buildTKConversion
k aftk (convCmp (ConvT2 ConvX0 ConvX0)
(ConvUnzip (ftkToSTK aftk1) (ftkToSTK aftk2)))
ConvNest (STKX sh x) -> ConvNest (STKX (SKnown k :!% sh) x)
ConvUnnest -> ConvUnnest
ConvZip astk1 astk2 -> ConvZip astk1 astk2
ConvUnzip astk1 astk2 -> ConvUnzip astk1 astk2
transposeTKConversion :: FullShapeTK a -> TKConversion a b -> TKConversion b a
transposeTKConversion aftk c0 = case c0 of
ConvId -> ConvId
ConvCmp c1 c2 -> transposeTKConversion aftk c2
`convCmp` transposeTKConversion (convertFTK c2 aftk) c1
ConvRX | FTKR @n _ x <- aftk
, Refl <- lemRankReplicate (Proxy @n) ->
ConvXR (ftkToSTK x)
ConvSX -> ConvXS
ConvXR @_ @sh _stk | Refl <- lemRankReplicate (Proxy @(Rank sh)) ->
convCmp (ConvXX' aftk) ConvRX
ConvXS -> ConvSX
ConvXS' (FTKS sh _) | Refl <- lemRankMapJust sh ->
convCmp (ConvXX' aftk) ConvSX
ConvXX' _ftk -> ConvXX' aftk
ConvRR c | FTKR _ x <- aftk -> ConvRR (transposeTKConversion x c)
ConvSS c | FTKS _ x <- aftk -> ConvSS (transposeTKConversion x c)
ConvXX c | FTKX _ x <- aftk -> ConvXX (transposeTKConversion x c)
ConvT2 c1 c2 | FTKProduct x1 x2 <- aftk ->
ConvT2 (transposeTKConversion x1 c1) (transposeTKConversion x2 c2)
Conv0X _stk -> ConvX0
ConvX0 | FTKX ZSX x <- aftk -> Conv0X (ftkToSTK x)
ConvNest _stk -> ConvUnnest
ConvUnnest | (FTKX shx (FTKX _ x)) <- aftk ->
ConvNest (STKX (ssxFromShX shx) (ftkToSTK x))
ConvZip stk1 stk2 -> ConvUnzip stk1 stk2
ConvUnzip stk1 stk2 -> ConvZip stk1 stk2