Section Vect.
(* This is our scalar space with its dimension *)
Variable p : params.
(* The operations for scalar have the expected properties *)
Hypothesis Hp : fparamsProp p.
Delimit Scope g_scope with g.
Open Scope g_scope.
Open Scope vector_scope.
(* We recover the usual mathematical notation *)
Definition K1 := K.
Notation "'K'" := (K1 p) : g_scope.
Notation "'kn'" := (kn p).
Notation projk := (proj p).
Ltac Kfold n :=
change (Kn.add p n) with (addE (Kn.vn_eparams p n));
change (Kn.scal p n) with (scalE (Kn.vn_eparams p n));
change (Kn.genk p n 0%f) with (E0 (Kn.vn_eparams p n)).
(* A vector is a full-binary tree of hight n *)
Fixpoint vect (n: nat): Set :=
match n with O => K | S n1 => (vect n1 * vect n1)%type end.
(* Equality over two trees: Equality on leaves *)
Fixpoint eq (n : nat) : vect n -> vect n -> bool :=
match n return (vect n -> vect n -> bool) with
| 0%nat => fun a b => (a ?= b)%f
| S n1 =>
fun l1 l2 =>
let (l3, l5) := l1 in
let (l4, l6) := l2 in
if eq n1 l3 l4 then eq n1 l5 l6 else false
end.
(* Adding two trees: adding its leaves *)
Fixpoint add (n : nat) : vect n -> vect n -> vect n :=
match n return (vect n -> vect n -> vect n) with
| 0%nat => fun a b => (a + b)%f
| S n1 =>
fun l1 l2 =>
let (l3, l5) := l1 in
let (l4, l6) := l2 in (add n1 l3 l4, add n1 l5 l6)
end.
(* Generate the constant k for the dimension n *)
Fixpoint genk (n: nat) (k: K) {struct n}: (vect n) :=
match n return vect n with 0%nat => k | n1.+1 => (genk n1 0%f, genk n1 k) end.
Notation " [ k ] " := (genk _ k%f) (at level 9): g_scope.
Arguments genk _ _%field_scope.
(* Multiplication by a scalar *)
Fixpoint scal (n : nat) (k: K) {struct n}: vect n -> vect n :=
match n return (vect n -> vect n) with
| 0%nat => fun a => (k * a)%f
| S n1 =>
fun l1 =>
let (l2, l3) := l1 in (scal n1 k l2, scal n1 k l3)
end.
Canonical Structure vn_eparams (n: nat) :=
Build_eparams (vect n) K [0] (eq n) (add n) (scal n).
Definition fn n : vparamsProp (vn_eparams n).
apply Build_vparamsProp; auto.
(* Equality *)
induction n as [| n IH]; simpl.
intros x y; apply eqK_dec; auto.
intros (l3,l5) (l4, l6); simpl in IH; generalize (IH l3 l4); case eq.
generalize (IH l5 l6); case eq; intros HH1 HH2; subst; auto.
intros HH3; case HH1; injection HH3; auto.
intros HH1 HH2; case HH1; injection HH2; auto.
(* Addition is associative *)
induction n as [| n IH]; simpl.
intros x y z; rewrite (addK_assoc _ Hp); auto.
intros (l3,l5) (l4, l6) (l7, l8); simpl in IH; rewrite !IH; auto.
(* Addition is commutative *)
induction n as [| n IH]; simpl.
intros x y; rewrite (addK_com _ Hp); auto.
intros (l3,l5) (l4, l6); simpl in IH; rewrite (IH l3), (IH l5); auto.
(* 0 is  a left neutral element for + *)
induction n as [| n IH]; simpl.
intros x; rewrite (addK0l _ Hp); auto.
intros (l1,l2); simpl in IH; rewrite IH, IH; auto.
(* Multiplication by 0 *)
induction n as [| n IH]; simpl.
intros x; rewrite (multK0l _ Hp); auto.
intros (l1, l2); simpl in IH; rewrite IH, IH; auto.
(* Multiplication by 1 *)
induction n as [| n IH]; simpl.
intros x; rewrite (multK1l _ Hp); auto.
intros (l1, l2); simpl in IH; rewrite IH, IH; auto.
(* Left addition of the multiplication by a scalar *)
induction n as [| n IH]; simpl.
intros k x y; rewrite (add_multKl _ Hp); auto.
intros k1 k2 (l1, l2); simpl in IH; rewrite IH, IH; auto.
(* Right addition of the multiplication by a scalar *)
induction n as [| n IH]; simpl.
intros k x y; rewrite (add_multKr _ Hp); auto.
intros k (l1, l3) (l2, l4); simpl in IH; rewrite IH, IH; auto.
(* Composition of the multiplication by a scalar *)
induction n as [| n IH]; simpl.
intros x y z; rewrite (multK_assoc _ Hp); auto.
intros k1 k2 (l1, l2); simpl in IH; rewrite IH, IH; auto.
Qed.
Hint Resolve fn.
Notation "1" := ([1]): g_scope.
Ltac Vfold n :=
change (add n) with (addE (vn_eparams n));
change (scal n) with (scalE (vn_eparams n));
change (genk n 0) with (E0 (vn_eparams n)).
Hint Rewrite multK0l multK0r oppK0 addK0l addK0r
addE0r addE0l scalE0r scalE0l: GRm0.
Ltac Grm0 := autorewrite with GRm0; auto.
(* Subtraction  *)
Fixpoint sub (n : nat) : vect n -> vect n -> vect n :=
match n return (vect n -> vect n -> vect n) with
| 0%nat => fun a b => (a + (- b))%f
| S n1 =>
fun v1 v2 =>
let (x1, y1) := v1 in
let (x2, y2) := v2 in (sub n1 x1 x2, sub n1 y1 y2)
end.
Notation "x - y" := (sub _ x y): g_scope.
(* Generate the p element of the base in dimension n *)
Fixpoint gen (n: nat) (p: nat) {struct n} : vect n :=
match n return vect n with 0 => 1%f | S n1 =>
match p with
0 => (genk n1 1%f, genk n1 0%f)
| S p1 =>  (genk n1 0%f, gen n1 p1)
end
end.
Notation "''e_' p" := (gen _ p) (at level 8, format "''e_' p"): g_scope.
(* Get the constant part of a vector *)
Fixpoint const (n: nat): (vect n) -> K :=
match n return vect n -> K with
| O => fun a => a
| S n1 => fun l => let (l1,l2) := l in const n1 l2
end.
Notation "'C[ x ]" := (const _ x).
(* Equality to zero: Equality to zero on leaves *)
Fixpoint eq0 (n : nat) : vect n -> bool :=
match n return (vect n -> bool) with
| 0%nat => fun a => (a ?= 0)%f
| S n1 =>
fun l1 =>
let (l2, l3) := l1 in
if eq0 n1 l2 then eq0 n1 l3 else false
end.
Notation "x ?= 0" := (eq0 _ x) (at level 70): g_scope.
(* Homogeneity *)
Fixpoint hom (n k : nat) {struct n} : vect n -> bool :=
match n return (vect n -> bool) with
| 0%nat => fun a => match k with O => true | S _ => a ?= 0 end
| S n1 =>
fun l1 =>
let (l2, l3) := l1 in
(match k with O => l2 ?= 0 | S k1 => hom n1 k1 l2 end) && hom n1 k l3
end.
Hint Resolve homk0.
Hint Resolve hom0K.
Hint Resolve add_hom.
Hint Resolve scal_hom.
(* Get homogeneity part *)
Fixpoint get_hom (n m : nat) {struct n} : vect n -> vect n :=
match n return (vect n -> vect n) with
| 0%nat => fun a => match m with O => a | S _ => 0 end
| S n1 =>
fun l1 =>
let (l2, l3) := l1 in
((match m with O => [0]
| S m1 => get_hom n1 m1 l2
end), get_hom n1 m l3)
end.

Lemma get_hom_up n m x : n < m -> get_hom n m x = [0].