module Feldspar.Vector.Internal where
import qualified Prelude
import Control.Applicative
import qualified Data.TypeLevel as TL
import Test.QuickCheck
import QuickAnnotate
import Language.Syntactic hiding (fold)
import Feldspar.Range (rangeSubSat)
import Feldspar hiding (sugar,desugar,resugar)
import Feldspar.Wrap
import Data.Tuple.Curry
import Data.Tuple.Select
data Vector a
= Empty
| Indexed
{ segmentLength :: Data Length
, segmentIndex :: Data Index -> a
, continuation :: Vector a
}
type instance Elem (Vector a) = a
type instance CollIndex (Vector a) = Data Index
type instance CollSize (Vector a) = Data Length
type Vector1 a = Vector (Data a)
type Vector2 a = Vector (Vector (Data a))
instance Syntax a => Syntactic (Vector a)
where
type Domain (Vector a) = FeldDomainAll
type Internal (Vector a) = [Internal a]
desugar = desugar . freezeVector . map resugar
sugar = map resugar . thawVector . sugar
instance Syntax a => Syntax (Vector a)
instance (Syntax a, Show (Internal a)) => Show (Vector a)
where
show = show . eval
indexed :: Data Length -> (Data Index -> a) -> Vector a
indexed 0 _ = Empty
indexed l idxFun = Indexed l idxFun Empty
segments :: Vector a -> [Vector a]
segments Empty = []
segments (Indexed l ixf cont) = Indexed l ixf Empty : segments cont
length :: Vector a -> Data Length
length Empty = 0
length vec = Prelude.sum $ Prelude.map segmentLength $ segments vec
mergeSegments :: Syntax a => Vector a -> Vector a
mergeSegments Empty = Empty
mergeSegments vec = Indexed (length vec) (ixFun (segments vec)) Empty
where
ixFun [] = const $ err "indexing in empty vector"
ixFun (Empty : vs) = ixFun vs
ixFun (Indexed l ixf _ : vs) = case vs of
[] -> ixf
_ -> \i -> (i<l) ? (ixf i, ixFun vs (il))
freezeVector :: Type a => Vector (Data a) -> Data [a]
freezeVector Empty = value []
freezeVector (Indexed l ixf cont) = parallel l ixf `append` freezeVector cont
thawVector :: Type a => Data [a] -> Vector (Data a)
thawVector arr = indexed (getLength arr) (getIx arr)
thawVector' :: Type a => Length -> Data [a] -> Vector (Data a)
thawVector' len arr = thawVector $ setLength (value len) arr
instance Syntax a => Indexed (Vector a)
where
(!) = segmentIndex . mergeSegments
instance Syntax a => Sized (Vector a)
where
collSize = length
setCollSize = newLen
instance CollMap (Vector a) (Vector b)
where
collMap = map
newLen :: Syntax a => Data Length -> Vector a -> Vector a
newLen l vec = (mergeSegments vec) {segmentLength = l}
(++) :: Vector a -> Vector a -> Vector a
Empty ++ v = v
v ++ Empty = v
Indexed l ixf cont ++ v = Indexed l ixf (cont ++ v)
infixr 5 ++
take :: Data Length -> Vector a -> Vector a
take _ Empty = Empty
take n (Indexed l ixf cont) = indexed nHead ixf ++ take nCont cont
where
nHead = min l n
nCont = sizeProp (uncurry rangeSubSat) (n,l) $ n min l n
drop :: Data Length -> Vector a -> Vector a
drop _ Empty = Empty
drop n (Indexed l ixf cont) = indexed nHead (ixf . (+n)) ++ drop nCont cont
where
nHead = sizeProp (uncurry rangeSubSat) (l,n) $ l min l n
nCont = sizeProp (uncurry rangeSubSat) (n,l) $ n min l n
splitAt :: Data Index -> Vector a -> (Vector a, Vector a)
splitAt n vec = (take n vec, drop n vec)
head :: Syntax a => Vector a -> a
head = (!0)
last :: Syntax a => Vector a -> a
last vec = vec ! (length vec 1)
tail :: Vector a -> Vector a
tail = drop 1
init :: Vector a -> Vector a
init vec = take (length vec 1) vec
tails :: Vector a -> Vector (Vector a)
tails vec = indexed (length vec + 1) (`drop` vec)
inits :: Vector a -> Vector (Vector a)
inits vec = indexed (length vec + 1) (`take` vec)
inits1 :: Vector a -> Vector (Vector a)
inits1 = tail . inits
permute' :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)
permute' _ Empty = Empty
permute' perm (Indexed l ixf Empty) = indexed l (ixf . perm l)
permute :: Syntax a =>
(Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)
permute perm = permute' perm . mergeSegments
reverse :: Syntax a => Vector a -> Vector a
reverse = permute $ \l i -> l1i
rotateVecL :: Syntax a => Data Index -> Vector a -> Vector a
rotateVecL ix = permute $ \l i -> (i + ix) `rem` l
rotateVecR :: Syntax a => Data Index -> Vector a -> Vector a
rotateVecR ix = reverse . rotateVecL ix . reverse
replicate :: Data Length -> a -> Vector a
replicate n a = Indexed n (const a) Empty
enumFromTo :: forall a. (Integral a)
=> Data a -> Data a -> Vector (Data a)
enumFromTo 1 n
| IntType U _ <- typeRep :: TypeRep a
= indexed (i2n n) ((+1) . i2n)
enumFromTo m n = indexed (i2n l) ((+m) . i2n)
where
l = (n<m) ? (0, nm+1)
enumFrom :: (Integral a) => Data a -> Vector (Data a)
enumFrom = flip enumFromTo (value maxBound)
(...) :: (Integral a) => Data a -> Data a -> Vector (Data a)
(...) = enumFromTo
map :: (a -> b) -> Vector a -> Vector b
map _ Empty = Empty
map f (Indexed l ixf cont) = Indexed l (f . ixf) $ map f cont
zip :: (Syntax a, Syntax b) => Vector a -> Vector b -> Vector (a,b)
zip v1 v2 = go (mergeSegments v1) (mergeSegments v2)
where
go Empty _ = Empty
go _ Empty = Empty
go (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) =
indexed (min l1 l2) ((,) <$> ixf1 <*> ixf2)
zip3 :: (Syntax a, Syntax b, Syntax c)
=> Vector a -> Vector b -> Vector c -> Vector (a,b,c)
zip3 v1 v2 v3 = go (mergeSegments v1) (mergeSegments v2) (mergeSegments v3)
where
go Empty _ _ = Empty
go _ Empty _ = Empty
go _ _ Empty = Empty
go (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) (Indexed l3 ixf3 Empty) =
indexed (Prelude.foldr1 min [l1,l2,l3]) ((,,) <$> ixf1 <*> ixf2 <*> ixf3)
zip4 :: (Syntax a, Syntax b, Syntax c, Syntax d)
=> Vector a -> Vector b -> Vector c -> Vector d -> Vector (a,b,c,d)
zip4 v1 v2 v3 v4 = go (mergeSegments v1) (mergeSegments v2) (mergeSegments v3) (mergeSegments v4)
where
go Empty _ _ _ = Empty
go _ Empty _ _ = Empty
go _ _ Empty _ = Empty
go _ _ _ Empty = Empty
go (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) (Indexed l3 ixf3 Empty) (Indexed l4 ixf4 Empty) =
indexed (Prelude.foldr1 min [l1,l2,l3,l4]) ((,,,) <$> ixf1 <*> ixf2 <*> ixf3 <*> ixf4)
zip5 :: (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e)
=> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -> Vector (a,b,c,d,e)
zip5 v1 v2 v3 v4 v5 = go (mergeSegments v1) (mergeSegments v2) (mergeSegments v3) (mergeSegments v4) (mergeSegments v5)
where
go Empty _ _ _ _ = Empty
go _ Empty _ _ _ = Empty
go _ _ Empty _ _ = Empty
go _ _ _ Empty _ = Empty
go _ _ _ _ Empty = Empty
go (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) (Indexed l3 ixf3 Empty) (Indexed l4 ixf4 Empty) (Indexed l5 ixf5 Empty) =
indexed (Prelude.foldr1 min [l1,l2,l3,l4,l5]) ((,,,,) <$> ixf1 <*> ixf2 <*> ixf3 <*> ixf4 <*> ixf5)
unzip :: Vector (a,b) -> (Vector a, Vector b)
unzip v = (map sel1 v, map sel2 v)
unzip3 :: Vector (a,b,c) -> (Vector a, Vector b, Vector c)
unzip3 v = (map sel1 v, map sel2 v, map sel3 v)
unzip4 :: Vector (a,b,c,d) -> (Vector a, Vector b, Vector c, Vector d)
unzip4 v = (map sel1 v, map sel2 v, map sel3 v, map sel4 v)
unzip5 :: Vector (a,b,c,d,e) -> (Vector a, Vector b, Vector c, Vector d, Vector e)
unzip5 v = (map sel1 v, map sel2 v, map sel3 v, map sel4 v, map sel5 v)
zipWith :: (Syntax a, Syntax b) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
zipWith f a b = map (uncurryN f) $ zip a b
zipWith3 :: (Syntax a, Syntax b, Syntax c) =>
(a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d
zipWith3 f a b c = map (uncurryN f) $ zip3 a b c
zipWith4 :: (Syntax a, Syntax b, Syntax c, Syntax d) =>
(a -> b -> c -> d -> e) -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e
zipWith4 f a b c d = map (uncurryN f) $ zip4 a b c d
zipWith5 :: (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e) =>
(a -> b -> c -> d -> e -> f) -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -> Vector f
zipWith5 f a b c d e = map (uncurryN f) $ zip5 a b c d e
fold :: (Syntax a) => (a -> b -> a) -> a -> Vector b -> a
fold _ x Empty = x
fold f x (Indexed l ixf cont) =
fold f (forLoop l x $ \ix s -> f s (ixf ix)) cont
fold1 :: Syntax a => (a -> a -> a) -> Vector a -> a
fold1 f a = fold f (head a) (tail a)
sum :: (Syntax a, Num a) => Vector a -> a
sum = fold (+) 0
maximum :: Ord a => Vector (Data a) -> Data a
maximum = fold1 max
minimum :: Ord a => Vector (Data a) -> Data a
minimum = fold1 min
scalarProd :: (Syntax a, Num a) => Vector a -> Vector a -> a
scalarProd a b = sum (zipWith (*) a b)
tVec :: Patch a a -> Patch (Vector a) (Vector a)
tVec _ = id
tVec1 :: Patch a a -> Patch (Vector (Data a)) (Vector (Data a))
tVec1 _ = id
tVec2 :: Patch a a -> Patch (Vector (Vector (Data a))) (Vector (Vector (Data a)))
tVec2 _ = id
instance (Arbitrary (Internal a), Syntax a) => Arbitrary (Vector a)
where
arbitrary = fmap value arbitrary
instance (Type a) => Wrap (Vector (Data a)) (Data [a]) where
wrap = freezeVector
instance (Wrap t u, Type a, TL.Nat s) => Wrap (Vector1 a -> t) (Data' s [a] -> u) where
wrap f = \(Data' d) -> wrap $ f $ thawVector $ setLength s' d where
s' = fromInteger $ toInteger $ TL.toInt (undefined :: s)
instance Annotatable a => Annotatable (Vector a)
where
annotate _ Empty = Empty
annotate info (Indexed len ixf cont) = Indexed
(annotate (info Prelude.++ " (vector length)") len)
(annotate (info Prelude.++ " (vector element)") . ixf)
(annotate info cont)