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.
(* Iterated product of a list of vectors *)
Fixpoint joinl n (l: list (vect n)) := match l with
| nil => 0
| a::nil => a
| a::l => a ∨ joinl n l
end.
induction l1 as [| a1 l1 IH].
intros H; case H; auto.
intros _ Hl2.
case (list_case _ l1); intros; subst; simpl app; rewrite joinlS; auto.
rewrite joinlS, IH, join_assoc; auto.
destruct l1; auto; try (intros; discriminate).
Qed.
Hint Resolve joinl_hom1.
Definition is_vector n v := cbl _ (base n 1) v.
Definition is_vector_space n l := forall x, In x l -> is_vector n x.
(* M is decomposable and l is its decomposition *)
Definition decomposable n l M := is_vector_space n l /\ M = joinl n l.
(* The linear form is defined by its finger print on the base *)
Fixpoint contra (n : nat) {struct n}: kn n -> vect n -> vect n :=
match n return (kn n -> vect n -> vect n) with
| 0%nat => fun k a => 0
| S n1 =>
fun lf l1 =>
let (k, lf1) := lf in
let (l2, l3) := l1 in
((- (1)).* (contra n1 lf1 l2),  (k : K) .* l2 + contra n1 lf1 l3)
end.
Notation "#< l , x ># " := (contra _ l x) (format "#< l ,  x >#").
Hint Rewrite contra0r: GRm0.
Hint Resolve contra_hom.
Fixpoint v2k (n : nat) : vect n -> kn n :=
match n return vect n -> kn n  with
| O => fun v : vect 0 => tt
| S n1  => fun v => let (v1,v2) := v in
('C[v1], v2k n1 v2)
end.
(* This function will be only call with first vector is hom 1 *)
Fixpoint factor n: (vect n) -> (vect n) -> vect n :=
match n return vect n -> vect n -> vect n with
| O => fun x1 x2 => (x2 * x1^-1)%f
| S n1 =>
fun x1 x2 =>
let (x11, x12) := x1 in
let (x21, x22) := x2 in
if x12 ?= 0 then
(* if x<> 0 then x11 <> 0 *)
((0: vect n1), ('C[x11]^-1).* x21: vect n1) else
let x32 := factor n1 x12 x22 in
(* We have x12 ∨ x32 = x22 *)
(* let x31 such that x12 /\ x31 = x11 ∨ x32 - x21                            *)
(* (x11,x12) /\ (x31,x32) = (x11 /\ x32 - x12 /\ x31, x12 /\ x32) (x21, x22) *)
(factor n1 x12 (add n1 (('C[x11]) .* x32: vect n1) (scal n1 (-(1))%f  x21: vect n1))
, x32)
end.
(* Orthogonalité for factorisation, i.e. condition for factorisation to be idempotent *)
Fixpoint fortho n : (vect n) -> (vect n) -> bool :=
match n return vect n -> vect n -> bool with
| O => fun x1 x2 => false
| S n1 =>
fun x1 x2 =>
let (x11, x12) := x1 in
let (x21, x22) := x2 in
if x12 ?= 0 then x21 ?= 0 else  fortho n1 x12 x21 && fortho n1 x12 x22
end.
(* Getting the canceling factor for fortho *)
Fixpoint fget n : (vect n) -> (vect n) -> K :=
match n return vect n -> vect n -> K with
| O => fun x1 x2 => 0%f
| S n1 =>
fun x1 x2 =>
let (x11, x12) := x1 in
let (x21, x22) := x2 in
if x12 ?= 0 then (('C[x11])^-1 * 'C[x21])%f else fget n1 x12 x22
end.
Hint Resolve mprod_hom.
Definition is_decomposable n M := exists l, decomposable n l M.
(* A factor of a special degre *)
Fixpoint one_factor (n: nat) k : vect n -> vect n :=
match n return vect n -> vect n with
| O => fun a  => a
| S n1 => fun l =>
match k with
| O => l
| S k1 =>
let (l1,l2) := l in
let r := one_factor n1 k1 l1 in
(0:vect n1, if r ?= 0 then one_factor n1 k l2 else r)
end
end.
Hint Resolve one_factor_hom.
(* Iterated contraction *)
Definition mcontra n (ll: list (kn n)) (x: vect n) :=
fold_left (fun x l => #<l,x>#) ll x.
Notation "#<< l , x >>#" := (mcontra _ l x).
Hint Rewrite mcontra0: GRm0.
Hint Resolve mcontra_hom.
Notation liftk := (Kn.lift p).
Inductive cbl n (l: list (vect n)): nat -> (vect n) -> Prop :=
| cbl_in: forall v, In v l -> cbl n l 0%nat v
| cbl_add: forall k x y, cbl n l k x -> cbl n l k y -> cbl n l k (x + y)
| cbl_scal: forall k k1 x, cbl n l k x -> cbl n l k (k1 .* x)
| cbl_join: forall k v x, In v l -> cbl n l k x -> cbl n l k.+1 (v ∨ x).
Fixpoint decomposek (n: nat) k (v: vect n) {struct k} : list (vect n) :=
match k with
| O => nil
| S O => v::nil
| S k1 => let v1 := one_factor n k1 v in
v1::decomposek n k1 (factor n v1 v)
end.
Definition all_hom1 n l := fold_left (fun c x => c && hom n 1 x) l true.
Definition decompose n (v: vect n) : option (list (vect n)) :=
let d := first_deg n v in
let l := decomposek n d v in
if all_hom1 n l then
if v ?= joinl n l then Some l else None
else None.
(* Grade definition *)
Definition grade n k x := hom n k x &&
if decompose n x then true else false.
(* Hodge Duality *)
Fixpoint dual n : vect n -> vect n :=
match n return vect n ->  vect n with
|    0 => fun a => a
| S n1 => fun v => let (x,y) := v in (dual n1 (y ^_'f), dual n1 x)
end.
Notation "'@ x " := (dual _ x) (at level 9).
Hint Rewrite dual0: GRm0.
Hint Resolve dual_hom.
(* Ad-hoc conjugate function in order to define the join *)
Fixpoint dconj (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 (dconj n1 b l2, dconj n1 (negb b) l3)
end.
Notation "x ^d_ b" := (dconj _ b x)  (at level 29, left associativity).
Notation "x ^d_'t" := (dconj _ true x)  (at level 29, left associativity).
Notation "x ^d_'f" := (dconj _ false x)  (at level 29, left associativity).
Hint Rewrite dconj0: GRm0.
Hint Resolve dconj_hom.

Lemma dconjf_joinr n (x y: vect n) : (x ∨ y) ^d_'f = x ^_'f ∨ y ^d_'f.