(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

(*********************************************************************)
(* The basic theory of paths over an eqType; this is essentially a   *)
(* complement to seq.v.                                              *)
(* Paths are non-empty sequences that obey a progression relation.   *)
(* They are passed around in three parts : the head and tail of the  *)
(* sequence, and a (boolean) predicate asserting the progression.    *)
(* This is rarely embarrassing, as the first two are usually         *)
(* implicit parameters inferred from the predicate, and it saves the *)
(* hassle of constantly constructing and destructing a dependent     *)
(* record.                                                           *)
(*    We define similarly cycles, but in this case we allow the      *)
(* empty sequence (which is a non-rooted empty cycle; by contrast,   *)
(* the empty path from x is the one-item sequence containing only x) *)
(* We allow duplicates; uniqueness, if desired (as is the            *)
(* case for several geometric constructions), must be asserted       *)
(* separately. We do provide shorthand, but for cycles only, because *)
(* the equational properties of "path" and "uniq" are unfortunately  *)
(* incompatible (esp. wrt "cat").                                    *)
(*    We define notations for the common cases of function paths,    *)
(* where the progress relation is actually a function. We also       *)
(* define additional traversal/surgery operations, many of which     *)
(* could have been in seq.v, but are here because they only really   *)
(* are useful for sequences considered as paths :                    *)
(*  - directed surgery : splitPl, splitP, splitPr are dependent      *)
(*    predicates whose elimination splits a path x0:p at one of its  *)
(*    elements (say x). The three variants differ as follows:        *)
(*      - splitPl applies when x is in x0::p, generates two paths p1 *)
(*        and p2, along with the equation x = (last x0 p), and       *)
(*        replaces p with (p1 ++ p2) in the goal (the patterned      *)
(*        Elim can be used to select occurrences and generate an     *)
(*        equation p = (p1 ++ p2).                                   *)
(*      - splitP applies when x is in p, and replaces p with         *)
(*        (rcons p1 x ++ p2), where x appears explicitly at the end  *)
(*        of the left part.                                          *)
(*      - splitPr similarly replaces p with (p1 ++ x :: p2), where x *)
(*        appears explicitly at the right of the split, when x       *)
(*        actually occurs in p.                                      *)
(*    The parts p1 and p2 are computed using index/take/drop. The    *)
(*    splitP variant (but not the others) attempts to replace the    *)
(*    explicit expressions for p1 and p2 by p1 and p2, respectively. *)
(*    This is moderately useful, but allows for defining other       *)
(*    splitting lemmas with conclusions of the form (split x p p1 p2)*)
(*    with other expressions for p1 and p2 that might be known to    *)
(*    occur.                                                         *)
(*  - function trajectories: traject, and  looping predicates.       *)
(*  - cycle surgery : arc extracts the sub-arc between two points    *)
(*    (including the first, excluding the second). (arc p x y) is    *)
(*    thus only meaningful if x and y are different points in p.     *)
(*  - cycle traversal : next, prev                                   *)
(*  - path order: mem2 checks whether two points belong to a path    *)
(*    and appear in order (i.e., (mem2 p x y) checks that y appears  *)
(*    after an occurrence of x in p). This predicate is a crucial    *)
(*    part of the definition of the abstract Jordan property.        *)
(*  - sorting: sorted checks whether a sequence is sorted wrt a      *)
(*    transitive relation; sorted e (x :: p) expands to path e x p,  *)
(*    and sort sorts a sequence recursively, using a "merge" function*)
(*    to interleave sorted sublists.                                 *)
(*  - loop removal : shorten returns a shorter, duplicate-free path  *)
(*    with the same endpoints as its argument. The related shortenP  *)
(*    dependent predicate simultaneously substitutes a new path p',  *)
(*    for (shorten e x p), (last x p') for (last x p), and generates *)
(*    predicates asserting that p' is a duplicate-free subpath of p. *)
(* Although these functions operate on the underlying sequences, we  *)
(* provide a series of lemmas that define their interaction with the *)
(* path and cycle predicates, e.g., the path_cat equation can be     *)
(* used to split the path predicate after splitting the underlying   *)
(* sequence.                                                         *)
(*********************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section Paths.

Variables (n0 : nat) (T : Type).

Section Path.

Variables (x0_cycle : T) (e : rel T).

Fixpoint path x (p : seq T) {struct p} :=
  if p is y :: p' then e x y && path y p' else true.

Lemma path_cat : forall x p1 p2,
  path x (p1 ++ p2) = path x p1 && path (last x p1) p2.
Proof.
by move=> x p1 p2; elim: p1 x => [|y p1 Hrec] x //=; rewrite Hrec -!andbA.
Qed.

Lemma pathP : forall x p x0,
  reflect (forall i, i < size p -> e (nth x0 (x :: p) i) (nth x0 p i))
          (path x p).
Proof.
move=> x p x0; elim: p x => [|y p Hrec] x /=; first by left.
apply: (iffP andP) => [[Hxy Hp]|Hp].
  move=> [|i] Hi //; exact: Hrec _ Hp i Hi.
split; first exact: Hp 0 (leq0n (size p)).
apply/(Hrec y) => i; exact: Hp i.+1.
Qed.

Definition cycle p := if p is x :: p' then path x (rcons p' x) else true.

Lemma cycle_path : forall p, cycle p = path (last x0_cycle p) p.
Proof. by move=> [|x p] //=; rewrite -cats1 path_cat /= andbT andbC. Qed.

Lemma cycle_rot : forall p, cycle (rot n0 p) = cycle p.
Proof.
case: (n0) => [|n] [|y0 p] //=; first by rewrite /rot /= cats0.
rewrite /rot /= -{3}(cat_take_drop n p) -cats1 -catA path_cat.
case: (drop n p) => [|z0 q]; rewrite /= -cats1 !path_cat /= !andbT andbC //.
by rewrite last_cat; repeat bool_congr.
Qed.

Lemma cycle_rotr : forall p, cycle (rotr n0 p) = cycle p.
Proof. by move=> p; rewrite -cycle_rot rotrK. Qed.

End Path.

Lemma eq_path : forall e e', e =2 e' -> path e =2 path e'.
Proof.
by move=> e e' Ee x p; elim: p x => [|y p Hrec] x //=; rewrite Ee Hrec.
Qed.

Lemma sub_path : forall e e', subrel e e' ->
  forall x p, path e x p -> path e' x p.
Proof.
move=> e e' He x p; elim: p x => [|y p Hrec] x //=.
by move/andP=> [Hx Hp]; rewrite (He _ _ Hx) (Hrec _ Hp).
Qed.

End Paths.

Implicit Arguments pathP [T e x p].
Prenex Implicits pathP.

Section EqPath.

Variables (n0 : nat) (T : eqType) (x0_cycle : T) (e : rel T).

CoInductive split x : seq T -> seq T -> seq T -> Type :=
  Split p1 p2 : split x (rcons p1 x ++ p2) p1 p2.

Lemma splitP : forall (p : seq T) x, x \in p ->
   let i := index x p in split x p (take i p) (drop i.+1 p).
Proof.
move=> p x Hx i; have := esym (cat_take_drop i p).
have Hi := Hx; rewrite -index_mem -/i in Hi; rewrite (drop_nth x Hi).
by rewrite -cat_rcons {2}/i (nth_index x Hx) => Dp; rewrite {1}Dp.
Qed.

CoInductive splitl (x1 x : T) : seq T -> Type :=
  Splitl p1 p2 of last x1 p1 = x : splitl x1 x (p1 ++ p2).

Lemma splitPl : forall x1 p x, x \in x1 :: p -> splitl x1 x p.
Proof.
move=> x1 p x; rewrite in_cons.
case: eqP => [->| _]; first by rewrite -(cat0s p).
case/splitP; split; exact: last_rcons.
Qed.

CoInductive splitr x : seq T -> Type :=
  Splitr p1 p2 : splitr x (p1 ++ x :: p2).

Lemma splitPr : forall (p : seq T) x, x \in p -> splitr x p.
Proof. by move=> p x; case/splitP=> p1 p2; rewrite cat_rcons. Qed.

Fixpoint next_at (x y0 y : T) (p : seq T) {struct p} :=
  match p with
  | [::] => if x == y then y0 else x
  | y' :: p' => if x == y then y' else next_at x y0 y' p'
  end.

Definition next p x := if p is y :: p' then next_at x y y p' else x.

Fixpoint prev_at (x y0 y : T) (p : seq T) {struct p} :=
  match p with
  | [::]     => if x == y0 then y else x
  | y' :: p' => if x == y' then y else prev_at x y0 y' p'
  end.

Definition prev p x := if p is y :: p' then prev_at x y y p' else x.

Lemma next_nth : forall p x,
  next p x = if x \in p then
               if p is y :: p' then nth y p' (index x p) else x
             else x.
Proof.
move=> [|y0 p] x //=; elim: p {2 3 5}y0 => [|y' p Hrec] y /=;
  by rewrite (eq_sym y) in_cons; case (x == y); try exact: Hrec.
Qed.

Lemma prev_nth : forall p x,
  prev p x = if x \in p then
               if p is y :: p' then nth y p (index x p') else x
             else x.
Proof.
move=> [|y0 p] x //=; rewrite in_cons orbC.
elim: p {2 5}y0 => [|y' p Hrec] y; rewrite /= ?in_cons // (eq_sym y').
by case (x == y') => /=; auto.
Qed.

Lemma mem_next : forall (p : seq T) x, (next p x \in p) = (x \in p).
Proof.
move=> p x; rewrite next_nth; case Hpx: (x \in p) => //.
case: p (index x p) Hpx => [|y0 p'] //= i _; rewrite in_cons.
case: (ltnP i (size p')) => Hi; first by rewrite /= (mem_nth y0 Hi) orbT.
by rewrite (nth_default y0 Hi) eqxx.
Qed.

Lemma mem_prev : forall (p : seq T) x, (prev p x \in p) = (x \in p).
Proof.
move=> p x; rewrite prev_nth; case Hpx: (x \in p) => //.
case: p Hpx => [|y0 p'] Hpx //.
by apply mem_nth; rewrite /= ltnS index_size.
Qed.

(* ucycleb is the boolean predicate, but ucycle is defined as a Prop *)
(* so that it can be used as a coercion target. *)
Definition ucycleb p := cycle e p && uniq p.
Definition ucycle p : Prop := cycle e p && uniq p.

(* Projections, used for creating local lemmas. *)
Lemma ucycle_cycle : forall p, ucycle p -> cycle e p.
Proof. by move=> p; case/andP. Qed.

Lemma ucycle_uniq : forall p, ucycle p -> uniq p.
Proof. by move=> p; case/andP. Qed.

Lemma next_cycle : forall p x, cycle e p -> x \in p -> e x (next p x).
Proof.
move=> [|y0 p] //= x.
elim: p {1 3 5}y0 => [|y' p Hrec] y /=; rewrite in_cons.
  by rewrite andbT orbF => Hy Dy; rewrite Dy (eqP Dy).
move/andP=> [Hy Hp]; case: (x =P y) => [->|_] //; exact: Hrec.
Qed.

Lemma prev_cycle : forall p x, cycle e p -> x \in p -> e (prev p x) x.
Proof.
move=> [|y0 p] //= x; rewrite in_cons orbC.
elim: p {1 5}y0 => [|y' p Hrec] y /=; rewrite ?in_cons.
  by rewrite andbT=> Hy Dy; rewrite Dy (eqP Dy).
move/andP=> [Hy Hp]; case: (x =P y') => [->|_] //; exact: Hrec.
Qed.

Lemma ucycle_rot : forall p, ucycle (rot n0 p) = ucycle p.
Proof. by move=> *; rewrite /ucycle rot_uniq cycle_rot. Qed.

Lemma ucycle_rotr : forall p, ucycle (rotr n0 p) = ucycle p.
Proof. by move=> *; rewrite /ucycle rotr_uniq cycle_rotr. Qed.

(* The "appears no later" partial preorder defined by a path. *)

Definition mem2 (p : seq T) x y := y \in drop (index x p) p.

Lemma mem2l : forall p x y, mem2 p x y -> x \in p.
Proof.
move=> p x y; rewrite /mem2 -!index_mem size_drop; move=> Hxy.
by rewrite -subn_gt0 -(ltn_predK Hxy) ltnS leq0n.
Qed.

Lemma mem2lf : forall (p : seq T) x,
  (x \in p) = false -> forall y, mem2 p x y = false.
Proof. move=> p x Hx y; apply/idP => Hp; case/idP: Hx; apply: mem2l Hp. Qed.

Lemma mem2r : forall p x y, mem2 p x y -> y \in p.
Proof.
rewrite /mem2; move=> p x y Hxy.
by rewrite -(cat_take_drop (index x p) p) mem_cat Hxy orbT.
Qed.

Lemma mem2rf : forall (p : seq T) y,
  (y \in p) = false -> forall x, mem2 p x y = false.
Proof. move=> p y Hy x; apply/idP => [Hp]; case/idP: Hy; apply: mem2r Hp. Qed.

Lemma mem2_cat : forall p1 p2 x y,
  mem2 (p1 ++ p2) x y = mem2 p1 x y || mem2 p2 x y || (x \in p1) && (y \in p2).
Proof.
move=> p1 p2 x y; rewrite {1}/mem2 index_cat drop_cat; case Hp1x: (x \in p1).
  rewrite index_mem Hp1x mem_cat /= -orbA.
  by case Hp2: (y \in p2); [ rewrite !orbT // | rewrite (mem2rf Hp2) ].
by rewrite ltnNge leq_addr /= orbF addKn (mem2lf Hp1x).
Qed.

Lemma mem2_splice : forall p1 p3 x y p2,
  mem2 (p1 ++ p3) x y -> mem2 (p1 ++ p2 ++ p3) x y.
Proof.
move=> p1 p3 x y p2 Hxy; move: Hxy; rewrite !mem2_cat mem_cat.
case: (mem2 p1 x y) (mem2 p3 x y) => [|] // [|] /=; first by rewrite orbT.
by case: (x \in p1) => [|] //= Hy; rewrite Hy !orbT.
Qed.

Lemma mem2_splice1 : forall p1 p3 x y z,
  mem2 (p1 ++ p3) x y -> mem2 (p1 ++ z :: p3) x y.
Proof. move=> p1 p3 x y z; exact: (mem2_splice [::z]). Qed.

Lemma mem2_cons : forall x p y,
  mem2 (x :: p) y =1 if x == y then predU1 x (mem p) : pred T else mem2 p y.
Proof. by move=> x p y z; rewrite {1}/mem2 /=; case (x == y). Qed.

Lemma mem2_last : forall y0 p x,
  mem2 (y0 :: p) x (last y0 p) = (x \in y0 :: p).
Proof.
move=> y0 p x; apply/idP/idP; first by apply mem2l.
rewrite -index_mem /mem2; move: (index x _) => i Hi.
by rewrite lastI drop_rcons ?size_belast // mem_rcons mem_head.
Qed.

Lemma mem2l_cat : forall (p1 : seq T) x, (x \in p1) = false ->
  forall p2, mem2 (p1 ++ p2) x =1 mem2 p2 x.
Proof. by move=> p1 x Hx p2 y; rewrite mem2_cat (Hx) (mem2lf Hx) /= orbF. Qed.

Lemma mem2r_cat : forall (p2 : seq T) y, (y \in p2) = false ->
   forall p1 x, mem2 (p1 ++ p2) x y = mem2 p1 x y.
Proof.
by move=> p2 y Hy p1 x; rewrite mem2_cat (Hy) (mem2rf Hy) andbF !orbF.
Qed.

Lemma mem2lr_splice : forall (p2 : seq T) x y,
    (x \in p2) = false -> (y \in p2) = false ->
  forall p1 p3, mem2 (p1 ++ p2 ++ p3) x y = mem2 (p1 ++ p3) x y.
Proof.
move=> p2 x y Hx Hy p1 p3.
by rewrite catA !mem2_cat !mem_cat Hx Hy (mem2lf Hx) !andbF !orbF.
Qed.

CoInductive split2r (x y : T) : seq T -> Type :=
  Split2r p1 p2 of y \in x :: p2 : split2r x y (p1 ++ x :: p2).

Lemma splitP2r : forall p x y, mem2 p x y -> split2r x y p.
Proof.
move=> p x y Hxy; have Hx := mem2l Hxy.
have Hi := Hx; rewrite -index_mem in Hi.
move: Hxy; rewrite /mem2 (drop_nth x Hi) (nth_index x Hx).
by case (splitP Hx); move=> p1 p2; rewrite cat_rcons; split.
Qed.

Fixpoint shorten x (p : seq T) {struct p} :=
  if p is y :: p' then
    if x \in p then shorten x p' else y :: shorten y p'
  else [::].

CoInductive shorten_spec (x : T) (p : seq T) : T -> seq T -> Type :=
   ShortenSpec p' of path e x p' & uniq (x :: p') & subpred (mem p') (mem p) :
     shorten_spec x p (last x p') p'.

Lemma shortenP : forall x p, path e x p ->
   shorten_spec x p (last x p) (shorten x p).
Proof.
move=> x p Hp; have: x \in x :: p by exact: mem_head.
elim: p x {1 3 5}x Hp => [|y2 p Hrec] x y1.
  by rewrite mem_seq1 => _; move/eqP->; split.
rewrite in_cons orbC /=; case/andP=> Hy12 Hp.
case: ifP => y2p_x.
  case: (Hrec _ _ Hp y2p_x) => p' Hp' Up' Hp'p _.
  by split=> // y; move/Hp'p; exact: predU1r.
case: (Hrec y2 _ Hp) => /= [|p' Hp' Up' Hp'p]; first by rewrite mem_head.
have{Hp'p} Hp'p: subpred (mem (y2 :: p')) (mem (y2 :: p)).
  by move=> z; rewrite /= !in_cons; case: (z == y2); last exact: Hp'p.
rewrite y2p_x -(last_cons x); move/eqP=> xy1.
split=> //=; first by rewrite xy1 Hy12.
by rewrite {}Up' andbT; apply/negP; move/Hp'p; case/negPf.
Qed.

End EqPath.

(* Ordered paths and sorting. *)

Section SortSeq.

Variable T : eqType.
Variable leT : rel T.

Definition sorted s := if s is x :: s' then path leT x s' else true.

Lemma path_sorted : forall x s, path leT x s -> sorted s.
Proof. by move=> x [|y s] //=; case/andP. Qed.

Section Transitive.

Hypothesis leT_tr : transitive leT.

Lemma order_path_min : forall x s, path leT x s -> all (leT x) s.
Proof.
move=> x [|y s] //=; case/andP=> le_xy; rewrite le_xy /=.
elim: s => //= z s IHs in y le_xy *; case/andP.
move/(leT_tr le_xy)=> le_xz; rewrite le_xz; exact: IHs.
Qed.

Lemma sorted_filter : forall a s, sorted s -> sorted (filter a s).
Proof.
move=> a s; elim: s => //= x s IHs ord_s.
move/(_ (path_sorted ord_s)): IHs; case: (a x) => //=.
case def_s': (filter a s) => //= [y s'] ->.
rewrite (allP (order_path_min ord_s)) //.
have: y \in filter a s by rewrite def_s' mem_head.
by rewrite mem_filter; case/andP.
Qed.

Lemma sorted_uniq : irreflexive leT -> forall s, sorted s -> uniq s.
Proof.
move=> leT_irr; elim=> //= x s IHs s_ord.
rewrite (IHs (path_sorted s_ord)) andbT; apply/negP=> s_x.
by case/allPn: (order_path_min s_ord); exists x; rewrite // leT_irr.
Qed.

Lemma eq_sorted : antisymmetric leT -> forall s1 s2,
   sorted s1 -> sorted s2 -> perm_eq s1 s2 -> s1 = s2.
Proof.
move=> leT_asym; elim=> [|x1 s1 IHs1] s2 //= ord_s1 ord_s2 eq_s12.
  by case: {+}s2 (perm_eq_size eq_s12).
have s2_x1: x1 \in s2 by rewrite -(perm_eq_mem eq_s12) mem_head.
case: s2 s2_x1 eq_s12 ord_s2 => //= x2 s2; rewrite in_cons.
case: eqP => [<- _| ne_x12 /= s2_x1] eq_s12 ord_s2.
  by rewrite {IHs1}(IHs1 s2) ?(@path_sorted x1) // -(perm_cons x1).
case: (ne_x12); apply: leT_asym; rewrite (allP (order_path_min ord_s2)) //.
have: x2 \in x1 :: s1 by rewrite (perm_eq_mem eq_s12) mem_head.
case/predU1P=> [eq_x12 | s1_x2]; first by case ne_x12.
by rewrite (allP (order_path_min ord_s1)).
Qed.

Lemma eq_sorted_irr : irreflexive leT -> forall s1 s2,
  sorted s1 -> sorted s2 -> s1 =i s2 -> s1 = s2.
Proof.
move=> leT_irr s1 s2 s1_sort s2_sort eq_s12.
have: antisymmetric leT.
  move=> m n; case/andP=> ? ltnm; case/idP: (leT_irr m); exact: leT_tr ltnm.
move/eq_sorted; apply=> //; apply: uniq_perm_eq => //; exact: sorted_uniq.
Qed.

End Transitive.

Hypothesis leT_total : total leT.

Fixpoint merge s1 :=
  if s1 is x1 :: s1' then
    let fix merge_s1 (s2 : seq T) :=
      if s2 is x2 :: s2' then
        if leT x2 x1 then x2 :: merge_s1 s2' else x1 :: merge s1' s2
      else s1 in
    merge_s1
  else id.

Lemma path_merge : forall x s1 s2,
  path leT x s1 -> path leT x s2 -> path leT x (merge s1 s2).
Proof.
move=> x s1 s2; elim: s1 s2 x => //= x1 s1 IHs1; elim=> //= x2 s2 IHs2 x.
case/andP=> le_x_x1 ord_s1; case/andP=> le_x_x2 ord_s2.
case: ifP => le_x21 /=; first by rewrite le_x_x2 {}IHs2 // le_x21.
by rewrite le_x_x1 IHs1 //=; have:= leT_total x2 x1; rewrite le_x21 /= => ->.
Qed.

Lemma sorted_merge : forall s1 s2,
  sorted s1 -> sorted s2 -> sorted (merge s1 s2).
Proof.
move=> [|x1 s1] [|x2 s2] //= ord_s1 ord_s2.
case: ifP => le_x21 /=.
  by apply: (@path_merge x2 (x1 :: s1)) => //=; rewrite le_x21.
by apply: path_merge => //=; have:= leT_total x2 x1; rewrite le_x21 /= => ->.
Qed.

Lemma perm_merge : forall s1 s2, perm_eql (merge s1 s2) (s1 ++ s2).
Proof.
move=> s1 s2; apply/perm_eqlP; rewrite perm_eq_sym.
elim: s1 s2 => //= x1 s1 IHs1.
elim=> [|x2 s2 IHs2]; rewrite /= ?cats0 //.
case: ifP => _ /=; last by rewrite perm_cons.
by rewrite (perm_catCA (_ :: _) [::x2]) perm_cons.
Qed.

Lemma mem_merge : forall s1 s2, merge s1 s2 =i s1 ++ s2.
Proof. by move=> s1 s2; apply: perm_eq_mem; rewrite perm_merge. Qed.

Lemma size_merge : forall s1 s2, size (merge s1 s2) = size (s1 ++ s2).
Proof. by move=> s1 s2; apply: perm_eq_size; rewrite perm_merge. Qed.

Lemma merge_uniq : forall s1 s2, uniq (merge s1 s2) = uniq (s1 ++ s2).
Proof. by move=> s1 s2; apply: perm_eq_uniq; rewrite perm_merge. Qed.

Fixpoint merge_sort_push (s1 : seq T) (ss : seq (seq T)) {struct ss} :=
  match ss with
  | [::] :: ss' | [::] as ss' => s1 :: ss'
  | s2 :: ss' => [::] :: merge_sort_push (merge s1 s2) ss'
  end.

Fixpoint merge_sort_pop (s1 : seq T) (ss : seq (seq T)) {struct ss} :=
  if ss is s2 :: ss' then merge_sort_pop (merge s1 s2) ss' else s1.

Fixpoint merge_sort_rec (ss : seq (seq T)) (s : seq T) {struct s} :=
  if s is [:: x1, x2 & s'] then
    let s1 := if leT x1 x2 then [:: x1; x2] else [:: x2; x1] in
    merge_sort_rec (merge_sort_push s1 ss) s'
  else merge_sort_pop s ss.

Definition sort := merge_sort_rec [::].

Lemma sorted_sort : forall s, sorted (sort s).
Proof.
rewrite /sort => s; have allss: all sorted [::] by [].
elim: {s}_.+1 {-2}s [::] allss (ltnSn (size s)) => // n IHn s ss allss.
have: sorted s -> sorted (merge_sort_pop s ss).
  elim: ss allss s => //= s2 ss IHss.
  by case/andP=> *; exact: IHss (sorted_merge _ _).
case: s => [|x1 [|x2 s _]]; try by auto.
move/ltnW; move/IHn; apply; rewrite {n IHn s} ifE; set s1 := if_expr _ _ _.
have: sorted s1 by exact: (@sorted_merge [::x2] [::x1]).
elim: ss {x1 x2}s1 allss => /= [|s2 ss IHss] s1; first by rewrite andbT.
case/andP=> ord_s2 ord_ss ord_s1.
by case: {1}s2=> /= [|_ _]; [rewrite ord_s1 | exact: IHss (sorted_merge _ _)].
Qed.

Lemma perm_sort : forall s, perm_eql (sort s) s.
Proof.
rewrite /sort => s; apply/perm_eqlP; pose catss := foldr (@cat T) [::].
rewrite perm_eq_sym -{1}[s]/(catss [::] ++ s).
elim: {s}_.+1 {-2}s [::] (ltnSn (size s)) => // n IHn s ss.
have: perm_eq (catss ss ++ s) (merge_sort_pop s ss).
  elim: ss s => //= s2 ss IHss s1; rewrite -{IHss}(perm_eqrP (IHss _)).
  by rewrite perm_catC catA perm_catC perm_cat2l -perm_merge.
case: s => // x1 [//|x2 s _]; move/ltnW; move/IHn=> {n IHn}IHs.
rewrite -{IHs}(perm_eqrP (IHs _)) ifE; set s1 := if_expr _ _ _.
rewrite (catA _ [::_;_] s) {s}perm_cat2r.
apply: (@perm_eq_trans _ (catss ss ++ s1)).
  by rewrite perm_cat2l /s1 -ifE; case ifP; rewrite // (perm_catC [::_]).
elim: ss {x1 x2}s1 => /= [|s2 ss IHss] s1; first by rewrite cats0.
rewrite perm_catC; case def_s2: {2}s2=> /= [|y s2']; first by rewrite def_s2.
by rewrite catA -{IHss}(perm_eqrP (IHss _)) perm_catC perm_cat2l -perm_merge.
Qed.

Lemma mem_sort : forall s, sort s =i s.
Proof. by move=> s; apply: perm_eq_mem; rewrite perm_sort. Qed.

Lemma size_sort : forall s, size (sort s) = size s.
Proof. by move=> s; apply: perm_eq_size; rewrite perm_sort. Qed.

Lemma sort_uniq : forall s, uniq (sort s) = uniq s.
Proof. by move=> s; apply: perm_eq_uniq; rewrite perm_sort. Qed.

Lemma perm_sortP : transitive leT -> antisymmetric leT ->
  forall s1 s2, reflect (sort s1 = sort s2) (perm_eq s1 s2).
Proof.
move=> leT_tr leT_asym s1 s2; apply: (iffP idP) => eq12; last first.
  by rewrite -perm_sort eq12 perm_sort.
apply: eq_sorted; rewrite ?sorted_sort //.
by rewrite perm_sort (perm_eqlP eq12) -perm_sort.
Qed.

End SortSeq.

Lemma sorted_ltn_uniq_leq : forall s, sorted ltn s = uniq s && sorted leq s.
Proof.
case=> //= n s; elim: s n => //= m s IHs n.
rewrite inE ltn_neqAle negb_or IHs -!andbA.
case sn: (n \in s); last do !bool_congr.
rewrite andbF; apply/and5P=> [[ne_nm lenm _ _ le_ms]]; case/negP: ne_nm.
rewrite eqn_leq lenm; exact: (allP (order_path_min leq_trans le_ms)).
Qed.

Lemma sorted_iota : forall i n, sorted leq (iota i n).
Proof. by move=> i n; elim: n i => // [[|n] //= IHn] i; rewrite IHn leqW. Qed.

Lemma sorted_ltn_iota : forall i n, sorted ltn (iota i n).
Proof. by move=> i n; rewrite sorted_ltn_uniq_leq sorted_iota iota_uniq. Qed.

(* Function trajectories. *)

Notation "'fpath' f" := (path (frel f))
  (at level 10, f at level 8) : seq_scope.

Notation "'fcycle' f" := (cycle (frel f))
  (at level 10, f at level 8) : seq_scope.

Notation "'ufcycle' f" := (ucycle (frel f))
  (at level 10, f at level 8) : seq_scope.

Prenex Implicits path next prev cycle ucycle mem2.

Section Trajectory.

Variables (T : Type) (f : T -> T).

Fixpoint traject x (n : nat) {struct n} :=
  if n is n'.+1 then x :: traject (f x) n' else [::].

Lemma size_traject : forall x n, size (traject x n) = n.
Proof. by move=> x n; elim: n x => [|n Hrec] x //=; nat_congr. Qed.

Lemma last_traject : forall x n, last x (traject (f x) n) = iter n f x.
Proof. by move=> x n; elim: n x => [|n Hrec] x //; rewrite iterSr -Hrec. Qed.

Lemma nth_traject : forall i n, i < n ->
  forall x, nth x (traject x n) i = iter i f x.
Proof.
move=> i n Hi x; elim: n {2 3}x i Hi => [|n Hrec] y [|i] Hi //=.
by rewrite Hrec -?iterSr.
Qed.

End Trajectory.

Section EqTrajectory.

Variables (T : eqType) (f : T -> T).

Lemma fpathP : forall x p,
  reflect (exists n, p = traject f (f x) n) (fpath f x p).
Proof.
move=> x p; elim: p x => [|y p Hrec] x; first by left; exists 0.
rewrite /= andbC; case: {Hrec}(Hrec y) => Hrec.
  apply: (iffP eqP); first by case: Hrec => [n ->] <-; exists n.+1.
  by case=> [] [|n] // [Dp].
by right; move=> [[|n] // [Dy Dp]]; case: Hrec; exists n; rewrite Dy -Dp.
Qed.

Lemma fpath_traject : forall x n, fpath f x (traject f (f x) n).
Proof. by move=> x n; apply/(fpathP x); exists n. Qed.

Definition looping x n := iter n f x \in traject f x n.

Lemma loopingP : forall x n,
  reflect (forall m, iter m f x \in traject f x n) (looping x n).
Proof.
move=> x n; apply introP; last by move=> Hn Hn'; rewrite /looping Hn' in Hn.
case: n => [|n] Hn //; elim=> [|m Hrec]; first by exact: predU1l.
move: (fpath_traject x n) Hn; rewrite /looping !iterS -last_traject /=.
rewrite /= in Hrec; case/splitPl: Hrec; move: (iter m f x) => y p1 p2 Ep1.
rewrite path_cat last_cat Ep1; case: p2 => [|z p2] //; case/and3P=> [_ Dy _] _.
by rewrite !(in_cons, mem_cat) (eqP Dy) eqxx !orbT.
Qed.

Lemma trajectP : forall x n y,
  reflect (exists2 i, i < n & y = iter i f x) (y \in traject f x n).
Proof.
move=> x n y; elim: n x => [|n Hrec] x; first by right; case.
  rewrite /= in_cons orbC; case: {Hrec}(Hrec (f x)) => Hrec.
  by left; case: Hrec => [i Hi ->]; exists i.+1; last by rewrite -iterSr.
apply: (iffP eqP); first by exists 0; first by rewrite ltnNge.
by move=> [[|i] Hi Dy] //; case Hrec; exists i; last by rewrite -iterSr.
Qed.

Lemma looping_uniq : forall x n, uniq (traject f x n.+1) = ~~ looping x n.
Proof.
move=> x n; rewrite /looping; elim: n x => [|n Hrec] x //.
rewrite iterSr {2}[succn]lock /= -lock {}Hrec -negb_or in_cons; bool_congr.
set y := iter n f (f x); case (trajectP (f x) n y); first by rewrite !orbT.
rewrite !orbF => Hy; apply/idP/eqP => [Hx|Dy]; last first.
  by rewrite -{1}Dy /y -last_traject mem_last.
case: {Hx}(trajectP _ n.+1 _ Hx) => [m Hm Dx].
have Hx': looping x m.+1 by rewrite /looping iterSr -Dx mem_head.
case/trajectP: (loopingP _ _ Hx' n.+1); rewrite iterSr -/y.
move=> [|i] Hi //; rewrite iterSr => Dy.
by case: Hy; exists i; first exact (leq_trans Hi Hm).
Qed.

End EqTrajectory.

Implicit Arguments fpathP [T f x p].
Implicit Arguments loopingP [T f x n].
Implicit Arguments trajectP [T f x n y].
Prenex Implicits traject fpathP loopingP trajectP.

Section UniqCycle.

Variables (n0 : nat) (T : eqType) (e : rel T) (p : seq T).

Hypothesis Up : uniq p.

Lemma prev_next : cancel (next p) (prev p).
Proof.
move=> x; rewrite prev_nth mem_next next_nth.
case Hpx: (x \in p) => [|] //; case Dp: p Up Hpx => [|y p'] //.
rewrite -(Dp) {1}Dp /=; move/andP=> [Hpy Hp'] Hx.
set i := index x p; rewrite -(nth_index y Hx) -/i; congr (nth y).
rewrite -index_mem -/i Dp /= ltnS leq_eqVlt in Hx.
case/predU1P: Hx => [Di|Hi]; last by apply: index_uniq.
rewrite Di (nth_default y (leqnn _)).
rewrite -index_mem -leqNgt in Hpy.
by apply: eqP; rewrite eqn_leq Hpy /index find_size.
Qed.

Lemma next_prev : cancel (prev p) (next p).
Proof.
move=> x; rewrite next_nth mem_prev prev_nth.
case Hpx: (x \in p) => [|] //; case Dp: p Up Hpx => [|y p'] //.
rewrite -Dp => Hp Hpx; set i := index x p'.
have Hi: i < size p by rewrite Dp /= ltnS /i /index find_size.
rewrite (index_uniq y Hi Hp); case Hx: (x \in p'); first by apply: nth_index.
rewrite Dp in_cons Hx orbF in Hpx; rewrite (eqP Hpx).
by apply: nth_default; rewrite leqNgt /i index_mem Hx.
Qed.

Lemma cycle_next : fcycle (next p) p.
Proof.
case Dp: {-2}p Up => [|x p'] Up' //; apply/(pathP x)=> i; rewrite size_rcons => Hi.
rewrite -cats1 -cat_cons nth_cat Hi /= next_nth {}Dp mem_nth //.
rewrite index_uniq // nth_cat /=; rewrite ltnS leq_eqVlt in Hi.
case/predU1P: Hi => [Di|Hi]; last by rewrite Hi eqxx.
by rewrite Di ltnn subnn nth_default ?leqnn /= ?eqxx.
Qed.

Lemma cycle_prev : cycle (fun x y => x == prev p y) p.
Proof.
apply: etrans cycle_next; symmetry; case Dp: p => [|x p'] //.
apply: eq_path; rewrite -Dp; exact (can2_eq prev_next next_prev).
Qed.

Lemma cycle_from_next : (forall x, x \in p -> e x (next p x)) -> cycle e p.
Proof.
move=> He; case Dp: p cycle_next => [|x p'] //; rewrite -Dp !(cycle_path x).
have Hx: last x p \in p by rewrite Dp /= mem_last.
move: (next p) He {Hx}(He _ Hx) => np.
elim: (p) {x p' Dp}(last x p) => [|y p' Hrec] x He Hx //=.
case/andP=> [Dy Hp']; rewrite -{1}(eqP Dy) Hx /=.
apply: Hrec Hp' => [z Hz|]; apply: He; [exact: predU1r | exact: predU1l].
Qed.

Lemma cycle_from_prev : (forall x, x \in p -> e (prev p x) x) -> cycle e p.
Proof.
move=> He; apply: cycle_from_next => [x Hx].
by rewrite -{1}[x]prev_next He ?mem_next.
Qed.

Lemma next_rot : next (rot n0 p) =1 next p.
Proof.
move=> x; have Hp := cycle_next; rewrite -(cycle_rot n0) in Hp.
case Hx: (x \in p); last by rewrite !next_nth mem_rot Hx.
rewrite -(mem_rot n0) in Hx; exact (esym (eqP (next_cycle Hp Hx))).
Qed.

Lemma prev_rot : prev (rot n0 p) =1 prev p.
Proof.
move=> x; have Hp := cycle_prev; rewrite -(cycle_rot n0) in Hp.
case Hx: (x \in p); last by rewrite !prev_nth mem_rot Hx.
rewrite -(mem_rot n0) in Hx; exact (eqP (prev_cycle Hp Hx)).
Qed.

End UniqCycle.

Section UniqRotrCycle.

Variables (n0 : nat) (T : eqType) (p : seq T).

Hypothesis Up : uniq p.

Lemma next_rotr : next (rotr n0 p) =1 next p. Proof. exact: next_rot. Qed.

Lemma prev_rotr : prev (rotr n0 p) =1 prev p. Proof. exact: prev_rot. Qed.

End UniqRotrCycle.

Section UniqCycleRev.

Variable T : eqType.

Lemma prev_rev : forall p : seq T, uniq p -> prev (rev p) =1 next p.
Proof.
move=> p Up x; case Hx: (x \in p); last first.
  by rewrite next_nth prev_nth mem_rev Hx.
case/rot_to: Hx (Up) => [i p' Dp] Urp; rewrite -rev_uniq in Urp.
rewrite -(prev_rotr i Urp); do 2 rewrite -(prev_rotr 1) ?rotr_uniq //.
rewrite -rev_rot -(next_rot i Up) {i p Up Urp}Dp.
case: p' => [|y p'] //; rewrite !rev_cons rotr1_rcons /= eqxx.
by rewrite -rcons_cons rotr1_rcons /= eqxx.
Qed.

Lemma next_rev : forall p : seq T, uniq p -> next (rev p) =1 prev p.
Proof. by move=> p Up x; rewrite -{2}[p]revK prev_rev // rev_uniq. Qed.

End UniqCycleRev.

Section MapPath.

Variables (T T' : Type) (h : T' -> T) (e : rel T) (e' : rel T').

Definition rel_base (b : pred T) :=
  forall x' y', ~~ b (h x') -> e (h x') (h y') = e' x' y'.

Lemma path_map : forall b x' p', rel_base b ->
    ~~ has (preim h b) (belast x' p') ->
  path e (h x') (map h p') = path e' x' p'.
Proof.
move=> b x' p' Hb; elim: p' x' => [|y' p' Hrec] x' //=; move/norP=> [Hbx Hbp].
congr andb; auto.
Qed.

End MapPath.

Section MapEqPath.

Variables (T T' : eqType) (h : T' -> T) (e : rel T) (e' : rel T').

Hypothesis Hh : injective h.

Lemma mem2_map : forall x' y' p',
  mem2 (map h p') (h x') (h y') = mem2 p' x' y'.
Proof. by move=> *; rewrite {1}/mem2 (index_map Hh) -map_drop mem_map. Qed.

Lemma next_map : forall p, uniq p ->
  forall x, next (map h p) (h x) = h (next p x).
Proof.
move=> p Up x; case Hx: (x \in p); last by rewrite !next_nth (mem_map Hh) Hx.
case/rot_to: Hx => [i p' Dp].
rewrite -(next_rot i Up); rewrite -(map_inj_uniq Hh) in Up.
rewrite -(next_rot i Up) -map_rot {i p Up}Dp /=.
by case: p' => [|y p] //=; rewrite !eqxx.
Qed.

Lemma prev_map : forall p, uniq p ->
  forall x, prev (map h p) (h x) = h (prev p x).
Proof.
by move=> p Up x; rewrite -{1}[x](next_prev Up) -(next_map Up) prev_next ?map_inj_uniq.
Qed.

End MapEqPath.

Definition fun_base (T T' : eqType) (h : T' -> T) f f' :=
  rel_base h (frel f) (frel f').

Section CycleArc.

Variable T : eqType.

Definition arc (p : seq T) x y :=
  let px := rot (index x p) p in take (index y px) px.

Lemma arc_rot : forall i p, uniq p -> {in p, arc (rot i p) =2 arc p}.
Proof.
move=> i p Up x Hx y; congr (fun q => take (index y q) q); move: Up Hx {y}.
rewrite -{1 2 5 6}(cat_take_drop i p) /rot cat_uniq; move/and3P=> [_ Hp _].
rewrite !drop_cat !take_cat !index_cat mem_cat orbC.
case Hx: (x \in drop i p) => /= => [_|Hx'].
  rewrite [x \in _](negbTE (hasPn Hp _ Hx)).
  by rewrite index_mem Hx ltnNge leq_addr /= addKn catA.
by rewrite Hx' index_mem Hx' ltnNge leq_addr /= addKn catA.
Qed.

Lemma left_arc : forall x y p1 p2,
  let p := x :: p1 ++ y :: p2 in uniq p -> arc p x y = x :: p1.
Proof.
move=> x y p1 p2 p Up; rewrite /arc {1}/p /= eqxx rot0.
move: Up; rewrite /p -cat_cons cat_uniq index_cat; move: (x :: p1) => xp1.
rewrite /= negb_or -!andbA; move/and3P=> [_ Hy _].
by rewrite (negbTE Hy) eqxx addn0 take_size_cat.
Qed.

Lemma right_arc : forall x y p1 p2,
  let p := x :: p1 ++ y :: p2 in uniq p -> arc p y x = y :: p2.
Proof.
move=> x y p1 p2 p Up; set n := size (x :: p1); rewrite -(arc_rot n Up).
  move: Up; rewrite -(rot_uniq n) /p -cat_cons /n rot_size_cat.
  by move=> *; rewrite /= left_arc.
by rewrite /p -cat_cons mem_cat /= mem_head orbT.
Qed.

CoInductive rot_to_arc_spec (p : seq T) (x y : T) : Type :=
    RotToArcSpec i p1 p2 of x :: p1 = arc p x y
                          & y :: p2 = arc p y x
                          & rot i p = x :: p1 ++ y :: p2 :
    rot_to_arc_spec p x y.

Lemma rot_to_arc : forall p x y,
  uniq p -> x \in p -> y \in p -> x != y -> rot_to_arc_spec p x y.
Proof.
move=> p x y Up Hx Hy Hxy; case: (rot_to Hx) (Hy) (Up) => [i p' Dp] Hy'.
rewrite -(mem_rot i) Dp in_cons eq_sym (negPf Hxy) in Hy'.
rewrite -(rot_uniq i) Dp.
case/splitPr: p' / Hy' Dp => [p1 p2] Dp Up'; exists i p1 p2; auto.
  by rewrite -(arc_rot i Up Hx) Dp (left_arc Up').
by rewrite -(arc_rot i Up Hy) Dp (right_arc Up').
Qed.

End CycleArc.

Prenex Implicits arc.


Require Import ZArith.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

Require Import Utils.

Class JoinSemiLattice (Lab : Type) :=
{ bot : Lab
; join : Lab -> Lab -> Lab
; flows : Lab -> Lab -> bool
; meet : Lab -> Lab -> Lab
; bot_flows : forall l, flows bot l = true
; flows_refl : forall l, flows l l = true
; flows_trans : forall l1 l2 l3, flows l1 l2 = true ->
                                 flows l2 l3 = true ->
                                 flows l1 l3 = true
; flows_antisymm : forall l1 l2, flows l1 l2 = true ->
                                 flows l2 l1 = true -> l1 = l2
; flows_join_right : forall l1 l2, flows l1 (join l1 l2) = true
; flows_join_left : forall l1 l2, flows l2 (join l1 l2) = true
; join_minimal : forall l1 l2 l, flows l1 l = true ->
                                 flows l2 l = true ->
                                 flows (join l1 l2) l = true
}.

Notation "l1 \_/ l2" := (join l1 l2) (at level 40) : type_scope.
Notation "l1 <: l2" := (flows l1 l2 = true)
  (at level 50, no associativity) : type_scope.
Notation "⊥" := bot.

Hint Resolve
  @flows_refl
  @flows_trans
  @flows_join_left
  @flows_join_right
  @flows_antisymm
  @join_minimal : lat.

Definition flows_to {Lab : Type} `{JoinSemiLattice Lab} (l1 l2 : Lab) : Z :=
  if flows l1 l2 then 1%Z else 0%Z.

(** Immediate properties from the semi-lattice structure. *)
Section JoinSemiLattice_properties.

Context {T: Type}.

Lemma flows_join {L : JoinSemiLattice T} : forall l1 l2,
  l1 <: l2 <-> l1 \_/ l2 = l2.
Proof.
  intros.
  split.
  - intros H.
    apply flows_antisymm.
    + apply join_minimal; auto with lat.
    + apply flows_join_left.
  - intros H.
    rewrite <- H.
    auto with lat.
Qed.

Lemma join_1_rev {L : JoinSemiLattice T} : forall l1 l2 l,
  l1 \_/ l2 <: l -> l1 <: l.
Proof. eauto with lat. Qed.

Lemma join_2_rev {L : JoinSemiLattice T} : forall l1 l2 l,
  l1 \_/ l2 <: l -> l2 <: l.
Proof. eauto with lat. Qed.

Lemma join_1 {L : JoinSemiLattice T} : forall l l1 l2,
  l <: l1 -> l <: l1 \_/ l2.
Proof. eauto with lat. Qed.

Lemma join_2 {L : JoinSemiLattice T} : forall l l1 l2,
  l <: l2 -> l <: l1 \_/ l2.
Proof. eauto with lat. Qed.

Lemma join_bot_right {L : JoinSemiLattice T} : forall l,
  l \_/ bot = l.
Proof.
  eauto using bot_flows with lat.
Qed.

Lemma join_bot_left {L:  JoinSemiLattice T} : forall l,
  bot \_/ l = l.
Proof. eauto using bot_flows with lat.
Qed.

Lemma not_flows_not_join_flows_left {L : JoinSemiLattice T} : forall l l1 l2,
  flows l1 l = false ->
  flows (l1 \_/ l2) l = false.
Proof.
  intros.
  destruct (flows (l1 \_/ l2) l) eqn:E.
  exploit join_1_rev; eauto.
  auto.
Qed.

Lemma not_flows_not_join_flows_right {L : JoinSemiLattice T} : forall l l1 l2,
  flows l2 l = false ->
  flows (l1 \_/ l2) l = false.
Proof.
  intros.
  destruct (flows (l1 \_/ l2) l) eqn:E.
  exploit join_2_rev; eauto.
  auto.
Qed.

Definition label_eqb {L : JoinSemiLattice T} l1 l2 :=
  flows l1 l2 && flows l2 l1.

Lemma label_eqP (L : JoinSemiLattice T) : Equality.axiom label_eqb.
Proof.
move => l1 l2.
rewrite /label_eqb.
apply/(iffP idP).
- move/andP => [H1 H2].
  by apply flows_antisymm.
- move => -> .
  by rewrite !flows_refl.
Qed.

Definition label_eqMixin (L : JoinSemiLattice T) := EqMixin (@label_eqP L).

End JoinSemiLattice_properties.

Hint Resolve
  @join_1
  @join_2
  @bot_flows
  @not_flows_not_join_flows_right
  @not_flows_not_join_flows_left : lat.

Definition label_dec {T : Type} {Lat : JoinSemiLattice T}
  : forall l1 l2 : T, {l1 = l2} + {l1 <> l2}.
Proof.
  intros x y.
  destruct (flows x y) eqn:xy;
  destruct (flows y x) eqn:yx; try (right; congruence).
  - left. eauto with lat.
  - generalize (flows_refl x). intros.
    right. congruence.
Defined.

Class Lattice (Lab: Type) :=
{ jslat :> JoinSemiLattice Lab
; top : Lab
; flows_top : forall l, l <: top
}.

Module Import LabelEqType.

Canonical label_eqType T {L : JoinSemiLattice T} := Eval hnf in EqType _ (label_eqMixin L).

End LabelEqType.

Class FiniteLattice (Lab : Type) :=
{
  lat :> Lattice Lab
; elems : list Lab
; all_elems : forall l : Lab, l \in elems
}.

Definition allThingsBelow {L : Type} `{FiniteLattice L} (l : L) : list L :=
  filter (fun l' => flows l' l) elems.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint even (even_arg0 : natural) : bool
           := match even_arg0 with
              | Zero => true
              | Succ n => negb (even n)
              end.

Lemma lem: forall m n, even (plus m n) = negb (even (plus m (Succ n))).
Proof.
induction m.
  - intros. simpl. rewrite <- IHm. reflexivity.
  - intros. simpl. unfold negb. destruct (even n). reflexivity. reflexivity.
Qed.

Lemma lem2: forall n, plus n Zero = n.
Proof.
induction n.
  - simpl. rewrite IHn. reflexivity.
  - reflexivity.
Qed.

(* An alternaturale proof strategy is to prove that plus is commutative as a helper lemma,
and then this theorem can be proven without induction. *)

Theorem theorem0 : forall (x : natural) (y : natural), eq (even (plus x y)) (even (plus y x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. rewrite lem. unfold negb.
  destruct (even (plus y (Succ x))). reflexivity. reflexivity.
- intros. simpl. lfind. Admitted.


(** **** KE DING 8318 *)

Require Export Poly. (* Just for definitions, not homework *)
(** **** Quiz #3
   Define a Coq polymorphic list function called
   "shuffle" which alternates the elements
   of two lists in the resulting output list
   e.g.,
   (shuffle [true] [false,false]) ==> [true,false,false]
   (shuffle [false,false] [true]) ==> [false,true,false]
   (shuffle [1,2,3] [10,11,12,13,14]) ==> [1,10,2,11,3,12,13,14]
   (shuffle [10,11,12,13,14] [1,2,3]) ==> [10,1,11,2,12,3,13,14]
   (shuffle [] [1,2]) ==> [1,2]
   (shuffle [1,2] []) ==> [1,2]

    Also devise a test or two for your function
*)

(* definition here *)
Fixpoint shuffle {X : Type} (l1 : list X) (l2 : list X) : list X :=
  match l1, l2 with
    | nil, _ => l2
    | _, nil => l1
    | x1::t1, x2::t2 => x1::x2::(shuffle t1 t2)
  end.

Example test1 : shuffle [true] [false,false] = [true,false,false].
Proof. reflexivity. Qed.
Example test2 : shuffle [false,false] [true] = [false,true,false].
Proof. reflexivity. Qed.
Example test3 : shuffle [1,2,3] [10,11,12,13,14] = [1,10,2,11,3,12,13,14].
Proof. reflexivity. Qed.
Example test4 : shuffle [10,11,12,13,14] [1,2,3] = [10,1,11,2,12,3,13,14].
Proof. reflexivity. Qed.
Example test5 : shuffle [] [1,2] = [1,2].
Proof. reflexivity. Qed.
Example test6 : shuffle [1,2] [] = [1,2].
Proof. reflexivity. Qed.

(* tests here *)
Example devise_test1 : shuffle ["c", "l", "o", "y", "pomona"] ["a", "p","l"]
                     = ["c", "a", "l", "p", "o", "l", "y", "pomona"].
Proof. reflexivity. Qed.
Example devise_test2 : shuffle [monday,wednesday,friday,sunday] [tuesday,thursday,saturday]
                     = [monday,tuesday,wednesday,thursday,friday,saturday,sunday].
Proof. reflexivity. Qed.
Example devise_test3 : shuffle [add o, add o, add o, add (dub o), dub (add o)] [dub o, dub o]
                     = [add o, dub o, add o, dub o, add o, add (dub o), dub (add o)].
Proof. reflexivity. Qed.
Example devise_test4 : @shuffle nat [] [] = [].
Proof. reflexivity. Qed.

(* email answers .v file to jrfisher@csupomona.edu, using quiz3 in subject line *)

(** **** KE DING 8318 *)


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (c) 2010-2013, ENS de Lyon and Inria.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

Require Import Rdefinitions Raxioms RIneq Rbasic_fun Zwf.
Require Import Epsilon FunctionalExtensionality Ranalysis1 Rsqrt_def.
From mathcomp Require Import ssreflect ssrfun ssrbool.
From mathcomp Require Import eqtype ssrnat seq choice bigop.
From mathcomp Require Import ssrnum ssralg fintype poly mxpoly.
From mathcomp Require Import div order.

Require Import Rtrigo1 Reals Lra.
Require Import Reals Coquelicot.Coquelicot Psatz.

Delimit Scope ring_scope with RR.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Local Open Scope R_scope.

Lemma Req_EM_T (r1 r2 : R) : {r1 = r2} + {r1 <> r2}.
Proof.
case: (total_order_T r1 r2) => [[r1Lr2 | <-] | r1Gr2].
- by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {2}r1Er2.
- by left.
by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {1}r1Er2.
Qed.

Definition eqr (r1 r2 : R) : bool :=
  if Req_EM_T r1 r2 is left _ then true else false.

Lemma eqrP : Equality.axiom eqr.
Proof.
by move=> r1 r2; rewrite /eqr; case: Req_EM_T=> H; apply: (iffP idP).
Qed.

Canonical Structure R_eqMixin := EqMixin eqrP.
Canonical Structure R_eqType := Eval hnf in EqType R R_eqMixin.

Fact inhR : inhabited R.
Proof. exact: (inhabits 0). Qed.

Definition pickR (P : pred R) (n : nat) :=
  let x := epsilon inhR P in if P x then Some x else None.

Fact pickR_some P n x : pickR P n = Some x -> P x.
Proof. by rewrite /pickR; case: (boolP (P _)) => // Px [<-]. Qed.

Fact pickR_ex (P : pred R) :
  (exists x : R, P x) -> exists n, pickR P n.
Proof. by rewrite /pickR; move=> /(epsilon_spec inhR)->; exists 0%N. Qed.

Fact pickR_ext (P Q : pred R) : P =1 Q -> pickR P =1 pickR Q.
Proof.
move=> PEQ n; rewrite /pickR; set u := epsilon _ _; set v := epsilon _ _.
suff->: u = v by rewrite PEQ.
by congr epsilon; apply: functional_extensionality=> x; rewrite PEQ.
Qed.

Definition R_choiceMixin : choiceMixin R :=
  Choice.Mixin pickR_some pickR_ex pickR_ext.

Canonical R_choiceType := Eval hnf in ChoiceType R R_choiceMixin.

Fact RplusA : associative (Rplus).
Proof. by move=> *; rewrite Rplus_assoc. Qed.

Definition R_zmodMixin := ZmodMixin RplusA Rplus_comm Rplus_0_l Rplus_opp_l.

Canonical Structure R_zmodType := Eval hnf in ZmodType R R_zmodMixin.

Fact RmultA : associative (Rmult).
Proof. by move=> *; rewrite Rmult_assoc. Qed.

Fact R1_neq_0 : R1 != R0.
Proof. by apply/eqP/R1_neq_R0. Qed.

Definition R_ringMixin := RingMixin RmultA Rmult_1_l Rmult_1_r
  Rmult_plus_distr_r Rmult_plus_distr_l R1_neq_0.

Canonical Structure R_ringType := Eval hnf in RingType R R_ringMixin.
Canonical Structure R_comRingType := Eval hnf in ComRingType R Rmult_comm.

Import Monoid.

Canonical Radd_monoid := Law RplusA Rplus_0_l Rplus_0_r.
Canonical Radd_comoid := ComLaw Rplus_comm.

Canonical Rmul_monoid := Law RmultA Rmult_1_l Rmult_1_r.
Canonical Rmul_comoid := ComLaw Rmult_comm.

Canonical Rmul_mul_law := MulLaw Rmult_0_l Rmult_0_r.
Canonical Radd_add_law := AddLaw Rmult_plus_distr_r Rmult_plus_distr_l.

Definition Rinvx r := if (r != 0) then / r else r.

Definition unit_R r := r != 0.

Lemma RmultRinvx : {in unit_R, left_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_l //; apply/eqP.
Qed.

Lemma RinvxRmult : {in unit_R, right_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_r //; apply/eqP.
Qed.

Lemma intro_unit_R x y : y * x = R1 /\ x * y = R1 -> unit_R x.
Proof.
move=> [yxE1 xyE1]; apply/eqP=> xZ.
by case/eqP: R1_neq_0; rewrite -yxE1 xZ Rmult_0_r.
Qed.

Lemma Rinvx_out : {in predC unit_R, Rinvx =1 id}.
Proof. by move=> x; rewrite inE /= /Rinvx -if_neg => ->. Qed.

Definition R_unitRingMixin :=
  UnitRingMixin RmultRinvx RinvxRmult intro_unit_R Rinvx_out.

Canonical Structure R_unitRing :=
  Eval hnf in UnitRingType R R_unitRingMixin.

Canonical Structure R_comUnitRingType :=
  Eval hnf in [comUnitRingType of R].

Lemma R_idomainMixin x y : x * y = 0 -> (x == 0) || (y == 0).
Proof.
(do 2 case: (boolP (_ == _))=> // /eqP)=> yNZ xNZ xyZ.
by case: (Rmult_integral_contrapositive_currified _ _ xNZ yNZ).
Qed.

Canonical Structure R_idomainType :=
   Eval hnf in IdomainType R R_idomainMixin.

Lemma R_fieldMixin : GRing.Field.mixin_of [unitRingType of R].
Proof. by done. Qed.

Definition R_fieldIdomainMixin := FieldIdomainMixin R_fieldMixin.

Canonical Structure R_fieldType := FieldType R R_fieldMixin.

(** Reflect the order on the reals to bool *)

Definition Rleb r1 r2 := if Rle_dec r1 r2 is left _ then true else false.
Definition Rltb r1 r2 := Rleb r1 r2 && (r1 != r2).
Definition Rgeb r1 r2 := Rleb r2 r1.
Definition Rgtb r1 r2 := Rltb r2 r1.

Lemma RlebP r1 r2 : reflect (r1 <= r2) (Rleb r1 r2).
Proof. by rewrite /Rleb; apply: (iffP idP); case: Rle_dec. Qed.

Lemma RltbP r1 r2 : reflect (r1 < r2) (Rltb r1 r2).
Proof.
rewrite /Rltb /Rleb; apply: (iffP idP); case: Rle_dec=> //=.
- by case=> // r1Er2 /eqP[].
- by move=> _ r1Lr2; apply/eqP/Rlt_not_eq.
by move=> Nr1Lr2 r1Lr2; case: Nr1Lr2; left.
Qed.

Lemma RgebP r1 r2 : reflect (r1 >= r2) (Rgeb r1 r2).
Proof.
rewrite /Rgeb /Rleb; apply: (iffP idP); case: Rle_dec=> //=.
  by move=> r2Lr1 _; apply: Rle_ge.
by move=> Nr2Lr1 r1Gr2; case: Nr2Lr1; apply: Rge_le.
Qed.

Lemma RgtbP r1 r2 : reflect (r1 > r2) (Rgtb r1 r2).
Proof.
rewrite /Rleb; apply: (iffP idP) => r1Hr2; first by apply: Rlt_gt; apply/RltbP.
by apply/RltbP; apply: Rgt_lt.
Qed.

(*
Ltac toR := rewrite /GRing.add /GRing.opp /GRing.zero /GRing.mul /GRing.inv
  /GRing.one //=.
*)

Section ssreal_struct.

Import GRing.Theory.
Import Num.Theory.
Import Num.Def.

Local Open Scope R_scope.

Lemma Rleb_norm_add x y : Rleb (Rabs (x + y)) (Rabs x + Rabs y).
Proof. by apply/RlebP/Rabs_triang. Qed.

Lemma addr_Rgtb0 x y : Rltb 0 x -> Rltb 0 y -> Rltb 0 (x + y).
Proof. by move/RltbP=> Hx /RltbP Hy; apply/RltbP/Rplus_lt_0_compat. Qed.

Lemma Rnorm0_eq0 x : Rabs x = 0 -> x = 0.
Proof. by move=> H; case: (x == 0) /eqP=> // /Rabs_no_R0. Qed.

Lemma Rleb_leVge x y : Rleb 0 x -> Rleb 0 y -> (Rleb x y) || (Rleb y x).
Proof.
move/RlebP=> Hx /RlebP Hy; case: (Rlt_le_dec x y).
by move/Rlt_le/RlebP=> ->.
by move/RlebP=> ->; rewrite orbT.
Qed.

Lemma RnormM : {morph Rabs : x y / x * y}.
exact: Rabs_mult. Qed.

Lemma Rleb_def x y : (Rleb x y) = (Rabs (y - x) == y - x).
apply/(sameP (RlebP x y))/(iffP idP)=> [/eqP H| /Rle_minus H].
  apply: Rminus_le; rewrite -Ropp_minus_distr.
  apply/Rge_le/Ropp_0_le_ge_contravar.
  by rewrite -H; apply: Rabs_pos.
apply/eqP/Rabs_pos_eq.
rewrite -Ropp_minus_distr.
by apply/Ropp_0_ge_le_contravar/Rle_ge.
Qed.

Lemma Rltb_def x y : (Rltb x y) = (y != x) && (Rleb x y).
apply/(sameP (RltbP x y))/(iffP idP).
  case/andP=> /eqP H /RlebP/Rle_not_gt H2.
  by case: (Rtotal_order x y)=> // [][] // /esym.
move=> H; apply/andP; split; [apply/eqP|apply/RlebP].
  exact: Rgt_not_eq.
exact: Rlt_le.
Qed.

Definition R_numMixin := NumMixin Rleb_norm_add addr_Rgtb0 Rnorm0_eq0.

Fact Rle_0D x y : Rleb 0 x -> Rleb 0 y -> Rleb 0 (x + y).
Proof. by move=> /RlebP Hx /RlebP Hy; apply/RlebP; lra. Qed.

Fact Rle_0M x y : Rleb 0 x -> Rleb 0 y -> Rleb 0 (x * y).
Proof. by move=> /RlebP Hx /RlebP Hy; apply/RlebP; nra. Qed.

Fact Rle_0A x : Rleb 0 x -> Rleb x 0 -> x = 0.
Proof. by move=> /RlebP Hx /RlebP Hy; nra. Qed.

Fact Rle_0B x y : Rleb 0 (y - x) = Rleb x y.
Proof. by apply/RlebP/RlebP; lra. Qed.

Fact Rle_0X x : Rleb 0 x || Rleb x 0.
Proof.
case: (Rle_dec 0 x) => [/RlebP->//|H]; rewrite orbC.
by have /RlebP-> : x <= 0 by lra.
Qed.

Fact Rle0_Rabs x : Rleb 0 x -> Rabs x = x.
Proof. by move=> /RlebP/Rabs_pos_eq. Qed.

Fact Rlt_def x y : (Rltb x y) = (y != x) && (Rleb x y).
Proof.
apply/RltbP/andP => [xLy|[/eqP yDx /RlebP xLy]]; last by lra.
  split; first by apply/eqP; lra.
by apply/RlebP; lra.
Qed.

Definition RLeMixin : realLeMixin R_idomainType :=
  RealLeMixin Rle_0D Rle_0M Rle_0A Rle_0B Rle_0X
              Rabs_Ropp Rle0_Rabs Rlt_def.
Lemma Rleb_total : total Rleb.
Proof.
move=> a b; have [/RlebP->//|/RlebP->//] : a <= b \/ b <= a by lra.
by rewrite orbT.
Qed.

Canonical RporderType := POrderType ring_display R RLeMixin.
Canonical RlatticeType := LatticeType R RLeMixin.
Canonical RdistrLatticeType := DistrLatticeType R RLeMixin.
Canonical RorderType := OrderType R Rleb_total.
Canonical RnumDomainType := NumDomainType R RLeMixin.
Canonical RnormedZmodType := NormedZmodType R R RLeMixin.
Canonical RnumFieldType := [numFieldType of R].
Canonical RrealDomainType := [realDomainType of R].
Canonical RrealFieldType := [realFieldType of R].

Lemma Rarchimedean_axiom : Num.archimedean_axiom RrealFieldType.
Proof.
move=> x; exists (Z.abs_nat (up x) + 2)%nat.
have [Hx1 Hx2]:= (archimed x).
have Hz (z : Z): z = (z - 1 + 1)%Z by rewrite Zplus_comm Zplus_minus.
have Zabs_nat_Zopp z : Z.abs_nat (- z)%Z = Z.abs_nat z by case: z.
apply/RltbP/Rabs_def1.
  apply: (Rlt_trans _ ((Z.abs_nat (up x))%:R)%RR); last first.
    rewrite -[((Z.abs_nat _)%:R)%RR]Rplus_0_r mulrnDr.
    by apply/Rplus_lt_compat_l/Rlt_0_2.
  apply: (Rlt_le_trans _ (IZR (up x)))=> //.
  elim/(well_founded_ind (Zwf_well_founded 0)): (up x) => z IHz.
  case: (Z_lt_le_dec 0 z) => [zp | zn].
    rewrite [z]Hz plus_IZR Zabs_nat_Zplus //; last exact: Zlt_0_le_0_pred.
    rewrite plusE mulrnDr.
    apply/Rplus_le_compat_r/IHz; split; first exact: Zlt_le_weak.
    exact: Zlt_pred.
  apply: (Rle_trans _ (IZR 0)); first exact: IZR_le.
  by apply/RlebP/(ler0n RnumDomainType (Z.abs_nat z)).
apply: (Rlt_le_trans _ (IZR (up x) - 1)).
  apply: Ropp_lt_cancel; rewrite Ropp_involutive.
  rewrite Ropp_minus_distr /Rminus -opp_IZR -{2}(Z.opp_involutive (up x)).
  elim/(well_founded_ind (Zwf_well_founded 0)): (- up x)%Z => z IHz .
  case: (Z_lt_le_dec 0 z) => [zp | zn].
  rewrite [z]Hz Zabs_nat_Zopp plus_IZR.
  rewrite Zabs_nat_Zplus //; last exact: Zlt_0_le_0_pred.
    rewrite plusE -Rplus_assoc -addnA [(_ + 2)%nat]addnC addnA mulrnDr.
    apply: Rplus_lt_compat_r; rewrite -Zabs_nat_Zopp.
    apply: IHz; split; first exact: Zlt_le_weak.
    exact: Zlt_pred.
  apply: (Rle_lt_trans _ 1).
    rewrite -{2}[1]Rplus_0_r; apply: Rplus_le_compat_l.
    by rewrite -/(IZR 0); apply: IZR_le.
  rewrite mulrnDr; apply: (Rlt_le_trans _ 2).
    by rewrite -{1}[1]Rplus_0_r; apply/Rplus_lt_compat_l/Rlt_0_1.
  rewrite -[2]Rplus_0_l; apply: Rplus_le_compat_r.
  by apply/RlebP/(ler0n RnumDomainType (Z.abs_nat _)).
apply: Rminus_le.
rewrite /Rminus Rplus_assoc [- _ + _]Rplus_comm -Rplus_assoc -!/(Rminus _ _).
exact: Rle_minus.
Qed.

Canonical Structure R_archiFieldType := ArchiFieldType R Rarchimedean_axiom.

(** Here are the lemmas that we will use to prove that R has
the rcfType structure. *)

Lemma continuity_eq f g : f =1 g -> continuity f -> continuity g.
Proof.
move=> Hfg Hf x eps Heps.
have [y [Hy1 Hy2]]:= Hf x eps Heps.
by exists y; split=> // z; rewrite -!Hfg; exact: Hy2.
Qed.

Lemma continuity_sum (I : finType) F (P : pred I):
(forall i, P i -> continuity (F i)) ->
continuity (fun x => (\sum_(i | P i) ((F i) x)))%RR.
Proof.
move=> H; elim: (index_enum I)=> [|a l IHl].
  set f:= fun _ => _.
  have Hf: (fun x=> 0) =1 f by move=> x; rewrite /f big_nil.
  by apply: (continuity_eq Hf); exact: continuity_const.
set f := fun _ => _.
case Hpa: (P a).
  have Hf: (fun x => F a x + \sum_(i <- l | P i) F i x)%RR =1 f.
    by move=> x; rewrite /f big_cons Hpa.
  apply: (continuity_eq Hf); apply: continuity_plus=> //.
  exact: H.
have Hf: (fun x => \sum_(i <- l | P i) F i x)%RR =1 f.
  by move=> x; rewrite /f big_cons Hpa.
exact: (continuity_eq Hf).
Qed.

Lemma continuity_exp f n: continuity f -> continuity (fun x => (f x)^+ n)%RR.
Proof.
move=> Hf; elim: n=> [|n IHn]; first exact: continuity_const.
set g:= fun _ => _.
have Hg: (fun x=> f x * f x ^+ n)%RR =1 g.
  by move=> x; rewrite /g exprS.
by apply: (continuity_eq Hg); exact: continuity_mult.
Qed.

Lemma Rreal_closed_axiom : Num.real_closed_axiom R_archiFieldType.
Proof.
move=> p a b; rewrite !le_eqVlt.
case Hpa: (p.[a] == 0)%RR.
  by move=> ? _ ; exists a=> //; rewrite lexx le_eqVlt.
case Hpb: (p.[b] == 0)%RR.
  by move=> ? _; exists b=> //; rewrite lexx le_eqVlt andbT.
case Hab: (a == b).
  by move=> _; rewrite (eqP Hab) eq_sym Hpb (ltNge 0) /=; case/andP=> /ltW ->.
rewrite eq_sym Hpb /=; clear=> /RltbP Hab /andP [] /RltbP Hpa /RltbP Hpb.
suff Hcp: continuity (fun x => (p.[x])%RR).
  have [z [[Hza Hzb] /eqP Hz2]]:= IVT _ a b Hcp Hab Hpa Hpb.
  by exists z=> //; apply/andP; split; apply/RlebP.
rewrite -[p]coefK poly_def.
set f := fun _ => _.
have Hf: (fun (x : R) => \sum_(i < size p) (p`_i * x^+i))%RR =1 f.
  move=> x; rewrite /f horner_sum.
  by apply: eq_bigr=> i _; rewrite hornerZ hornerXn.
apply: (continuity_eq Hf); apply: continuity_sum=> i _.
apply:continuity_scal; apply: continuity_exp=> x esp Hesp.
by exists esp; split=> // y [].
Qed.

Canonical Structure R_rcfType := RcfType R Rreal_closed_axiom.

(* proprietes utiles de l'exp *)

Open Scope ring_scope.

Lemma expR0 :
    exp(GRing.zero R_zmodType) = 1.
Proof. by rewrite exp_0. Qed.

Lemma expRD x y :
    exp(x) * exp(y) = exp(GRing.add x y).
Proof. by rewrite exp_plus. Qed.

Lemma expRX x :
  forall n : nat,
    exp(x) ^+ n = exp(x *+ n).
Proof.
elim => [|n Ihn].
  by rewrite expr0 mulr0n exp_0.
by rewrite exprS Ihn mulrS expRD.
Qed.

 Lemma Rplus_add x y :
  Rplus x y = GRing.add x y.
Proof. by done. Qed.

Lemma Rmult_mul x y :
  Rmult x y = GRing.mul x y.
Proof. by done. Qed.

Lemma Ropp_opp x :
  Ropp x = GRing.opp x.
Proof. by done. Qed.

Lemma Rdiv_div x y :
  y != 0 -> Rdiv x y = x / y.
Proof.
move=> Hneq0.
apply: (@mulIr _ y).
  by rewrite unitfE.
rewrite -!mulrA.
rewrite mulVr;
  last by rewrite unitfE.
rewrite -[X in _*X]Rmult_mul.
rewrite Rinv_l //.
by apply: (elimN eqP Hneq0).
Qed.

Lemma sin_add x y :
   sin (GRing.add x y) = sin x * cos y + cos x * sin y.
Proof. by rewrite sin_plus. Qed.

Lemma cos_add x y :
   cos (GRing.add x y) = (cos x * cos y - sin x * sin y).
Proof. by rewrite cos_plus. Qed.

Lemma natr_INR n : n%:R = INR n.
Proof.
elim: n => // n IH.
rewrite  S_INR [_.+1%:R](natrD _ 1) IH -[1%:R]/1.
by rewrite addrC.
Qed.

Lemma natrS (R :ringType) n : n.+1%:R = 1 + n%:R :> R.
Proof. by rewrite -(natrD _ 1 n). Qed.

Lemma Z_of_nat_gt0 n: (0 < n)%nat -> (0 < Z.of_nat n)%Z.
Proof. by case: n. Qed.

Lemma IZR_Zof_nat n : IZR (Z.of_nat n) = n%:R.
Proof. by rewrite -INR_IZR_INZ natr_INR. Qed.

Lemma expr_Rexp a1 b1 : (a1 ^+ b1)%RR = (a1 ^ b1)%R.
Proof.  by elim: b1 => //= n <-; rewrite exprS. Qed.

End ssreal_struct.

(* More theorems to make Reals and ssreflect work together *)

Ltac toR := rewrite /GRing.add /GRing.opp /GRing.zero /GRing.mul /GRing.inv
  /GRing.one ?natr_INR //=.

Lemma pow_expn x n : Nat.pow x n = expn x n.
Proof. by elim: n => //= n ->; rewrite expnS. Qed.

Lemma Rabs_expr x n : Rabs (x ^+ n)%RR = (Rabs x ^+ n)%RR.
Proof.
elim: n => [|n IH]; first by rewrite !expr0 Rabs_R1.
by rewrite !exprS Rabs_mult IH.
Qed.

Lemma Rabs_exprN1 n : Rabs ((-1) ^+ n)%RR = 1.
Proof. by rewrite Rabs_expr Rabs_Ropp Rabs_R1 expr1n. Qed.

Lemma continuous_continuity_pt f t :
  continuous f t -> continuity_pt f t.
Proof.
move=> Hc.
apply: limit1_imp; last first.
  apply: is_lim_Reals_0.
  apply: is_lim_comp_continuous => //.
  apply: is_lim_id.
by move=> x [_]; lra.
Qed.

Import path.

Lemma eqR_leb a b : (a == b) = (Rleb a b && Rleb b a).
Proof.
apply/eqP/andP=> [->|[/RlebP H /RlebP]]; try lra.
by split; apply/RlebP; lra.
Qed.

Lemma Rleb_trans : transitive Rleb.
Proof. by move=> a b c /RlebP H /RlebP H1;apply/RlebP; lra. Qed.

Lemma Rltb_trans : transitive Rltb.
Proof. by move=> a b c /RltbP H /RltbP H1;apply/RltbP; lra. Qed.

Lemma Rltb_sorted_uniq_leb s : sorted Rltb s = uniq s && sorted Rleb s.
Proof.
case: s => //= n s; elim: s n => //= m s IHs n.
rewrite inE Rltb_def negb_or IHs -!andbA eq_sym.
case sn: (n \in s); last do !bool_congr.
rewrite andbF; apply/and5P=> [[ne_nm lenm _ _ le_ms]]; case/negP: ne_nm.
by rewrite eqR_leb lenm; apply: (allP (order_path_min Rleb_trans le_ms)).
Qed.

Lemma ex_derive_n_minus_inter f g n a b (h := fun z => f z - g z) :
      (forall x k,
        (k <= n)%nat -> a < x < b -> ex_derive_n f k x) ->
      (forall x k,
        (k <= n)%nat -> a < x < b -> ex_derive_n g k x) ->
      (forall x k,
        (k <= n)%nat -> a < x < b -> ex_derive_n h k x).
Proof.
move=> Hf Hg x k kLn aLxLb.
pose d := (Rmin (x - a) (b - x)) / 2.
have Pd : 0 < d.
  by rewrite /d /Rmin; case: Rle_dec; lra.
have Hd : a < x - d < x /\ x < x + d < b.
  by rewrite /d /Rmin; case: Rle_dec; lra.
apply: ex_derive_n_minus.
  exists (mkposreal _ Pd) => /= y Hy k1 Hk1.
  apply: Hf; first apply: leq_trans kLn.
    by apply/ssrnat.leP.
  rewrite /ball /= /AbsRing_ball /= /abs /= /minus /plus /opp /= in Hy.
  split_Rabs; lra.
exists (mkposreal _ Pd) => /= y Hy k1 Hk1.
apply: Hg; first apply: leq_trans kLn.
  by apply/ssrnat.leP.
rewrite /ball /= /AbsRing_ball /= /abs /= /minus /plus /opp /= in Hy.
split_Rabs; lra.
Qed.

Lemma Z_of_nat_S n : Z.of_nat n.+1 = (Z.of_nat n + 1)%Z.
Proof. rewrite /=; lia. Qed.

Lemma Z_of_nat_double n : Z.of_nat n.*2 = (Z.of_nat n * 2)%Z.
Proof.
by elim: n => [//=|n IH]; rewrite doubleS !Z_of_nat_S IH; lia.
Qed.

Lemma RInt_deriv_lin (f : R -> R) (x y : R) t1 t2  b1 b2 c1 c2 :
   y != 0 -> t1 <= t2 -> c1 < b1 -> b2 < c2 ->
  b1 <= x + t1 * y <= b2 ->
  b1 <= x + t2 * y <= b2 ->
  (forall x, c1 < x < c2 -> ex_derive f x) ->
  (forall x, b1 <= x <= b2 -> continuous (Derive f) x) ->
   RInt (fun z : R => Derive f  (y * z + x)) t1 t2 =
    (/y) * (f (y * t2 + x) - f (y * t1 + x)).
Proof.
pose g t := y * t + x.
have ef u : ex_derive g u.
  by repeat (apply: ex_derive_mult || apply: ex_derive_plus ||
             apply : ex_derive_const || apply: ex_derive_id).
have Dg u : Derive g u = y.
    rewrite !(Derive_plus, Derive_const, Derive_mult, Derive_id) ; try
      by repeat (apply: ex_derive_mult || apply: ex_derive_plus ||
                apply : ex_derive_const || apply: ex_derive_id).
    by ring.
have Cg u : continuous g u.
  by do 5
   (apply: continuous_plus || apply: continuous_mult || apply: continuous_id ||
    apply: continuous_const).
pose RC := R_CompleteNormedModule.
move=> /eqP xDy t1Lt2 c1Lb1 b2Lc2 xt1B xt2B Df Cf.
have RyP : 0 < Rabs y by split_Rabs; lra.
have CDfg t : t1 <= t <= t2 ->continuous (Derive (f \o g)) t.
  move=> tB.
  have : continuous (fun x => Derive g x * Derive f (g x)) t.
    apply: continuous_mult.
      apply: (continuous_ext (fun _ => y)) => [v//|].
      by apply: continuous_const.
    apply: continuous_comp => //.
    apply: Cf.
    by rewrite /g; nra.
  apply: continuous_ext_loc.
  have K2 a b c : 0 < a -> b < c / a -> a * b < c.
    move=> aP abLc.
    rewrite (_ : c =  a * (c / a)).
      by apply: Rmult_lt_compat_l.
    by field; lra.
  have gtB : b1 <= g t <= b2 by rewrite /g; nra.
  pose eps := Rmin (Rabs ((c1 - g t)/ y))
                   (Rabs ((c2 - g t)/ y)).
  have epsP : 0 < eps by
  apply: Rmin_glb_lt; rewrite Rabs_div //;
  apply: Rdiv_lt_0_compat; split_Rabs; lra.
  exists (mkposreal _ epsP) => u /= Hu.
  have uB : c1 < g u < c2.
    have F u1 u2 u3 : u1 < Rmin u2 u3 -> (u1 < u2 /\ u1 < u3).
      by rewrite /Rmin; case: Rle_dec; lra.
    have /F[F1 F2] : Rabs (u - t) < eps by apply: Hu.
    split.
      suff : Rabs (g t - g u) < Rabs (c1 - g t) by split_Rabs; lra.
      have -> : g t - g u = y * (t - u)  by rewrite /g; lra.
      rewrite Rabs_mult.
      apply: K2 => //.
      by rewrite -Rabs_div // Rabs_minus_sym.
    suff : Rabs (g t - g u) < Rabs (c2 - g t) by split_Rabs; lra.
    have -> : g t - g u = y * (t - u)  by rewrite /g; lra.
    rewrite Rabs_mult.
    apply: K2 => //.
    by rewrite -Rabs_div // Rabs_minus_sym.
  rewrite [RHS]Derive_comp //.
  by apply: Df; lra.
rewrite (_ : _ - _ = (f \o g) t2 - (f \o g) t1); last first.
  by rewrite /g; congr (_ - f _); ring.
rewrite -RInt_Derive; last 2 first.
  move=> t; rewrite Rmin_left // Rmax_right // => tB.
  apply: ex_derive_comp => //.
    by apply: Df; rewrite /g; nra.
  move=> t; rewrite Rmin_left // Rmax_right // => tB //.
  by exact: CDfg.
rewrite -[RHS](@RInt_scal RC); last first.
  apply: ex_RInt_continuous => t; rewrite Rmin_left // Rmax_right //.
  by exact: CDfg.
apply: RInt_ext; rewrite Rmin_left // Rmax_right // => u Hu.
rewrite [in RHS]Derive_comp => //; last first.
  by apply: Df; rewrite /g; nra.
rewrite Dg /g /scal /= /mult /=; field; lra.
Qed.

Section Sum.

Import GRing.Theory.
Open Scope ring_scope.

Lemma ex_RInt_sum (T : eqType) (P : pred T) (f : T -> R -> R) a b l :
  (forall i, i \in l -> P i -> ex_RInt (f i) a b) ->
  ex_RInt (fun x : R => \sum_(j <- l | P j) f j x)  a b.
Proof.
elim: l => /= [_|c l IH He].
  apply: ex_RInt_ext => [x Hx|].
    by rewrite big_nil.
  by apply: ex_RInt_const.
apply: ex_RInt_ext => [x Hx|].
  by rewrite big_cons.
have [Pc | NPc] := boolP (P c); last first.
  apply: IH => i iIl.
  by apply: He; rewrite inE iIl orbT.
apply: ex_RInt_plus.
  by apply: He => //; rewrite inE eqxx.
apply: IH => i iIl.
by apply: He; rewrite inE iIl orbT.
Qed.

Lemma RInt_sum (T : eqType) (P : pred T) (f : T -> R -> R) a b l :
  (forall i, i \in l -> P i -> ex_RInt (f i) a b) ->
  RInt
    (fun x : R => \sum_(i <- l| P i) (f i x)) a b =
  \sum_(i <- l | P i)
    RInt
      (fun x : R => (f i x)) a b.
Proof.
elim: l => /= [HR|c l IH HR].
  apply: etrans.
    apply: RInt_ext => i Hi.
    by rewrite big_nil.
  by rewrite RInt_const [LHS](@mulr0 [ringType of R]) big_nil.
rewrite big_cons.
apply: etrans.
  apply: RInt_ext => x Hx.
  by rewrite big_cons.
case: (boolP (P c)) => [HP|HNP]; last first.
  apply: IH => i iIl Pi.
  by apply: HR; rewrite ?inE ?iIl ?orbT.
rewrite RInt_plus ?IH => // [i iIl Pi||].
- by apply: HR; rewrite ?inE ?iIl ?orbT.
- by apply: HR; rewrite ?inE ?eqxx.
apply: ex_RInt_sum=> i iIl Pi.
by apply: HR; rewrite ?inE ?iIl ?orbT.
Qed.

End Sum.

Lemma ex_RInt_comp_lin1 f (u v a b : R) :
       ex_RInt f (u * a + v) (u * b + v) ->
       @ex_RInt R_CompleteNormedModule (fun y : R => f (u * y + v)) a b.
Proof.
move=> H.
case: (Req_dec u 0) => [->|/eqP uNz].
  apply: ex_RInt_ext => [x Hx|].
    rewrite [_ * _](@mul0r [ringType of R])
            [_ + _](@add0r [ringType of R]).
     by [].
  by apply: ex_RInt_const.
apply: ex_RInt_ext => [x Hx|].
  rewrite -[RHS](@mulfK _ u); last by [].
  by rewrite mulrC [(_ * u)%RR]mulrC.
apply: ex_RInt_scal.
by apply: ex_RInt_comp_lin.
Qed.

Lemma MVT_le (f : R -> R) (a b : R) (df : R -> R):
   (forall x : R,
     a <= x <= b -> is_derive f x (df x)) ->
   (forall x : R,
     a <= x <= b -> 0 <= df x) ->
   (forall x : R,
      a <= x <= b -> continuity_pt f x) ->
     a <= b -> f a <= f b.
Proof.
move=> H1 H2 H3 aLb.
case: (MVT_gen f a b df) => x;
    rewrite Rmin_left // Rmax_right // => Hx.
- by apply: H1; lra.
- by apply: H3.
rewrite (_ : f b = f b - f a + f a); try lra.
have [Hx1 ->] := Hx.
have := H2 _ Hx1.
nra.
Qed.

Lemma natDivP x y : (0 < y)%nat -> (x %/ y)%nat = (x / y)%nat.
Proof.
move=> yP.
apply: (Nat.div_unique _ _ _ (x %% y)).
 by apply/ssrnat.ltP; rewrite ltn_mod.
by rewrite [(_ * _)%coq_nat]mulnC -[RHS]divn_eq.
Qed.

Lemma Rchar : [char R]%RR =i pred0.
Proof.
case => //= i; rewrite !inE.
by rewrite (@eqr_nat [numDomainType of R] i.+1 0%nat) andbF.
Qed.


Require Import Omega.

(* combinadores de táticas *)

Theorem seq_comb
  : forall (A B : Prop), (((A -> B) -> B) -> B) -> A -> B.
Proof.
  intros A B HImp Ha ; apply HImp ; intros Hab ; apply Hab ; assumption.
Qed.

Theorem chain
  : forall (A B C : Prop), (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
  intros A B C Habc Hab Ha ; apply Habc ; [ assumption | apply Hab ; assumption ].
Qed.

Theorem orElse_example
  : forall (A B C D : Prop), (A -> B) -> C -> ((A -> B) -> C -> (D -> B) -> D) -> A -> D.
Proof.
  intros A B C D Hab Hc H Ha ;
    apply H ; (assumption || intro H1) ;
      apply Hab ; assumption.
Qed.

Lemma try_test
  : forall (A B C D : Prop), (A -> B -> C -> D) -> (A -> B) -> (A -> C -> D).
Proof.
  intros A B C D H H1 HA HC.
  apply H  ; try (assumption || (apply H1 ; assumption)).
Qed.

Inductive even : nat -> Prop :=
| ev_zero : even 0
| ev_ss   : forall n, even n -> even (S (S n)).

Lemma even_100 : even 100.
Proof.
  repeat ((apply ev_ss) || (apply ev_zero)).
Qed.

(** táticas adicionais *)

Lemma one_not_zero : 0 <> 1.
Proof.
  intro ; congruence.
Qed.

Theorem orElse_example1
  : forall (A B C D : Prop), (A -> B) -> C -> ((A -> B) -> C -> (D -> B) -> D) -> A -> D.
Proof.
  intuition.
Qed.

Lemma le_S_cong_omega : forall n m, S n <= S m -> n <= m.
Proof.
  intros n m ; omega.
Qed.

(** tática auto *)

Theorem auto_example1
  : forall (A B C D : Prop), (A -> B) -> C -> ((A -> B) -> C -> (D -> B) -> D) -> A -> D.
Proof.
  auto.
Qed.

Inductive Plus : nat -> nat -> nat -> Prop :=
| PlusZero
  : forall m, Plus 0 m m
| PlusSucc
  : forall n m r,
    Plus n m r ->
    Plus (S n) m (S r).

Example plus_4_3 : Plus 4 3 7.
Proof.
  repeat constructor.
Qed.

Hint Constructors Plus.

Example plus_4_3_auto : Plus 4 3 7.
Proof.
  auto.
Qed.

Lemma plus_complete : forall n m r, Plus n m r -> n + m = r.
Proof.
  induction n ; intros m r H ; inversion H ;
    subst ; clear H ; simpl ; f_equal ; auto.
Qed.

(** programando táticas com Ltac *)

Ltac break_if :=
  match goal with
  | [ |- if ?X then _ else _ ] => destruct X
  end.

Theorem hmm : forall (a b c : bool),
    if a
    then if b
         then True
         else True
    else if c
         then True
         else True.
Proof.
  intros; repeat break_if; constructor.
Qed.

Ltac break_if_inside :=
  match goal with
  | [ |- context[if ?X then _ else _] ] => destruct X
  end.

Theorem hmm2 : forall (a b : bool),
    (if a then 42 else 42) = (if b then 42 else 42).
Proof.
  intros; repeat break_if_inside; reflexivity.
Qed.

Ltac simple_tauto :=
  repeat match goal with
         | [ H : ?P |- ?P ] => exact H
         | [ |- True ] => constructor
         | [ |- _ /\ _ ] => constructor
         | [ |- _ -> _ ] => intro
         | [ H : False |- _ ] => destruct H
         | [ H : _ /\ _ |- _ ] => destruct H
         | [ H : _ \/ _ |- _ ] => destruct H
         | [ H1 : ?P -> ?Q, H2 : ?P |- _ ] => apply H1 in H2
         end.

Lemma simple_example : forall A B C, (A -> B) -> (B -> C) -> A -> C.
Proof.
  simple_tauto.
Qed.


Require Import Frap Pset9Sig.
(** * 6.822 Formal Reasoning About Programs, Spring 2020 - Pset 9 *)

(* Authors: Adam Chlipala (adamc@csail.mit.edu),
 * Peng Wang (wangpeng@csail.mit.edu) *)

(* The Forgetful Loop Rule
 *
 * In this pset, we explore a different proof rule for loops, which combines
 * some of the nifty small-footprint reasoning of the frame rule.  Specifically,
 * we consider loops where we traverse linked data structures, *forgetting*
 * about nodes as we pass through them, narrowing our focus to just the subsets
 * of nodes that future loop iterations might touch.  Recall how, to prove
 * linked-list length, we needed to do some grunt work with a predicate for
 * linked-list segments, even though the function will never again access the
 * segments described in the loop invariant.  The forgetful loop rule will allow
 * us to skip the segments and write a loop invariant the matches the overall
 * function specification. *)

(* From the Sig file:
Inductive hoare_triple : forall {result}, assertion -> cmd result -> (result -> assertion) -> Prop :=
(* First, some basic rules that look exactly the same as before *)
| HtReturn : forall P {result : Set} (v : result),
    hoare_triple P (Return v) (fun r => P * [| r = v |])%sep
| HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
    hoare_triple P c1 Q
    -> (forall r, hoare_triple (Q r) (c2 r) R)
    -> hoare_triple P (Bind c1 c2) R

(* THIS RULE IS DIFFERENT. *)
| HtLoop : forall {acc res : Set} (init : acc) (body : acc -> cmd (loop_outcome acc res)) P Q,
    (* As before, the premise forces us to consider any accumulator at the start
     * of a loop iteration, proving a Hoare triple for each case. *)
    (forall acc,
        (* Important difference: now the rule is parameterized over both a
         * precondition [P] and a postcondition [Q], each of which takes, as an
         * extra argument, the latest accumulator value. *)
        hoare_triple (P acc) (body acc)
                     (fun r =>
                        match r with
                        | Done res =>
                          Q acc res
                          (* The loop is done?  Then the postcondition had
                           * better be satisfied directly.  Note that it takes
                           * the "before" and "after" accumulators as arguments.
                           * We'll see shortly why that pays off.... *)
                        | Again acc' =>
                          (* It's time for more iterations?  Then we'd better
                           * satisfy [P] w.r.t. the "after" accumulator, but
                           * with a twist.  We are allowed to *forget* some
                           * state, captured by the arbitrary frame predicate
                           * [R].  The idea is that the state we shunt into [R]
                           * will not be touched again until the loop finishes
                           * running. *)
                          exists R, P acc' * R
                                    (* There is another important requirement on
                                     * [R]: Assume that the loop finishes, so
                                     * that the postcondition [Q] is satisfied
                                     * w.r.t. the new accumulator [acc'].  If we
                                     * *put back* [R], we should then arrive at
                                     * a state where the postcondition is
                                     * satisfied w.r.t. the "before" accumulator
                                     * [acc]! *)
                                    * [| forall r, Q acc' r * R ===> Q acc r |]
                        end%sep))
    -> hoare_triple (P init) (Loop init body) (Q init)
(* All that may be a bit abstract, but we will show an example
 * verification below, to illustrate. *)

| HtFail : forall {result},
    hoare_triple (fun _ => False) (Fail (result := result)) (fun _ _ => False)

| HtRead : forall a R,
    hoare_triple (exists v, a |-> v * R v)%sep (Read a) (fun r => a |-> r * R r)%sep
| HtWrite : forall a v v',
    hoare_triple (a |-> v)%sep (Write a v') (fun _ => a |-> v')%sep
| HtAlloc : forall numWords,
    hoare_triple emp%sep (Alloc numWords) (fun r => [| r <> 0 |] * r |--> zeroes numWords)%sep
(* ----------------------------------------------------^^^^^^
 * DIFFERENCE FROM CLASS: Now we record that a freshly allocated object has
 * a nonnull address, so that we are free to use null (0) for a special purpose
 * in linked data structures. *)

| HtFree : forall a numWords,
    hoare_triple (a |->? numWords)%sep (Free a numWords) (fun _ => emp)%sep

| HtConsequence : forall {result} (c : cmd result) P Q (P' : assertion) (Q' : _ -> assertion),
    hoare_triple P c Q
    -> P' ===> P
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple P' c Q'
| HtFrame : forall {result} (c : cmd result) P Q R,
    hoare_triple P c Q
    -> hoare_triple (P * R)%sep c (fun r => Q r * R)%sep.

Notation "{{ P }} c {{ r ~> Q }}" :=
  (hoare_triple P%sep c (fun r => Q%sep)) (at level 90, c at next level).
*)

(** * EXAMPLE VERIFICATION: linked-list length revisited *)

(* First, here's essentially the same list-predicate definition from class. *)

Fixpoint llist' (ls : list nat) (p : nat) : hprop :=
  match ls with
  | nil => [| p = 0 |]
  | x :: ls' => [| p <> 0 |] * exists p', p |--> [x; p'] * llist' ls' p'
  end%sep.

(* Let's define a less precise version, which forgets exactly which data a list
 * stores, only remembering that there is indeed a list rooted at [p]. *)
Definition llist (p : nat) :=
  (exists ls, llist' ls p)%sep.
(* In general with this pset, we'll work with less precise predicates like this
 * [llist], to give you a bit of a break! *)

(* We can prove some logical equivalences on our predicates. *)

Lemma llist'_null : forall {ls p}, p = 0
  -> llist' ls p === [| ls = nil |].
Proof.
  heq; cases ls; cancel.
Qed.

Theorem llist_null : forall p, p = 0
  -> llist p === emp.
Proof.
  unfold llist; simplify.
  setoid_rewrite (llist'_null H).
  (* setoid_rewrite does not support "with", just positional arguments *)
  heq; cancel.
Qed.

Lemma llist'_nonnull : forall {ls p}, p <> 0
  -> llist' ls p === exists ls' x p', [| ls = x :: ls' |] * p |--> [x; p'] * llist' ls' p'.
Proof.
  heq; cases ls; cancel.
  equality.
  invert H0; cancel.
Qed.

Theorem llist_nonnull : forall {p}, p <> 0
  -> llist p === exists x p', p |--> [x; p'] * llist p'.
Proof.
  unfold llist; simplify.
  setoid_rewrite (llist'_nonnull H).
  heq; cancel.
Qed.

Opaque llist.
(* It's important that we mark [llist] as opaque after we've finished proving
 * the lemmas, so that its definition is never again unfolded.  Rather, we
 * reason about it only with the two lemmas we proved for it. *)

(* Now here's linked-list length again. *)
Definition llength (p : nat) :=
  for a := (p, 0) loop
    if fst a ==n 0 then
      Return (Done (snd a))
    else
      y <- Read (fst a + 1);
      Return (Again (y, snd a + 1))
  done.

(* And here's the simpler proof. However, this time around, we
 * don't prove any functional correctness. We only confirm
 * the absence of memory errors and that if a [llength] call finishes,
 * [p] still points to some linked list.
 *)
Theorem llength_ok : forall p,
  {{llist p}}
    llength p
  {{_ ~> llist p}}.
Proof.
  unfold llength.
  simp.
  (* We have reached the loop, and it's time to pick an invariant.  The
   * forgetful loop rule asks for both a precondition and a postcondition, so
   * the [loop_inv] tactic takes both as separate arguments. *)
  loop_inv (fun a : nat * nat => llist (fst a))
           (fun (a : nat * nat) (_ : nat) => llist (fst a)).
    (* We can use the most natural invariant: there is a list rooted at the first
     * component of the accumulator [a]. *)
  -
    cases (a ==n 0).
    + step.
      cancel.
    + rewrite llist_nonnull by assumption.
      step.
      step.
      simp.
      step.
      (* Here's where we encounter the extra quantified [R] from the forgetful loop
       * rule.  The automation isn't quite smart enough to pick a good [R] for us,
       * and anyway we might prefer to be in control of what we forget!  We use the
       * lemma [exis_right] to manually instantiate an existential quantifier
       * immediately to the right of [===>]. *)
      apply exis_right with (x := ((a+1) |-> r * exists n0, a |-> n0)%sep).
      (* The right choice in this case: forget the list cell that [a] points to.  We
       * are done with this cell and can continue the loop using only the cells that
       * follow it. *)
      cancel.
      rewrite (llist_nonnull n).
      (* We specify the hypothesis [n] of [llist_nonnull] so that Coq chooses to
       * rewrite the correct occurrence of [llist] in the goal.  Try without that
       * detail and watch Coq make the wrong choice! *)
      cancel.
  - cancel.
  - cancel.
Qed.

(** * Binary trees *)

(* Now we define binary trees and ask you to verify two of their classic
 * operations. This verification task only concerns memory safety, not
   functional correctness -- which you already tackled in pset 4! *)

(*
Inductive tree :=
| Leaf
| Node (l : tree) (x : nat) (r : tree).
*)

(* [m] for memory! *)
Fixpoint mtree' (t : tree) (p : nat) : hprop :=
  match t with
  | Leaf => [| p = 0 |]
  | Node l x r => [| p <> 0 |]
                  * exists p1 p2, p |--> [p1; x; p2]
                                  * mtree' l p1
                                  * mtree' r p2
  end%sep.

(* Here's the version that forgets exactly which tree it is. *)
Definition mtree (p : nat) : hprop :=
  (exists t, mtree' t p)%sep.

(* And here's an extra layer of indirection: a mutable pointer to a tree, which
 * comes in handy for operations that modify the tree. *)
Definition mtreep (p : nat) : hprop :=
  (exists p', [| p <> 0 |] * p |-> p' * mtree p')%sep.

(* Your task: verify the lookup and insertion methods below.
 *
 * Before diving into the proof hacking, it might be a good idea to review the
 * relevant material from the lecture. To help you do that, we suggest that you
 * briefly answer each of the questions below. This exercise is not graded, but
 * we hope it will help you understand the material better.
 * We will also reference this list in office hours to see where you
 * might be stuck.
 *
 * - What does A * B mean?
 *
 * - What does h === g mean?
 *
 * - What does [| P |] do? (When is it necessary?)
 *
 * - What does p |--> [x;y] mean?
 *
 * - What does emp mean?
 *
 * - What memory does an empty llist use?
 *
 * - How can code detect that an llist is empty?
 *
 * - What memory does an llist cons cell use?
 *
 * - How can code detect that an llist starts with a cons cell?
 *
 * - If an llist starts with a cons cell, which lemma/theorem can we use to learn something about its tail, and what does it tell us?
 *
 * - What is the difference between llist' and llist?
 *
 * - How do proofs of lemmas about llist use lemmas about llist'?
 *
 * (extra pedantry:)
 *
 * - Have you read the proof of llength_ok?
 *
 * - Have you stepped through the proof of llength_ok?
 *
 * - Have you read the goal before and after every commented tactic invocation in llength_ok?
 *
 * Now proving correctness of binary-tree manipulation shouldn't be too bad. Cheers!
*)

(* IMPORTANT NOTE:
 * The difficulty of this problem set is scoped assuming you will use the
 * tactics included in the Sig file, which are very similar to the ones from
 * lecture!  Trying to attack these proofs from first principles will likely
 * lead to proof size spiraling out of control. The main ingredients you should
 * expect to reuse are:
 *  - [step]: A tactic to choose the right Hoare-logic rule to apply next, when
 *    your goal is a Hoare triple
 *  - [cancel]: A tactic to prove an implication between two separation-logic
 *    assertions, or reduce it to a simpler implication by *cancel*ing matching
 *    subformulas; before calling [cancel], be sure you have marked [Opaque]
 *    all of the predicates standing for data structures!  There is an [Opaque
 *    mtree] command right below for precisely this reason; please put any lemmas
 *    about [mtree] before it and all program logic proofs after.
 *  - [heq]: A tactic to reduce a separation-logic assertion implication (using
 *    [===]) to two implications (using [===>])
 *  - [loop_inv P0 Q0]: A tactic to apply the loop rule, given an invariant
 *    split in a peculiar way; see above for an example
 *  - [setoid_rewrite H]: A tactic to rewrite within a separation-logic
 *    implication, using an equivalence that applies to one of its subterms
 *
 * Our solution also has a few direct uses of rules [HtConsequence] and
 * [HtFrame], sometimes using the [with] syntax of [apply] to specify values
 * for some variables that appear in these rules' statements. In particular,
 * you can use [HtConsequence] before [HtFrame] to ensure that the predicate
 * that you want to frame out is in the desired syntactic position so that
 * [HtFrame] will apply. The [exis_right] lemma will also be handy, as used
 * in the example above. *)

(* Space is provided here for additional lemmas about [mtree] and [mtree']. *)

Opaque mtree.
(* ^-- Keep predicates opaque after you've finished proving all the key
* algebraic properties about them, in order for them to work well with
* the [cancel] tactic. *)

(* Here's the usual lookup operation. *)
Definition lookup (x p : nat) :=
  t <- Read p; (* First peel away the initial layer of indirection.
                * You will want to use the regular old frame rule to forget
                * about some of the state that you won't need after this
                * point! *)
  for a := t loop
    (* The accumulator tells us: the node of the tree we have reached
     * (for [Again]) or whether the key [x] has been found (for [Done]). *)
    if a ==n 0 then
      (* Oh, the pointer is null.  Sorry, didn't find [x]. *)
      Return (Done false)
    else
      (* Read the data value of the current node (which must be nonnull). *)
      y <- Read (a + 1);
      if x ==n y then
        (* Found it! *)
        Return (Done true)
      else if x <=? y then
        (* The key must be earlier in the tree.  Read the left-child pointer and
         * continue looping with it. *)
        l <- Read a;
        Return (Again l)
      else
        (* The key must be later in the tree.  Read the right-child pointer and
         * continue looping with it. *)
        r <- Read (a + 1 + 1);
        (* Why [+ 1 + 1] instead of [+ 2]?  It happens to work better with the
         * automation we're using. ;) *)
        Return (Again r)
  done.

Theorem lookup_ok : forall x p,
  {{mtreep p}}
    lookup x p
  {{_ ~> mtreep p}}.
Proof.
Admitted.

(* And here's the operation to add a new key to a tree. *)
Definition insert (x p : nat) :=
  for a := p loop
    (* Note that now the accumulator is not the latest tree root, but instead
     * *a pointer to it*, so that we may overwrite that pointer if necessary.
     * We start by reading the actual root out of the pointer [p]. *)
    q <- Read a;
    if q ==n 0 then
      (* It's a null pointer?  Perfect.  This is the spot to insert a new
       * node. *)
      node <- Alloc 3;
      (* Initialize its data field with [x]. *)
      _ <- Write (node + 1) x;
      (* Redirect the pointer [p] to the new node. *)
      _ <- Write a node;
      Return (Done tt)
    else
      (* Nonnull?  Read the data field into [y]. *)
      y <- Read (q + 1);
      if x <=? y then
        (* The right spot to insert must be to the left.  Recurse thataway. *)
        Return (Again q)
      else
        (* The right spot to insert must be to the right.  Recurse thataway. *)
        Return (Again (q + 1 + 1))
  done.

(* Something very subtle happened in that loop: we iterated using a pointer into
 * *the interior of a struct*, in each branch of the last [if]!  This is a fun
 * example of the kinds of tricks that can be played in a low-level language,
 * and the verification techniques are up to the challenge. *)

Theorem insert_ok : forall x p,
  {{mtreep p}}
    insert x p
  {{_ ~> mtreep p}}.
Proof.
Admitted.

(* Our solution also includes a proof that the Hoare triples in this pset
 * correspond to the usual operational semantics... which you do not need
 * to prove. *)


Require Export Iron.Language.SystemF2Cap.Type.Exp.
Require Export Iron.Language.SystemF2Cap.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Cap.Type.Operator.LowerTT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.WfT.

(********************************************************************)
(* Substitution of Types in Types. *)
Fixpoint substTT (d: nat) (u: ty) (tt: ty) : ty
 := match tt with
    | TVar ix
    => match nat_compare ix d with
       | Eq          => u
       | Gt          => TVar (ix - 1)
       | _           => TVar  ix
       end

    |  TForall k t   => TForall k (substTT (S d) (liftTT 1 0 u) t)
    |  TApp t1 t2    => TApp      (substTT d u t1) (substTT d u t2)
    |  TSum t1 t2    => TSum      (substTT d u t1) (substTT d u t2)
    |  TBot k        => TBot k

    | TCon0 tc       => TCon0 tc
    | TCon1 tc t1    => TCon1 tc  (substTT d u t1)
    | TCon2 tc t1 t2 => TCon2 tc  (substTT d u t1) (substTT d u t2)
    | TCap _         => tt
  end.

(********************************************************************)
(* What might happen when we substitute for a variable.
   This can be easier use than the raw substTT definition. *)
Lemma substTT_TVar_cases
 :  forall n1 n2 t1
 ,  (substTT n1 t1 (TVar n2) = t1            /\ n1 = n2)
 \/ (substTT n1 t1 (TVar n2) = TVar (n2 - 1) /\ n1 < n2)
 \/ (substTT n1 t1 (TVar n2) = TVar n2       /\ n1 > n2).
Proof.
 intros.
 unfold substTT.
  lift_cases; burn.
Qed.

Lemma substTT_wfT_above
 :  forall d ix t t2
 ,  WfT d t
 -> substTT (d + ix) t2 t = t.
Proof.
 intros. gen d ix t2.
 induction t; rip; inverts H; simpl; f_equal; burn.

 Case "TVar".
  norm; omega.
  lets D: IHt H1. burn.
Qed.
Hint Resolve substTT_wfT_above.

Lemma substTT_wfT
 :  forall d ix t1 t2
 ,  ix <= d
 -> WfT (S d) t1
 -> WfT d     t2
 -> WfT d (substTT ix t2 t1).
Proof.
 intros. gen d ix t2.
 induction t1; rip; inverts H0; simpl; snorm.
Qed.
Hint Resolve substTT_wfT.

(* Closing substitution of types in types *)
Lemma substTT_closing
 :  forall t1 t2
 ,  WfT 1 t1
 -> ClosedT t2
 -> ClosedT (substTT 0 t2 t1).
Proof. eauto. Qed.
Hint Resolve substTT_closing.

Lemma substTT_closedT_id
 :  forall d t t2
 ,  ClosedT t
 -> substTT d t2 t = t.
Proof.
 intros. rrwrite (d = d + 0). eauto.
Qed.
Hint Resolve substTT_closedT_id.

Lemma substTT_liftTT_wfT1
 :  forall t1 t2
 ,  WfT 1 t1
 -> ClosedT t2
 -> substTT 0 t2 t1 = liftTT 1 0 (substTT 0 t2 t1).
Proof.
 intros.
 have    (ClosedT (substTT 0 t2 t1)).
 rrwrite (liftTT 1 0 (substTT 0 t2 t1) = substTT 0 t2 t1).
 trivial.
Qed.
Hint Resolve substTT_liftTT_wfT1.

(* Substituting into TBot is still TBot. *)
Lemma substTT_TBot
 : forall d t2 k
 , substTT d t2 (TBot k) = TBot k.
Proof. burn. Qed.
Hint Resolve substTT_TBot.
Hint Rewrite substTT_TBot : global.


Require Import Setoid.

Parameter A : Set.

Axiom eq_dec : forall a b : A, {a = b} + {a <> b}.

Inductive set : Set :=
  | Empty : set
  | Add : A -> set -> set.

Fixpoint In (a : A) (s : set) {struct s} : Prop :=
  match s with
  | Empty => False
  | Add b s' => a = b \/ In a s'
  end.

Definition same (s t : set) : Prop := forall a : A, In a s <-> In a t.

Lemma setoid_set : Setoid_Theory set same.

unfold same in |- *; split ; red.
red in |- *; auto.

red in |- *.
intros.
elim (H a); auto.

intros.
elim (H a); elim (H0 a).
split; auto.
Qed.

Add Setoid set same setoid_set as setsetoid.

Add Morphism In : In_ext.
unfold same in |- *; intros a s t H; elim (H a); auto.
Qed.

Lemma add_aux :
 forall s t : set,
 same s t -> forall a b : A, In a (Add b s) -> In a (Add b t).
unfold same in |- *; simple induction 2; intros.
rewrite H1.
simpl in |- *; left; reflexivity.

elim (H a).
intros.
simpl in |- *; right.
apply (H2 H1).
Qed.

Add Morphism Add : Add_ext.
split; apply add_aux.
assumption.

rewrite H.
reflexivity.
Qed.

Fixpoint remove (a : A) (s : set) {struct s} : set :=
  match s with
  | Empty => Empty
  | Add b t =>
      match eq_dec a b with
      | left _ => remove a t
      | right _ => Add b (remove a t)
      end
  end.

Lemma in_rem_not : forall (a : A) (s : set), ~ In a (remove a (Add a Empty)).

intros.
setoid_replace (remove a (Add a Empty)) with Empty.

auto.

unfold same in |- *.
split.
simpl in |- *.
case (eq_dec a a).
intros e ff; elim ff.

intros; absurd (a = a); trivial.

simpl in |- *.
intro H; elim H.
Qed.

Parameter P : set -> Prop.
Parameter P_ext : forall s t : set, same s t -> P s -> P t.

Add Morphism P : P_extt.
intros; split; apply P_ext; (assumption || apply (Seq_sym _ _ setoid_set); assumption).
Qed.

Lemma test_rewrite :
 forall (a : A) (s t : set), same s t -> P (Add a s) -> P (Add a t).
intros.
rewrite <- H.
rewrite H.
setoid_rewrite <- H.
setoid_rewrite H.
setoid_rewrite <- H.
trivial.
Qed.

(* Unifying the domain up to delta-conversion (example from emakarov) *)

Definition id: Set -> Set := fun A => A.
Definition rel : forall A : Set, relation (id A) := @eq.
Definition f: forall A : Set, A -> A := fun A x => x.

Add Relation (id A) (rel A) as eq_rel.

Add Morphism (@f A) : f_morph.
Proof.
unfold rel, f. trivial.
Qed.

(* Submitted by Nicolas Tabareau *)
(* Needs unification.ml to support environments with de Bruijn *)

Goal forall
  (f : Prop -> Prop)
  (Q : (nat -> Prop) -> Prop)
  (H : forall (h : nat -> Prop), Q (fun x : nat => f (h x)) <-> True)
  (h:nat -> Prop),
  Q (fun x : nat => f (Q (fun b : nat => f (h x)))) <-> True.
intros f0 Q H.
setoid_rewrite H.
tauto.
Qed.

(** Check proper refreshing of the lemma application for multiple
   different instances in a single setoid rewrite. *)

Section mult.
  Context (fold : forall {A} {B}, (A -> B) -> A -> B).
  Context (add : forall A, A -> A).
  Context (fold_lemma : forall {A B f} {eqA : relation B} x, eqA (fold A B f (add A x)) (fold _ _ f x)).
  Context (ab : forall B, A -> B).
  Context (anat : forall A, nat -> A).

Goal forall x, (fold _ _ (fun x => ab A x) (add A x) = anat _ (fold _ _ (ab nat) (add _ x))).
Proof. intros.
  setoid_rewrite fold_lemma.
  change (fold A A (fun x0 : A => ab A x0) x = anat A (fold A nat (ab nat) x)).
Abort.

End mult.

(** Current semantics for rewriting with typeclass constraints in the lemma
   does not fix the instance at the first unification, use [at], or simply rewrite for
   this semantics. *)

Require Import Arith.

Class Foo (A : Type) := {foo_neg : A -> A ; foo_prf : forall x : A, x = foo_neg x}.
Instance: Foo nat. admit. Defined.
Instance: Foo bool. admit. Defined.

Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y.
Proof. intros. setoid_rewrite <- foo_prf. change (beq_nat x 0 = y). Abort.

Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y.
Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y). Abort.


Lemma impl_and_iff {A B C} : (A -> (B /\ C)) <-> ((A -> B) /\ (A -> C)).
Proof. tauto. Qed.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import codegen.codegen primitivity nat_word BinNat.
Require mt cycle.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section gluing.
Local Open Scope N_scope.

Notation len := 624. (* 'n' in tgfsr3.pdf, p.4 is 623*)
Notation m := 397. (* 'm' in  tgfsr3.pdf, p.4 *)
Notation w := 32.
Notation r := 31.
Notation u := 11.
Notation s := 7.
Notation t := 15.
Notation l := 18.
Notation a := 2567483615.
Notation b := 2636928640.
Notation c := 4022730752.

Definition upper_mask := Eval compute in @mt.upper_mask r w erefl.
Definition lower_mask := Eval compute in @mt.lower_mask r w erefl.
Definition whole_mask :=
Eval compute in N_of_word (Tuple (@introTF _ _ true eqP (size_rep (1%R: 'F_2) w))).
Definition set_nth d xs n := Eval compute in @set_nth N d xs n.
Definition nth d xs n := Eval compute in @nth N d xs n.
Definition next_random_state (rand : mt.random_state) :=
let state_vec := mt.state_vector rand in
let ind := mt.index rand in
let current := nth 0 state_vec ind in
let next_ind := N.succ ind mod len in
let next := nth 0 state_vec next_ind in
let far_ind := (ind + m) mod len in
let far := nth 0 state_vec far_ind in
let z := N.lor (N.land current upper_mask) (N.land next lower_mask) in
let xi := N.lxor (N.lxor far (N.shiftr z 1)) (if N.testbit z 0 then a else 0) in
let next_rand :=
  {| mt.index := next_ind; mt.state_vector := set_nth 0 state_vec ind xi |} in
(xi, next_rand).

Lemma next_random_stateE2 :
  next_random_state =1 @mt.next_random_state len m r a w erefl.
Proof. by []. Qed.

Definition tempering xi :=
  let y1 := N.lxor xi (N.shiftr xi u) in
  let y2 := N.lxor y1 (N.land (N.shiftl y1 s) b) in
  let y3 := N.lxor y2 (N.land (N.shiftl y2 t) c) in
  let y4 := N.lxor y3 (N.shiftr y3 l) in
  y4.
Lemma temperingE : tempering =1 mt.tempering u s t l b c.
Proof. by []. Qed.

Definition cycle_next_random_state :=
  @cycle.cycle_next_random_state w len (len - m) r (word_of_N w a) pm
                                 erefl erefl erefl erefl erefl.
End gluing.

CodeGen Snippet "#include <stdbool.h> /* for bool, true and false */".

CodeGen Inductive Type bool => "bool".
CodeGen Inductive Match bool => ""
| true => "default"
| false => "case 0".
CodeGen Constant true => "true".
CodeGen Constant false => "false".

CodeGen Snippet "#include <stdint.h>".
CodeGen Snippet "#include <stdio.h>".
CodeGen Snippet "typedef uint64_t nat;".
CodeGen Snippet "typedef uint32_t positive;".
CodeGen Snippet "typedef uint32_t N;".
CodeGen Snippet "#define succ(n) ((n)+1)".
CodeGen Snippet "#define succn(n) ((n)+1)".
CodeGen Snippet "#define predn(n) ((n)-1)".
CodeGen Snippet "#define xH() (1)".
CodeGen Snippet "#define xO(n) (2*(n))".
CodeGen Snippet "#define xI(n) (2*(n)+1)".
CodeGen Snippet "#define add(n, m) ((n) + (m))".
CodeGen Snippet "#define subn(n, m) ((n) - (m))".
CodeGen Snippet "#define modulo(n, m) ((n) % (m))".
CodeGen Snippet "#define lxor(n, m) ((n) ^ (m))".
CodeGen Snippet "#define lor(n, m) ((n) | (m))".
CodeGen Snippet "#define land(n, m) ((n) & (m))".
CodeGen Snippet "#define testbit(n1,n2) ((n1)&(1<<(n2)))".
CodeGen Snippet "#define nat_of_bin(n) ((nat)(n))".
CodeGen Snippet "#define N0() (0)".
CodeGen Snippet "#define Npos(n) ((nat)(n))".
CodeGen Snippet "#define shiftl(n1,n2) ((n1)<<(n2))".
CodeGen Snippet "#define shiftr(n1,n2) ((n1)>>(n2))".

CodeGen Inductive Type nat => "nat".
CodeGen Inductive Match nat => ""
| O => "case 0"
| S => "default" "predn".
CodeGen Primitive S => "succn".

CodeGen Snippet "#define LARGE_NUM 1000".
CodeGen Snippet "
typedef struct {
  N list[LARGE_NUM];
  int index;
} list_N;
".

CodeGen Snippet "
typedef struct {
  N index;
  list_N state_vector;
} rand_state;
".

CodeGen Snippet "
rand_state Build_random_state(N index, list_N list) {
  rand_state r = {index,list};
  return r;
}
".

CodeGen Snippet "#define INDEX(x)        ((x).index)".
CodeGen Snippet "#define STATE_VECTOR(x) ((x).state_vector)".

CodeGen Inductive Type mt.random_state => "rand_state".
CodeGen Primitive mt.index => "INDEX".
CodeGen Primitive mt.state_vector => "STATE_VECTOR".

CodeGen Snippet "
typedef struct {
  nat fst;
  rand_state snd;
} prodNrnd;
".
CodeGen Snippet "#define make_prodNrnd(x, y) ((prodNrnd){ (x), (y) })".

CodeGen Inductive Type N * mt.random_state => "prodNrnd".
CodeGen Primitive pair N mt.random_state => "make_prodNrnd".

CodeGen Snippet "
N nth(N default_value, list_N l, N index) {
  return l.list[index];
}
".

CodeGen Snippet "
list_N set_nth(N default_value, list_N l, N index, N value) {
  l.list[index] = value;
  return l;
}
".

CodeGen Function lower_mask.
CodeGen Function upper_mask.
CodeGen Function next_random_state.
CodeGen Function tempering.

CodeGen Snippet "
rand_state initialize_random_state(int s)
{
    static list_N mt;
    int mti;
    mt.list[0]= s & 0xffffffffUL;
    for (mti=1; mti<LARGE_NUM; mti++) {
        mt.list[mti] =
	    (1812433253UL * (mt.list[mti-1] ^ (mt.list[mti-1] >> 30)) + mti);
        mt.list[mti] &= 0xffffffffUL;
    }
    return Build_random_state(0, mt);
}
".

CodeGen Snippet "
int main(void) {
  int seed = 20190820;
  rand_state r = initialize_random_state(seed);
  int i;
  for (i = 0; i < 2048; ++i) {
    prodNrnd p = next_random_state(r);
    printf(""%d:%u\n"", i, tempering(p.fst));
    r = p.snd;
  }
  return 0;
}
".

CodeGen GenerateFile "./mt19937_generated.c".


Require Import FMapPositive.
Require Import NArith.
Require Import ZArith.

Require Word.

(** Vectors (that is, arrays)  *)
Section t.
  Variable length : nat.
  Variable X  : Type.
  Definition T := Word.T length ->  X.

  Definition set  (v : T) (j: Word.T length) (x: X) : T :=
    fun i => if Word.eqb i j then x else v i.

  Definition get (v: T) (i : Word.T length) : X :=
    v i.

  Lemma gso (v : T)  i j x:
    Word.eqb i j = false ->
    get (set v i x) j = get v j.
  Proof.
    intros; unfold get, set. simpl.
    replace (Word.eqb j i) with (Word.eqb i j). rewrite H. auto.
    rewrite (Bool.eq_iff_eq_true). rewrite ? Word.eqb_correct. intuition.
  Qed.

  Lemma gss v i j x:
    Word.eqb i j = true ->
    get (set v i x) j = x.
  Proof.
    unfold get, set. intros.
    replace (Word.eqb j i) with (Word.eqb i j). rewrite H. auto.
    rewrite (Bool.eq_iff_eq_true). rewrite ? Word.eqb_correct. intuition.
  Qed.
End t.

Arguments get {length X} _ _.
Arguments set {length X} _ _ _ _.


(* Collect lemmas that are missing from the Coq stdlib and describe the
   Ensemble-operations as boolean algebra.
   Associativity, idempotence, commutativity, complements, distributivity, …
*)

From Coq.Sets Require Export Powerset_facts.
Require Export EnsemblesImplicit EnsemblesTactics.

Lemma Intersection_Full_set
  {X : Type}
  {U : Ensemble X} :
  Intersection Full_set U = U.
Proof.
now extensionality_ensembles.
Qed.

Lemma Intersection_associative
  {X : Type}
  (U V W: Ensemble X) :
  Intersection (Intersection U V) W = Intersection U (Intersection V W).
Proof.
now extensionality_ensembles.
Qed.


Coq < Section Easy007.

Coq < Require Import Classical.

Coq < Variables C D E: Prop.
C is assumed
D is assumed
E is assumed

Coq < Load CpdtTactics.

Coq < Goal ((C -> D) -> (D -> E)) /\ D -> (C -> E).
1 subgoal

  C : Prop
  D : Prop
  E : Prop
  ============================
   ((C -> D) -> D -> E) /\ D -> C -> E

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined