(**************************************************************************)
(*                                                                        *)
(*  This file is part of octant-proof.                                    *)
(*                                                                        *)
(*  Copyright (C) 2019-2020 Orange                                        *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, either version 3 of the License, or (at your option)      *)
(*  any later version.                                                    *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  You should have received a copy of the GNU Lesser General Public      *)
(*  License along with the software. If not, see                          *)
(*  <https://www.gnu.org/licenses/>.                                      *)
(*                                                                        *)
(**************************************************************************)

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun choice fintype tuple finset.

Require Import bigop_aux.

Set Implicit Arguments.
Unset Strict Implicit.

(** * Various utilitary lemmas to reduce proof sizes *)

(** ** bool *)
Section boolUtils.

Lemma ite_id {A : Type} (b : bool) (x : A) : (if b then x else x) = x.
Proof.
by destruct b.
Qed.

Lemma bool_to_prop_l (a b : bool) : (a && b) -> a.
Proof.
by move => /andP [].
Qed.

Lemma bool_to_prop_r (a b : bool) : (a && b) -> b.
Proof.
by move => /andP [].
Qed.

Lemma Eqdep_dec_bool : forall (b : bool) (p1 p2 : b = true), p1 = p2.
Proof.
  by move => b p1 p2 ; apply Eqdep_dec.eq_proofs_unicity;
  move => x y ; destruct (Bool.bool_dec x y) ; [left | right].
Qed.

Lemma bool_des_rew (b : bool) : (b = true) \/ (b = false).
Proof.
by case b;[left|right].
Qed.

End boolUtils.

(** ** nat *)

Section nat.

Lemma pred_ltn0_l : forall n m , n > 0 -> n.-1 = m -> n = m.+1.
Proof.
destruct n as [|n];move=>m // H.
rewrite PeanoNat.Nat.pred_succ. by move=>->.
Qed.

Lemma ltn_leq_trans : forall n m p : nat, m < n -> n <= p -> m < p.
Proof.
move => n m p.
move : n m.
destruct p.
- move => n m H.
  rewrite leqn0.
  move=>/eqP H2. rewrite H2 in H; inversion H.
- move => n m Hmn.
  rewrite leq_eqVlt.
  by move=>/orP [/eqP <- |];[|apply ltn_trans].
Qed.

Lemma pred_ltn : forall n m, n.+1 < m -> n < m.
Proof.
move=>n m H. apply (ltn_trans (ltnSn n) H).
Qed.

(** *** Lemmas on max *)

Section max.

Lemma gtn_max_l : forall m n1 n2, (maxn n1 n2 < m) -> n1 < m.
Proof.
move => m n1 n2 H ; rewrite gtn_max in H ; apply (bool_to_prop_l H).
Qed.

Lemma gtn_max_r : forall m n1 n2, (maxn n1 n2 < m) -> n2 < m.
Proof.
move => m n1 n2 H ; rewrite gtn_max in H ; apply (bool_to_prop_r H).
Qed.

Lemma geq_max_l : forall m n1 n2, (maxn n1 n2 <= m) -> n1 <= m.
Proof.
move => m n1 n2 H ; rewrite geq_max in H ; apply (bool_to_prop_l H).
Qed.

Lemma geq_max_r : forall m n1 n2, (maxn n1 n2 <= m) -> n2 <= m.
Proof.
move => m n1 n2 H ; rewrite geq_max in H ; apply (bool_to_prop_r H).
Qed.

End max.

End nat.

(** ** Finset *)

Section notin.

Lemma set_notin_f_in {A : finType} (x : A) (s : {set A}) :
  x \notin s = false -> x \in s.
Proof.
destruct (bool_des_rew (x \in s)) as [H|H].
auto.
by rewrite H.
Qed.

Lemma seq_notin_f_in {A : eqType} (x : A) (s : seq A) :
  x \notin s = false -> x \in s.
Proof.
destruct (bool_des_rew (x \in s)) as [H|H].
auto.
by rewrite H.
Qed.

End notin.

Section finset.

(** *** Iter is increasing *)
(** if f is increasing and "smaller" than g, the iterations have the same order *)
(* TODO: generalize on the type and order *)
Lemma iter_fun_incr {A : finType} (f g : {set A} -> {set A}) (i : nat) (b : {set A}) :
   [forall x : {set A}, forall y : {set A}, (x \subset y) ==> (f x \subset f y)]
-> [forall x, f x \subset g x] -> iter i f b \subset iter i g b.
Proof.
move=>Hf /forallP Hfg.
induction i as [|i Hi];auto. simpl.
apply/subset_trans.
apply (implyP (forallP (forallP Hf (iter i f b)) (iter i g b)) Hi).
apply Hfg.
Qed.

(** *** Disjoint *)
Lemma disjointC {A : finType} (s : {set A}) : [disjoint s & ~: s].
Proof.
by rewrite -subsets_disjoint.
Qed.

Lemma disjoint_in_false {A : finType} (t1 t2 : {set A}) (x : A) :
  x \in t1 -> x \in t2 -> [disjoint t1 & t2] -> False.
Proof.
move=>H1 H2 Hdisj.
rewrite disjoint_subset in Hdisj.
have Hf := (subsetP Hdisj _ H1).
unfold mem in Hf. simpl in Hf. unfold in_mem in Hf. simpl in Hf.
unfold negb in Hf. unfold mem in H2. unfold in_mem in H2. simpl in H2.
rewrite H2 in Hf. inversion Hf.
Qed.

Lemma subset_to_in {A : finType} (x : A) (s1 s2 : {set A}) : x \in s1 -> s1 \subset s2 -> x \in s2.
Proof.
move=>H /subsetP H1. by apply H1.
Qed.

(** *** Equivalence partitions *)

Lemma equiv_part_set0 {T : finType} (P : rel T) :
  equivalence_partition P set0 = set0.
Proof.
apply/eqP. rewrite -subset0.
apply/subsetP=>x /imsetP [y Hf]. by rewrite in_set0 in Hf.
Qed.

Lemma equiv_part_set_mon {T : finType} (P : rel T) (s1 s2 : {set T}) :
  s1 \subset s2 ->
  [forall x in equivalence_partition P s1, exists y in equivalence_partition P s2,
      x \subset y].
Proof.
move=>Hsub. apply/forallP=>x; apply/implyP=>/imsetP [y Hy1 ->].
apply/existsP. exists [set z in s2 | P y z]. apply/andP;split.
apply/imsetP. exists y. apply (subset_to_in Hy1 Hsub). reflexivity.
apply/subsetP=>z. rewrite in_set. move=>/andP [H1 H2].
rewrite in_set. apply/andP;split. apply (subset_to_in H1 Hsub). apply H2.
Qed.

(** *** A set that is not a singleton {x} is empty or contains y != x *)

Lemma set0_set1_neq {A : finType} (x : A) : set0 != [set x].
Proof.
rewrite eq_sym.
by rewrite -card_gt0 cards1.
Qed.

Lemma not_set1P {A : finType} (x : A) (s : {set A}) :
  reflect (s != [set x]) ((s == set0) || [exists y in s, y != x]).
Proof.
apply/(iffP orP).
move => [Hsset0|/existsP Hex].
- rewrite (eqP Hsset0). apply set0_set1_neq.
- destruct Hex as [y Hy].
  destruct (andP Hy) as [Hyin Hyxneq].
  rewrite eqEsubset negb_and. apply/orP. left.
  apply/subsetP. move => Hf.
  rewrite (set1P (Hf y Hyin)) in Hyxneq.
  by apply (negP Hyxneq).
move => Hneq.
destruct (set_0Vmem s) as [Hsset0|[y Hy]].
- by left ; apply/eqP.
- right.
  rewrite -negb_forall_in.
  apply/negP. move => Hf.
  apply/(negP Hneq). rewrite eqEsubset.
  apply/andP ; split.
  + apply/subsetP. move=>z Hz.
    apply/set1P/eqP/(implyP (forallP Hf z))/Hz.
  + rewrite sub1set.
    by rewrite -(eqP (implyP (forallP Hf y) Hy)).
Qed.

End finset.

(** ** Seq *)
Section seq.

(** *** Fold with max *)

Section fold.

(** Technical lemma: Folding with obind starting from None can only give None *)
Lemma foldObindNone {A B : Type} l (f : B -> A -> option A) : foldl (fun acc p => obind (f p) acc)
                 None l = None.
Proof.
by induction l as [|h l Hl]; [reflexivity| simpl ;rewrite Hl].
Qed.

Lemma fold_maxn_n_map_geq {A : Type} {w n : nat} {l : seq A} {f : A -> nat} :
  (has (fun t => (w <= f t)) l) -> w <= foldr maxn n (map f l).
Proof.
induction l;auto.
move=>/orP [Ha|Hl];rewrite leq_max; apply/orP.
- left. apply Ha.
- right. apply/IHl/Hl.
Qed.

Lemma fold_maxn_n_map_gtn {A : Type} {w n : nat} {l : seq A} {f : A -> nat} :
  (has (fun t => (w < f t)) l) -> w < foldr maxn n (map f l).
Proof.
induction l;auto.
move=>/orP [Ha|Hl]; rewrite leq_max; apply/orP.
- left. apply Ha.
- right. apply/IHl/Hl.
Qed.

Lemma leq_fold_maxl : forall l n, n <= foldr maxn n l.
Proof.
by induction l ; [ | move => n ; rewrite leq_max ; apply/orP ; right ; apply IHl].
Qed.

Lemma leq_fold_base : forall n m l, foldr maxn n l <= m -> n <= m.
Proof.
induction l;auto.
rewrite geq_max ; move => /andP [Han Hnl] ; apply/IHl/Hnl.
Qed.

Lemma foldr_maxn_base {x y m : nat} {l : seq nat} (Hyx : y <= x) (Hf : foldr maxn x l <= m) : foldr maxn y l <= m.
Proof.
induction l.
- apply leq_trans with (n := x) ; [apply Hyx | apply Hf].
- rewrite geq_max. apply/andP. split.
  + apply (geq_max_l Hf).
  + apply/IHl/geq_max_r/Hf.
Qed.

End fold.

(** *** rem *)
Section rem.

Lemma in_rem {A : eqType} : forall x h (l : seq A),
x \in l -> x != h -> x \in rem h l.
Proof.
induction l.
- move => Habs ; inversion Habs.
- rewrite in_cons ; move => Hxal Hneq.
  destruct (orP Hxal) as [Hxa | Hxl].
  + destruct (eqVneq a h) as [Hha | Hhna].
    - by rewrite -Hha (eqP Hxa) eq_refl in Hneq.
    - simpl. rewrite (ifN_eq _ _ Hhna). by apply/orP ; left.
  + destruct (eqVneq a h) as [Hha | Hhna].
    - by rewrite -Hha /= eq_refl.
    - simpl. rewrite (ifN_eq _ _ Hhna). by apply/orP ; right ; apply IHl.
Qed.

Lemma mem_body : forall (T : eqType) (s : seq T) (x y : T) , x \in s -> x \in y :: s.
Proof.
intros. rewrite in_cons. by apply/orP;right.
Qed.

Lemma sub_rem {A : eqType} : forall (s l : seq A) h,
{subset h :: l <= s} -> h \notin l -> {subset l <= rem h s}.
Proof.
destruct s as [| a s].
- move => l h Habs. have Hf := (Habs h (mem_head h _)). by rewrite in_nil in Hf.
- move => l h Hsub Hnotin x Hx.
  simpl. pose Hxas := Hsub x (mem_body _ Hx).
  destruct (eqVneq a h) as [Haq | Hanq].
  + rewrite Haq eq_refl. move:Hxas. rewrite in_cons. move => Hxas.
    destruct (orP Hxas) as [Hxa | Hxs].
    - rewrite (eqP Hxa) Haq in Hx.
      by rewrite Hx in Hnotin.
    - apply Hxs.
  + rewrite (ifN_eq _ _ Hanq).
    move : Hxas. rewrite in_cons. move => Hxas.
    destruct (orP Hxas) as [Hxa | Hxs].
    - by apply/orP ; left.
    - apply/orP ; right.
      destruct (eqVneq x h) as [Hxh | Hnxh].
      + by rewrite -Hxh Hx in Hnotin.
      + by apply in_rem.
Qed.

Lemma seq_in_rem_size {A : eqType} : forall (h : A) s, h \in s -> size s = (size (rem h s)).+1.
Proof.
induction s.
- move => H. inversion H.
- rewrite in_cons. move => Hin. destruct (orP Hin).
  + rewrite (eqP H). simpl. by rewrite eq_refl.
  + simpl ; apply/eq_S. destruct (a == h).
    - auto.
    - by rewrite (IHs H).
Qed.

(** *** set_nth *)

Lemma set_nth_notin_base {A : eqType} (x y def : A) (i : nat) :
   x != def
-> x != y
-> x \notin iter i (cons def) [:: y].
Proof.
induction i as [|i Hrec];
move=>Hxdef Hxy //=;rewrite in_cons negb_or;
apply/andP;split;auto.
Qed.

Lemma set_nth_notin {A : eqType} (x y def : A) (l : seq A) (i : nat) :
   x != def
-> x != y
-> x \notin l -> x \notin set_nth def l i y.
Proof.
move:x y i.
induction l as [|h l Hrec];
move=>x y [|i] Hxdef Hxy Hnotin //=;
rewrite in_cons negb_or;apply/andP;split;auto.
- by apply/set_nth_notin_base.
- rewrite in_cons negb_or in Hnotin.
  by destruct (andP Hnotin).
- rewrite in_cons negb_or in Hnotin.
  by destruct (andP Hnotin).
- apply/Hrec;auto.
  rewrite in_cons negb_or in Hnotin.
  by destruct (andP Hnotin).
Qed.

(** *** sremove: trying to remove the element at a given index *)

Fixpoint sremove {A : Type} (s : seq A)  (i : nat) : seq A :=
  match i with
      0 => behead s
    | i.+1 => match s with
      | [::] => [::]
      | a::l => a::sremove l i end end.

Lemma sremove_size {A : Type} (s : seq A) (j : 'I_(size s)) :
  size s = (size (sremove s j)).+1.
Proof.
move:j.
induction s as [|h s Hs]; move=> [j Hj].
inversion Hj.
destruct j as [|j]. auto.
assert (Hib : j < size s). apply Hj. simpl.
by rewrite (Hs (Ordinal Hib)).
Qed.

Lemma sremove_in_size {A : Type} (s : seq A) (j : nat) :
  j < size s -> size (sremove s j) = (size s).-1.
Proof.
move:s. induction j as [|j Hj];move=>[|h l] // H.
simpl in H. rewrite -addn1 -(@addn1 (size l)) (@leq_add2r 1) in H.
simpl. rewrite Hj. by rewrite (ltn_predK H). apply H.
Qed.

Lemma sremove_map {A B : Type} (s : seq A) (j : nat) (f : A -> B) :
  sremove (map f s) j = map f (sremove s j).
Proof.
move:s. induction j as [|j Hj];move=>[|h l] //=.
apply/f_equal/Hj.
Qed.

Lemma sremove_rem {A : eqType} (s : seq A) (j : nat) (x : A) :
   find (fun y => y == x) s = j
-> j < size s
-> sremove s j = rem x s.
Proof.
move:j x.
induction s as [|h s Hrec];
move=>[|j] x //=.
- by destruct (bool_des_rew (h == x)) as [Hhx|Hhx];
  rewrite Hhx.
- destruct (bool_des_rew (h == x)) as [Hhx|Hhx];
  rewrite Hhx;move=>H Hsize.
  + inversion H.
  + inversion H as [Hb].
    apply/f_equal/Hrec. auto. rewrite Hb. apply Hsize.
Qed.

Lemma sremove_nth {A : eqType} (s : seq A) (j : nat) (x y : A) :
    j < size s
-> sremove (set_nth x s j y) j = sremove s j.
Proof.
move:j.
induction s as [|h s Hrec];
move=>[|j] //= Hsize.
apply/f_equal/Hrec/Hsize.
Qed.

End rem.

Section size_map_leq.
(** *** (p)map leq size *)
Lemma size_map_leq {A B : Type} {s : seq A} {f : A -> B} {w : nat} : size s <= w -> size (map f s) <= w.
Proof.
by rewrite size_map.
Qed.

Lemma pmap_size_leq {A B : Type} (f : A -> option B) (s : seq A) : size (pmap f s) <= size s.
Proof.
by rewrite size_pmap count_size.
Qed.

End size_map_leq.

Section all.
(** *** all *)

Lemma in_nth_P {A : eqType} (def : A) (s : seq A) (P : pred A) j :
 all P s -> j < size s -> P (nth def s j).
Proof.
move:s def P.
induction j as [|j Hrec];
move=>[|h s] def P //=.
- move=>/andP [] //.
- move=>/andP [H1 H2] H3.
  apply/Hrec. apply H2. apply H3.
Qed.

Lemma all_exist_seq {A B : finType} (s : seq A) P :
    all (fun x => [exists im : B, P x im]) s
 -> exists sb,
      ((map fst sb) == s) && all (fun x => P (fst x) (snd x)) sb.
Proof.
move=>H.
induction s as [|h tl Hs]. by exists [::].
destruct (andP H) as [H1 H2].
destruct (existsP H1) as [im Him].
destruct (Hs H2) as [sr Hsr]. destruct (andP Hsr) as [Hsr1 Hsr2].
exists ((h,im) :: sr).  apply/andP;split.
by rewrite -(eqP Hsr1). apply/andP;auto.
Qed.

Lemma all_exist_enum {A B : finType} (s : {set A}) P :
    [forall x in enum s, [exists im : B, P x im]]
 -> exists sb,
      ((map fst sb) == enum s) && all (fun x => P (fst x) (snd x)) sb.
Proof.
move=>H.
induction (enum s)as [|h tl Hs]. by exists [::].
assert (Hr : [forall x in tl, exists im, P x im]).
apply/forallP=>x. apply/implyP=>Hx. apply (implyP (forallP H x)).
rewrite in_cons. by apply/orP;right.
destruct (Hs Hr) as [sr Hsr].
assert (Hrb: [exists im, P h im]). apply (implyP (forallP H h)).
by rewrite in_cons;apply/orP;left.
destruct (existsP Hrb) as [im Pim].
destruct (andP Hsr) as [H1 H2].
exists ((h,im) :: sr). apply/andP;split.
by rewrite -(eqP H1). apply/andP;auto.
Qed.

Lemma all_exist_tuple {A B : finType} (s : {set A}) P :
    [forall x in s, [exists im : B, P x im]]
 -> [exists t : #|s|.-tuple (prod A B),
      ((map fst t) == enum s) && all (fun x => P (fst x) (snd x)) t].
Proof.
move=>Hb. assert (H:[forall x in enum s, [exists im : B, P x im]]).
apply/forallP=>x. apply/implyP=>Hx. rewrite mem_enum in Hx.
apply (implyP (forallP Hb x) Hx).
apply/existsP.
destruct (all_exist_enum H) as [sr Hsr].
assert (Hsize : size sr = #|s|). destruct (andP Hsr) as [H1 H2].
by rewrite cardE -(@size_map _ _ (fun x=>x.1)) (eqP H1).
rewrite -Hsize. by exists (in_tuple sr).
Qed.

Lemma sub_all_and_l (A : eqType) (a1 a2 : pred A) l : all (fun x => (a1 x) && a2 x) l -> all a1 l.
Proof.
apply sub_all. by move=> x /andP [H1 H2].
Qed.

Lemma sub_all_and_r (A : eqType) (a1 a2 : pred A) l : all (fun x => (a1 x) && a2 x) l -> all a2 l.
Proof.
apply sub_all. by move=> x /andP [H1 H2].
Qed.

Lemma negb_has_predC_all {A : Type} (a : pred A) (s : seq A) :
has (predC a) s = false -> all a s.
Proof.
rewrite has_predC.
by destruct (bool_des_rew (all a s)) as [H|H];rewrite H.
Qed.

End all.

Lemma pair_seq_nth_proj_l {A B : Type} (x : seq A) (k : nat) (def : (A * B)%type) (s : seq (A * B)%type) :
[seq i.1 | i <- s] = x ->
(nth def s k).1 = nth def.1 x k.
Proof.
move:x k.
induction s as [|h tl Htup];move=>[|hl ll] [|k] //= [H1 H2].
apply H1.
by rewrite (Htup ll k H2).
Qed.

Lemma map_square_eq {A B C D : Type} (f : A -> C) (g : B -> C) (h : A -> D) (m : B -> D)
  (l1 : seq A) (l2 : seq B) :
   (forall x y, (f x = g y -> h x = m y))
-> [seq f x | x <- l1] = [seq g y | y <- l2]
-> [seq h x | x <- l1] = [seq m y | y <- l2].
Proof.
move:l2;induction l1 as [|h1 l1 Hl]; move=>[|h2 l2] //= Heq [H1 H2].
rewrite (Heq h1 h2 H1). apply/f_equal.
by rewrite (Hl l2 Heq).
Qed.

Lemma seq_inj T (x y : T) (xs ys : seq T) :
  [:: x & xs] = [:: y & ys] -> x = y /\ xs = ys.
Proof. by case. Qed.

Lemma seq_in_ind {A : eqType} (def x : A) (s : seq A) :
   x \in s
-> exists y : 'I_(size s), nth def s y = x.
Proof.
induction s as [|h s Hrec].
by rewrite in_nil.
rewrite in_cons. move=>/orP[H|H].
assert (H0 : 0 < size (h :: s)). auto.
exists (Ordinal H0). simpl. by rewrite (eqP H).
destruct (Hrec H) as [[z Hz1] Hz2].
assert (Hz3 : z.+1 < (size (h :: s))).
apply Hz1.
exists (Ordinal Hz3). simpl. apply Hz2.
Qed.

(** *** nth_error: trying to get the i-th element of a seq *)
Section nth_error.

(* source: https://coq.inria.fr/library/Coq.Lists.List.html *)
Fixpoint nth_error (A : Type) (l:seq A) (n:nat) {struct n} : option A :=
  match n, l with
    | O, x :: _ => Some x
    | S n, _ :: l => nth_error l n
    | _, _ => None
  end.

Lemma nth_error_in (A : eqType) (l:seq A) (n:nat) (x:A):
  nth_error l n = Some x -> x \in l.
Proof.
move:n.
induction l ; destruct n as [|n] ; try (by []) ;
rewrite in_cons ; move => H ; apply/orP.
by inversion H ; left.
right ; apply (IHl n H).
Qed.

Lemma nth_error_map (A B : eqType) (f: A -> B) (l:seq A) (n:nat) (x:A):
  nth_error l n = Some x -> nth_error (map f l) n = Some (f x).
Proof.
move:n.
induction l ; destruct n as [|n] ; try (by []).
by move=>[->].
move=>/= H. apply/IHl/H.
Qed.

Lemma nth_error_map_none (A B : eqType) (f: A -> B) (l:seq A) (n:nat):
  nth_error l n = None -> nth_error (map f l) n = None.
Proof.
move:n.
induction l ; destruct n as [|n] ; try (by []).
move=>/= H. apply/IHl/H.
Qed.

Lemma nth_error_nth (A : eqType) (l : seq A) (x def : A) (n : nat) :
  nth_error l n = Some x -> nth def l n = x.
Proof.
move:x n. induction l as [|h l Hrec];
move=>x [|n] //=.
- by move=>[->].
- apply/Hrec.
Qed.

Lemma nth_error_ncons1 {A : Type} (m n : nat) (x:A) :
   n <= m
-> nth_error (ncons m x [:: x]) n = Some x.
Proof.
move:m x.
induction n as [|n Hrec];
move=>[|m] x Hm //=.
apply/Hrec/Hm.
Qed.

Lemma nth_error_set_nth {A : Type} (l:seq A) (n:nat) (x:A) :
  nth_error (set_nth x l n x) n = Some x.
Proof.
move:x n.
induction l as [|h l Hrec];
move=>x [|n] //=.
by apply/nth_error_ncons1.
Qed.

Lemma nth_error_preim {A B : eqType} (f : A -> B) (l : seq A) (y : B) (i : nat) :
  nth_error (map f l) i = Some y -> exists x : A, (nth_error l i = Some x /\ f x = y).
Proof.
move:i. induction l as [|h l Hl];move=>[|i]//=.
move=>[<-]. by exists h.
move=>H. apply/Hl/H.
Qed.

Lemma nth_error_in_size {A : Type} (l : seq A) (i : nat) (x : A) :
  nth_error l i = Some x -> size l > i.
Proof.
move:l. induction i as [|i Hi];move=>[|h l] //= H.
by apply Hi.
Qed.

Lemma nth_error_notin_size {A : Type} (l : seq A) (i : nat) :
  nth_error l i = None -> size l <= i.
Proof.
move:l. induction i as [|i Hi];move=>[|h l] //= H.
by apply Hi.
Qed.

Lemma nth_error_size_notin {A : Type} (l : seq A) (i : nat) :
  size l <= i -> nth_error l i = None.
Proof.
move:l. induction i as [|i Hi];move=>[|h l] //= H.
by apply Hi.
Qed.

Lemma nth_error_sremove {A : eqType} (l : seq A) (i : nat) (x y : A) :
  nth_error l i = Some x
-> x <> y
-> y \in l = (y \in sremove l i).
Proof.
move:x y i.
induction l as [|h l Hrec];
move=>x y [|i] //=.
- move=>[->] Hneq. rewrite in_cons Bool.orb_lazy_alt.
  destruct (bool_des_rew (y == x)) as [Hf|Hf].
  exfalso. apply/Hneq. by rewrite (eqP Hf).
  by rewrite Hf.
- move=>Hnth Hneq. rewrite !in_cons.
  apply/orb_id2l. move=>Hneqb.
  apply (Hrec _ _ _ Hnth Hneq).
Qed.

Lemma nth_error_sremove_eq {A : eqType} (l1 l2 : seq A) (i : nat) :
   nth_error l1 i = nth_error l2 i
-> sremove l1 i = sremove l2 i
-> l1 = l2.
Proof.
move:l2 i.
induction l1 as [|h1 l1 Hrec];
move=>[|h2 l2] [|i] //=.
- by move=>[->] H;apply/f_equal.
- move=>Hnth [-> Htleq]. apply/f_equal.
  apply/Hrec. apply Hnth. apply Htleq.
Qed.

Lemma tnth_nth_error {A : Type} (l : seq A) i :
  Some (tnth (in_tuple l) i) = nth_error l i.
Proof.
induction l.
destruct i as [[|i] Hi] ; inversion Hi.
destruct i as [[|i] Hi]. by apply/f_equal.
simpl.
rewrite -(IHl (Ordinal (n:=size l) (m:=i) Hi)).
(* both "calls" use different implicits *)
by rewrite (tnth_nth (tnth_default (in_tuple (a :: l)) (Ordinal Hi)))
           (tnth_nth (tnth_default (in_tuple (a :: l)) (Ordinal Hi))).
Qed.

Lemma nth_error_size_leq {A : Type} (l : seq A) i :
  i < size l -> exists x : A, nth_error l i = Some x.
Proof.
move:i. induction l as [|h l Hl]. move=>//.
destruct i as [|i];move=>Hi. by exists h.
by apply Hl.
Qed.

Lemma oob_nth_error {A : Type} (s : seq A) (ind : 'I_(size s)) :
  nth_error s ind <> None.
Proof.
destruct ind as [ind Hind].
destruct (nth_error_size_leq Hind) as [x Hx].
by rewrite Hx.
Qed.

Lemma nth_error_leq_size {A : Type} (l : seq A) i :
  (exists x : A, nth_error l i = Some x) -> i < size l.
Proof.
move:i. induction l as [|h l Hl]; move=> [|i] [x Hx] //.
apply Hl. by exists x.
Qed.

Lemma nth_error_case {A : eqType} (l : seq A) (n:nat) :
  nth_error l n = None \/ exists x, (x \in l) /\ nth_error l n = Some x.
Proof.
move:n.
induction l as [|h tl Hl];destruct n as [|n].
by left.
by left.
right. exists h. split. by rewrite in_cons ; apply/orP;left. auto.
simpl. destruct (Hl n) as [H|[x [Hx1 Hx2]]].
by left.
right. exists x. split. by rewrite in_cons ; apply/orP;right. auto.
Qed.

Lemma nth_error_some_none_size {A B : Type} (l1 : seq A) (l2 : seq B) (x : A) (j : nat) :
  nth_error l1 j = Some x -> nth_error l2 j = None -> size l1 = size l2 -> False.
Proof.
move=>H1 H2 H3.
have Hf1:= nth_error_in_size H1.
have Hf2 := nth_error_notin_size H2.
rewrite H3 in Hf1. have Hf3 := leq_ltn_trans Hf2 Hf1.
rewrite leqNgt ltnSn in Hf3. inversion Hf3.
Qed.

End nth_error.

Section find.

Lemma find_val {A : Type} {Q : pred A} {B : subType Q} (l : seq B) (P : pred A) :
   find (fun x => P (val x)) l = find P (map val l).
Proof.
induction l as [|h l Hl];
move=> //=.
destruct (bool_des_rew (P (val h))) as [Hp|Hp];
rewrite !Hp;auto.
Qed.

Lemma nth_default_size {A : eqType} (def : A) (l : seq A) (i : nat) :
  nth def l i != def -> i < size l.
Proof.
move:i.
induction l as [|l Hl].
by destruct i;rewrite eq_refl.
move=>[|i] //= Hnth.
by apply IHHl.
Qed.

(* generalize on uniq *)
Lemma find_eq_nth_uniq {A : eqType} {def : A} (x : A) (l : seq A) (j : nat) :
   nth def l j = x
-> x != def
-> uniq l
-> find [pred y | y == x] l = j.
Proof.
move:j.
induction l as [|z l Hl];
move=>[|j] //=.
- move=>->. by rewrite eq_refl.
- move=>-> Hu. by rewrite eq_refl.
- move=> Hnth Hnx /andP [Hzl Hul] /=.
  destruct (bool_des_rew (z == x)) as [Hxz|Hxz].
  + unfold negb in Hzl.
    assert (Hzlb : x \in l). apply/nthP. exists j.
    apply/(@nth_default_size _ def l j). rewrite Hnth. apply Hnx.
    apply Hnth.
    by rewrite (eqP Hxz) Hzlb in Hzl.
  + rewrite Hxz. apply/f_equal/Hl. apply Hnth.
    apply Hnx.
    apply Hul.
Qed.

(* TODO: generalize *)
Lemma find_iota i k :
   k < i
-> find [pred x | x == k] (iota 0 i) = k.
Proof.
move=>Hki.
apply (@find_eq_nth_uniq _ i.+1).
by rewrite nth_iota.
rewrite neq_ltn. apply/orP;left.
apply/ltn_trans. apply Hki. auto.
apply iota_uniq.
Qed.

End find.

End seq.

(** * Various definitions *)

(** *** dep_iota: returning a sequence of nats as ordinals *)

Definition dep_iota (m n : nat) : seq ('I_(m+n)) :=
  pmap insub (iota m n).

Lemma dep_iotaE (m n : nat) : map val (dep_iota m n) = iota m n.
Proof.
move:m.
induction n as [|n Hn] => [|m] //=.
unfold dep_iota. simpl. unfold oapp.
rewrite insubT.
rewrite addnS -addSn.
by apply ltn_addr.
move=>H /=.
by rewrite -addSnnS (Hn m.+1).
Qed.

Lemma dep_iota_uniq (m n : nat) : uniq (dep_iota m n).
Proof.
induction n as [|n Hn].
auto.
unfold dep_iota.
apply/pmap_uniq. apply insubK.
apply/iota_uniq.
Qed.

Lemma size_dep_iota (m n : nat) : size (dep_iota m n) = n.
Proof.
by rewrite -(size_map val) dep_iotaE size_iota.
Qed.

(** *** Equip the elements of a set with a property *)
(** Thanks to Arthur Azevedo De Amorim *)
Definition equip (T : finType) (P : pred T) (A : {set T}) : {set {x : T | P x}} :=
  [set x in pmap insub (enum A)].

(** ** bigop *)
Section bigop.

Lemma bigcup_type_seq {A B : finType} {f : A -> {set B}} : forall (x : B) z,
 x \in \bigcup_(y <- z) f y -> x \in \bigcup_y f y.
Proof.
move => x z /bigcup_seqP [a Haz /andP [Hxfa Htriv]].
apply/bigcupP. by exists a.
Qed.

End bigop.

Section Prod.

Lemma prod_eq {A B : Type} (x y : prod A B) : fst x = fst y -> snd x = snd y -> x = y.
Proof.
by case x;case y=>a b c d /= -> ->.
Qed.

End Prod.

(** *** Shifting operations on ordinals *)

Section ord.

Lemma ord_shiftl {i : nat} : forall x : 'I_i, x.+1 < i.+1.
Proof.
move => x ; elim:x ; move => // m i0.
Qed.

Definition ord_shift {i : nat} (x : 'I_i) : 'I_i.+1 :=
  Ordinal (ord_shiftl x).

Definition shift {i j : nat} (l : j.-tuple 'I_i) : j.-tuple 'I_(i.+1) :=
  [tuple of (map (fun (x : 'I_i) =>  ord_shift x) l)].

End ord.

(** *** pset: pmap for finsets *)

Definition pimset {A B : finType} (f : A -> option B) (s : {set A}) : {set B} :=
   [set id x | x in (pmap f [seq y | y in s])].

Definition pset {A : finType} (s : {set (option A)}) : {set A} := pimset id s.

Lemma mem_set_pset {A : finType} (x : A) (s : {set (option A)}) : Some x \in s -> x \in pset s.
Proof.
move => Hin.
apply/mem_imset.
rewrite mem_pmap.
apply (@map_f _ _ id).
by rewrite mem_image.
Qed.

Lemma mem_pset_set {A : finType} (x : A) (s : {set (option A)}) : x \in pset s -> Some x \in s.
Proof.
move => /imsetP Hin.
destruct Hin as [a Hin Heq].
rewrite mem_pmap map_id in Hin.
destruct (imageP Hin) as [b Hbin Hbeq].
by rewrite Heq Hbeq.
Qed.

(** *** Prop version of all *)
Section all_prop.

Fixpoint all_prop (T : Type) (a : T -> Prop) (s : seq T) := match s with
  | [::] => True
  | x::s' => a x /\ all_prop a s' end.

Lemma all_prop_cat_l {A : Type} {P : A -> Prop} {l l' : seq A} (H : all_prop P (l ++ l')) : all_prop P l.
Proof.
by induction l ; [ | destruct H ; split ; [ | apply IHl] ].
Qed.

Lemma all_prop_cat_r {A : Type} {P : A -> Prop} {l l' : seq A} (H : all_prop P (l ++ l')) : all_prop P l'.
Proof.
by induction l ; [ | apply IHl ; destruct H].
Qed.

Lemma all_prop_cat {A : Type} {P : A -> Prop} {l l' : seq A} :
  all_prop P (l ++ l') <-> all_prop P l /\ all_prop P l'.
Proof.
split.
- move => H ; split ; [apply (all_prop_cat_l H) | apply (all_prop_cat_r H)].
- move => [Hl Hr].
  induction l.
  + move => //.
  + destruct Hl as [Ha Hl]. split ; [apply Ha | apply (IHl Hl)].
Qed.

Lemma all_prop_in {A : eqType} {P : A -> Prop} {l : seq A} {x : A}
  (Hp : all_prop P l) (Hin : x \in l) : P x.
Proof.
induction l.
- inversion Hin.
- unfold in_mem in Hin. simpl in Hin. destruct (orP Hin).
  + rewrite (eqP H). by destruct Hp.
  + apply IHl.
    - by destruct Hp.
    - apply H.
Qed.

Lemma all_prop_seq_decr {A : eqType} {P : A -> Prop}:
  forall l1 l2, all_prop P l2 -> {subset l1 <= l2} -> all_prop P l1.
Proof.
induction l1.
- move => //.
- move => /= l2 Hp Hsub ; split.
  + assert (Hal2 : a \in l2).
    - apply/(Hsub a)/mem_head.
    by apply (@all_prop_in A P l2 a).
  + apply IHl1 with (l2 := l2).
    - apply Hp.
    - move => x Hxl1. apply Hsub. unfold in_mem. simpl. apply/orP. by right.
Qed.

Lemma all_prop_prop_decr {A : eqType} (a1 a2 : A -> Prop) (s : seq A) :
                      (all_prop a1 s) -> (forall x, x \in s -> a1 x -> a2 x) -> all_prop a2 s.
Proof.
induction s. auto. move=>[H1 H2] H. split. apply H. apply mem_head. apply H1. apply IHs.
apply H2.
move=>x Hx. apply H. apply/mem_body/Hx.
Qed.

Lemma fold_maxn_n_map_leq {A : Type} {w n : nat} {l : seq A} {f : A -> nat} :
  n <= w -> (all_prop (fun t => (f t <= w)) l) -> foldr maxn n (map f l) <= w.
Proof.
induction l;auto.
move=> Hn [Ha Hl] /=.
rewrite geq_max ; apply/andP ; split.
- apply Ha.
- apply/IHl/Hl/Hn.
Qed.

Lemma fold_maxn_n_map_ltn {A : Type} {w n : nat} {l : seq A} {f : A -> nat} :
  n < w -> (all_prop (fun t => (f t < w)) l) -> foldr maxn n (map f l) < w.
Proof.
induction l;auto.
move=>Hn [Ha Hl] /=.
rewrite gtn_max ; apply/andP ; split.
- apply Ha.
- apply/IHl/Hl/Hn.
Qed.

Lemma sub_rem_seq {A : eqType} : forall (l : seq (seq A)) s h,
all_prop (fun x : seq A => {subset x <= s}) [seq h :: i | i <- l] ->
all_prop (fun sl => h \notin sl) l ->
all_prop (fun x : seq_predType A => {subset x <= rem h s}) l.
Proof.
move=> l s h H1 H2.
apply (all_prop_prop_decr H2)=>x Hx.
apply sub_rem.
apply/(all_prop_in H1)/mapP.
by exists x.
Qed.

Lemma sub_val_map (A : eqType) (P : pred A) (B : subType P) (l : seq A)
          (ls : seq B) (Heq : l = map val ls) :
          all_prop (fun x : A => exists px : P x, @Sub A P B x px \in ls) l.
Proof.
move: ls Heq.
induction l ; [ by [] | ].
move => ls Heq.
destruct ls ; [by inversion Heq | ].
inversion Heq as [[Haseq Hllseq]].
split.
- exists (valP s).
  assert (Heqb : Sub (val s) (valP (sT:=B) s) == s).
  + rewrite <- inj_eq with (f := val).
    - simpl ; apply/eqP. destruct B as [sub_sort val Sub Helim Hvseq]. simpl. by rewrite Hvseq.
    - apply val_inj.
  rewrite (eqP Heqb) ; apply/mem_head.
- assert (Hsimpl : all_prop (fun x : A => exists px : P x, Sub x px \in ls)
  [seq val i | i <- ls]).
  + rewrite Hllseq in IHl. by apply IHl with (ls0 := ls).
  apply/all_prop_prop_decr. apply Hsimpl.
  move => x Hb Hfall.
  destruct Hfall as [Px] ; exists Px ; apply/mem_body/H.
Qed.

End all_prop.

(** *** Cartesian product *)
Definition gen_cart_prod {A : finType} (ss : seq {set A}) : {set (size ss).-tuple A} :=
  let m := size ss in
  [set x : m.-tuple A | [forall j : 'I_m, tnth x j \in tnth (in_tuple ss) j]].


Require Coq.Lists.List.
Require Export TypeClasses.Applicative.

(** * The Monad Type Class *)
Class Monad (M : Type -> Type) :=
  { Monad_Applicative :> Applicative M;
    bind : forall {A B : Type}, M A -> (A -> M B) -> M B;
    (** Laws. *)
    pure_left : forall {A B : Type} (a : A) (f : A -> M B),
      bind (pure a) f = f a;
    pure_right : forall {A : Type} (m : M A),
      bind m pure = m;
    bind_assoc : forall {A B C : Type} (m : M A) (k : A -> M B) (h : B -> M C),
      bind m (fun a => bind (k a) h) = bind (bind m k) h;
    fmap_bind : forall {A B : Type} (m : M A) (f : A -> B),
      fmap f m = bind m (pure ∘ f) }.
(**[]*)

(** Haskellites will note the absence of [return : A -> M A].
    [return] has been substituted with [pure] to streamline
    the definitions in the spirit of this proposal:
    [https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return] *)

Notation "'let*' a ':=' ma 'in' mb"
  := (bind ma (fun a => mb))
       (at level 61, a pattern, right associativity).

Notation "'let*' ' a ':=' ma 'in' mb"
  := (bind ma (fun a => mb))
       (at level 61, a pattern, right associativity).

Infix ">>=" := bind (at level 43, left associativity).

Definition mcompose {A B C : Type} {M : Type -> Type} `{Monad M}
           (f : A -> M B) (h : B -> M C) (a : A) : M C := f a >>= h.

Infix ">=>" := mcompose (at level 44, right associativity).

(** The Monad Laws (more elegeantly)
    in terms of Composition. *)
Section MonadLaws.
  Context {M : Type -> Type}.

  Context `{HM : Monad M}.

  (** Left [pure] is idempotent. *)
  Lemma left_pure_idem :
    forall {A B : Type} (f : A -> M B),
      pure >=> f = f.
  Proof.
    intros. unfold mcompose.
    extensionality a. apply pure_left.
  Qed.

  (** Right [pure] is idempotent. *)
  Lemma right_pure_idem :
    forall {A B : Type} (f : A -> M B),
      f >=> pure = f.
  Proof.
    intros. unfold mcompose.
    extensionality a. apply pure_right.
  Qed.

  (** Composition is associative. *)
  Lemma mcompose_assoc :
  forall {A B C D : Type}
    (f : A -> M B) (h : B -> M C) (k : C -> M D),
    (f >=> h) >=> k = f >=> h >=> k.
  Proof.
    intros. unfold mcompose.
    extensionality a. rewrite bind_assoc.
    reflexivity.
  Qed.

  (** The join operator. *)
  Definition
    join {A : Type} (m : M (M A))
    : M A := let* m' := m in m'.
End MonadLaws.

(** * Monad Specification *)
Module Type MonadSpec <: ApplicativeSpec.
  Include ApplicativeSpec.
  Definition M : Type -> Type := F.

  Parameter bind : forall {A B : Type}, M A -> (A -> M B) -> M B.

  (** Laws. *)

  (** Promontion to a Monad has no effect. *)
  Axiom pure_left : forall {A B : Type} (a : A) (f : A -> M B),
      bind (pure a) f = f a.

  (** Binding a Monad with [pure] has no effect. *)
  Axiom pure_right : forall {A : Type} (m : M A),
      bind m pure = m.

  (** Associativity of bind. *)
  Axiom bind_assoc : forall {A B C : Type} (m : M A) (k : A -> M B) (h : B -> M C),
      bind m (fun a => bind (k a) h) = bind (bind m k) h.

  (** Fmap is equivalent to bind. *)
  Axiom fmap_bind : forall {A B : Type} (m : M A) (f : A -> B),
      fmap f m = bind m (pure ∘ f).
End MonadSpec.

Module MonadFactory (MS : MonadSpec).
  Include ApplicativeFactory MS.

  Instance MonadInstance : Monad MS.M :=
    { bind _ _ := MS.bind;
      pure_left _ _ := MS.pure_left;
      pure_right _ := MS.pure_right;
      bind_assoc _ _ _ := MS.bind_assoc;
      fmap_bind _ _ := MS.fmap_bind }.
End MonadFactory.

(** Identity *)
Module IdentityMonadSpec <: MonadSpec.
  Include IdentityApplicativeSpec.
  Definition M : Type -> Type := fun X => X.

  Definition bind {A B : Type} : A -> (A -> B) -> B := pipeline.

  Lemma pure_left : forall {A B : Type} (a : A) (f : A -> B),
      bind (pure a) f = f a.
  Proof. intros. reflexivity. Qed.

  Lemma pure_right : forall {A : Type} (m : A),
      bind m pure = m.
  Proof. intros. reflexivity. Qed.

  Lemma bind_assoc : forall {A B C : Type} (m : A) (k : A -> B) (h : B -> C),
      bind m (fun a => bind (k a) h) = bind (bind m k) h.
  Proof. intros. reflexivity. Qed.

  Lemma fmap_bind : forall {A B : Type} (m : A) (f : A -> B),
      fmap f m = bind m (pure ∘ f).
  Proof. intros; reflexivity. Qed.
End IdentityMonadSpec.

Module IdentityMonadFactory := MonadFactory IdentityMonadSpec.
Instance IdentityMonad : Monad (fun X => X) :=
  IdentityMonadFactory.MonadInstance.

(** Option *)
Module OptionMonadSpec <: MonadSpec.
  Include OptionApplicativeSpec.

  Definition M : Type -> Type := option.

  Definition bind {A B : Type} (m : option A) (f : A -> option B) : option B :=
    match m with
    | None   => None
    | Some a => f a
    end.

  Lemma pure_left : forall {A B : Type} (a : A) (f : A -> option B),
      bind (pure a) f = f a.
  Proof. intros. reflexivity. Qed.

  Lemma pure_right : forall {A : Type} (m : option A),
      bind m pure = m.
  Proof. intros. destruct m; reflexivity. Qed.

  Lemma bind_assoc :
    forall {A B C : Type} (m : option A) (k : A -> option B) (h : B -> option C),
      bind m (fun a => bind (k a) h) = bind (bind m k) h.
  Proof. intros. destruct m; reflexivity. Qed.

  Lemma fmap_bind : forall {A B : Type} (m : option A) (f : A -> B),
      fmap f m = bind m (pure ∘ f).
  Proof. intros; destruct m; reflexivity. Qed.
End OptionMonadSpec.

Module OptionMonadFactory := MonadFactory OptionMonadSpec.
Instance OptionMonad : Monad option :=
  OptionMonadFactory.MonadInstance.

Compute Some 5 >>= (fun x => pure (x * x)) >>= (fun y => pure (y + y)).
Compute Some 5 >>= (fun _ => None) >>= (fun y => pure (y + y)).
Compute let* x := Some 5 in let* y := Some 6 in pure (x * y).

(** List *)
Module ListMonadSpec <: MonadSpec.
  Import Coq.Lists.List.
  Import ListNotations.

  Include ListApplicativeSpec.
  Definition M : Type -> Type := list.

  Definition bind {A B : Type} (l : list A) (f : A -> list B) : list B :=
    flat_map f l.

  Lemma pure_left : forall {A B : Type} (a : A) (f : A -> list B),
      bind (pure a) f = f a.
  Proof. intros. simpl. apply app_nil_r. Qed.

  Lemma pure_right : forall {A : Type} (m : list A),
      bind m pure = m.
  Proof.
    intros. unfold bind.
    induction m; auto.
    simpl. apply f_equal. assumption.
  Qed.

  Lemma bind_assoc :
    forall {A B C : Type} (m : list A) (k : A -> list B) (h : B -> list C),
      bind m (fun a => bind (k a) h) = bind (bind m k) h.
  Proof.
    intros. unfold bind.
    induction m as [| a t IHt]; simpl in *; auto.
    rewrite IHt; clear IHt.
    rewrite flat_map_app. reflexivity.
  Qed.

  Lemma fmap_bind : forall {A B : Type} (m : list A) (f : A -> B),
      fmap f m = bind m (pure ∘ f).
  Proof. intros; destruct m; reflexivity. Qed.
End ListMonadSpec.

Module ListMonadFactory := MonadFactory ListMonadSpec.
Instance ListMonad : Monad list :=
  ListMonadFactory.MonadInstance.

Module ListPlayground.
  Import Coq.Lists.List.
  Import ListNotations.

  Definition list_pairs {A B : Type} (la : list A) (lb : list B) : list (A * B) :=
    let* a := la in let* b := lb in pure (a,b).

  Compute list_pairs [1;2;3;4;5;6] [None; Some 69; None; None; Some 42].

  Compute join [[1;2;3;4;5];[23;76;11];[];[69;42]].

  Remark join_concat : forall {A : Type} (l : list (list A)),
      join l = concat l.
  Proof. intros. induction l; auto. Qed.
End ListPlayground.

(** * Parameterized Monads *)

Module Type ParamMonadSpec <: ParamApplicativeSpec.
  Include ParamApplicativeSpec.
  Definition M : Type -> Type -> Type := F.

  Section Spec.
    Context {T : Type}.

    Parameter bind : forall {A B : Type}, M T A -> (A -> M T B) -> M T B.

    (** Laws. *)

    (** Promontion to a Monad has no effect. *)
    Axiom pure_left : forall {A B : Type} (a : A) (f : A -> M T B),
        bind (pure a) f = f a.

    (** Binding a Monad with [pure] has no effect. *)
    Axiom pure_right : forall {A : Type} (m : M T A),
        bind m pure = m.

    (** Associativity of bind. *)
    Axiom bind_assoc :
      forall {A B C : Type} (m : M T A) (k : A -> M T B) (h : B -> M T C),
        bind m (fun a => bind (k a) h) = bind (bind m k) h.

    Axiom fmap_bind : forall {A B : Type} (m : M T A) (f : A -> B),
      fmap f m = bind m (pure ∘ f).
  End Spec.
End ParamMonadSpec.

Module ParamMonadFactory (MS : ParamMonadSpec).
  Include ParamApplicativeFactory MS.

  Instance ParamMonadInstance (T : Type) : Monad (MS.M T) :=
    { bind := @MS.bind T;
      pure_left := @MS.pure_left T;
      pure_right := @MS.pure_right T;
      bind_assoc := @MS.bind_assoc T;
      fmap_bind := @MS.fmap_bind T }.
End ParamMonadFactory.

(** Either. *)
Module EitherMonadSpec <: ParamMonadSpec.
  Include EitherApplicativeSpec.
  Definition M : Type -> Type -> Type := either.

  Section Spec.
    Context {T : Type}.

    Definition bind {A B : Type}
               (m : either T A) (f : A -> either T B) : either T B :=
      match m with
      | Left t  => Left t
      | Right a => f a
      end.

    Lemma pure_left : forall {A B : Type} (a : A) (f : A -> either T B),
        bind (pure a) f = f a.
    Proof. intros. reflexivity. Qed.

    Lemma pure_right : forall {A : Type} (m : either T A),
        bind m pure = m.
    Proof. intros. destruct m; reflexivity. Qed.

    Lemma bind_assoc :
      forall {A B C : Type} (m : either T A)
        (k : A -> either T B) (h : B -> either T C),
        bind m (fun a => bind (k a) h) = bind (bind m k) h.
    Proof. intros. destruct m; reflexivity. Qed.

    Lemma fmap_bind : forall {A B : Type} (m : either T A) (f : A -> B),
        fmap f m = bind m (pure ∘ f).
    Proof. intros; destruct m; reflexivity. Qed.
  End Spec.
End EitherMonadSpec.

Module EitherMonadFactory := ParamMonadFactory EitherMonadSpec.
Instance EitherMonad (A : Type) : Monad (either A) :=
  EitherMonadFactory.ParamMonadInstance A.

(** Arrow. *)
Module ArrowMonadSpec <: ParamMonadSpec.
  Include ArrowApplicativeSpec.
  Definition M : Type -> Type -> Type := (fun T R => T -> R).

  Section Spec.
    Context {T : Type}.

    Definition bind {A B : Type}
               (m : T -> A) (f : A -> T -> B) : T -> B := fun t => f (m t) t.

    Lemma pure_left : forall {A B : Type} (a : A) (f : A -> T -> B),
        bind (pure a) f = f a.
    Proof. intros. reflexivity. Qed.

    Lemma pure_right : forall {A : Type} (m : T -> A),
        bind m pure = m.
    Proof. intros. reflexivity. Qed.

    Lemma bind_assoc :
      forall {A B C : Type} (m : T -> A) (k : A -> T -> B) (h : B -> T -> C),
        bind m (fun a => bind (k a) h) = bind (bind m k) h.
    Proof. intros. reflexivity. Qed.

    Lemma fmap_bind : forall {A B : Type} (m : T -> A) (f : A -> B),
        fmap f m = bind m (pure ∘ f).
    Proof. intros; reflexivity. Qed.
  End Spec.
End ArrowMonadSpec.

Module ArrowMonadFactory := ParamMonadFactory ArrowMonadSpec.
Instance ArrowMonad (A : Type) : Monad (fun B => A -> B) :=
  ArrowMonadFactory.ParamMonadInstance A.

(** State. *)
Module StateMonadSpec <: ParamMonadSpec.
  Include StateApplicativeSpec.
  Definition M : Type -> Type -> Type := F.

  Section Spec.
    Context {S : Type}.

    Definition bind {A B : Type}
               (m : state S A) (f : A -> state S B) : state S B :=
      fun st => let (a, st) := m st in f a st.

    Lemma pure_left : forall {A B : Type} (a : A) (f : A -> state S B),
        bind (pure a) f = f a.
    Proof. intros. reflexivity. Qed.

    Lemma pure_right : forall {A : Type} (m : state S A),
        bind m pure = m.
    Proof.
      intros. extensionality st. unfold bind, pure.
      destruct (m st) ; reflexivity.
    Qed.

    Lemma bind_assoc :
      forall {A B C : Type} (m : state S A)
        (k : A -> state S B) (h : B -> state S C),
        bind m (fun a => bind (k a) h) = bind (bind m k) h.
    Proof.
      intros. extensionality st. unfold bind.
      destruct (m st); reflexivity.
    Qed.

    Lemma fmap_bind : forall {A B : Type} (m : state S A) (f : A -> B),
        fmap f m = bind m (pure ∘ f).
    Proof. intros; reflexivity. Qed.
  End Spec.
End StateMonadSpec.

Module StateMonadFactory := ParamMonadFactory StateMonadSpec.
Instance StateMonad (S : Type) : Monad (state S) :=
  StateMonadFactory.ParamMonadInstance S.
(**[]*)

(** Continuations. *)
Module ContMonadSpec <: ParamMonadSpec.
  Include ContApplicativeSpec.
  Definition M : Type -> Type -> Type := cont.

  Section Spec.
    Context {R : Type}.

    Definition bind {A B : Type}
               (c : cont R A) (f : A -> cont R B) : cont R B :=
      fun k => c (fun a => f a k).

    Lemma pure_left : forall {A B : Type} (a : A) (f : A -> cont R B),
        bind (pure a) f = f a.
    Proof. intros. reflexivity. Qed.

    (** Binding a Monad with [pure] has no effect. *)
    Lemma pure_right : forall {A : Type} (m : cont R A),
        bind m pure = m.
    Proof. intros. reflexivity. Qed.

    Lemma bind_assoc :
      forall {A B C : Type} (m : cont R A)
        (k : A -> cont R B) (h : B -> cont R C),
        bind m (fun a => bind (k a) h) = bind (bind m k) h.
    Proof. intros. reflexivity. Qed.

    Lemma fmap_bind : forall {A B : Type} (m : cont R A) (f : A -> B),
        fmap f m = bind m (pure ∘ f).
    Proof. intros; reflexivity. Qed.
  End Spec.
End ContMonadSpec.

Module ContMonadFactory := ParamMonadFactory ContMonadSpec.
Instance ContMonad (R : Type) : Monad (cont R) :=
  ContMonadFactory.ParamMonadInstance R.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export representant_unitaire.
Set Implicit Arguments.
Unset Strict Implicit.
Hint Resolve distance_non_nulle scalaire_positif: geo.

Definition distance (A B : PO) := sqrt (scalaire (vec A B) (vec A B)).

Lemma distance_pos : forall A B : PO, distance A B >= 0.
unfold distance in |- *; intros; auto with geo real.
Qed.

Lemma distance_sym : forall A B : PO, distance A B = distance B A.
unfold distance in |- *; intros; auto.
VReplace (vec B A) (mult_PP (-1) (vec A B)).
Simplscal.
replace (-1 * -1 * scalaire (vec A B) (vec A B)) with
 (scalaire (vec A B) (vec A B)); try ring.
Qed.

Lemma distance_refl : forall A B : PO, distance A B = 0 <-> A = B.
unfold distance in |- *; intros; red in |- *.
split; [ idtac | try assumption ].
intros H; try assumption.
apply distance_nulle.
RReplace 0 (0 * 0).
rewrite <- H; auto.
symmetry  in |- *.
apply def_sqrt; auto with geo real.
intros.
rewrite <- H; auto.
VReplace (vec A A) (mult_PP (-0) (vec A B)).
Simplscal.
replace (-0 * -0 * scalaire (vec A B) (vec A B)) with 0; try ring.
try exact sqrt_0.
Qed.

Lemma distance_refl1 : forall A B : PO, distance A B = 0 :>R -> A = B :>PO.
intros.
elim (distance_refl A B); auto.
Qed.

Lemma distance_refl2 : forall A B : PO, A = B :>PO -> distance A B = 0 :>R.
intros.
elim (distance_refl A B); auto.
Qed.
Hint Resolve distance_refl1 distance_refl2: geo.

Lemma caract_representant_unitaire :
 forall A B C : PO,
 A <> B ->
 vec A C = representant_unitaire (vec A B) ->
 vec A C = mult_PP (/ distance A B) (vec A B).
unfold distance in |- *; intros.
cut
 (alignes A B C /\
  scalaire (vec A C) (vec A C) = 1 /\ scalaire (vec A B) (vec A C) >= 0);
 intros.
elim H1; intros H2 H3; elim H3; intros H4 H5; try clear H3 H1; try exact H5.
halignes H2 ipattern:(k).
rewrite H1 in H4.
cut (/ scalaire (vec A B) (vec A B) = k * k); intros.
cut (k = sqrt (/ scalaire (vec A B) (vec A B))); intros.
rewrite H1; rewrite H6.
rewrite sqrt_Rinv; auto with geo real.
apply inversion_sqr; auto with geo real.
rewrite H1 in H5.
replace k with
 (k * scalaire (vec A B) (vec A B) * / scalaire (vec A B) (vec A B)).
replace (k * scalaire (vec A B) (vec A B)) with
 (scalaire (vec A B) (mult_PP k (vec A B))).
apply Rmult_pos; auto with geo real.
Simplscal.
field; auto with geo.
replace (/ scalaire (vec A B) (vec A B)) with
 (1 * / scalaire (vec A B) (vec A B)).
rewrite <- H4.
Simplscal.
field; auto with geo.
field; auto with geo.
apply def_representant_unitaire2; auto.
Qed.

Lemma distance_vecteur :
 forall A B : PO,
 A <> B -> vec A B = mult_PP (distance A B) (representant_unitaire (vec A B)).
unfold distance in |- *; intros.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros C H0; try clear existence_unitaire; try exact H0 | auto ].
rewrite <- H0; auto.
rewrite (caract_representant_unitaire (A:=A) (B:=B) (C:=C)); auto.
unfold distance in |- *.
cut (sqrt (scalaire (vec A B) (vec A B)) <> 0); intros.
Fieldvec (sqrt (scalaire (vec A B) (vec A B))).
auto with *.
Qed.

Lemma dist_non_nulle : forall A B : PO, distance A B <> 0 -> A <> B.
unfold distance in |- *; red in |- *; intros.
apply H.
rewrite H0.
replace (scalaire (vec B B) (vec B B)) with 0.
rewrite sqrt_0; ring.
replace (vec B B) with (mult_PP 0 (vec A B)).
Simplscal.
Ringvec.
Qed.
Hint Resolve distance_pos dist_non_nulle: geo.

Lemma distincts_dist_non_nulle : forall A B : PO, A <> B -> distance A B <> 0.
unfold distance in |- *; intros; red in |- *; intros.
apply H.
apply distance_nulle.
rewrite <- (def_sqrt (scalaire (vec A B) (vec A B))); auto with geo.
rewrite H0; ring.
Qed.
Hint Resolve distincts_dist_non_nulle: geo.

Lemma isometrie_distinct :
 forall A B A' B' : PO, A <> B -> distance A B = distance A' B' -> A' <> B'.
intros.
apply dist_non_nulle; rewrite <- H0; auto with geo.
Qed.

Lemma carre_scalaire_distance :
 forall A B : PO, scalaire (vec A B) (vec A B) = distance A B * distance A B.
unfold distance in |- *; intros.
rewrite def_sqrt; auto with geo.
Qed.

Lemma carre_egalite_distance :
 forall A B C D : PO,
 distance A B * distance A B = distance C D * distance C D ->
 distance A B = distance C D.
intros.
apply resolution; auto with geo.
Qed.

Lemma distance_carre :
 forall A B C D : PO,
 Rsqr (distance A B) = Rsqr (distance C D) -> distance A B = distance C D.
unfold Rsqr in |- *; intros.
apply carre_egalite_distance; auto with geo.
Qed.
Hint Resolve carre_egalite_distance distance_carre: geo.

Lemma carre_scalaire_egalite_distance :
 forall A B C D : PO,
 scalaire (vec A B) (vec A B) = scalaire (vec C D) (vec C D) ->
 distance A B = distance C D.
intros.
apply carre_egalite_distance.
repeat rewrite <- carre_scalaire_distance; auto with geo.
Qed.

Lemma unitaire_distincts2 : forall A B : PO, distance A B = 1 -> A <> B.
intros.
apply dist_non_nulle.
rewrite H.
discrR.
Qed.
Hint Resolve unitaire_distincts2: geo.

Lemma distance_1_representant :
 forall A B : PO,
 distance A B = 1 -> vec A B = representant_unitaire (vec A B).
intros.
apply def_representant_unitaire; auto with geo.
rewrite carre_scalaire_distance; rewrite H; ring.
Qed.

Lemma distance_1_carre_scalaire :
 forall A B : PO, distance A B = 1 -> scalaire (vec A B) (vec A B) = 1.
intros.
rewrite carre_scalaire_distance.
rewrite H; ring.
Qed.

Lemma carre_scalaire_1_distance :
 forall A B : PO, scalaire (vec A B) (vec A B) = 1 -> distance A B = 1.
intros.
unfold distance in |- *.
rewrite H.
rewrite sqrt_1; auto with geo.
Qed.
Hint Resolve carre_scalaire_1_distance distance_1_carre_scalaire
  distance_1_representant: geo.

Lemma milieu_distance :
 forall A B I : PO, I = milieu A B -> distance I A = distance I B.
intros.
apply carre_scalaire_egalite_distance.
rewrite <- (milieu_vecteur (A:=A) (B:=B) (M:=I)); auto with geo.
replace (vec I A) with (mult_PP (-1) (vec A I)); [ idtac | Ringvec ].
Simplscal.
Qed.
Hint Resolve milieu_distance: geo.

Lemma egalite_vecteur_distance :
 forall A B C D : PO, vec A B = vec C D -> distance A B = distance C D :>R.
intros.
apply carre_scalaire_egalite_distance.
rewrite H; auto.
Qed.

Lemma colinearite_distance :
 forall (k : R) (A B C D : PO),
 vec C D = mult_PP k (vec A B) :>PP -> distance C D = Rabs k * distance A B.
unfold distance in |- *; intros.
rewrite H; Simplscal.
replace (k * k) with (Rsqr k); auto with real.
rewrite sqrt_mult; auto with real geo.
rewrite sqrt_Rsqr_abs; ring.
Qed.
Hint Resolve colinearite_distance: geo.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(* Notation management revised in December 2002 *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  PlusZ.v                                                                 *)
(*                                                                          *)
(*  Basic properties of the addition on integers                            *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                               PlusZ.v                                    *)
(****************************************************************************)

Require Import AC.
Require Import HS.
Require Import quotient.

Section PlusZ.

Require Import nat.
Require Import integer_defs.

(* To get operators of nat available, but we don't open nat as default...*)

Open Scope INT_scope.

Lemma plusZ_sym : forall n m : Z, n + m = m + n.

intro n; pattern n in |- *; apply (Closure_prop Z_typ Z_rel n).
simple induction x; intros a1 a2.
intro m; pattern m in |- *; apply (Closure_prop Z_typ Z_rel m).
simple induction x0; intros b1 b2.
unfold plusZ in |- *.
rewrite (Reduce Z_typ Z_rel (Z -> Z) plusZ_X Compat_plusZ_X (a1, a2)).
rewrite (Reduce Z_typ Z_rel (Z -> Z) plusZ_X Compat_plusZ_X (b1, b2)).
unfold plusZ_X in |- *; simpl in |- *.
repeat rewrite Reduce.
unfold plusZ_XX in |- *; simpl in |- *.
unfold plusZ_XXX in |- *; simpl in |- *.
apply (From_R_to_L Z_typ Z_rel).
red in |- *; simpl in |- *.
ACNa.
Qed.

Lemma plusZ_assoc_l : forall n m p : Z, n + (m + p) = n + m + p.

(* almost identical proof as previous lemma *)
intro n; pattern n in |- *; apply (Closure_prop Z_typ Z_rel n).
simple induction x; intros a1 a2.
intro m; pattern m in |- *; apply (Closure_prop Z_typ Z_rel m).
simple induction x0; intros b1 b2.
intro p; pattern p in |- *; apply (Closure_prop Z_typ Z_rel p).
simple induction x1; intros c1 c2.
unfold plusZ in |- *; simpl in |- *.
rewrite (Reduce Z_typ Z_rel (Z -> Z) plusZ_X Compat_plusZ_X (b1, b2)).
rewrite (Reduce Z_typ Z_rel (Z -> Z) plusZ_X Compat_plusZ_X (a1, a2)).
unfold plusZ_X in |- *; simpl in |- *.
repeat rewrite (Reduce Z_typ Z_rel Z).
unfold plusZ_XX in |- *; simpl in |- *.
repeat rewrite (Reduce Z_typ Z_rel Z).
unfold plusZ_XXX in |- *; simpl in |- *.
rewrite
 (Reduce Z_typ Z_rel (Z -> Z)
    (fun x : Z_typ =>
     lift Z_typ Z_rel Z
       (fun y : Z_typ => |((x .1 + y .1)%nat, (x .2 + y .2)%nat) |z)
       (Compat_plusZ_XX x)) Compat_plusZ_X ((a1 + b1)%nat, (a2 + b2)%nat))
 .
repeat rewrite (Reduce Z_typ Z_rel Z).
simpl in |- *.
apply (From_R_to_L Z_typ Z_rel).
red in |- *; simpl in |- *.
ACNa.
Qed.

Lemma plusZ_permute : forall n m p : Z, n + (m + p) = m + (n + p).

intro n; pattern n in |- *; apply (Closure_prop Z_typ Z_rel n).
simple induction x; intros a1 a2.
intro m; pattern m in |- *; apply (Closure_prop Z_typ Z_rel m).
simple induction x0; intros b1 b2.
intro p; pattern p in |- *; apply (Closure_prop Z_typ Z_rel p).
simple induction x1; intros c1 c2.
unfold plusZ in |- *; simpl in |- *.
rewrite (Reduce Z_typ Z_rel (Z -> Z) plusZ_X Compat_plusZ_X (b1, b2)).
rewrite (Reduce Z_typ Z_rel (Z -> Z) plusZ_X Compat_plusZ_X (a1, a2)).
unfold plusZ_X in |- *; simpl in |- *.
repeat rewrite (Reduce Z_typ Z_rel Z).
unfold plusZ_XX in |- *; simpl in |- *.
repeat rewrite (Reduce Z_typ Z_rel Z).
unfold plusZ_XXX in |- *; simpl in |- *.
apply (From_R_to_L Z_typ Z_rel).
red in |- *; simpl in |- *.
ACNa.
Qed.

Lemma plusZ_assoc_r : forall n m p : Z, n + m + p = n + (m + p).

intros.
elim plusZ_sym.
elim (plusZ_sym (n + m)).
rewrite <- (plusZ_assoc_l n m p).
auto.
Qed.

Lemma plusZ_plus_l : forall n m p : Z, n + m = n + p -> m = p.

intro n; pattern n in |- *; apply (Closure_prop Z_typ Z_rel n).
simple induction x; intros a1 a2.
intro m; pattern m in |- *; apply (Closure_prop Z_typ Z_rel m).
simple induction x0; intros b1 b2.
intro p; pattern p in |- *; apply (Closure_prop Z_typ Z_rel p).
simple induction x1; intros c1 c2.
unfold plusZ in |- *.
rewrite (Reduce Z_typ Z_rel (Z -> Z) plusZ_X Compat_plusZ_X (a1, a2)).
unfold plusZ_X in |- *.
repeat rewrite Reduce.
unfold plusZ_XX in |- *.
repeat rewrite Reduce.
unfold plusZ_XXX in |- *; simpl in |- *.
intro HH.
cut (Z_rel ((a1 + b1)%nat, (a2 + b2)%nat) ((a1 + c1)%nat, (a2 + c2)%nat)).
unfold Z_rel in |- *; simpl in |- *.
intro H'.
apply (From_R_to_L Z_typ Z_rel).
red in |- *; simpl in |- *.
apply (fun a b : nat => plus_reg_l a b a2).
apply (fun a b : nat => plus_reg_l a b a1).
rewrite (plus_permute a2).
rewrite plus_assoc.
rewrite H'.
ACNa.
apply (From_L_to_R Z_typ Z_rel).
exact HH.
Qed.

Lemma plusZ_O : forall n : Z, n + 0 = n.

intro n; pattern n in |- *; apply (Closure_prop Z_typ Z_rel n).
simple induction x; intros a1 a2.
unfold plusZ in |- *.
rewrite (Reduce Z_typ Z_rel (Z -> Z) plusZ_X Compat_plusZ_X (a1, a2)).
unfold plusZ_X in |- *.
repeat rewrite Reduce.
unfold plusZ_XX in |- *.
repeat rewrite Reduce.
unfold plusZ_XXX in |- *; simpl in |- *.
repeat elim (plus_comm 0).
simpl in |- *.
auto.
Qed.

End PlusZ.


(**************************************)
(**************************************)
(****                              ****)
(****   The preservation theorem   ****)
(****                              ****)
(**************************************)
(**************************************)

Require Import Main.STLC.FreeVar.
Require Import Main.STLC.Name.
Require Import Main.STLC.Semantics.
Require Import Main.STLC.Substitution.
Require Import Main.STLC.Typing.
Require Import Main.Tactics.

Theorem typingJudgmentClosed :
  forall c e x t1,
  hasType c e t1 ->
  freeVar e x ->
  exists t2, lookup c x = Some t2.
Proof.
  clean. induction H; invert H0; eSearch.
Qed.

#[export] Hint Resolve typingJudgmentClosed : main.

Theorem contextInvariance :
  forall c1 c2 e t,
  hasType c1 e t ->
  (forall x, freeVar e x -> lookup c1 x = lookup c2 x) ->
  hasType c2 e t.
Proof.
  clean. outro c2. induction H; search; clean.
  - apply htVar. rewrite <- H0; search.
  - apply htAbs. apply IHhasType. search.
  - eapply htApp; search.
Qed.

#[export] Hint Resolve contextInvariance : main.

Theorem substitutionPreservesTyping :
  forall c x e1 e2 t1 t2,
  hasType (cExtend c x t1) e2 t2 ->
  hasType cEmpty e1 t1 ->
  hasType c (sub e2 x e1) t2.
Proof.
  clean. outro c t2. induction e2; clean; invert H; eSearch; clean.
  - destruct (nameEq x n); destruct (nameEq n x); search.
    apply contextInvariance with (c1 := cEmpty); search.
    clean. pose proof (typingJudgmentClosed cEmpty e1 x0 t1). search.
  - destruct (nameEq x n); apply htAbs.
    + apply contextInvariance with (c1 := cExtend (cExtend c n t1) n t);
      search.
    + apply IHe2.
      apply contextInvariance with (c1 := cExtend (cExtend c x t1) n t);
      search.
Qed.

#[export] Hint Resolve substitutionPreservesTyping : main.

Theorem preservation :
  forall e1 e2 t,
  hasType cEmpty e1 t ->
  step e1 e2 ->
  hasType cEmpty e2 t.
Proof.
  clean. outro e2. remember cEmpty. induction H; search; clean.
  - invert H2; search.
  - invert H1; eSearch.
    apply substitutionPreservesTyping with (t1 := t2); search.
    invert H; search.
Qed.

#[export] Hint Resolve preservation : main.


Require Import
        List
        Discrete.Count
        Discrete.DiscType.

Import ListNotations.

(** test case *)

Example test_count_bool : count [true ; false] true = 1.
Proof.
  reflexivity.
Qed.


Require Export XR_Rlt_0_1.

Local Open Scope R_scope.

Lemma Rle_0_1 : R0 <= R1.
Proof.
  unfold "<=".
  left.
  exact Rlt_0_1.
Qed.


Require Import Coq.Vectors.Vector.
Require Import IList.
Require Import IList2.

Generalizable All Variables.

(** This code is borrowed from the Fiat code base. *)

Section i2list.

  (* Lists of elements whose types depend on an indexing set (CPDT's hlists).
     These lists are a convenient way to implement finite maps
     whose elements depend on their keys. The data structures used
     by our ADT notations uses these to implement notation-friendly
     method lookups.  *)

  Import Vectors.VectorDef.VectorNotations.

  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The type of indexed elements. *)
  Variable C : forall a, B a ->  Type. (* The type of doubly-indexed elements. *)

  Fixpoint i2list {n}
           {l : Vector.t A n}
    : ilist2 (B := B) l -> Type :=
    match l return ilist2 (B := B) l -> Type with
    | [] => fun _ => unit
    | a :: l' => fun il => @prim_prod (C _ (ilist2_hd il))
                                      (i2list (ilist2_tl il))
    end.

  Definition i2cons
             {a : A}
             {n}
             {l : Vector.t A n}
             {b : B a}
             {il : ilist2 l}
             (c : C _ b)
             (il2 : i2list il)
  : i2list (icons2 _ b il)
    := {| prim_fst := c; prim_snd := il2 |}.

  Definition i2nil : i2list inil2 := tt.

  (* Get the car of an i2list. *)
  Definition i2list_hd {n}
             (As : Vector.t A n)
             (Bs : ilist2 As)
             (i2l : i2list Bs) :
    match As return forall Bs : ilist2 As, i2list Bs -> Type with
    | a :: As' => fun Bs i2l => C _ (ilist2_hd Bs)
      | [] => fun _ _ => unit
    end Bs i2l :=
    match As as As' return
          forall Bs i2l,
          match As' return forall Bs : ilist2 As', i2list Bs -> Type with
          | a :: As' => fun Bs i2l => C _ (ilist2_hd Bs)
          | [] => fun _ _ => unit
          end Bs i2l with
    | [] => fun _ _ => tt
    | a :: As' => fun Bs il => prim_fst _ _ il
    end Bs i2l.

  (* Get the cdr of an i2list. *)
  Definition i2list_tl {n}
             (As : Vector.t A n)
             (Bs : ilist2 As)
             (i2l : i2list Bs) :
    match As return forall Bs : ilist2 As, i2list Bs -> Type with
    | a :: As' => fun Bs i2l => i2list (ilist2_tl Bs)
    | [] => fun _ _ => unit
    end Bs i2l :=
    match As as As' return
          forall Bs i2l,
          match As' return forall Bs : ilist2 As', i2list Bs -> Type with
          | a :: As' => fun Bs i2l => i2list (ilist2_tl Bs)
          | [] => fun _ _ => unit
          end Bs i2l with
    | [] => fun _ _ => tt
    | a :: As' => fun Bs il => prim_snd _ _ il
    end Bs i2l.

  Fixpoint i2th
           {m : nat}
           {As : Vector.t A m}
           {Bs : ilist2 As}
           (i2l : i2list Bs)
           (n : Fin.t m)
           {struct n}
    : C _ (ith2 Bs n) :=
    match n in Fin.t m return
          forall (As : Vector.t A m)
                 (Bs : ilist2 As),
            i2list Bs
            -> C _ (ith2 Bs n) with
    | Fin.F1 =>
      fun As Bs i2l =>
        Vector.caseS (fun n As =>
                        forall (Bs : ilist2 As), i2list Bs
                                   -> C _ (ith2 Bs (@Fin.F1 n)))
                     (fun a' n' As' (Bs' : ilist2 (a' :: As')) i2l' => prim_fst _ _ i2l' ) As Bs i2l
    | Fin.FS n'' =>
      fun As Bs i2l =>
        Vector_caseS' Fin.t
                      (fun n' As i =>
                        forall (Bs'' : ilist2 As),
                          i2list Bs''
                          -> C _ (ith2 Bs'' (@Fin.FS n' i)))
                     (fun a' n' As' n'' (Bs' : ilist2 (a' :: As')) i2l' => i2th (prim_snd _ _ i2l') n'')
                     As n'' Bs i2l
    end As Bs i2l.

End i2list.

Arguments i2cons [_ _ _ _ _ _ _ _] _ _.
Arguments i2nil [_ _].
Arguments i2th [_ _ _ _ _ _] _ _.

Section i2list_replace.

  (* Replacing an element of an indexed list. *)
  Variable A : Type. (* The indexing type. *)
  Variable B : A -> Type. (* The two types of indexed elements. *)
  Variable C : forall a, B a -> Type. (* The type of doubly-indexed elements. *)

  Import Vectors.VectorDef.VectorNotations.

  Fixpoint replace2_Index2
          {m : nat}
          {As : Vector.t A m}
          {Bs : ilist2 As}
          (i2l : i2list C Bs)
          (n : Fin.t m)
          (new_c : C _ (ith2 Bs n))
    : i2list C Bs :=
        match n in Fin.t m return
          forall (As : Vector.t A m)
                 (Bs : ilist2 As),
            i2list C Bs
            -> C _ (ith2 Bs n)
            -> i2list C Bs with
        | Fin.F1 =>
          fun As Bs i2l new_c =>
            Vector.caseS (fun n As =>
                            forall (Bs : ilist2 As), i2list C Bs
                                                     -> C _ (ith2 Bs (@Fin.F1 n))
                                                     -> i2list C Bs)
                         (fun a' n' As' (Bs' : ilist2 (a' :: As')) i2l' new_c => i2cons new_c (prim_snd _ _ i2l') ) As Bs i2l new_c
    | Fin.FS n'' =>
      fun As Bs i2l new_c =>
        Vector.caseS (fun n' As =>
                        forall (i : Fin.t n') (Bs'' : ilist2 As),
                          i2list C Bs''
                          -> C _ (ith2 Bs'' (@Fin.FS n' i))
                          -> i2list C Bs'')
                     (fun a' n' As' n'' (Bs' : ilist2 (a' :: As')) i2l' new_c => i2cons (prim_fst _ _ i2l') (replace2_Index2 (prim_snd _ _ i2l') n'' new_c))
                     As n'' Bs i2l new_c
        end As Bs i2l new_c.

  Lemma i2th_replace_Index_neq
    : forall {m : nat}
             {As : Vector.t A m}
             {Bs : ilist2 As}
             (i2l : i2list C Bs)
             (n n' : Fin.t m)
             (new_c : C _ (ith2 Bs n)),
      n <> n'
      -> i2th (replace2_Index2 i2l n new_c) n' =
         i2th i2l n'.
  Proof.
    induction As.
    - intros; inversion n.
    - intros; revert n' As Bs i2l new_c H IHAs; pattern n, n0.
      match goal with
        |- ?P n n0 => simpl; apply (@Fin.caseS P); clear n n0; simpl in *
      end.
      + intros n n'; pattern n, n';
        match goal with
          |- ?P n n' => simpl; apply (@Fin.caseS P); clear n n'; intros; simpl in *;
                        eauto; congruence
        end.
      + intros n p n'; revert p; pattern n, n';
        match goal with
          |- ?P n n' => simpl; apply (@Fin.caseS P); clear n n'; intros; simpl in *;
                        eauto
        end.
        eapply IHAs; congruence.
  Qed.

  Lemma i2th_replace_Index_eq
    : forall {m : nat}
             {As : Vector.t A m}
             {Bs : ilist2 As}
             (i2l : i2list C Bs)
             (n : Fin.t m)
             (new_c : C _ (ith2 Bs n)),
      i2th (replace2_Index2 i2l n new_c) n = new_c.
  Proof.
    induction As.
    - intros; inversion n.
    - intros; revert As Bs i2l new_c IHAs; pattern n, n0.
      match goal with
        |- ?P n n0 => simpl; apply (@Fin.caseS P); clear n n0; simpl in *; eauto
      end.
  Qed.

  (*Program Fixpoint replace_Index2'
           (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (new_c : Dep_Option_elim_P C (ith_error Bs n))
           {struct Cs} : i2list C Bs :=
    match n return
          Dep_Option_elim_P C (ith_error Bs n)
            -> i2list C Bs with
      | 0 => match Cs in i2list _ Bs return
                   Dep_Option_elim_P C (ith_error Bs 0)
                   -> i2list C Bs with
                 | i2nil Bs =>
                   fun _ => i2nil _ Bs
                 | i2cons a As' Bs' c i2l' =>
                   fun new_c =>
                     i2cons Bs' new_c i2l'
               end
      | S n => match Cs in i2list _ Bs return
                     Dep_Option_elim_P C (ith_error Bs (S n))
                     -> i2list C Bs with
                 | i2nil Bs => fun _ => i2nil _ Bs
                 | i2cons a As' Bs' c i2l' =>
                   fun new_c =>
                     i2cons Bs' c (@replace_Index2' n As' (ilist_tl Bs') i2l' new_c)
               end
    end new_c.

  Lemma i2th_replace_Index'_neq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list C Bs)
      (n' : nat)
      (new_c : Dep_Option_elim_P C (ith_error Bs n')),
      n <> n'
      -> i2th_error' (replace_Index2' n' Cs new_c) n =
         i2th_error' Cs n.
  Proof.
    induction n; simpl; destruct Cs; intros; icons_invert;
    simpl in *; auto;
    destruct n'; simpl; try congruence.
    unfold replace_Index2.
    eapply IHn; congruence.
  Qed.

  Lemma i2th_replace_Index'_eq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list C Bs)
      (new_c : Dep_Option_elim_P C (ith_error Bs n)),
      i2th_error' (replace_Index2' n Cs new_c) n = new_c.
  Proof.
    induction n; destruct Cs; simpl; auto; intros;
    destruct new_c; eauto.
  Qed. *)

End i2list_replace.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A C U : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ O O /\ (wd_ C O /\ (col_ O E A /\ (col_ O E O /\ (col_ O E C /\ (col_ O E O /\ (col_ O E U /\ col_ O U Eprime)))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q S X Y : Universe, ((wd_ P X /\ (wd_ S X /\ (wd_ Q Y /\ (wd_ S Y /\ (wd_ Q S /\ (wd_ P S /\ (col_ P Q S /\ (col_ Q Y S /\ col_ P X S)))))))) -> col_ Q S X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import extraInv.
Local Open Scope Z.

Definition cond5 :=
ctrlState1.[of_Z timer1]<>ctrlWaiting /\ ctrlState1.[of_Z timer1]=ctrlDrying /\ hands1.[of_Z timer1]=ON /\ ctrlTimer2=0 /\
 ctrlState2=ctrlState1.[of_Z timer1 <- ctrlDrying] /\ ctrlTimer2<10.


Require Import ModelProperties.
Require Import AuxiliaryLemmas.

Section aclstatIsSecure.

Lemma AclstatPSS :
 forall (s t : SFSstate) (u : SUBJECT),
 SecureState s -> TransFunc u s Aclstat t -> SecureState t.
OpDontChangeStPSS.
Qed.

Lemma AclstatPSP :
 forall (s t : SFSstate) (u : SUBJECT),
 StarProperty s -> TransFunc u s Aclstat t -> StarProperty t.
OpDontChangeStPSP.
Qed.

Lemma AclstatPCP : forall s t : SFSstate, PreservesControlProp s Aclstat t.
intros; unfold PreservesControlProp in |- *; intros Sub TF; inversion TF;
 unfold ControlProperty in |- *.
split.
intros.
split.
intros; absurd (DACCtrlAttrHaveChanged t t o0); auto.

intro; absurd (MACObjCtrlAttrHaveChanged t t o0); auto.

intros; absurd (MACSubCtrlAttrHaveChanged t t u0); auto.

Qed.

End aclstatIsSecure.

Hint Resolve AclstatPSS AclstatPSP AclstatPCP.