I started reading Chapter 6 of "Type-driven development with Idris" and attempted to write a smart constructor for a tupled vector.
TupleVect : Nat -> Type -> Type
TupleVect Z _ = ()
TupleVect (S k) a = (a, TupleVect k a)
someValue : TupleVect 4 Nat
someValue = (1,2,3,4,())
TupleVectConstructorType : Nat -> Type -> Type
TupleVectConstructorType n typ = helper n
where
helper : Nat -> Type
helper Z = TupleVect n typ
helper (S k) = typ -> helper k
tupleVect : (n : Nat) -> (a : Type) -> TupleVectConstructorType n a
tupleVect Z a = ()
tupleVect (S Z) a = \val => (val, ())
tupleVect (S (S Z)) a = \val2 => \val1 => (val2, val1, ())
-- ??? how to create tupleVect (S k) a
How to create a constructor for an arbitrary k?
Basically #Matthias Berndt's idea. Counting down the arrows to be added, while making the final tuple longer. For this we need to access the more permissive helper from TupleVectType.
TupleVectType' : Nat -> Nat -> Type -> Type
TupleVectType' Z n a = TupleVect n a
TupleVectType' (S k) n a = a -> TupleVectType' k (S n) a
TupleVectType : Nat -> Type -> Type
TupleVectType n = TupleVectType' n Z
tupleVect : (n : Nat) -> (a : Type) -> TupleVectType n a
tupleVect n a = helper n Z a ()
where
helper : (k, n : Nat) -> (a : Type) -> (acc : TupleVect n a)
-> TupleVectType' k n a
helper Z n a acc = acc
helper (S k) n a acc = \x => helper k (S n) a (x, acc)
someValue2 : TupleVect 4 Nat
someValue2 = (tupleVect 4 Nat) 4 3 2 1
Though note that this will result in \v2 => \v1 => (v1, v2, ()) and not \v2 => \v1 => (v2, v1, ()) as the former fits the recursive definition of TupleVect (S k) a = (a, TupleVect k a) better.
I know almost nothing about Idris except that it's a dependently-typed, Haskell-like language. But I find this problem intriguing, so I gave it a shot.
Clearly you need a recursive solution here. My idea is to use an additional parameter f which accumulates the val1..val_n parameters that the function has eaten so far. When the base case is reached, f is returned.
tupleVectHelper Z a f = f
tupleVectHelper (S n) a f = \val => tupleVectHelper n a (val, f)
tupleVect n a = tupleVectHelper n a ()
I have no idea if this works, and I haven't yet figured out how to write the type of tupleVectHelper, but I've tried doing the substitutions manually for n = 3 and it does seem to work out on paper, though the resulting tuple is backwards. But I think that shouldn't be too hard to fix.
Hope this helps!
Related
Okasaki describes persistent real-time queues which can be realized in Haskell using the type
data Queue a = forall x . Queue
{ front :: [a]
, rear :: [a]
, schedule :: [x]
}
where incremental rotations maintain the invariant
length schedule = length front - length rear
More details
If you're familiar with the queues involved, you can skip this section.
The rotation function looks like
rotate :: [a] -> [a] -> [a] -> [a]
rotate [] (y : _) a = y : a
rotate (x : xs) (y : ys) a =
x : rotate xs ys (y : a)
and it's called by a smart constructor
exec :: [a] -> [a] -> [x] -> Queue a
exec f r (_ : s) = Queue f r s
exec f r [] = Queue f' [] f' where
f' = rotate f r []
after each queue operation. The smart constructor is always called when length s = length f - length r + 1, ensuring that the pattern match in rotate will succeed.
The problem
I hate partial functions! I'd love to find a way to express the structural invariant in the types. The usual dependent vector seems a likely choice:
data Nat = Z | S Nat
data Vec n a where
Nil :: Vec 'Z a
Cons :: a -> Vec n a -> Vec ('S n) a
and then (perhaps)
data Queue a = forall x rl sl . Queue
{ front :: Vec (sl :+ rl) a
, rear :: Vec rl a
, schedule :: Vec sl x
}
The trouble is that I haven't been able to figure out how to juggle the types. It seems extremely likely that some amount of unsafeCoerce will be needed to make this efficient. However, I haven't been able to come up with an approach that's even vaguely manageable. Is it possible to do this nicely in Haskell?
Here is what I got:
open import Function
open import Data.Nat.Base
open import Data.Vec
grotate : ∀ {n m} {A : Set}
-> (B : ℕ -> Set)
-> (∀ {n} -> A -> B n -> B (suc n))
-> Vec A n
-> Vec A (suc n + m)
-> B m
-> B (suc n + m)
grotate B cons [] (y ∷ ys) a = cons y a
grotate B cons (x ∷ xs) (y ∷ ys) a = grotate (B ∘ suc) cons xs ys (cons y a)
rotate : ∀ {n m} {A : Set} -> Vec A n -> Vec A (suc n + m) -> Vec A m -> Vec A (suc n + m)
rotate = grotate (Vec _) _∷_
record Queue (A : Set) : Set₁ where
constructor queue
field
{X} : Set
{n m} : ℕ
front : Vec A (n + m)
rear : Vec A m
schedule : Vec X n
open import Relation.Binary.PropositionalEquality
open import Data.Nat.Properties.Simple
exec : ∀ {m n A} -> Vec A (n + m) -> Vec A (suc m) -> Vec A n -> Queue A
exec {m} {suc n} f r (_ ∷ s) = queue (subst (Vec _) (sym (+-suc n m)) f) r s
exec {m} f r [] = queue (with-zero f') [] f' where
with-zero = subst (Vec _ ∘ suc) (sym (+-right-identity m))
without-zero = subst (Vec _ ∘ suc) (+-right-identity m)
f' = without-zero (rotate f (with-zero r) [])
rotate is defined in terms of grotate for the same reason reverse is defined in terms of foldl (or enumerate in terms of genumerate): because Vec A (suc n + m) is not definitionally Vec A (n + suc m), while (B ∘ suc) m is definitionally B (suc m).
exec has the same implementation as you provided (modulo those substs), but I'm not sure about the types: is it OK that r must be non-empty?
The other answer is super clever (please take a moment to upvote it), but as someone not familiar with Agda, how this would be implemented in Haskell was not obvious to me. Here's a full Haskell version. We'll need a whole slew of extensions, as well as Data.Type.Equality (since we will need to do some limited amount of type-proofs).
{-# LANGUAGE GADTs, ScopedTypeVariables,RankNTypes,
TypeInType, TypeFamilies, TypeOperators #-}
import Data.Type.Equality
Defining Nat, Vec, and Queue
Next, we define the usual type-level natural numbers (this looks like just a regular data definition, but because we have TypeInType enabled, it will get automatically promoted when we use it in a type) and a type function (a type family) for addition. Note that although there are multiple ways of defining +, our choice here will impact what follows. We'll also define the usual Vec which is very much like a list except that it encodes its length in the phantom type n. With that, we can go ahead and define the type of our queue.
data Nat = Z | S Nat
type family n + m where
Z + m = m
S n + m = S (n + m)
data Vec a n where
Nil :: Vec a Z
(:::) :: a -> Vec a n -> Vec a (S n)
data Queue a where
Queue :: { front :: Vec a (n + m)
, rear :: Vec a m
, schedule :: Vec x n } -> Queue a
Defining rotate
Now, things start to get hairier. We want to define a function rotate that has type rotate :: Vec a n -> Vec a (S n + m) -> Vec a m -> Vec a (S n + m), but you quickly run into a variety of proof related problems with just defining this recursively. The solution is instead to define a slightly more general grotate, which can be defined recursively, and for which rotate is a special case.
The point of Bump is to circumvent the fact that there is no such thing as type level composition in Haskell. There is no way of writing things an operator like (∘) such that (S ∘ S) x is S (S x). The workaround is to continuously wrap/unwrap with Bump/lower.
newtype Bump p n = Bump { lower :: p (S n) }
grotate :: forall p n m a.
(forall n. a -> p n -> p (S n)) ->
Vec a n ->
Vec a (S n + m) ->
p m ->
p (S n + m)
grotate cons Nil (y ::: _) zs = cons y zs
grotate cons (x ::: xs) (y ::: ys) zs = lower (grotate consS xs ys (Bump (cons y zs)))
where
consS :: forall n. a -> Bump p n -> Bump p (S n)
consS = \a -> Bump . cons a . lower
rotate :: Vec a n -> Vec a (S n + m) -> Vec a m -> Vec a (S n + m)
rotate = grotate (:::)
We need explicit foralls here to make it very clear which type variables are getting captured and which aren't, as well as to denote higher-rank types.
Singleton natural numbers SNat
Before we proceed to exec, we set up some machinery that will allow us to prove some type-level arithmetic claims (which we need to get exec to typecheck). We start by making an SNat type (which is a singleton type corresponding to Nat). SNat reflects its value in a phantom type variable.
data SNat n where
SZero :: SNat Z
SSucc :: SNat n -> SNat (S n)
We can then make a couple useful functions to do things with SNat.
sub1 :: SNat (S n) -> SNat n
sub1 (SSucc x) = x
size :: Vec a n -> SNat n
size Nil = SZero
size (_ ::: xs) = SSucc (size xs)
Finally, we are prepared to prove some arithmetic, namely that n + S m ~ S (n + m) and n + Z ~ n.
plusSucc :: (SNat n) -> (SNat m) -> (n + S m) :~: S (n + m)
plusSucc SZero _ = Refl
plusSucc (SSucc n) m = gcastWith (plusSucc n m) Refl
plusZero :: SNat n -> (n + Z) :~: n
plusZero SZero = Refl
plusZero (SSucc n) = gcastWith (plusZero n) Refl
Defining exec
Now that we have rotate, we can define exec. This definition looks almost identical to the one in the question (with lists), except annotated with gcastWith <some-proof>.
exec :: Vec a (n + m) -> Vec a (S m) -> Vec a n -> Queue a
exec f r (_ ::: s) = gcastWith (plusSucc (size s) (sub1 (size r))) $ Queue f r s
exec f r Nil = gcastWith (plusZero (sub1 (size r))) $
let f' = rotate f r Nil in (Queue f' Nil f')
It is probably worth noting that we can get some stuff for free by using singletons. With the right extensions enabled, the following more readable code
import Data.Singletons.TH
singletons [d|
data Nat = Z | S Nat
(+) :: Nat -> Nat -> Nat
Z + n = n
S m + n = S (m + n)
|]
defines, Nat, the type family :+ (equivalent to my +), and the singleton type SNat (with constructors SZ and SS equivalent to my SZero and SSucc) all in one.
I have a recursive function f that takes two parameters x and y. The function is uniquely determined by the first parameter; the second one merely makes things easier.
I now want to memoise that function w.r.t. it's first parameter while ignoring the second one. (I.e. f is evaluated at most one for every value of x)
What is the easiest way to do that? At the moment, I simply define an array containing all values recursively, but that is a somewhat ad-hoc solution. I would prefer some kind of memoisation combinator that I can just throw at my function.
EDIT: to clarify, the function f takes a pair of integers and a list. The first integer is some parameter value, the second one denotes the index of an element in some global list xs to consume.
To avoid indexing the list, I pass the partially consumed list to f as well, but obviously, the invariant is that if the first parameter is (m, n), the second one will always be drop n xs, so the result is uniquely determined by the first parameter.
Just using a memoisation combinator on the partially applied function will not work, since that will leave an unevaluated thunk \xs -> … lying around. I could probably wrap the two parameters in a datatype whose Eq instance ignores the second value (and similarly for other instances), but that seems like a very ad-hoc solution. Is there not an easier way?
EDIT2: The concrete function I want to memoise:
g :: [(Int, Int)] -> Int -> Int
g xs n = f 0 n
where f :: Int -> Int -> Int
f _ 0 = 0
f m n
| m == length xs = 0
| w > n = f (m + 1) n
| otherwise = maximum [f (m + 1) n, v + f (m + 1) (n - w)]
where (w, v) = xs !! m
To avoid the expensive indexing operation, I instead pass the partially-consumed list to f as well:
g' :: [(Int, Int)] -> Int -> Int
g' xs n = f xs 0 n
where f :: [(Int, Int)] -> Int -> Int -> Int
f [] _ _ = 0
f _ _ 0 = 0
f ((w,v) : xs) m n
| w > n = f xs (m + 1) n
| otherwise = maximum [f xs (m + 1) n, v + f xs (m + 1) (n - w)]
Memoisation of f w.r.t. the list parameter is, of course, unnecessary, since the list does not (morally) influence the result. I would therefore like the memoisation to simply ignore the list parameter.
Your function is unnecessarily complicated. You don't need the index m at all:
foo :: [(Int, Int)] -> Int -> Int
foo [] _ = 0
foo _ 0 = 0
foo ((w,v):xs) n
| w > n = foo xs n
| otherwise = foo xs n `max` foo xs (n - w) + v
Now if you want to memoize foo then both the arguments must be considered (as it should be).
We'll use the monadic memoization mixin method to memoize foo:
First, we create an uncurried version of foo (because we want to memoize both arguments):
foo' :: ([(Int, Int)], Int) -> Int
foo' ([], _) = 0
foo' (_, 0) = 0
foo' ((w,v):xs, n)
| w > n = foo' (xs, n)
| otherwise = foo' (xs, n) `max` foo' (xs, n - w) + v
Next, we monadify the function foo' (because we want to thread a memo table in the function):
foo' :: Monad m => ([(Int, Int)], Int) -> m Int
foo' ([], _) = return 0
foo' (_, 0) = return 0
foo' ((w,v):xs, n)
| w > n = foo' (xs, n)
| otherwise = do
a <- foo' (xs, n)
b <- foo' (xs, n - w)
return (a `max` b + v)
Then, we open the self-reference in foo' (because we want to call the memoized function):
type Endo a = a -> a
foo' :: Monad m => Endo (([(Int, Int)], Int) -> Int)
foo' _ ([], _) = return 0
foo' _ (_, 0) = return 0
foo' self ((w,v):xs, n)
| w > n = foo' (xs, n)
| otherwise = do
a <- self (xs, n)
b <- self (xs, n - w)
return (a `max` b + v)
We'll use the following memoization mixin to memoize our function foo':
type Dict a b m = (a -> m (Maybe b), a -> b -> m ())
memo :: Monad m => Dict a b m -> Endo (a -> m b)
memo (check, store) super a = do
b <- check a
case b of
Just b -> return b
Nothing -> do
b <- super a
store a b
return b
Our dictionary (memo table) will use the State monad and a Map data structure:
import Prelude hiding (lookup)
import Control.Monad.State
import Data.Map.Strict
mapDict :: Ord a => Dict a b (State (Map a b))
mapDict = (check, store) where
check a = gets (lookup a)
store a b = modify (insert a b)
Finally, we combine everything to create a memoized function memoFoo:
import Data.Function (fix)
type MapMemoized a b = a -> State (Map a b) b
memoFoo :: MapMemoized ([(Int, Int)], Int) Int
memoFoo = fix (memo mapDict . foo')
We can recover the original function foo as follows:
foo :: [(Int, Int)] -> Int -> Int
foo xs n = evalState (memoFoo (xs, n)) empty
Hope that helps.
Here's a vector whose elements are indexed by the length of the vector.
data IxVect : (n : Nat) -> (a : Nat -> Type) -> Type where
Nil : IxVect 0 a
(::) : a n -> IxVect n a -> IxVect (S n) a
I want to fold up an IxVect.
total
foldr : {b : Nat -> Type} -> ({m : Nat} -> a m -> b m -> b (S m)) -> b Z -> IxVect n a -> b n
foldr f z Nil = z
foldr f z (x :: xs) = f x (foldr f z xs)
I get the following error in the step case:
test.idr:9:25:
When elaborating right hand side of Main.foldr:
Can't convert
(Nat -> Type) -> Type
with
Type -> Type
I'm confused about what the error is trying to tell me. My definition of foldr doesn't look wrong to me, and it works just fine in Haskell:
data Nat = Z | S Nat
data IxVect n a where
Nil :: IxVect Z a
Cons :: a n -> IxVect n a -> IxVect (S n) a
foldr :: (forall m. a m -> b m -> b (S m)) -> b Z -> IxVect n a -> b n
foldr f z Nil = z
foldr f z (Cons x xs) = f x (foldr f z xs)
Why won't my foldr type check in Idris?
Idris is mixing up your foldr with the already existing one. You can solve this by qualifying the recursive foldr occurrence, or renaming your foldr.
foldr :
{n : Nat} -> {a, b : Nat -> Type}
-> ({m : Nat} -> a m -> b m -> b (S m)) -> b Z -> IxVect n a -> b n
foldr f z Nil = z
foldr f z (x :: xs) = f x (Main.foldr f z xs)
I wrote an Agda-function prefixApp which applies a Vector-Function to a prefix of a vector:
split : {A : Set}{m n : Nat} -> Vec A (n + m) -> (Vec A n) * (Vec A m)
split {_} {_} {zero} xs = ( [] , xs )
split {_} {_} {suc _} (x :: xs) with split xs
... | ( ys , zs ) = ( (x :: ys) , zs )
prefixApp : {A : Set}{n m k : Nat} -> (Vec A n -> Vec A m) -> Vec A (n + k) -> Vec A (m + k)
prefixApp f xs with split xs
... | ( ys , zs ) = f ys ++ zs
I like the fact, that prefixApp can be used without explicitly providing a length argument, e.g.
gate : Vec Bool 4 -> Vec Bool 3
gate = prefixApp xorV
(where xorV : Vec Bool 2 -> Vec Bool 1 is the Vector-Xor-Function)
Unfortunately, I dont know how to write a postfixApp-function which can be used without explicitly providing a length argument. My function definition so far looks like this:
postfixApp : {A : Set}{n m k : Nat} -> (Vec A n -> Vec A m) -> Vec A (k + n) -> Vec A (k + m)
postfixApp {_} {_} {_} {k} f xs with split {_} {_} {k} xs
... | ( ys , zs ) = ys ++ (f zs)
It seems, however, that postfixApp always needs a length argument. E.g.
gate : Vec Bool 4 -> Vec Bool 3
gate = postfixApp {k = 2} xorV
Does anyone know, how to eliminate this asymmetry, i.e. how to write a function postfixApp which works without an explicit length argument. I guess, I need another split-function?
With your prefixApp, you have
prefixApp : {A : Set}{n m k : Nat} -> (Vec A n -> Vec A m) -> Vec A (n + k) -> Vec A (m + k)
and you pass it a function Vec Bool 2 -> Vec Bool 1, so it knows that n = 2 and m = 1 by simple unification. Then, because addition is defined by recursion on the left arguments, the remainder of the function type reduces from Vec A (2 + k) -> Vec A (1 + k) to Vec A (suc (suc k)) -> Vec A (suc k). Agda can then apply straight-up unification (expanding the number literals) of:
Vec A (suc (suc k)) -> Vec A (suc k)
Vec Bool (suc (suc (suc (suc zero)))) -> Vec Bool (suc (suc (suc zero)))
to infer that k = 2.
Looking at the other one:
postfixApp : {A : Set}{n m k : Nat} -> (Vec A n -> Vec A m) -> Vec A (k + n) -> Vec A (k + m)
The only difference is that the known quantities that your xorV forces n and m to be 2 and 1, but this only makes the remainder of your function type into Vec A (k + 2) -> Vec A (k + 1). This type does not reduce further, because addition is defined by recursion on the first argument, k, which is unknown at this point. You then try to unify k + 2 with 4 and k + 1 with 3, and Agda spits out yellow. "But clearly k = 2," you say! You know that because you know math, and can apply subtraction and other simple principles, but Agda does not know that. _+_ is just another function to it, and unifying arbitrary function applications is hard. What if I asked you to unify (2 + x) * (2 + y) with 697, for example? Should the typechecker be expected to factor the number and complain that there isn't a unique factorization? I guess since multiplication is commutative there generally won't be unless you restrict the sides, but should Agda know that multiplication is commutative?
Anyway, so Agda only knows how to do unification, which basically matches "structural" quantities to each other. Data constructors have this structural quality to them, as do type constructors, so those can all be unified unambiguously. When it comes to anything fancier than that, you run into the "higher-order unification" problem, which can't be solved in general. Agda implements a fancy algorithm called Miller pattern unification, that lets it solve some restricted sorts of fancier situations, but there are some things it just can't do, and your kind of function application is one of them.
If you look in the standard library, you'll find that most cases in which a type involves an addition of naturals, one of the addends (the left one) will generally not be implicit, unless another argument specifies it completely (as is the case in your prefixApp).
As far as what to do about it, there isn't much to tackle the problem in general. After a while, you develop a sense for what Agda can infer and what it can't, and then stop making the uninferrable arguments implicit. You can define a "symmetric" version of _+_, but it ends up just being equally painful to work with both sides of it, so I don't recommend that either.
Actually, it's possible to define this function with almost the same type.
postfixApp : {A : Set}{n m k : ℕ} -> (Vec A n -> Vec A m) -> Vec A (n + k) -> Vec A (k + m)
postfixApp f xs with splitAt' (reverse xs)
... | ys , zs = reverse zs ++ f (reverse ys)
test-func : Vec Bool 3 -> Vec Bool 2
test-func (x1 ∷ x2 ∷ x3 ∷ []) = (x1 ∧ x2) ∷ (x2 ∨ x3) ∷ []
test : postfixApp test-func (false ∷ false ∷ true ∷ false ∷ true ∷ [])
≡ false ∷ false ∷ false ∷ true ∷ []
test = refl
The whole code: http://lpaste.net/107176
I have the following definition of fixed-length-vectors using ghcs extensions GADTs, TypeOperators and DataKinds:
data Vec n a where
T :: Vec VZero a
(:.) :: a -> Vec n a -> Vec (VSucc n) a
infixr 3 :.
data VNat = VZero | VSucc VNat -- ... promoting Kind VNat
type T1 = VSucc VZero
type T2 = VSucc T1
and the following defiition of a TypeOperator :+:
type family (n::VNat) :+ (m::VNat) :: VNat
type instance VZero :+ n = n
type instance VSucc n :+ m = VSucc (n :+ m)
For my whole intented library to make sense, I need to apply a fixed-length-vector-function of type (Vec n b)->(Vec m b) to the inial part of a longer vector Vec (n:+k) b. Let's call that function prefixApp. It should have type
prefixApp :: ((Vec n b)->(Vec m b)) -> (Vec (n:+k) b) -> (Vec (m:+k) b)
Here's an example application with the fixed-length-vector-function change2 defined like this:
change2 :: Vec T2 a -> Vec T2 a
change2 (x :. y :. T) = (y :. x :. T)
prefixApp should be able to apply change2 to the prefix of any vector of length >=2, e.g.
Vector> prefixApp change2 (1 :. 2 :. 3 :. 4:. T)
(2 :. 1 :. 3 :. 4 :. T)
Has anyone any idea how to implement prefixApp?
(The problem is, that a part of the type of the fixed-length-vector-function has to be used to grab the prefix of the right size...)
Edit:
Daniel Wagners (very clever!) solution seems to have worked with some release candidate of ghc 7.6 (not an official release!). IMHO it shouldnt work, however, for 2 reasons:
The type-declaration for prefixApp lacks an VNum m in the context (for prepend (f b) to typecheck correctly.
Even more problematic: ghc 7.4.2 does not assume the TypeOperator :+ to be injective in its first argument (nor the second, but thats not essential here), which leads to a type error: from the type-declaration, we know that vec must have type Vec (n:+k) a and the type-checker infers for the expression split vec on the right-hand side of the definition a type of Vec (n:+k0) a. But: the type-checker cannot infer that k ~ k0 (since there is no assurance that :+ is injective).
Does anyone know a solution to this second issue? How can I declare :+ to be injective in its first argument and/or how can I avoid running into this issue at all?
Here is a version where split is not in a type class. Here we build a singleton type for natural numbers (SN), which enables to pattern match on `n' in the definition of split'.
This extra argument can then be hidden by the use of a type class (ToSN).
The type Tag is used to manually specify the non-inferred arguments.
(this answer has been co-authored with Daniel Gustafsson)
Here is the code:
{-# LANGUAGE TypeFamilies, TypeOperators, DataKinds, GADTs, ScopedTypeVariables, FlexibleContexts #-}
module Vec where
data VNat = VZero | VSucc VNat -- ... promoting Kind VNat
data Vec n a where
T :: Vec VZero a
(:.) :: a -> Vec n a -> Vec (VSucc n) a·
infixr 3 :.
type T1 = VSucc VZero
type T2 = VSucc T1
data Tag (n::VNat) = Tag
data SN (n::VNat) where
Z :: SN VZero
S :: SN n -> SN (VSucc n)
class ToSN (n::VNat) where
toSN :: SN n
instance ToSN VZero where
toSN = Z
instance ToSN n => ToSN (VSucc n) where
toSN = S toSN
type family (n::VNat) :+ (m::VNat) :: VNat
type instance VZero :+ n = n
type instance VSucc n :+ m = VSucc (n :+ m)
split' :: SN n -> Tag m -> Vec (n :+ m) a -> (Vec n a, Vec m a)
split' Z _ xs = (T , xs)
split' (S n) _ (x :. xs) = let (as , bs) = split' n Tag xs in (x :. as , bs)
split :: ToSN n => Tag m -> Vec (n :+ m) a -> (Vec n a, Vec m a)
split = split' toSN
append :: Vec n a -> Vec m a -> Vec (n :+ m) a
append T ys = ys
append (x :. xs) ys = x :. append xs ys
prefixChange :: forall a m n k. ToSN n => (Vec n a -> Vec m a) -> Vec (n :+ k) a -> Vec (m :+ k) a
prefixChange f xs = let (as , bs) = split (Tag :: Tag k) xs in append (f as) bs
Make a class:
class VNum (n::VNat) where
split :: Vec (n:+m) a -> (Vec n a, Vec m a)
prepend :: Vec n a -> Vec m a -> Vec (n:+m) a
instance VNum VZero where
split v = (T, v)
prepend _ v = v
instance VNum n => VNum (VSucc n) where
split (x :. xs) = case split xs of (b, e) -> (x :. b, e)
prepend (x :. xs) v = x :. prepend xs v
prefixApp :: VNum n => (Vec n a -> Vec m a) -> (Vec (n:+k) a -> (Vec (m:+k) a))
prefixApp f vec = case split vec of (b, e) -> prepend (f b) e
If you can live with a slightly different type of prefixApp:
{-# LANGUAGE GADTs, TypeOperators, DataKinds, TypeFamilies #-}
import qualified Data.Foldable as F
data VNat = VZero | VSucc VNat -- ... promoting Kind VNat
type T1 = VSucc VZero
type T2 = VSucc T1
type T3 = VSucc T2
type family (n :: VNat) :+ (m :: VNat) :: VNat
type instance VZero :+ n = n
type instance VSucc n :+ m = VSucc (n :+ m)
type family (n :: VNat) :- (m :: VNat) :: VNat
type instance n :- VZero = n
type instance VSucc n :- VSucc m = n :- m
data Vec n a where
T :: Vec VZero a
(:.) :: a -> Vec n a -> Vec (VSucc n) a
infixr 3 :.
-- Just to define Show for Vec
instance F.Foldable (Vec n) where
foldr _ b T = b
foldr f b (a :. as) = a `f` F.foldr f b as
instance Show a => Show (Vec n a) where
show = show . F.foldr (:) []
class Splitable (n::VNat) where
split :: Vec k b -> (Vec n b, Vec (k:-n) b)
instance Splitable VZero where
split r = (T,r)
instance Splitable n => Splitable (VSucc n) where
split (x :. xs) =
let (xs' , rs) = split xs
in ((x :. xs') , rs)
append :: Vec n a -> Vec m a -> Vec (n:+m) a
append T r = r
append (l :. ls) r = l :. append ls r
prefixApp :: Splitable n => (Vec n b -> Vec m b) -> Vec k b -> Vec (m:+(k:-n)) b
prefixApp f v = let (v',rs) = split v in append (f v') rs
-- A test
inp :: Vec (T2 :+ T3) Int
inp = 1 :. 2 :. 3 :. 4:. 5 :. T
change2 :: Vec T2 a -> Vec T2 a
change2 (x :. y :. T) = (y :. x :. T)
test = prefixApp change2 inp -- -> [2,1,3,4,5]
In fact, your original signature can also be used (with augmented context):
prefixApp :: (Splitable n, (m :+ k) ~ (m :+ ((n :+ k) :- n))) =>
((Vec n b)->(Vec m b)) -> (Vec (n:+k) b) -> (Vec (m:+k) b)
prefixApp f v = let (v',rs) = split v in append (f v') rs
Works in 7.4.1
Upd: Just for fun, the solution in Agda:
data Nat : Set where
zero : Nat
succ : Nat -> Nat
_+_ : Nat -> Nat -> Nat
zero + r = r
succ n + r = succ (n + r)
data _*_ (A B : Set) : Set where
_,_ : A -> B -> A * B
data Vec (A : Set) : Nat -> Set where
[] : Vec A zero
_::_ : {n : Nat} -> A -> Vec A n -> Vec A (succ n)
split : {A : Set}{k n : Nat} -> Vec A (n + k) -> (Vec A n) * (Vec A k)
split {_} {_} {zero} v = ([] , v)
split {_} {_} {succ _} (h :: t) with split t
... | (l , r) = ((h :: l) , r)
append : {A : Set}{n m : Nat} -> Vec A n -> Vec A m -> Vec A (n + m)
append [] r = r
append (h :: t) r with append t r
... | tr = h :: tr
prefixApp : {A : Set}{n m k : Nat} -> (Vec A n -> Vec A m) -> Vec A (n + k) -> Vec A (m + k)
prefixApp f v with split v
... | (l , r) = append (f l) r