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.
Fixpoint sum (n : nat) (f: (nat -> vect n)) (m : nat) {struct m} :
vect n :=
match m with
| 0%nat => f 0%nat
| S m1 => f m + sum n f m1
end.
(* First degre that is used to guess if a vector is homegene *)
Fixpoint first_deg (n : nat) {struct n} : vect n -> nat :=
match n return (vect n -> nat) with
| 0%nat => fun a => 0%nat
| S n1 =>
fun l1 =>
let (l2, l3) := l1 in
if l2 ?= 0 then first_deg n1 l3 else S (first_deg n1 l2)
end.
(* Lift a vector of dimension n into a vector of dimension n+1 whose first component is 0 *)
Definition lift (n: nat) (v: vect n) : (vect n.+1) :=  ((0: vect n), v).
Notation " x ^'l " := (lift _ x) (at level 9, format "x ^'l"): g_scope.
(* Dual lift*)
Definition dlift (n: nat) (v: vect n) : (vect n.+1) := (v,(0: vect n)).
Notation "x ^'dl" := (dlift _ x) (at level 9, format "x ^'dl" ): g_scope.
(* Coordinates for k vector *)
Fixpoint proj (n: nat) k: (vect n) -> (list K) :=
match n return vect n -> list  K with
| O => fun a  =>
match k with | O => a::nil | _ => nil end
| S n1 => fun l => let (l1,l2) := l in
match k with | O => proj n1 k l2 | S k1 =>
(proj n1 k1 l1 ++ proj n1 k l2)%list
end
end.
Fixpoint all (n: nat): vect n :=
match n return vect n with
| 0 => 1
| S n1 => (all n1, 0: vect n1)
end.
Notation "'E'" := (all _).
Hint Resolve all_hom.
(* Base of k vector *)
Fixpoint base (n: nat) k:list (vect n) :=
match n return list (vect n) with
| O =>  match k with | O => 1%f::nil | _ => nil end
| S n1 =>
match k with | O =>
map (lift n1) (base n1 k) | S k1 =>
(map (dlift n1) (base n1 k1) ++
map (lift n1) (base n1 k))%list
end
end.
(* Ad-hoc conjugate function in order to define the product *)
Fixpoint conj (n : nat) (b: bool) {struct n}: vect n -> vect n :=
match n return (vect n -> vect n) with
| 0%nat => fun a => if b then (- a)%f else a
| S n1 =>
fun l1 =>
let (l2, l3) := l1 in (conj n1 (negb b) l2, conj n1 b l3)
end.
Notation "x ^_ b" := (conj _ b x)  (at level 30).
Notation "x ^_'t" := (conj _ true x)  (at level 30).
Notation "x ^_'f" := (conj _ false x)  (at level 30).
Hint Rewrite conj0: GRm0.
Hint Resolve conj_hom.
(* We are now ready to define our multiplication *)
Fixpoint join (n : nat) : vect n -> vect n -> vect n :=
match n return (vect n -> vect n -> vect n) with
| 0%nat => fun x y => (x * y)%f
| S n1 =>
fun x y =>
let (x1, x2) := x in
let (y1, y2) := y in (join n1 x1 y2 + join n1 (x2 ^_'f) y1,
join n1 x2 y2)
end.
(* Unicode u2228 *)
Notation "x '∨' y" := (join _ x y) (at level 40, left associativity): type_scope.
Hint Rewrite join0l: GRm0.
Hint Rewrite join0r: GRm0.
Hint Resolve join_hom.
(* given a list of vectors produce the list of all products *)
Fixpoint all_prods (n: nat) (vs: list (vect n)) {struct vs} : list (vect n) :=
match vs with
nil => 1 :: nil
| v::vs1 => let vs1 := all_prods n vs1 in
(map (join n v) vs1 ++ vs1)%list
end.
(* Turn a vector in a list of scalar to be used for multiple product *)
Fixpoint v2l (n: nat) : vect n -> list K :=
match n return vect n -> list K with
O => fun k => k :: nil
| S n1 => fun x => let (x1, x2) := x in
(v2l n1 x1 ++ v2l n1 x2)%list
end.

(* Ad-hoc inductive principes for vectors *)
Lemma vect_induct n (P: vect n -> Prop) :
P (1: vect n) -> (forall v, In v (base n 1) -> P v) ->
(forall v1 v2, P v1 -> P v2 -> P (v1 ∨ v2)) ->
(forall v1 v2, P v1 -> P v2 -> P (v1 + v2)) ->
(forall k v, P v -> P (k .* v)) ->
(forall v, P v).