(* Copyright © 1998-2008
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Cezary Kaliszyk
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
Require Export CoRN.algebra.COrdFields2.

(**
** Properties of [AbsSmall]
*)

(* Begin_SpecReals *)

Definition AbsSmall (R : COrdField) (e x : R) : Prop := [--]e [<=] x /\ x [<=] e.

Arguments AbsSmall [R].

(* End_SpecReals *)

Section AbsSmall_properties.

(**
%\begin{convention}% Let [R] be an ordered field.
%\end{convention}%
*)
Variable R : COrdField.

Lemma AbsSmall_wdr : rel_wdr R (AbsSmall (R:=R)).
Proof.
 unfold rel_wdr in |- *.
 unfold AbsSmall in |- *.
 intros.
 elim H; intros.
 split.
  astepr y.
  assumption.
 astepl y.
 assumption.
Qed.

Lemma AbsSmall_wdr_unfolded : forall x y z : R,
 AbsSmall x y -> y [=] z -> AbsSmall x z.
Proof AbsSmall_wdr.

Lemma AbsSmall_wdl : rel_wdl R (AbsSmall (R:=R)).
Proof.
 unfold rel_wdl in |- *.
 unfold AbsSmall in |- *.
 intros.
 elim H; intros.
 split.
  astepl ([--]x).
  assumption.
 astepr x.
 assumption.
Qed.

Lemma AbsSmall_wdl_unfolded : forall x y z : R,
 AbsSmall x y -> x [=] z -> AbsSmall z y.
Proof AbsSmall_wdl.

Declare Left Step AbsSmall_wdl_unfolded.
Declare Right Step AbsSmall_wdr_unfolded.

(* begin hide *)
Notation ZeroR := ([0]:R).
(* end hide *)

Lemma AbsSmall_leEq_trans : forall e1 e2 d : R,
 e1 [<=] e2 -> AbsSmall e1 d -> AbsSmall e2 d.
Proof.
 unfold AbsSmall in |- *.
 intros.
 elim H0; intros.
 split.
  apply leEq_transitive with ([--]e1).
   apply inv_resp_leEq.
   assumption.
  assumption.
 apply leEq_transitive with e1.
  assumption.
 assumption.
Qed.

Lemma zero_AbsSmall : forall e : R, [0] [<=] e -> AbsSmall e [0].
Proof.
 intros.
 unfold AbsSmall in |- *.
 split.
  astepr ([--]ZeroR).
  apply inv_resp_leEq.
  assumption.
 assumption.
Qed.

Lemma AbsSmall_reflexive : forall (e : R), [0] [<=] e -> AbsSmall e e.
Proof.
 intros.
 unfold AbsSmall.
 split.
  apply leEq_transitive with ([0]:R); auto.
  astepr ([--][0]:R).
  apply inv_resp_leEq.
  auto.
 apply leEq_reflexive.
Qed.

Lemma AbsSmall_trans : forall e1 e2 d : R,
 e1 [<] e2 -> AbsSmall e1 d -> AbsSmall e2 d.
Proof.
 intros.
 apply AbsSmall_leEq_trans with e1.
  apply less_leEq.
  assumption.
 assumption.
Qed.

Lemma leEq_imp_AbsSmall : forall e d : R, [0] [<=] e -> e [<=] d -> AbsSmall d e.
Proof.
 intros.
 unfold AbsSmall in |- *.
 split; try assumption.
 apply leEq_transitive with ZeroR; try assumption.
 astepr ([--]ZeroR).
 apply inv_resp_leEq.
 apply leEq_transitive with e; assumption.
Qed.

Lemma inv_resp_AbsSmall : forall x y : R, AbsSmall x y -> AbsSmall x [--]y.
Proof.
 unfold AbsSmall in |- *.
 intros.
 elim H; intros.
 split.
  apply inv_resp_leEq.
  assumption.
 astepr ([--][--]x).
 apply inv_resp_leEq.
 assumption.
Qed.

Lemma mult_resp_AbsSmall: forall (R: COrdField) (x y e : R) (H: [0][<=]y),
AbsSmall e x -> AbsSmall (y[*]e) (y[*]x).
Proof.
 unfold AbsSmall.
 intros.
 destruct H0.
 split.
  rstepl (y[*]([--]e)).
  apply mult_resp_leEq_lft; auto.
 apply mult_resp_leEq_lft; auto.
Qed.

Lemma div_resp_AbsSmall: forall (R: COrdField) (x y e : R) (H: [0][<]y),
AbsSmall e x -> AbsSmall (e[/]y[//]pos_ap_zero _ _ H) (x[/]y[//]pos_ap_zero _ _ H).
Proof.
 unfold AbsSmall.
 intros.
 destruct H0.
 split.
  rstepl (([--]e)[/]y[//]pos_ap_zero _ _ H).
  apply div_resp_leEq; auto.
 apply div_resp_leEq; auto.
Qed.

Lemma sum_resp_AbsSmall : forall
(x y : nat -> R) (n m: nat)
(H1 : m <= n) (H2 : forall i : nat, m <= i -> i <= n ->  AbsSmall (y i) (x i)),
AbsSmall (Sum m n y) (Sum m n x).
Proof.
 unfold AbsSmall.
 intros.
 assert (H3 : forall i : nat, m <= i -> i <= n ->  [--](y i)[<=]x i).
  intros.
  elim (H2 i H H0). auto.
  assert (H4 : forall i : nat, m <= i -> i <= n ->  x i[<=]y i).
  intros.
  elim (H2 i H H0). auto.
  split.
  astepl (Sum m n (fun k: nat => [--](y k))).
  apply Sum_resp_leEq .
   auto with arith. intros. auto.
  apply Sum_resp_leEq .
  auto with arith. intros. auto.
Qed.

Lemma AbsSmall_minus : forall e x1 x2 : R, AbsSmall e (x1[-]x2) -> AbsSmall e (x2[-]x1).
Proof.
 intros.
 rstepr ([--](x1[-]x2)).
 apply inv_resp_AbsSmall.
 assumption.
Qed.

Lemma AbsSmall_plus : forall e1 e2 x1 x2 : R,
 AbsSmall e1 x1 -> AbsSmall e2 x2 -> AbsSmall (e1[+]e2) (x1[+]x2).
Proof.
 unfold AbsSmall in |- *.
 intros.
 elim H; intros.
 elim H0; intros.
 split.
  rstepl ([--]e1[+][--]e2).
  apply plus_resp_leEq_both; assumption.
 apply plus_resp_leEq_both; assumption.
Qed.

Lemma AbsSmall_eps_div_two : forall e x1 x2 : R,
 AbsSmall (e [/]TwoNZ) x1 -> AbsSmall (e [/]TwoNZ) x2 -> AbsSmall e (x1[+]x2).
Proof.
 intros.
 rstepl (e [/]TwoNZ[+]e [/]TwoNZ).
 apply AbsSmall_plus.
  assumption.
 assumption.
Qed.

Lemma AbsSmall_x_plus_delta : forall x eps delta : R,
 [0] [<=] eps -> [0] [<=] delta -> delta [<=] eps -> AbsSmall eps (x[-] (x[+]delta)).
Proof.
 intros.
 (* astepr ((x[-]x)[-]delta).
 astepr ([0][-]delta). *)
 rstepr ([--]delta).
 apply inv_resp_AbsSmall.
 apply leEq_imp_AbsSmall.
  assumption.
 assumption.
Qed.

Lemma AbsSmall_x_minus_delta : forall x eps delta : R,
 [0] [<=] eps -> [0] [<=] delta -> delta [<=] eps -> AbsSmall eps (x[-] (x[-]delta)).
Proof.
 intros.
 (* astepr ((x[-]x)[+]delta).
 astepr ([0][+]delta). *)
 rstepr delta.
 apply leEq_imp_AbsSmall.
  assumption.
 assumption.
Qed.

Lemma AbsSmall_x_plus_eps_div2 : forall x eps : R, [0] [<=] eps -> AbsSmall eps (x[-] (x[+]eps [/]TwoNZ)).
Proof.
 intros.
 apply AbsSmall_x_plus_delta.
   assumption.
  apply nonneg_div_two.
  assumption.
 apply nonneg_div_two'.
 assumption.
Qed.

Lemma AbsSmall_x_minus_eps_div2 : forall x eps : R, [0] [<=] eps -> AbsSmall eps (x[-] (x[-]eps [/]TwoNZ)).
Proof.
 intros.
 apply AbsSmall_x_minus_delta.
   assumption.
  apply nonneg_div_two.
  assumption.
 apply eps_div_leEq_eps.
  assumption.
 apply less_leEq.
 apply one_less_two.
Qed.

Lemma AbsSmall_intermediate : forall x y z eps : R,
 x [<=] y -> y [<=] z -> AbsSmall eps (z[-]x) -> AbsSmall eps (z[-]y).
Proof.
 intros.
 apply leEq_imp_AbsSmall.
  apply shift_leEq_minus; astepl y.
  assumption.
 unfold AbsSmall in H1.
 elim H1; intros.
 apply leEq_transitive with (z[-]x); try assumption.
 apply minus_resp_leEq_rht.
 assumption.
Qed.

Lemma AbsSmall_eps_div2 : forall eps : R, [0] [<=] eps -> AbsSmall eps (eps [/]TwoNZ).
Proof.
 intros.
 apply leEq_imp_AbsSmall.
  apply nonneg_div_two.
  assumption.
 apply eps_div_leEq_eps.
  assumption.
 apply less_leEq.
 apply one_less_two.
Qed.

Lemma AbsSmall_nonneg : forall e x : R, AbsSmall e x -> [0] [<=] e.
Proof.
 unfold AbsSmall in |- *.
 intros.
 elim H.
 intros.
 cut ([--]e [<=] e).
  intros.
  apply mult_cancel_leEq with (z := Two:R).
   apply pos_two.
  apply plus_cancel_leEq_rht with (z := [--]e).
  rstepl ([--]e).
  rstepr e.
  assumption.
 apply leEq_transitive with (y := x).
  assumption.
 assumption.
Qed.

Lemma AbsSmall_mult : forall e1 e2 x1 x2 : R,
 AbsSmall e1 x1 -> AbsSmall e2 x2 -> AbsSmall (Three[*] (e1[*]e2)) (x1[*]x2).
Proof.
 unfold AbsSmall in |- *.
 intros.
 elim H.
 intros.
 elim H0.
 intros.
 cut ([0] [<=] e1).
  intro.
  cut ([0] [<=] e2).
   intro.
   split.
    apply plus_cancel_leEq_rht with (z := Three[*] (e1[*]e2)).
    rstepl ZeroR.
    rstepr (x1[*]x2[+]e1[*]e2[+]e1[*]e2[+]e1[*]e2).
    apply leEq_transitive with (y := x1[*]x2[+]e1[*]e2[+]x1[*]e2[+]e1[*]x2).
     rstepr ((e1[+]x1)[*](e2[+]x2)).
     apply mult_resp_nonneg.
      apply plus_cancel_leEq_rht with (z := [--]x1).
      rstepl ([--]x1).
      rstepr ([--][--]e1).
      apply inv_resp_leEq.
      assumption.
     apply plus_cancel_leEq_rht with (z := [--]x2).
     rstepl ([--]x2).
     rstepr ([--][--]e2).
     apply inv_resp_leEq.
     assumption.
    rstepl (x1[*]x2[+]e1[*]e2[+](x1[*]e2[+]e1[*]x2)).
    rstepr (x1[*]x2[+]e1[*]e2[+](e1[*]e2[+]e1[*]e2)).
    apply plus_resp_leEq_lft.
    apply plus_resp_leEq_both.
     apply mult_resp_leEq_rht.
      assumption.
     assumption.
    apply mult_resp_leEq_lft.
     assumption.
    assumption.
   apply plus_cancel_leEq_rht with (z := [--](x1[*]x2)).
   rstepl ZeroR.
   rstepr ([--](x1[*]x2)[+]e1[*]e2[+](e1[*]e2[+]e1[*]e2)).
   apply leEq_transitive with (y := [--](x1[*]x2)[+]e1[*]e2[+](x1[*]e2[-]e1[*]x2)).
    rstepr ((e1[+]x1)[*](e2[-]x2)).
    apply mult_resp_nonneg.
     apply plus_cancel_leEq_rht with (z := [--]x1).
     rstepl ([--]x1).
     rstepr ([--][--]e1).
     apply inv_resp_leEq.
     assumption.
    apply plus_cancel_leEq_rht with (z := x2).
    rstepl x2.
    rstepr e2.
    assumption.
   apply plus_resp_leEq_lft.
   rstepl (x1[*]e2[+][--]e1[*]x2).
   apply plus_resp_leEq_both.
    apply mult_resp_leEq_rht.
     assumption.
    assumption.
   rstepl (e1[*][--]x2).
   apply mult_resp_leEq_lft.
    rstepr ([--][--]e2).
    apply inv_resp_leEq.
    assumption.
   assumption.
  apply AbsSmall_nonneg with (e := e2) (x := x2).
  assumption.
 apply AbsSmall_nonneg with (e := e1) (x := x1).
 assumption.
Qed.

Lemma AbsSmall_cancel_mult : forall e x z : R,
 [0] [<] z -> AbsSmall (e[*]z) (x[*]z) -> AbsSmall e x.
Proof.
 unfold AbsSmall in |- *.
 intros.
 elim H.
 intros.
 split.
  apply mult_cancel_leEq with (z := z).
   assumption.
  rstepl ([--](e[*]z)).
  assumption.
 apply mult_cancel_leEq with (z := z).
  assumption.
 assumption.
Qed.

Lemma AbsSmall_approach_zero : forall x : R, (forall e, [0] [<] e -> AbsSmall e x) -> x [=] [0].
Proof.
 intros.
 apply not_ap_imp_eq.
 intro H0.
 elim (ap_imp_less _ _ _ H0).
  change (Not (x [<] [0])).
  rewrite <- leEq_def.
  apply inv_cancel_leEq.
  astepr ZeroR.
  apply approach_zero_weak.
  intros.
  apply inv_cancel_leEq; astepr x.
  elim (H e); auto.
 change (Not ([0] [<] x)).
 rewrite <- leEq_def.
 apply approach_zero_weak.
 intros.
 elim (H e); auto.
Qed.

Lemma mult_AbsSmall'_rht : forall x y C : R, [0] [<=] C ->
 [--]C [<=] x -> x [<=] C -> [--]C [<=] y -> y [<=] C -> x[*]y [<=] Three[*]C[^]2.
Proof.
 intros.
 astepl ([0][+]x[*]y). apply shift_plus_leEq.
 apply leEq_transitive with ((C[+]x)[*](C[-]y)).
  apply mult_resp_nonneg.
   apply shift_leEq_plus. astepl ([--]x). astepr ([--][--]C).
   apply inv_resp_leEq. auto.
   apply shift_leEq_minus. astepl y. auto.
  rstepl (C[^]2[-]x[*]y[+]C[*](x[-]y)).
 rstepr (C[^]2[-]x[*]y[+]C[*](C[-][--]C)).
 apply plus_resp_leEq_lft.
 apply mult_resp_leEq_lft.
  apply minus_resp_leEq_both.
   auto. auto. auto.
Qed.

Lemma mult_AbsSmall_rht : forall x y X Y : R, [0] [<=] X ->
 [0] [<=] Y -> [--]X [<=] x -> x [<=] X -> [--]Y [<=] y -> y [<=] Y -> x[*]y [<=] X[*]Y.
Proof.
 intros.
 rewrite -> leEq_def.
 intro.
 cut ([0] [<] x[*]y); intros.
  2: apply leEq_less_trans with (X[*]Y); auto.
 rewrite -> leEq_def in *.
 cut (x[*]y [#] [0]); intros.
  2: apply pos_ap_zero; auto.
 cut (x [#] [0]); intros.
  2: apply mult_cancel_ap_zero_lft with y; auto.
 elim (ap_imp_less _ _ _ X3); intro.
  cut (y [<] [0]); intros.
   2: astepl ([--][--]y); astepr ([--]([0]:R)); apply inv_resp_less.
   2: apply mult_cancel_pos_rht with ([--]x).
    2: astepr (x[*]y); auto.
   2: astepl ([--]([0]:R)); apply less_leEq; apply inv_resp_less; auto.
  apply (less_irreflexive_unfolded R [1]).
  apply leEq_less_trans with (X[*]Y[/] _[//]X2).
   rstepr ((X[/] [--]x[//]inv_resp_ap_zero _ _ X3)[*]
     (Y[/] [--]y[//]inv_resp_ap_zero _ _ (less_imp_ap _ _ _ X4))).
   astepl ([1][*]([1]:R)).
   apply mult_resp_leEq_both.
      apply less_leEq; apply pos_one.
     apply less_leEq; apply pos_one.
    apply shift_leEq_div.
     astepl ([--]([0]:R)); apply inv_resp_less; auto.
    astepl ([--]x); astepr ([--][--]X); apply inv_resp_leEq; firstorder using leEq_def.
   apply shift_leEq_div.
    astepl ([--]([0]:R)); apply inv_resp_less; auto.
   astepl ([--]y); astepr ([--][--]Y); apply inv_resp_leEq; firstorder using leEq_def.
  apply shift_div_less; auto.
  astepr (x[*]y); auto.
 cut ([0] [<] y); intros.
  2: apply mult_cancel_pos_rht with x; try apply less_leEq; auto.
 apply (less_irreflexive_unfolded R [1]).
 apply leEq_less_trans with (X[*]Y[/] _[//]X2).
  rstepr ((X[/] x[//]X3)[*](Y[/] y[//]pos_ap_zero _ _ X4)).
  astepl ([1][*]([1]:R)).
  apply mult_resp_leEq_both.
     apply less_leEq; apply pos_one.
    apply less_leEq; apply pos_one.
   apply shift_leEq_div; auto.
   astepl x; firstorder using leEq_def.
  apply shift_leEq_div; auto.
  astepl y; firstorder using leEq_def.
 apply shift_div_less; auto.
 astepr (x[*]y); firstorder using leEq_def.
Qed.

Lemma mult_AbsSmall_lft : forall x y X Y : R, [0] [<=] X -> [0] [<=] Y ->
 [--]X [<=] x -> x [<=] X -> [--]Y [<=] y -> y [<=] Y -> [--](X[*]Y) [<=] x[*]y.
Proof.
 intros.
 rstepr ([--]([--]x[*]y)).
 apply inv_resp_leEq.
 apply mult_AbsSmall_rht; auto.
  apply inv_resp_leEq. auto.
  rstepr ([--][--]X).
 apply inv_resp_leEq. auto.
Qed.

Lemma mult_AbsSmall : forall x y X Y : R,
 AbsSmall X x -> AbsSmall Y y -> AbsSmall (X[*]Y) (x[*]y).
Proof.
 unfold AbsSmall in |- *.
 intros.
 elim H. intros. elim H0. intros.
 cut ([0] [<=] X). intro. cut ([0] [<=] Y). intro.
  split.
    apply mult_AbsSmall_lft; auto.
   apply mult_AbsSmall_rht; auto.
  apply AbsSmall_nonneg with y; auto.
 apply AbsSmall_nonneg with x; auto.
Qed.

End AbsSmall_properties.

Declare Left Step AbsSmall_wdl_unfolded.
Declare Right Step AbsSmall_wdr_unfolded.

(**
** Properties of [AbsBig] *)

Definition absBig (R : COrdField) (e x : R) : CProp :=
 [0] [<] e and (e [<=] x or x [<=] [--]e).

Notation AbsBig := (absBig _).

Lemma AbsBigSmall_minus : forall (R : COrdField) (e1 e2 x1 x2 : R),
 e2 [<] e1 -> AbsBig e1 x1 -> AbsSmall e2 x2 -> AbsBig (e1[-]e2) (x1[-]x2).
Proof.
 intros.
 unfold absBig in |- *.
 split.
  apply plus_cancel_less with (z := e2).
  rstepl e2.
  rstepr e1.
  assumption.
 unfold absBig in X0.
 elim X0.
 intros H2 H3.
 case H3.
  intro H4.
  left.
  unfold AbsSmall in H.
  elim H.
  intros.
  rstepl (e1[+][--]e2).
  rstepr (x1[+][--]x2).
  apply plus_resp_leEq_both.
   assumption.
  apply inv_cancel_leEq.
  rstepl x2.
  rstepr e2.
  assumption.
 intro H4.
 right.
 unfold AbsSmall in H.
 elim H.
 intros H5 H6.
 rstepr ([--]e1[+]e2).
 rstepl (x1[+][--]x2).
 apply plus_resp_leEq_both.
  assumption.
 apply inv_cancel_leEq.
 rstepr x2.
 rstepl ([--]e2).
 assumption.
Qed.

Section absBig_wd_properties.
(**
%\begin{convention}% Let [R] be an ordered field.
%\end{convention}%
*)

Variable R : COrdField.

Lemma AbsBig_wdr : Crel_wdr R AbsBig.
Proof.
 red in |- *.
 intros.
 unfold absBig in |- *.
 unfold absBig in H.
 elim X.
 intros H1 H2.
 split.
  assumption.
 case H2.
  intro H3.
  left.
  apply leEq_wdr with y.
   assumption.
  assumption.
 intro H3.
 right.
 apply leEq_wdl with y.
  assumption.
 assumption.
Qed.

Lemma AbsBig_wdl : Crel_wdl R AbsBig.
Proof.
 red in |- *.
 unfold absBig in |- *.
 intros.
 elim X.
 intros H1 H2.
 split.
  astepr x.
  assumption.
 case H2.
  intro H3.
  left.
  astepl x.
  assumption.
 intro H3.
 right.
 astepr ([--]x).
 assumption.
Qed.

Lemma AbsBig_wdr_unfolded : forall x y z : R, AbsBig x y -> y [=] z -> AbsBig x z.
Proof AbsBig_wdr.

Lemma AbsBig_wdl_unfolded : forall x y z : R, AbsBig x y -> x [=] z -> AbsBig z y.
Proof AbsBig_wdl.

End absBig_wd_properties.

Declare Left Step AbsBig_wdl_unfolded.
Declare Right Step AbsBig_wdr_unfolded.

Add Parametric Morphism c : (@AbsSmall c) with signature (@cs_eq (cof_crr c)) ==> (@cs_eq c) ==> iff as AbsSmall_morph_wd.
Proof with try assumption.
 intros x1 x2 xeq y1 y2 yeq.
 split; intro H.
  stepr y1...
  stepl x1...
 symmetry in xeq, yeq.
 stepr y2...
 stepl x2...
Qed.


(*************************************************************************

 Monads in `op2 B`

 Comnads can be defined as monads internal to a bicategory. More
 specifically, comonads in `B` are the same as moands in `op2 B`.

 Contents
 1. Comonads
 2. Comonad morphisms
 3. Comonad cells
 4. Monads in `op2 B`
 5. Monad morphisms in `op2 B`
 6. Monad cells in `op2 B`

 *************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OpCellBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.

Local Open Scope cat.

(**
 1. Comonads
 *)
Section Comonads.
  Context {B : bicat}.

  Definition comnd_data
    : UU
    := ∑ (x : B)
         (f : x --> x),
       f ==> id₁ _ × f ==> f · f.

  Definition make_comnd_data
             (x : B)
             (f : x --> x)
             (ex : f ==> id₁ _)
             (dup : f ==> f · f)
    : comnd_data
    := x ,, f ,, ex ,, dup.

  Section Projections.
    Context (C : comnd_data).

    Definition ob_of_comnd
      : B
      := pr1 C.

    Definition endo_of_comnd
      : ob_of_comnd --> ob_of_comnd
      := pr12 C.

    Definition counit_of_comnd
      : endo_of_comnd ==> id₁ _
      := pr122 C.

    Definition comult_of_comnd
      : endo_of_comnd ==> endo_of_comnd · endo_of_comnd
      := pr222 C.
  End Projections.

  Section ComonadLaws.
    Context (C : comnd_data).

    Definition comnd_counit_left_law
      : UU
      := comult_of_comnd C • (counit_of_comnd C ▹ _) • lunitor _
         =
         id₂ _.

    Definition comnd_counit_right_law
      : UU
      := comult_of_comnd C • (_ ◃ counit_of_comnd C) • runitor _
         =
         id₂ _.

    Definition comnd_comult_assoc_law
      : UU
      := comult_of_comnd C
         • (_ ◃ comult_of_comnd C)
         • lassociator _ _ _
         =
         comult_of_comnd C • (comult_of_comnd C ▹ _).
  End ComonadLaws.

  Definition comnd_laws
             (C : comnd_data)
    : UU
    := comnd_counit_left_law C
       ×
       comnd_counit_right_law C
       ×
       comnd_comult_assoc_law C.

  Definition isaprop_comnd_laws
             (C : comnd_data)
    : isaprop (comnd_laws C).
  Proof.
    repeat (use isapropdirprod) ; apply cellset_property.
  Qed.

  Definition comnd
    : UU
    := ∑ (C : comnd_data), comnd_laws C.

  Coercion comnd_to_comnd_data (C : comnd) : comnd_data := pr1 C.

  Section LawsProjections.
    Context (C : comnd).

    Definition comnd_counit_left
      : comult_of_comnd C • (counit_of_comnd C ▹ _) • lunitor _
        =
        id₂ _
      := pr12 C.

    Definition comnd_counit_right
      : comult_of_comnd C • (_ ◃ counit_of_comnd C) • runitor _
        =
        id₂ _
      := pr122 C.

    Definition comnd_comult_assoc
      : comult_of_comnd C
        • (_ ◃ comult_of_comnd C)
        • lassociator _ _ _
        =
        comult_of_comnd C • (comult_of_comnd C ▹ _)
      := pr222 C.
  End LawsProjections.

  Definition make_comnd
             (C : comnd_data)
             (HC : comnd_laws C)
    : comnd
    := C ,, HC.
End Comonads.

Arguments comnd_data : clear implicits.
Arguments comnd : clear implicits.

(**
 2. Comonad morphisms
 *)
Section ComonadMorphism.
  Context {B : bicat}
          {C₁ C₂ : comnd B}.

  Definition comnd_mor_data
    : UU
    := ∑ (f : ob_of_comnd C₁ --> ob_of_comnd C₂),
       endo_of_comnd C₁ · f ==> f · endo_of_comnd C₂.

  Definition make_comnd_mor_data
             (f : ob_of_comnd C₁ --> ob_of_comnd C₂)
             (fe : endo_of_comnd C₁ · f ==> f · endo_of_comnd C₂)
    : comnd_mor_data
    := f ,,  fe.

  Coercion mor_of_comnd_mor
           (f : comnd_mor_data)
    : ob_of_comnd C₁ --> ob_of_comnd C₂
    := pr1 f.

  Definition comnd_mor_endo
             (f : comnd_mor_data)
    : endo_of_comnd C₁ · f ==> f · endo_of_comnd C₂
    := pr2 f.

  Section ComonadMorphismLaws.
    Context (f : comnd_mor_data).

    Definition comnd_mor_counit_law
      : UU
      := (counit_of_comnd C₁ ▹ _) • lunitor _
         =
         comnd_mor_endo f • (_ ◃ counit_of_comnd C₂) • runitor _.

    Definition comnd_mor_comult_law
      : UU
      := (comult_of_comnd C₁ ▹ _)
         • rassociator _ _ _
         • (_ ◃ comnd_mor_endo f)
         • lassociator _ _ _
         • (comnd_mor_endo f ▹ _)
         • rassociator _ _ _
         =
         comnd_mor_endo f
         • (_ ◃ comult_of_comnd C₂).
  End ComonadMorphismLaws.

  Definition comnd_mor_laws
             (f : comnd_mor_data)
    : UU
    := comnd_mor_counit_law f × comnd_mor_comult_law f.

  Definition comnd_mor
    : UU
    := ∑ (f : comnd_mor_data), comnd_mor_laws f.

  Coercion comnd_mor_to_comnd_mor_data
           (f : comnd_mor)
    : comnd_mor_data
    := pr1 f.

  Definition make_comnd_mor
             (f : comnd_mor_data)
             (Hf : comnd_mor_laws f)
    : comnd_mor
    := f ,, Hf.

  Section LawProjections.
    Context (f : comnd_mor).

    Definition comnd_mor_counit
      : (counit_of_comnd C₁ ▹ _) • lunitor _
         =
         comnd_mor_endo f • (_ ◃ counit_of_comnd C₂) • runitor _
      := pr12 f.

    Definition comnd_mor_comult
      : (comult_of_comnd C₁ ▹ _)
        • rassociator _ _ _
        • (_ ◃ comnd_mor_endo f)
        • lassociator _ _ _
        • (comnd_mor_endo f ▹ _)
        • rassociator _ _ _
        =
        comnd_mor_endo f
        • (_ ◃ comult_of_comnd C₂)
      := pr22 f.
  End LawProjections.
End ComonadMorphism.

Arguments comnd_mor_data {_} _ _.
Arguments comnd_mor {_} _ _.

(**
 3. Comonad cells
 *)
Definition is_comnd_cell
           {B : bicat}
           {C₁ C₂ : comnd B}
           {f₁ f₂ : comnd_mor C₁ C₂}
           (α : f₂ ==> f₁)
  : UU
  := (_ ◃ α) • comnd_mor_endo f₁
     =
     comnd_mor_endo f₂ • (α ▹ _).

Definition comnd_cell
           {B : bicat}
           {C₁ C₂ : comnd B}
           (f₁ f₂ : comnd_mor C₁ C₂)
  : UU
  := ∑ (α : f₂ ==> f₁), is_comnd_cell α.

Coercion comnd_cell_to_cell
         {B : bicat}
         {C₁ C₂ : comnd B}
         {f₁ f₂ : comnd_mor C₁ C₂}
         (α : comnd_cell f₁ f₂)
  : f₂ ==> f₁
  := pr1 α.

Definition make_comnd_cell
           {B : bicat}
           {C₁ C₂ : comnd B}
           {f₁ f₂ : comnd_mor C₁ C₂}
           (α : f₂ ==> f₁)
           (Hα : is_comnd_cell α)
  : comnd_cell f₁ f₂
  := α ,, Hα.

(**
 4. Monads in `op2 B`
 *)
Section MonadsInOp2Bicat.
  Context {B : bicat}.

  Definition op2_mnd_to_comnd
             (m : mnd (op2_bicat B))
    : comnd B.
  Proof.
    use make_comnd.
    - use make_comnd_data.
      + exact (ob_of_mnd m).
      + exact (endo_of_mnd m).
      + exact (unit_of_mnd m).
      + exact (mult_of_mnd m).
    - repeat split.
      + abstract
          (unfold comnd_counit_left_law ;
           rewrite !vassocl ;
           exact (mnd_unit_left m)).
      + abstract
          (unfold comnd_counit_right_law ;
           rewrite !vassocl ;
           exact (mnd_unit_right m)).
      + abstract
          (unfold comnd_comult_assoc_law ;
           rewrite !vassocl ;
           exact (mnd_mult_assoc m)).
  Defined.

  Definition comnd_to_op2_mnd
             (C : comnd B)
    : mnd (op2_bicat B).
  Proof.
    use make_mnd.
    - use make_mnd_data.
      + exact (ob_of_comnd C).
      + exact (endo_of_comnd C).
      + exact (counit_of_comnd C).
      + exact (comult_of_comnd C).
    - repeat split.
      + abstract
          (cbn ;
           rewrite !vassocr ;
           exact (comnd_counit_left C)).
      + abstract
          (cbn ;
           rewrite !vassocr ;
           exact (comnd_counit_right C)).
      + abstract
          (cbn ;
           rewrite !vassocr ;
           exact (comnd_comult_assoc C)).
  Defined.

  Definition op2_mnd_weq_comnd_inv₁
             (m : mnd (op2_bicat B))
    : comnd_to_op2_mnd (op2_mnd_to_comnd m) = m.
  Proof.
    refine (maponpaths (λ z, ob_of_mnd m ,, z) _).
    use subtypePath.
    {
      intro.
      apply isaprop_is_mnd.
    }
    apply idpath.
  Qed.

  Definition op2_mnd_weq_comnd_inv₂
             (C : comnd B)
    : op2_mnd_to_comnd (comnd_to_op2_mnd C) = C.
  Proof.
    use subtypePath.
    {
      intro.
      apply isaprop_comnd_laws.
    }
    apply idpath.
  Qed.
End MonadsInOp2Bicat.

Definition op2_mnd_weq_comnd
           (B : bicat)
  : mnd (op2_bicat B) ≃ comnd B.
Proof.
  use make_weq.
  - exact op2_mnd_to_comnd.
  - use isweq_iso.
    + exact comnd_to_op2_mnd.
    + exact op2_mnd_weq_comnd_inv₁.
    + exact op2_mnd_weq_comnd_inv₂.
Defined.

(**
 5. Monad morphisms in `op2 B`
 *)
Section MonadMorInOp2Bicat.
  Context {B : bicat}
          {m₁ m₂ : mnd (op2_bicat B)}.

  Definition op2_mnd_mor_to_comnd_mor
             (f : m₁ --> m₂)
    : comnd_mor (op2_mnd_to_comnd m₁) (op2_mnd_to_comnd m₂).
  Proof.
    use make_comnd_mor.
    - use make_comnd_mor_data.
      + exact (mor_of_mnd_mor f).
      + exact (mnd_mor_endo f).
    - split.
      + abstract
          (unfold comnd_mor_counit_law ;
           cbn ;
           rewrite !vassocl ;
           exact (mnd_mor_unit f)).
      + abstract
          (unfold comnd_mor_comult_law ;
           cbn ;
           rewrite !vassocl ;
           exact (mnd_mor_mu f)).
  Defined.

  Definition comnd_mor_to_op2_mnd_mor
             (f : comnd_mor (op2_mnd_to_comnd m₁) (op2_mnd_to_comnd m₂))
    : m₁ --> m₂.
  Proof.
    use make_mnd_mor.
    - use make_mnd_mor_data.
      + exact f.
      + exact (comnd_mor_endo f).
    - split.
      + abstract
          (cbn ;
           rewrite !vassocr ;
           exact (comnd_mor_counit f)).
      + abstract
          (cbn ;
           rewrite !vassocr ;
           exact (comnd_mor_comult f)).
  Defined.

  Definition op2_mnd_mor_weq_comnd_mor_inv₁
             (f : m₁ --> m₂)
    : comnd_mor_to_op2_mnd_mor (op2_mnd_mor_to_comnd_mor f) = f.
  Proof.
    refine (maponpaths (λ z, _ ,, z) _).
    use subtypePath.
    {
      intro ; apply isapropunit.
    }
    use subtypePath.
    {
      intro.
      apply isapropdirprod ; apply cellset_property.
    }
    apply idpath.
  Qed.

  Definition op2_mnd_mor_weq_comnd_mor_inv₂
             (f : comnd_mor (op2_mnd_to_comnd m₁) (op2_mnd_to_comnd m₂))
    : op2_mnd_mor_to_comnd_mor (comnd_mor_to_op2_mnd_mor f) = f.
  Proof.
    use subtypePath.
    {
      intro.
      apply isapropdirprod ; apply cellset_property.
    }
    apply idpath.
  Qed.
End MonadMorInOp2Bicat.

Definition op2_mnd_mor_weq_comnd_mor
           {B : bicat}
           (m₁ m₂ : mnd (op2_bicat B))
  : m₁ --> m₂ ≃ comnd_mor (op2_mnd_to_comnd m₁) (op2_mnd_to_comnd m₂).
Proof.
  use make_weq.
  - exact op2_mnd_mor_to_comnd_mor.
  - use isweq_iso.
    + exact comnd_mor_to_op2_mnd_mor.
    + exact op2_mnd_mor_weq_comnd_mor_inv₁.
    + exact op2_mnd_mor_weq_comnd_mor_inv₂.
Defined.

(**
 6. Monad cells in `op2 B`
 *)
Section MonadMorInOp2Bicat.
  Context {B : bicat}
          {m₁ m₂ : mnd (op2_bicat B)}
          {f₁ f₂ : m₁ --> m₂}.

  Definition op2_mnd_cell_to_comnd_cell
             (α : f₁ ==> f₂)
    : comnd_cell (op2_mnd_mor_to_comnd_mor f₁) (op2_mnd_mor_to_comnd_mor f₂).
  Proof.
    use make_comnd_cell.
    - exact (cell_of_mnd_cell α).
    - exact (mnd_cell_endo α).
  Defined.

  Definition comnd_cell_to_op2_mnd_cell
             (α : comnd_cell (op2_mnd_mor_to_comnd_mor f₁) (op2_mnd_mor_to_comnd_mor f₂))
    : f₁ ==> f₂.
  Proof.
    use make_mnd_cell.
    - exact (pr1 α).
    - exact (pr2 α).
  Defined.
End MonadMorInOp2Bicat.

Definition op2_mnd_cell_weq_comnd_cell
           {B : bicat}
           {m₁ m₂ : mnd (op2_bicat B)}
           (f₁ f₂ : m₁ --> m₂)
  : f₁ ==> f₂ ≃ comnd_cell (op2_mnd_mor_to_comnd_mor f₁) (op2_mnd_mor_to_comnd_mor f₂).
Proof.
  use make_weq.
  - exact op2_mnd_cell_to_comnd_cell.
  - use isweq_iso.
    + exact comnd_cell_to_op2_mnd_cell.
    + abstract
        (intro ;
         use eq_mnd_cell ;
         apply idpath).
    + abstract
        (intro ;
         use subtypePath ; [ intro ; apply cellset_property | ] ;
         apply idpath).
Defined.


Require Import String.
Require Import TypeAssignmentPoly.
Require Import ResultBasics.
Require Import TacticsSF.
Require Import TacticsCPDT.
Require Import List.

Require String. Open Scope string_scope.

Require Import Recdef.

(* ================================================================ *)

Inductive naming_tree : Set :=
| NTFinal : naming_tree
| NTName : free_id -> naming_tree -> naming_tree
| NTBranch : naming_tree -> naming_tree -> naming_tree.

Definition undebruijn_value (v : value) : string :=
  match v with
    | ValName (Nm (Free i)) => "%" ++ i
    | ValName (CoNm (Free i)) => "%/" ++ i
    | ValToken (Token s) => "'" ++ s ++ "'"
    | ValVariable (Var (Free i)) => "$" ++ i
    | _ => "?"
  end.

Fixpoint undebruijn_proc (n : nat) (nt : naming_tree) (P : proc)  : string :=
  match n with
    | 0 => "*"
    | S m =>
      match nt with
        | NTFinal => "@"
        | NTName i nt1 =>
          match P with
            | u? ; P =>
              (undebruijn_value u) ++ " ? " ++ (undebruijn_value (open_value i 0 (ValVariable (Var (Bound 0))))) ++
              ". " ++ (undebruijn_proc m nt1 (open_proc i 0 P))
            | u!v ; P =>
              (undebruijn_value u) ++ " ! " ++ (undebruijn_value v) ++ ". " ++ (undebruijn_proc m nt P)
            | IsEq u v P => "[" ++ (undebruijn_value u) ++ "=" ++ (undebruijn_value v) ++ "]" ++ ". " ++ (undebruijn_proc m nt P)
            | IsNotEq u v P => "[" ++ (undebruijn_value u) ++ "<>" ++ (undebruijn_value v) ++ "]" ++ ". " ++ (undebruijn_proc m nt P)
            | New P => "(new " ++ i ++ ") (" ++ (undebruijn_proc m nt1 (open_proc i 0 P)) ++ ")"
            | ( ! P ) => "rep (" ++ (undebruijn_proc m nt P) ++ "))"
            | Zero => "0"
            | _ => "@"
          end
        | NTBranch nt1 nt2 =>
          match P with
            | (P ||| Q) => "(" ++ (undebruijn_proc m nt1 P) ++ " | " ++ (undebruijn_proc m nt2 Q) ++ ")"
            | (P +++ Q) => "((" ++ (undebruijn_proc m nt1 P) ++ ") + (" ++ (undebruijn_proc m nt2 Q) ++ "))"
            | _ => "@"
          end
      end
  end.

(* ================================================================ *)

Notation "x % nt" := (NTName x nt) (at level 45, right associativity).
Notation "nt1 ^^ nt2" := (NTBranch nt1 nt2) (at level 40, left associativity).
Notation "$$" := (NTName "unused" NTFinal).

(* ================================================================ *)

(*
Require Import ExampleCommon.
Require Import ExampleUniForwarderMultiStepTyping.

Eval compute in
  (undebruijn_proc 50
    (NTName "c"
      (NTBranch
        (NTName "d"
          (NTName "unused" NTFinal))
        (NTName "xd"
          (NTName "xin"
            (NTName "xout"
              (NTName "y"
                (NTName "d2"
                  (NTName "unused" NTFinal))))))
      )
    )
    (uni_forwarder_multi_step (ValVariable (Var (Free "in"))) (ValVariable (Var (Free "out"))))).

Eval compute in
  (undebruijn_proc 50
    ("c"% (("d" % $$) ^^ ("xd" % "xin" % "xout" % "y" % "d2" % $$)))
    (uni_forwarder_multi_step (ValVariable (Var (Free "in"))) (ValVariable (Var (Free "out"))))).

*)


From Hammer Require Import Hammer.

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import NArith.
From IntMap Require Import Map.
From IntMap Require Import Mapaxioms.
From IntMap Require Import Fset.
From IntMap Require Import Mapiter.
From IntMap Require Import Mapsubset.
Require Import List.
From IntMap Require Import Lsort.
From IntMap Require Import Mapcard.
From IntMap Require Import Mapcanon.

Section MapC.

Variables A B C : Type.

Lemma MapPut_as_Merge_c :
forall m:Map A,
mapcanon A m ->
forall (a:ad) (y:A), MapPut A m a y = MapMerge A m (M1 A a y).
Proof. hammer_hook "Mapc" "Mapc.MapPut_as_Merge_c".
intros. apply mapcanon_unique. exact (MapPut_canon A m H a y).
apply MapMerge_canon. assumption.
apply M1_canon.
apply MapPut_as_Merge.
Qed.

Lemma MapPut_behind_as_Merge_c :
forall m:Map A,
mapcanon A m ->
forall (a:ad) (y:A), MapPut_behind A m a y = MapMerge A (M1 A a y) m.
Proof. hammer_hook "Mapc" "Mapc.MapPut_behind_as_Merge_c".
intros. apply mapcanon_unique. exact (MapPut_behind_canon A m H a y).
apply MapMerge_canon. apply M1_canon.
assumption.
apply MapPut_behind_as_Merge.
Qed.

Lemma MapMerge_empty_m_c : forall m:Map A, MapMerge A (M0 A) m = m.
Proof. hammer_hook "Mapc" "Mapc.MapMerge_empty_m_c".
trivial.
Qed.

Lemma MapMerge_assoc_c :
forall m m' m'':Map A,
mapcanon A m ->
mapcanon A m' ->
mapcanon A m'' ->
MapMerge A (MapMerge A m m') m'' = MapMerge A m (MapMerge A m' m'').
Proof. hammer_hook "Mapc" "Mapc.MapMerge_assoc_c".
intros. apply mapcanon_unique.
apply MapMerge_canon; try assumption. apply MapMerge_canon; try assumption.
apply MapMerge_canon; try assumption. apply MapMerge_canon; try assumption.
apply MapMerge_assoc.
Qed.

Lemma MapMerge_idempotent_c :
forall m:Map A, mapcanon A m -> MapMerge A m m = m.
Proof. hammer_hook "Mapc" "Mapc.MapMerge_idempotent_c".
intros. apply mapcanon_unique. apply MapMerge_canon; assumption.
assumption.
apply MapMerge_idempotent.
Qed.

Lemma MapMerge_RestrTo_l_c :
forall m m' m'':Map A,
mapcanon A m ->
mapcanon A m'' ->
MapMerge A (MapDomRestrTo A A m m') m'' =
MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m'').
Proof. hammer_hook "Mapc" "Mapc.MapMerge_RestrTo_l_c".
intros. apply mapcanon_unique. apply MapMerge_canon. apply MapDomRestrTo_canon; assumption.
assumption.
apply MapDomRestrTo_canon; apply MapMerge_canon; assumption.
apply MapMerge_RestrTo_l.
Qed.

Lemma MapRemove_as_RestrBy_c :
forall m:Map A,
mapcanon A m ->
forall (a:ad) (y:B), MapRemove A m a = MapDomRestrBy A B m (M1 B a y).
Proof. hammer_hook "Mapc" "Mapc.MapRemove_as_RestrBy_c".
intros. apply mapcanon_unique. apply MapRemove_canon; assumption.
apply MapDomRestrBy_canon; assumption.
apply MapRemove_as_RestrBy.
Qed.

Lemma MapDomRestrTo_assoc_c :
forall (m:Map A) (m':Map B) (m'':Map C),
mapcanon A m ->
MapDomRestrTo A C (MapDomRestrTo A B m m') m'' =
MapDomRestrTo A B m (MapDomRestrTo B C m' m'').
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrTo_assoc_c".
intros. apply mapcanon_unique. apply MapDomRestrTo_canon; try assumption.
apply MapDomRestrTo_canon; try assumption.
apply MapDomRestrTo_canon; try assumption.
apply MapDomRestrTo_assoc.
Qed.

Lemma MapDomRestrTo_idempotent_c :
forall m:Map A, mapcanon A m -> MapDomRestrTo A A m m = m.
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrTo_idempotent_c".
intros. apply mapcanon_unique. apply MapDomRestrTo_canon; assumption.
assumption.
apply MapDomRestrTo_idempotent.
Qed.

Lemma MapDomRestrTo_Dom_c :
forall (m:Map A) (m':Map B),
mapcanon A m ->
MapDomRestrTo A B m m' = MapDomRestrTo A unit m (MapDom B m').
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrTo_Dom_c".
intros. apply mapcanon_unique. apply MapDomRestrTo_canon; assumption.
apply MapDomRestrTo_canon; assumption.
apply MapDomRestrTo_Dom.
Qed.

Lemma MapDomRestrBy_Dom_c :
forall (m:Map A) (m':Map B),
mapcanon A m ->
MapDomRestrBy A B m m' = MapDomRestrBy A unit m (MapDom B m').
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrBy_Dom_c".
intros. apply mapcanon_unique. apply MapDomRestrBy_canon; assumption.
apply MapDomRestrBy_canon; assumption.
apply MapDomRestrBy_Dom.
Qed.

Lemma MapDomRestrBy_By_c :
forall (m:Map A) (m' m'':Map B),
mapcanon A m ->
MapDomRestrBy A B (MapDomRestrBy A B m m') m'' =
MapDomRestrBy A B m (MapMerge B m' m'').
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrBy_By_c".
intros. apply mapcanon_unique. apply MapDomRestrBy_canon; try assumption.
apply MapDomRestrBy_canon; try assumption.
apply MapDomRestrBy_canon; try assumption.
apply MapDomRestrBy_By.
Qed.

Lemma MapDomRestrBy_By_comm_c :
forall (m:Map A) (m':Map B) (m'':Map C),
mapcanon A m ->
MapDomRestrBy A C (MapDomRestrBy A B m m') m'' =
MapDomRestrBy A B (MapDomRestrBy A C m m'') m'.
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrBy_By_comm_c".
intros. apply mapcanon_unique. apply MapDomRestrBy_canon.
apply MapDomRestrBy_canon; assumption.
apply MapDomRestrBy_canon. apply MapDomRestrBy_canon; assumption.
apply MapDomRestrBy_By_comm.
Qed.

Lemma MapDomRestrBy_To_c :
forall (m:Map A) (m':Map B) (m'':Map C),
mapcanon A m ->
MapDomRestrBy A C (MapDomRestrTo A B m m') m'' =
MapDomRestrTo A B m (MapDomRestrBy B C m' m'').
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrBy_To_c".
intros. apply mapcanon_unique. apply MapDomRestrBy_canon.
apply MapDomRestrTo_canon; assumption.
apply MapDomRestrTo_canon; assumption.
apply MapDomRestrBy_To.
Qed.

Lemma MapDomRestrBy_To_comm_c :
forall (m:Map A) (m':Map B) (m'':Map C),
mapcanon A m ->
MapDomRestrBy A C (MapDomRestrTo A B m m') m'' =
MapDomRestrTo A B (MapDomRestrBy A C m m'') m'.
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrBy_To_comm_c".
intros. apply mapcanon_unique. apply MapDomRestrBy_canon.
apply MapDomRestrTo_canon; assumption.
apply MapDomRestrTo_canon. apply MapDomRestrBy_canon; assumption.
apply MapDomRestrBy_To_comm.
Qed.

Lemma MapDomRestrTo_By_c :
forall (m:Map A) (m':Map B) (m'':Map C),
mapcanon A m ->
MapDomRestrTo A C (MapDomRestrBy A B m m') m'' =
MapDomRestrTo A C m (MapDomRestrBy C B m'' m').
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrTo_By_c".
intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
apply MapDomRestrBy_canon; assumption.
apply MapDomRestrTo_canon; assumption.
apply MapDomRestrTo_By.
Qed.

Lemma MapDomRestrTo_By_comm_c :
forall (m:Map A) (m':Map B) (m'':Map C),
mapcanon A m ->
MapDomRestrTo A C (MapDomRestrBy A B m m') m'' =
MapDomRestrBy A B (MapDomRestrTo A C m m'') m'.
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrTo_By_comm_c".
intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
apply MapDomRestrBy_canon; assumption.
apply MapDomRestrBy_canon. apply MapDomRestrTo_canon; assumption.
apply MapDomRestrTo_By_comm.
Qed.

Lemma MapDomRestrTo_To_comm_c :
forall (m:Map A) (m':Map B) (m'':Map C),
mapcanon A m ->
MapDomRestrTo A C (MapDomRestrTo A B m m') m'' =
MapDomRestrTo A B (MapDomRestrTo A C m m'') m'.
Proof. hammer_hook "Mapc" "Mapc.MapDomRestrTo_To_comm_c".
intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
apply MapDomRestrTo_canon; assumption.
apply MapDomRestrTo_canon. apply MapDomRestrTo_canon; assumption.
apply MapDomRestrTo_To_comm.
Qed.

Lemma MapMerge_DomRestrTo_c :
forall (m m':Map A) (m'':Map B),
mapcanon A m ->
mapcanon A m' ->
MapDomRestrTo A B (MapMerge A m m') m'' =
MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m'').
Proof. hammer_hook "Mapc" "Mapc.MapMerge_DomRestrTo_c".
intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
apply MapMerge_canon; assumption.
apply MapMerge_canon. apply MapDomRestrTo_canon; assumption.
apply MapDomRestrTo_canon; assumption.
apply MapMerge_DomRestrTo.
Qed.

Lemma MapMerge_DomRestrBy_c :
forall (m m':Map A) (m'':Map B),
mapcanon A m ->
mapcanon A m' ->
MapDomRestrBy A B (MapMerge A m m') m'' =
MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m'').
Proof. hammer_hook "Mapc" "Mapc.MapMerge_DomRestrBy_c".
intros. apply mapcanon_unique. apply MapDomRestrBy_canon. apply MapMerge_canon; assumption.
apply MapMerge_canon. apply MapDomRestrBy_canon; assumption.
apply MapDomRestrBy_canon; assumption.
apply MapMerge_DomRestrBy.
Qed.

Lemma MapDelta_nilpotent_c :
forall m:Map A, mapcanon A m -> MapDelta A m m = M0 A.
Proof. hammer_hook "Mapc" "Mapc.MapDelta_nilpotent_c".
intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
apply M0_canon.
apply MapDelta_nilpotent.
Qed.

Lemma MapDelta_as_Merge_c :
forall m m':Map A,
mapcanon A m ->
mapcanon A m' ->
MapDelta A m m' =
MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m).
Proof. hammer_hook "Mapc" "Mapc.MapDelta_as_Merge_c".
intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
apply MapMerge_canon; apply MapDomRestrBy_canon; assumption.
apply MapDelta_as_Merge.
Qed.

Lemma MapDelta_as_DomRestrBy_c :
forall m m':Map A,
mapcanon A m ->
mapcanon A m' ->
MapDelta A m m' =
MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m').
Proof. hammer_hook "Mapc" "Mapc.MapDelta_as_DomRestrBy_c".
intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
apply MapDomRestrBy_canon. apply MapMerge_canon; assumption.
apply MapDelta_as_DomRestrBy.
Qed.

Lemma MapDelta_as_DomRestrBy_2_c :
forall m m':Map A,
mapcanon A m ->
mapcanon A m' ->
MapDelta A m m' =
MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m).
Proof. hammer_hook "Mapc" "Mapc.MapDelta_as_DomRestrBy_2_c".
intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
apply MapDomRestrBy_canon. apply MapMerge_canon; assumption.
apply MapDelta_as_DomRestrBy_2.
Qed.

Lemma MapDelta_sym_c :
forall m m':Map A,
mapcanon A m -> mapcanon A m' -> MapDelta A m m' = MapDelta A m' m.
Proof. hammer_hook "Mapc" "Mapc.MapDelta_sym_c".
intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
apply MapDelta_canon; assumption. apply MapDelta_sym.
Qed.

Lemma MapDom_Split_1_c :
forall (m:Map A) (m':Map B),
mapcanon A m ->
m = MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m').
Proof. hammer_hook "Mapc" "Mapc.MapDom_Split_1_c".
intros. apply mapcanon_unique. assumption.
apply MapMerge_canon. apply MapDomRestrTo_canon; assumption.
apply MapDomRestrBy_canon; assumption.
apply MapDom_Split_1.
Qed.

Lemma MapDom_Split_2_c :
forall (m:Map A) (m':Map B),
mapcanon A m ->
m = MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m').
Proof. hammer_hook "Mapc" "Mapc.MapDom_Split_2_c".
intros. apply mapcanon_unique. assumption.
apply MapMerge_canon. apply MapDomRestrBy_canon; assumption.
apply MapDomRestrTo_canon; assumption.
apply MapDom_Split_2.
Qed.

Lemma MapDom_Split_3_c :
forall (m:Map A) (m':Map B),
mapcanon A m ->
MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m') =
M0 A.
Proof. hammer_hook "Mapc" "Mapc.MapDom_Split_3_c".
intros. apply mapcanon_unique. apply MapDomRestrTo_canon.
apply MapDomRestrTo_canon; assumption.
apply M0_canon.
apply MapDom_Split_3.
Qed.

Lemma Map_of_alist_of_Map_c :
forall m:Map A, mapcanon A m -> Map_of_alist A (alist_of_Map A m) = m.
Proof. hammer_hook "Mapc" "Mapc.Map_of_alist_of_Map_c".
intros. apply mapcanon_unique; try assumption. apply Map_of_alist_canon.
apply Map_of_alist_of_Map.
Qed.

Lemma alist_of_Map_of_alist_c :
forall l:alist A,
alist_sorted_2 A l -> alist_of_Map A (Map_of_alist A l) = l.
Proof. hammer_hook "Mapc" "Mapc.alist_of_Map_of_alist_c".
intros. apply alist_canonical. apply alist_of_Map_of_alist.
apply alist_of_Map_sorts2.
assumption.
Qed.

Lemma MapSubset_antisym_c :
forall (m:Map A) (m':Map B),
mapcanon A m ->
mapcanon B m' ->
MapSubset A B m m' -> MapSubset B A m' m -> MapDom A m = MapDom B m'.
Proof. hammer_hook "Mapc" "Mapc.MapSubset_antisym_c".
intros. apply (mapcanon_unique unit). apply MapDom_canon; assumption.
apply MapDom_canon; assumption.
apply MapSubset_antisym; assumption.
Qed.

Lemma FSubset_antisym_c :
forall s s':FSet,
mapcanon unit s ->
mapcanon unit s' -> MapSubset _ _ s s' -> MapSubset _ _ s' s -> s = s'.
Proof. hammer_hook "Mapc" "Mapc.FSubset_antisym_c".
intros. apply (mapcanon_unique unit); try assumption. apply FSubset_antisym; assumption.
Qed.

Lemma MapDisjoint_empty_c :
forall m:Map A, mapcanon A m -> MapDisjoint A A m m -> m = M0 A.
Proof. hammer_hook "Mapc" "Mapc.MapDisjoint_empty_c".
intros. apply mapcanon_unique; try assumption; try apply M0_canon.
apply MapDisjoint_empty; assumption.
Qed.

Lemma MapDelta_disjoint_c :
forall m m':Map A,
mapcanon A m ->
mapcanon A m' ->
MapDisjoint A A m m' -> MapDelta A m m' = MapMerge A m m'.
Proof. hammer_hook "Mapc" "Mapc.MapDelta_disjoint_c".
intros. apply mapcanon_unique. apply MapDelta_canon; assumption.
apply MapMerge_canon; assumption. apply MapDelta_disjoint; assumption.
Qed.

End MapC.

Lemma FSetDelta_assoc_c :
forall s s' s'':FSet,
mapcanon unit s ->
mapcanon unit s' ->
mapcanon unit s'' ->
MapDelta _ (MapDelta _ s s') s'' = MapDelta _ s (MapDelta _ s' s'').
Proof. hammer_hook "Mapc" "Mapc.FSetDelta_assoc_c".
intros. apply (mapcanon_unique unit). apply MapDelta_canon. apply MapDelta_canon; assumption.
assumption.
apply MapDelta_canon. assumption.
apply MapDelta_canon; assumption.
apply FSetDelta_assoc; assumption.
Qed.

Lemma FSet_ext_c :
forall s s':FSet,
mapcanon unit s ->
mapcanon unit s' -> (forall a:ad, in_FSet a s = in_FSet a s') -> s = s'.
Proof. hammer_hook "Mapc" "Mapc.FSet_ext_c".
intros. apply (mapcanon_unique unit); try assumption. apply FSet_ext. assumption.
Qed.

Lemma FSetUnion_comm_c :
forall s s':FSet,
mapcanon unit s -> mapcanon unit s' -> FSetUnion s s' = FSetUnion s' s.
Proof. hammer_hook "Mapc" "Mapc.FSetUnion_comm_c".
intros.
apply (mapcanon_unique unit);
try (unfold FSetUnion in |- *; apply MapMerge_canon; assumption).
apply FSetUnion_comm.
Qed.

Lemma FSetUnion_assoc_c :
forall s s' s'':FSet,
mapcanon unit s ->
mapcanon unit s' ->
mapcanon unit s'' ->
FSetUnion (FSetUnion s s') s'' = FSetUnion s (FSetUnion s' s'').
Proof. hammer_hook "Mapc" "Mapc.FSetUnion_assoc_c".
exact (MapMerge_assoc_c unit).
Qed.

Lemma FSetUnion_M0_s_c : forall s:FSet, FSetUnion (M0 unit) s = s.
Proof. hammer_hook "Mapc" "Mapc.FSetUnion_M0_s_c".
exact (MapMerge_empty_m_c unit).
Qed.

Lemma FSetUnion_s_M0_c : forall s:FSet, FSetUnion s (M0 unit) = s.
Proof. hammer_hook "Mapc" "Mapc.FSetUnion_s_M0_c".
exact (MapMerge_m_empty_1 unit).
Qed.

Lemma FSetUnion_idempotent :
forall s:FSet, mapcanon unit s -> FSetUnion s s = s.
Proof. hammer_hook "Mapc" "Mapc.FSetUnion_idempotent".
exact (MapMerge_idempotent_c unit).
Qed.

Lemma FSetInter_comm_c :
forall s s':FSet,
mapcanon unit s -> mapcanon unit s' -> FSetInter s s' = FSetInter s' s.
Proof. hammer_hook "Mapc" "Mapc.FSetInter_comm_c".
intros.
apply (mapcanon_unique unit);
try (unfold FSetInter in |- *; apply MapDomRestrTo_canon; assumption).
apply FSetInter_comm.
Qed.

Lemma FSetInter_assoc_c :
forall s s' s'':FSet,
mapcanon unit s ->
FSetInter (FSetInter s s') s'' = FSetInter s (FSetInter s' s'').
Proof. hammer_hook "Mapc" "Mapc.FSetInter_assoc_c".
exact (MapDomRestrTo_assoc_c unit unit unit).
Qed.

Lemma FSetInter_M0_s_c : forall s:FSet, FSetInter (M0 unit) s = M0 unit.
Proof. hammer_hook "Mapc" "Mapc.FSetInter_M0_s_c".
trivial.
Qed.

Lemma FSetInter_s_M0_c : forall s:FSet, FSetInter s (M0 unit) = M0 unit.
Proof. hammer_hook "Mapc" "Mapc.FSetInter_s_M0_c".
exact (MapDomRestrTo_m_empty_1 unit unit).
Qed.

Lemma FSetInter_idempotent :
forall s:FSet, mapcanon unit s -> FSetInter s s = s.
Proof. hammer_hook "Mapc" "Mapc.FSetInter_idempotent".
exact (MapDomRestrTo_idempotent_c unit).
Qed.

Lemma FSetUnion_Inter_l_c :
forall s s' s'':FSet,
mapcanon unit s ->
mapcanon unit s'' ->
FSetUnion (FSetInter s s') s'' =
FSetInter (FSetUnion s s'') (FSetUnion s' s'').
Proof. hammer_hook "Mapc" "Mapc.FSetUnion_Inter_l_c".
intros. apply (mapcanon_unique unit). unfold FSetUnion in |- *. apply MapMerge_canon; try assumption.
unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption.
unfold FSetInter in |- *; unfold FSetUnion in |- *;
apply MapDomRestrTo_canon; apply MapMerge_canon;
assumption.
apply FSetUnion_Inter_l.
Qed.

Lemma FSetUnion_Inter_r :
forall s s' s'':FSet,
mapcanon unit s ->
mapcanon unit s' ->
FSetUnion s (FSetInter s' s'') =
FSetInter (FSetUnion s s') (FSetUnion s s'').
Proof. hammer_hook "Mapc" "Mapc.FSetUnion_Inter_r".
intros. apply (mapcanon_unique unit). unfold FSetUnion in |- *. apply MapMerge_canon; try assumption.
unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption.
unfold FSetInter in |- *; unfold FSetUnion in |- *;
apply MapDomRestrTo_canon; apply MapMerge_canon;
assumption.
apply FSetUnion_Inter_r.
Qed.

Lemma FSetInter_Union_l_c :
forall s s' s'':FSet,
mapcanon unit s ->
mapcanon unit s' ->
FSetInter (FSetUnion s s') s'' =
FSetUnion (FSetInter s s'') (FSetInter s' s'').
Proof. hammer_hook "Mapc" "Mapc.FSetInter_Union_l_c".
intros. apply (mapcanon_unique unit). unfold FSetInter in |- *.
apply MapDomRestrTo_canon; try assumption. unfold FSetUnion in |- *.
apply MapMerge_canon; assumption.
unfold FSetUnion in |- *; unfold FSetInter in |- *; apply MapMerge_canon;
apply MapDomRestrTo_canon; assumption.
apply FSetInter_Union_l.
Qed.

Lemma FSetInter_Union_r :
forall s s' s'':FSet,
mapcanon unit s ->
mapcanon unit s' ->
FSetInter s (FSetUnion s' s'') =
FSetUnion (FSetInter s s') (FSetInter s s'').
Proof. hammer_hook "Mapc" "Mapc.FSetInter_Union_r".
intros. apply (mapcanon_unique unit). unfold FSetInter in |- *.
apply MapDomRestrTo_canon; try assumption.
unfold FSetUnion in |- *. apply MapMerge_canon; unfold FSetInter in |- *; apply MapDomRestrTo_canon;
assumption.
apply FSetInter_Union_r.
Qed.


Require Import VST.msl.msl_direct.
Require Import FunctionalExtensionality.
Require Import CertiGraph.msl_ext.ramify_tactics.
Require Import CertiGraph.msl_ext.overlapping_direct.
Require Import CertiGraph.heap_model_direct.SeparationAlgebra.
Require Import Peano_dec.

Definition mapsto (x y: adr) : pred world :=
  fun w => x <> 0 /\
    (forall a, a <> x -> lookup_fpm w a = None) /\
    lookup_fpm w x = Some y.

Lemma join_sub_mapsto: forall w1 w2 x y, join_sub w1 w2 -> (mapsto x y * TT)%pred w1 -> (mapsto x y * TT)%pred w2.
Proof.
  intros. destruct_sepcon H0 h. destruct H as [w3 ?]. try_join h2 w3 m. exists h1, m. split; auto.
Qed.

Lemma mapsto_unique: forall x a b w, ~ (mapsto x a * mapsto x b)%pred w.
Proof.
  repeat intro. destruct_sepcon H h. destruct H0 as [? [? ?]]. destruct H1 as [? [? ?]]. destruct h1 as [f1 m1].
  destruct h2 as [f2 m2]. destruct w as [fw mw]. hnf in *. simpl in *. specialize (H x). rewrite H3 in *. rewrite H5 in *.
  inversion H. inversion H9.
Qed.

Lemma mapsto__precise: forall p, precise (EX  v : adr, mapsto p v).
Proof.
  intros.
  repeat intro.
  destruct H1 as [w3 ?], H2 as [w4 ?]; destruct H as [? [? [? ?]]], H0 as [? [? [? ?]]].
  destruct w1 as [v1 f1]; destruct w2 as [v2 f2]; destruct w3 as [v3 f3]; destruct w4 as [v4 f4]; destruct w as [v f].
  hnf in H1, H2; simpl in *. apply exist_ext. extensionality mm. destruct (eq_dec mm p).
  + subst. specialize (H1 p). specialize (H2 p). rewrite H4 in *. rewrite H6 in *. inversion H1.
    - subst. inversion H2.
      * rewrite H10, H12. auto.
      * subst. rewrite <- H8 in H2. rewrite <- H11 in H2. hnf in H2. inversion H2. subst. inversion H15.
    - subst. rewrite <- H8 in H1. rewrite <- H9 in H1. hnf in H1. inversion H1. subst. inversion H13.
  + specialize (H3 mm n). specialize (H5 mm n). rewrite H3, H5. auto.
Qed.

Lemma mapsto_conflict: forall p1 p2 v1 v2, p1 = p2 -> mapsto p1 v1 * mapsto p2 v2 |-- FF.
Proof.
  intros.
  subst.
  intro w. apply mapsto_unique.
Qed.

Lemma disj_mapsto_: forall p1 p2, p1 <> p2 -> disjointed (EX v1: adr, mapsto p1 v1) (EX v2: adr, mapsto p2 v2).
Proof.
  intros.
  hnf. intros. destruct H2 as [v1 ?]. destruct H3 as [v2 ?].
  generalize H2; intro Hx. generalize H3; intro Hy.
  destruct h12 as [f12 x12] eqn:? . hnf in H2. simpl in H2. destruct H2 as [? [? ?]].
  destruct h23 as [f23 x23] eqn:? . hnf in H3. simpl in H3. destruct H3 as [? [? ?]].
  remember (fun xx : adr => if NPeano.Nat.eq_dec xx p1 then Some v1 else (if NPeano.Nat.eq_dec xx p2 then Some v2 else None)) as f.
  assert (finMap f). {
    exists (p1 :: p2 :: nil). intro z. intros. rewrite Heqf. destruct (NPeano.Nat.eq_dec z p1).
    + subst. exfalso. apply H8. apply in_eq.
    + destruct (NPeano.Nat.eq_dec z p2).
      - subst. exfalso. apply H8. apply in_cons, in_eq.
      - trivial.
  } remember (exist (finMap (B:=adr)) f H8) as ff.
  assert (join h12 h23 ff). {
    rewrite Heqw, Heqw0, Heqff. hnf; simpl. rewrite Heqf. intro z. destruct (NPeano.Nat.eq_dec z p1).
    + rewrite e in *. rewrite H5. generalize (H6 p1 H); intro HS. rewrite HS. constructor.
    + destruct (NPeano.Nat.eq_dec z p2).
      - rewrite e in *. rewrite H7. generalize (H4 p2 n); intro HS. rewrite HS. constructor.
      - specialize (H4 z n). specialize (H6 z n0). rewrite H4, H6. constructor.
  } rewrite <- Heqw0 in *. rewrite <- Heqw in *.
  assert (emp h2). {
    apply join_sub_joins_identity with h23.
    + exists h3; auto.
    + try_join h2 h23 t. exists t; auto.
  } elim_emp_direct.
  split; auto. exists ff; auto.
Qed.

Lemma mapsto_inj: forall p v1 v2, mapsto p v1 && mapsto p v2 |-- !! (v1 = v2).
Proof.
  intros; simpl; intro w; intros. destruct H.
  destruct H as [? [? ?]]. destruct H0 as [? [? ?]]. rewrite H2 in H4.
  inversion H4. subst; auto.
Qed.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From fourcolor Require Import color ctree dyck.

(******************************************************************************)
(*   Creation of an initial (full) coloring tree and its correctness theorem. *)
(* This tree is constructed using dynamic programming, tabulating first its   *)
(* leaves, then subtrees of height 1, 2, etc, until h - 2, where h is the     *)
(* perimeter length / ring size. Subtrees of odd traces are pruned at this    *)
(* stage, and the final tree (of height h - 1) is assembled from the three    *)
(* pruned subtrees of height h - 2.                                           *)
(*   The tables are simply lists of tree pairs. The i'th pair consists of the *)
(* two subtrees that can occur after a trace where Color2 and Color3 occur a  *)
(* total of i times; the first component of the pair occurs at traces t whose *)
(* color sum is even (~~ color_bit0 (sumt t)), the second at odd-sum traces.  *)
(*   Main definitions:                                                        *)
(* ctree_init_tree h == the full tree storing all even partial traces for     *)
(*                  ring size h.                                              *)
(*   ctree_table := seq ctree_pair, the type of tables storing subtrees of a  *)
(*                  given height of the full tree for a given ring size.      *)
(*  ctree_table_sub tab i b == the ctree in tab : ctree_table storing traces  *)
(*                  that can occur after a trace et where Color2 and Color3   *)
(*                  occur a total of i times and whose color sum has parity b *)
(*                  (color_bit0 (sumt et) == b).                              *)
(* ctree_leaf_table h == the table of non empty leaves at ring size h.        *)
(* ctree_merge_table tab == compute the table of subtrees of height n+1 from  *)
(*                  the table of subtrees of height n.                        *)
(* ctree_prune_i t == prune all branches of t where Color i+2 occurs before   *)
(*                 Color i+1 (with i in [1,3], and +1 cycling from 3 to 1).   *)
(******************************************************************************)

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

Definition ctree_table := seq ctree_pair.

Section InitCtree.

Notation ctz := ctree_empty_pair (only parsing).

Definition ctree_table_sub (tab : ctree_table) n23 :=
  ctree_pair_sub (nth ctz tab n23).

(* First, leaf construction.                                                 *)

Fixpoint ctree_add_dyck m n :=
  if n is n'.+1 then iteri m.+1 (fun m' => ctree_add_dyck m'.+1 n') else
  CtreeLeaf.

Fixpoint ctree_leaf_table_from lf n h : ctree_table :=
  match h with
  | 0 => [::]
  | 1 => [:: CtreePair lf lf]
  | h'.+2 =>
      [:: CtreePair lf lf, CtreePair CtreeEmpty lf
        & ctree_leaf_table_from (ctree_add_dyck 2 n lf) n.+1 h']
  end.

Definition ctree_leaf_table h : ctree_table :=
  let leaf1 := CtreeLeaf CtreeEmpty in
  CtreePair CtreeEmpty leaf1 :: ctree_leaf_table_from leaf1 0 h.

(* Pairs are merged pairwise to build higher trees.                          *)
(* CtreeNode instead of ctree_cons would be correct here, but hard to prove. *)

Definition ctree_merge_pair tu tu' :=
  let: CtreePair t0 t1 := tu in let: CtreePair t2 t3 := tu' in
  CtreePair (ctree_cons t1 t2 t3) (ctree_cons t0 t3 t2).

Definition ctree_merge_table (tab : ctree_table) : ctree_table :=
  if tab is line :: tab' then pairmap ctree_merge_pair line tab' else tab.

(* Pruning odd permutations.                                                 *)

Fixpoint ctree_prune_1 t :=
  if t is CtreeNode t1 t2 t3 then
    ctree_cons (ctree_prune_1 t1) t2 CtreeEmpty
  else t.

Fixpoint ctree_prune_2 t :=
  if t is CtreeNode t1 t2 t3 then
    ctree_cons CtreeEmpty (ctree_prune_2 t2) t3
  else t.

Fixpoint ctree_prune_3 t :=
  if t is CtreeNode t1 t2 t3 then
    ctree_cons t1 CtreeEmpty (ctree_prune_3 t3)
  else t.

(* Putting everything together.                                              *)

Definition ctree_init_tree h :=
  if iter h.-1 ctree_merge_table (ctree_leaf_table h)
    is [:: CtreePair t0 t1, CtreePair t2 t3 & _]
  then ctree_cons (ctree_prune_1 t1) (ctree_prune_2 t2) (ctree_prune_3 t3)
  else CtreeEmpty.

(* Leaf correctness. *)

Lemma ctree_add_dyck_leaf_of m n d :
  ctree_add_dyck m n (ctree_leaf_of d)
   = ctree_leaf_of (gen_dyck m.+1 (m + n.*2) + d).
Proof.
elim: n m d => [|n IHn] m /=; first by rewrite addn0 gen_dyck_all_close.
elim: m => [|m IHm] d; rewrite doubleS /=; first by rewrite addn0 IHn.
by rewrite IHm IHn doubleS addnA -addnE !addnS.
Qed.

Lemma ctree_leaf_table_size h : size (ctree_leaf_table h) = h.+1.
Proof.
rewrite /ctree_leaf_table_from /=; congr _.+1.
rewrite -(odd_double_half h) addnC; move: (CtreeLeaf CtreeEmpty) 0.
by elim: h./2 => [|h2 IHh] t n; [case: (odd h) | rewrite /= IHh].
Qed.

Lemma ctree_leaf_table_sub h i b0 :
   i <= h ->
   let cet := [:: ccons (odd i) b0] in let n_i := i + count_cbit1 cet in
  ctree_table_sub (ctree_leaf_table h) i b0
   = (if Color0 \in cet then CtreeEmpty else ctree_leaf_of (dyck n_i)).
Proof.
rewrite /ctree_leaf_table -{1 2 4}[i]odd_double_half.
move: (odd i) i./2 => b1 m; rewrite (addnC b1) => lemh.
rewrite /= cbit1_ccons inE addn0 -addnA -{2}[m]addn0.
set t1 := CtreeLeaf _; rewrite -{1}[t1]/(ctree_leaf_of (dyck 0.*2)).
rewrite -{t1}[t1]/(ctree_leaf_of (dyck 1.*2)).
elim: m 0 h lemh => [|m IHm] n.
  by rewrite /= !add0n addnC; case: b1 b0 => [[] [|[]] | []].
case=> [|[|h]] // /(IHm n.+1); rewrite addSnnS => <-.
by rewrite /dyck /= ctree_add_dyck_leaf_of !addn0.
Qed.

(* Global correctness; we run through the construction twice, once to check *)
(* that subtrees are proper, and once to check the counts.                  *)

Lemma ctree_init_tree_proper h : ctree_proper h (ctree_init_tree h).
Proof.
case Dh: h => [|h'] //=; rewrite /ctree_init_tree.
move Dltab: (ctree_leaf_table _) => ltab /=; move Dtab: (iter _ _ ltab) => tab.
have{Dtab ltab Dltab} [Dsz sub_ok]: h' + size tab = h.+1
  /\ forall i b0, i < size tab -> ctree_proper h' (ctree_table_sub tab i b0).
- have:= leqnSn h'; rewrite -{tab}Dtab -Dh.
  elim: (h') => [_ | n IHn /leqW ltnh].
    rewrite /= -{ltab}Dltab -Dh ctree_leaf_table_size; split=> // i b0 leih.
    rewrite ctree_leaf_table_sub //; case: ifP => // _.
    exact: ctree_leaf_of_proper.
  move Dctp': (ctree_proper n.+1) => ctp' /=.
  case: (iter n _ ltab) {IHn}(IHn ltnh) => [|pt0 tab] [Dn tab_ok].
    by rewrite -Dn /= addn0 ltnn in ltnh.
  rewrite /= addSnnS size_pairmap /=; split=> {Dn}// i b0 ltitab.
  move/tab_ok: (ltnW ltitab); move/(tab_ok i.+1): (ltitab) => {tab_ok}.
  rewrite /ctree_table_sub (nth_pairmap ctz) {ltitab}//=.
  case: (nth _ _ i) => t0 t1; case: {i tab}(nth _ _ i) => t2 t3.
  do 2![move=> t_ok; move: {t_ok}(t_ok false) (t_ok true) => /= ? ?].
  by case: b0; rewrite /= -Dctp'; apply ctree_cons_proper.
have{h Dh} Dsz: size tab = 2 by apply: (@addnI h'); rewrite Dsz Dh addn2.
case: tab Dsz => [|[t0 t1] [|[t2 t3] tab']] //= _ in sub_ok *.
have ok1 := sub_ok 1 _ isT.
move: {sub_ok ok1}(sub_ok 0 true isT) (ok1 false) (ok1 true).
rewrite /ctree_table_sub {t0 tab'}/= => t1ok t2ok t3ok.
apply ctree_cons_proper;
 [ move: t1 t1ok {t2 t2ok t3 t3ok}
 | move: {t1 t1ok} t2 t2ok {t3 t3ok}
 | move: {t1 t1ok t2 t2ok} t3 t3ok ];
 elim: h' => [|h IHh] [t1 t2 t3|lf|] //= [_ t1ok t2ok t3ok];
 by apply ctree_cons_proper => //; apply: IHh.
Qed.

Lemma ctree_sub_init_tree h (et : colseq) :
 let et_ok := [&& size et == h, Color0 \notin ctrace et & even_trace et] in
 ctree_sub (ctree_init_tree h) et =
   (if et_ok then dyck (count_cbit1 (ctrace et)) else 0).
Proof.
case Dh: h => [|h']; [by case: et | rewrite /ctree_init_tree [_.-1]/= -Dh].
move Dltab: (ctree_leaf_table h) => ltab; move Dtab: (iter _ _ ltab) => tab.
have{ltab Dtab Dltab} [Dsz Dsub]: h' + size tab = h.+1
    /\ forall i, i < size tab -> forall b0 et,
       let cet := rcons et (ccons (odd i) b0 +c sumt et) in
       let et_ok := (size et == h') && (Color0 \notin cet) in
       ctree_sub (ctree_table_sub tab i b0) et
         = (if et_ok then dyck (i + count_cbit1 cet) else 0).
- have:= leqnSn h'; rewrite -{et tab}Dtab -Dh.
  elim: (h') => [_ | n IHn /leqW ltnh] /=.
    rewrite -{ltab}Dltab ctree_leaf_table_size add0n; split=> //= i ileh b0.
    rewrite ctree_leaf_table_sub //; move: (ccons _ _) => c.
    by case=> *; rewrite ?addc0; case: ifP => // _; apply: ctree_sub_leaf_of.
  case: (iter n _ _) {IHn}(IHn ltnh) => [|pt tab] [Dn tab_ok].
    by rewrite -Dn /= addn0 ltnn in ltnh.
  rewrite /= size_pairmap addSnnS {}Dn; split=> // i ltitab b0.
  move: {tab_ok}(tab_ok i (ltnW ltitab)) (tab_ok i.+1 ltitab).
  rewrite /ctree_table_sub (nth_pairmap ctz) {ltitab}//=.
  case: {pt}(nth _ _ i) => t0 t1; case: {tab}(nth _ _ i) => t2 t3.
  do 2![move=> Dsub; move: {Dsub}(Dsub false) (Dsub true) => /= ? ?].
  case=> [|e et]; first by case: b0; rewrite ctree_sub_cons.
  rewrite /= addcA eqSS -[_ +c e]ccons_cbits inE.
  rewrite cbit0_addc cbit0_ccons cbit1_addc cbit1_ccons.
  case: e; rewrite /= ?addbT ?addbF -1?addSnnS;
    by case: b0; rewrite /= ctree_sub_cons /= ?andbF ?add0n.
have {}Dsz: size tab = 2 by apply: (@addnI h'); rewrite Dsz Dh addnC.
case: tab Dsz => [|[t0 t1] [|[t2 t3] tab']] //= _ in Dsub *.
move Dtec: {-}(even_trace et) => tec; rewrite /= ctree_sub_cons {h}Dh.
case: et => [|e et] //= in Dtec *; rewrite eqSS.
move: {Dsub}(Dsub 0 isT true et) (Dsub 1 isT false et) (Dsub 1 isT true et).
rewrite /ctree_table_sub {t0 tab'}/= => Dt1 Dt2 Dt3.
case: e Dtec; [by rewrite andbF | move: t1 Dt1 | move: t2 Dt2 | move: t3 Dt3];
  by clear=> t Dt Dtec; transitivity (if tec then ctree_sub t et else 0);
  [ rewrite -{h' tec Dt}Dtec; elim: et t => [|e et IHet] [t1 t2 t3|lf|];
    rewrite /= ?if_same // ctree_sub_cons //; case: e; rewrite /= ?if_same
  | by rewrite Dtec andbA andbC; case tec].
Qed.

End InitCtree.


Require Import TraceModel.
Require Import XPrefix.
Require Import Properties.
Require Import ClassicalExtras.
Require Import Events.

(** This file defines the notion of language and of compilation
    chain we use in the rest of the development *)

Set Implicit Arguments.

Record language :=
  {
    par  : Set;  (* partial programs *)
    prg  : Set;  (* whole programs *)
    ctx  : Set;  (* context *)
    plug : par -> ctx -> prg;
    sem  : prg -> prop;
    non_empty_sem : forall W, exists t, sem W t
  }.

Axiom src : language.
Axiom tgt : language.
Axiom compile_par : (par src) -> (par tgt).
Axiom compile_ctx : (ctx src) -> (ctx tgt).
Axiom compile_prg : (prg src) -> (ctx tgt).

Notation "C [ P ]" := (plug _ P C) (at level 50).
Notation "P ↓" := (compile_par P) (at level 50).

Definition psem {K : language}
                (P : prg K)
                (m : finpref) : Prop :=
  exists t, prefix m t /\ (sem K) P t.

Definition xsem {K : language}
                (P : prg K)
                (x : xpref) : Prop :=
  exists t, xprefix x t /\ (sem K) P t.

Definition sat {K : language}
               (P : prg K)
               (π : prop) : Prop :=
  forall t, sem K P t -> π t.

Definition rsat {K : language}
                (P : par K)
                (π : prop) : Prop :=
  forall C, sat (C [ P ] ) π.

Lemma neg_rsat {K : language} :
    forall P π, (~ rsat P π <->
           (exists C t, sem K (C [ P ]) t /\ ~ π t)).
Proof.
   unfold rsat. unfold sat. split.
  - intros r. rewrite not_forall_ex_not in r.
    destruct r as [C r]. rewrite not_forall_ex_not in r.
    destruct r as [t r]. exists C,t. rewrite not_imp in r.
    assumption.
  - intros [C [t r]]. rewrite not_forall_ex_not.
    exists C. rewrite not_forall_ex_not. exists t.
    rewrite not_imp. assumption.
Qed.

Definition beh {K : language} (P : prg K) : prop :=
  fun b => sem K P b.

Definition hsat {K : language}
                (P : prg K)
                (H : hprop) : Prop :=
  H (beh P).

Definition rhsat {K : language}
                 (P : par K)
                 (H : hprop) : Prop :=
  forall C, hsat ( C [ P ] ) H.

Lemma neg_rhsat {K : language} :
  forall P H,  (~ rhsat P H <-> ( exists (C : ctx K), ~ H (beh ( C [ P ] )))).
Proof.
  intros P H. split; unfold rhsat; intro H0;
  [now rewrite <- not_forall_ex_not | now rewrite not_forall_ex_not].
Qed.

Definition sat2 {K : language} (P1 P2 : @prg K) (r : rel_prop) : Prop :=
  forall t1 t2, sem K P1 t1 -> sem K P2 t2 -> r t1 t2.

Lemma neg_sat2 {K : language} : forall P1 P2 r,
    ~ sat2 P1 P2 r <-> (exists t1 t2, sem K P1 t1 /\ sem K P2 t2 /\ ~ r t1 t2).
Proof.
  unfold sat2. intros P1 P2 r. split.
  +  intros H. rewrite not_forall_ex_not in H.
    destruct H as [t1 H]. rewrite not_forall_ex_not in H.
    destruct H as [t2 H]. rewrite not_imp in H. destruct H as [H1 H2].
    rewrite not_imp in H2. destruct H2 as [H2 H3].
    now exists t1, t2.
  + intros [t1 [t2  [H1 [H2 H3]]]]. rewrite not_forall_ex_not.
    exists t1. rewrite not_forall_ex_not. exists t2.
    rewrite not_imp. split.
    ++ assumption.
    ++ rewrite not_imp. now auto.
Qed.

Definition rsat2 {K : language} (P1 P2 : @par K) (r : rel_prop) : Prop :=
  forall C, sat2 (C [ P1 ]) (C [ P2 ]) r.

Definition hsat2 {K : language} (P1 P2 : @prg K) (r : rel_hprop) : Prop :=
   r (sem K P1) (sem K P2).

Definition hrsat2 {K : language} (P1 P2 : @par K) (r : rel_hprop) : Prop :=
  forall C, r (sem K (C [P1])) (sem K (C [P2])).

(**************************************************************************)

Definition input_totality (K : language) : Prop :=
  forall (P : prg K) l e1 e2,
    is_input e1  -> is_input e2 -> psem P (ftbd (snoc l e1)) -> psem P (ftbd (snoc l e2)).

Definition traces_match (t1 t2 : trace) : Prop :=
 t1 = t2 \/
 (exists (l : list event) (e1 e2 : event),
   is_input e1 /\ is_input e2 /\  e1 <> e2 /\
   prefix (ftbd (snoc l e1)) t1 /\ prefix (ftbd (snoc l e2)) t2).

Definition determinacy (K : language) : Prop :=
  forall (P : prg K) t1 t2,
    sem K P t1 -> sem K P t2 -> traces_match t1 t2.

Definition semantics_safety_like (K : language) : Prop :=
  forall t P,
    ~ sem K P t -> inf t -> ~ diverges t ->
    (exists l ebad, psem P (ftbd l) /\ prefix (ftbd (snoc l ebad)) t /\ ~ psem P (ftbd (snoc l ebad))).


(**
Signing - Simple definitions for message signing and signature checking

Perry Alexander
The University of Kansas

Provides definitions for:
- [is_signed] - proof that signature checking is decidable and provides a decision procedure for signature check.
- [check] - checks a signature on a message with a given key.  Returns a proof that the check succeeds or does not succeed.
- [check_dec] - proof that signature checking is decidable and provides a decision procedure for signature checking.  Alternative function for [check].

Depends on:
- Crypto.v
*)

Require Import Omega.
Require Import CpdtTactics.
Require Import Eqdep_dec.
Require Import Peano_dec.
Require Import Coq.Program.Equality.
Require Export Crypto.

(** Generate a signature using encryption and hash *)

Definition sign{t:type}(m:message t)(k:keyType) :=
  (pair t (Encrypt (Hash t)) m (encrypt (Hash t) (hash t m) k)).

Eval compute in sign (basic 1) (public 1).

Ltac eq_key_helper :=
  match goal with
  | [ |- {symmetric ?P = symmetric ?Q} + {symmetric ?P <> symmetric ?Q} ] =>
    (eq_not_eq (eq_nat_dec P Q))
  | [ |- {public ?P = public ?Q} + {public ?P <> public ?Q} ] =>
    (eq_not_eq (eq_nat_dec P Q))
  | [ |- {private ?P = private ?Q} + {private ?P <> private ?Q} ] =>
    (eq_not_eq (eq_nat_dec P Q))
  | [ |- _ ] => right; unfold not; intros; inversion H
  end.

Theorem eq_key_dec: forall k k':keyType, {k=k'}+{k<>k'}.
Proof.
  intros.
  destruct k; destruct k'; eq_key_helper.
Defined.

Hint Resolve eq_key_dec.

Theorem eq_type_dec: forall x y : type, {x = y} + {x <> y}.
Proof.
  induction x, y;
  match goal with
  | [ |- {?T = ?T} + {?T <> ?T} ] => left; reflexivity
  | [ |- {?C ?T = ?C ?U} + {?C ?T <> ?C ?U} ] => specialize IHx with y; destruct IHx; [ left; subst; reflexivity | right; unfold not; intros; inversion H; contradiction ]
  | [ |- {?C ?T ?U = ?C ?T' ?U'} + {?C ?T ?U <> ?C ?T' ?U'} ] => specialize IHx1 with y1; specialize IHx2 with y2; destruct IHx1; destruct IHx2;
  [ left; subst; reflexivity
   | subst; right; unfold not; intros; inversion H; contradiction
   | subst; right; unfold not; intros; inversion H; contradiction
   | subst; right; unfold not; intros; inversion H; contradiction ]
  | [ |- _ ] => right; unfold not; intros; inversion H
  end.
  Defined.

Theorem message_eq_lemma: forall t, forall m:(message t), forall m':(message t), forall k k',
    {m=m'}+{m<>m'} ->
    {k=k'}+{k<>k'} ->
    {(encrypt t m k)=(encrypt t m' k')}+{(encrypt t m k) <> (encrypt t m' k')}.
Proof.
  intros.
  destruct H; destruct H0.
  left; subst; reflexivity.
  right; subst; unfold not; intros; inversion H; contradiction.
  right. subst. unfold not. intros. inversion H. apply inj_pair2_eq_dec in H1. contradiction.
  apply eq_type_dec.
  right. unfold not. intros. inversion H. apply inj_pair2_eq_dec in H1. contradiction.
  apply eq_type_dec.
Defined.

Hint Resolve message_eq_lemma.

Ltac whack_right :=
  match goal with
  | [ |- {basic ?P = basic ?Q}+{basic ?P <> basic ?Q} ] =>
    (eq_not_eq (eq_nat_dec P Q))
  | [ |- {key ?P = key ?Q}+{key ?P <> key ?Q} ] =>
    (eq_not_eq (eq_key_dec P Q))
  | [ |- {encrypt ?P ?P' = encrypt ?Q ?Q'}+{encrypt ?P ?P' <> encrypt ?Q ?Q'} ] =>
    auto
  | [ H : {?P = ?Q}+{?P <> ?Q} |- {hash ?P = hash ?Q}+{hash ?P <> hash ?Q} ] =>
    (eq_not_eq H)
  | [ H1 : {?P = ?P'}+{?P <> ?P'},
      H2 : {?Q = ?Q'}+{?Q <> ?Q'}
      |- {pair ?P ?Q = pair ?P' ?Q'}+{pair ?P ?Q <> pair ?P' ?Q'} ] =>
    (eq_not_eq' H1 H2)
  | [ |- _ ] => right; unfold not; intros; inversion H
  end.

Theorem message_eq_dec: forall t, forall m:(message t), forall m':(message t), {m=m'}+{m<>m'}.
Proof.
  dependent induction m; dependent induction m'.
  (eq_not_eq (eq_nat_dec n n0)).
  right; unfold not; intros; inversion H.
  (eq_not_eq (eq_key_dec k k0)).
  right; unfold not; intros; inversion H.

  specialize IHm with m'.
  destruct IHm; destruct (eq_key_dec k k0);
  [ left; subst; reflexivity
  | right; unfold not; intros; inversion H; contradiction
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1;
    [contradiction | apply eq_type_dec]
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1;
    [contradiction | apply eq_type_dec]].

  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.

  specialize IHm with m'.
  destruct IHm;
  [ left; subst; reflexivity
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1;
    [contradiction | apply eq_type_dec]].

  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.

  specialize IHm2 with m'2.
  specialize IHm1 with m'1.
  destruct IHm1; destruct IHm2;
  [ left; subst; reflexivity
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1; apply inj_pair2_eq_dec in H2; [ contradiction | apply eq_type_dec | apply eq_type_dec | apply eq_type_dec ]
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1; apply inj_pair2_eq_dec in H2; [ contradiction | apply eq_type_dec | apply eq_type_dec | apply eq_type_dec ]
  | right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1; apply inj_pair2_eq_dec in H2; [ contradiction | apply eq_type_dec | apply eq_type_dec | apply eq_type_dec ]].

  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  right; unfold not; intros; inversion H; apply inj_pair2_eq_dec in H1.
  left; reflexivity.
Defined.

Hint Resolve message_eq_dec.

Print encrypt.

Definition signed_message_type{t:type}(m:message (Pair t (Encrypt (Hash t)))):type := t.

Definition is_signed{t:type}(m:message (Pair t (Encrypt (Hash t))))(k:keyType):Prop.
  refine match m in (message r) with
         | pair r1 (Encrypt (Hash r2)) n n' => if (eq_type_dec r1 r2)
                                              then match (decrypt n' k) with
                                                   | inleft m' => _
                                                   | inright _ => False
                                                   end
                                              else False
         | _ => False
         end.
  Proof.
    subst.
    apply (if (message_eq_dec _ (hash r2 n) m') then True else False).
  Defined.

  Example ex1: is_signed (sign (basic 1) (private 1)) (public 2) -> False.
  Proof.
    simpl. tauto.
  Qed.

  Example ex2: is_signed (sign (basic 1) (symmetric 1)) (public 2) -> False.
  Proof.
    simpl. tauto.
  Qed.

  Example ex3: is_signed (sign (basic 1) (symmetric 1)) (symmetric 2) -> False.
  Proof.
    simpl; tauto.
  Qed.

  Example ex4: is_signed (sign (basic 1) (symmetric 1)) (symmetric 1).
  Proof.
    simpl.
  Admitted.

  Theorem check_dec: forall t:type, forall m:message (Pair t (Encrypt (Hash t))), forall k, {(is_signed m k)}+{not (is_signed m k)}.
  Admitted.

  (* Proof.
  intros.
  destruct m; try tauto.
  destruct m2; try tauto.
    destruct m2; try tauto.
      destruct (is_inverse k k0).
        destruct (message_eq_dec m1 m2); try tauto.
        left. subst. simpl. tauto.
          right. unfold not. intros. simpl in H. tauto.
          right. unfold not. intros. simpl in H. tauto.
   *)

Example sign_1_ex: is_signed (sign (basic 1) (private 1)) (public 1).
Proof.
  unfold is_signed. fold (is_signed (t := Basic)).
Admitted.

Example sign_2_ex: not (is_signed (sign (basic 1) (private 1)) (public 2)).
Proof.
  unfold not. intros.
  simpl in H. assumption.
Qed.

(*
Eval compute in check_dec (sign (basic 1) (private 1)) (public 1).

Eval compute in check_dec (sign (basic 1) (private 1)) (public 2).
 *)

Notation " 'good' " := (left _ _).

Notation " 'bad' " := (right _ _).

(*
Eval compute in check_dec (sign (basic 1) (private 1)) (public 1).

Eval compute in check_dec (sign (basic 1) (private 1)) (public 2).
 *)


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import type_sys_useful.
Require Import dest_close.

Lemma per_product_eq_preserves_eq_term_equals {p} :
  forall lib (eqa1 eqa2 : per(p)) eqb1 eqb2 t1 t2,
    eq_term_equals eqa1 eqa2
    -> (forall (a1 a2 : CTerm) (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
          eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
    -> per_product_eq lib eqa1 eqb1 t1 t2
    -> per_product_eq lib eqa2 eqb2 t1 t2.
Proof.
  introv eqta eqtb peq.
  allunfold @per_product_eq; exrepnd.
  assert (eqa2 a a') as e' by (rw <- eqta; sp).
  exists a a' b b' e'; sp.
  generalize (eqtb a a' e e'); intro eqt.
 rw <- eqt; sp.
Qed.

Lemma per_product_eq_sym {p} :
  forall lib (eqa : per(p)) eqb t1 t2,
    term_equality_symmetric eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          term_equality_symmetric (eqb a1 a2 e))
    -> (forall (a1 a2 : CTerm) (e1 : eqa a1 a2) (e2 : eqa a2 a1),
          eq_term_equals (eqb a1 a2 e1) (eqb a2 a1 e2))
    -> per_product_eq lib eqa eqb t1 t2
    -> per_product_eq lib eqa eqb t2 t1.
Proof.
  introv syma symb symb2 peq.
  allunfold @per_product_eq; exrepnd.
  assert (eqa a' a) as e' by (apply syma; sp).
  exists a' a b' b e'; sp.
  apply symb; sp.
  generalize (symb2 a a' e e'); intro eqt.
  apply eqt; sp.
Qed.

Lemma per_product_eq_trans {p} :
  forall lib (eqa : per(p)) eqb t1 t2 t3,
    term_equality_symmetric eqa
    -> term_equality_transitive eqa
    -> (forall a1 a2 (e : eqa a1 a2),
          term_equality_transitive (eqb a1 a2 e))
    -> (forall a1 a2 (e1 : eqa a1 a2) (e : eqa a1 a1),
          eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e))
    -> (forall a1 a2 (e2 : eqa a2 a1) (e : eqa a1 a1),
          eq_term_equals (eqb a2 a1 e2) (eqb a1 a1 e))
    -> per_product_eq lib eqa eqb t1 t2
    -> per_product_eq lib eqa eqb t2 t3
    -> per_product_eq lib eqa eqb t1 t3.
Proof.
  introv syma tra trb refb1 refb2 peq1 peq2.
  allunfold @per_product_eq; exrepnd.
  spcast; computes_to_eqval.
  assert (eqa a0 a') as e' by (apply tra with (t2 := a'0); sp).
  exists a0 a' b0 b' e'; sp; try (complete (spcast; sp)).
  assert (eqa a0 a0) as e1 by (apply tra with (t2 := a'0); sp).
  assert (eqa a'0 a'0) as e2 by (apply tra with (t2 := a0); sp).
  generalize (refb1 a'0 a' e e2); intro eqt1.
  rw eqt1 in peq0.
  generalize (refb2 a'0 a0 e0 e2); intro eqt2.
  rw <- eqt2 in peq0.
  generalize (trb a0 a'0 e0 b0 b'0 b'); intro trb1.
  repeat (autodimp trb1 hyp).
  generalize (refb1 a0 a'0 e0 e1); intro eqt3.
  generalize (refb1 a0 a' e' e1); intro eqt4.
  rw eqt3 in trb1.
  rw eqt4; sp.
Qed.

Lemma per_product_eq_cequivc {p} :
  forall lib (eqa : per(p)) eqb t1 t2,
    term_equality_respecting lib eqa
    -> (forall a1 a2 (e : eqa a1 a2),
          term_equality_respecting lib (eqb a1 a2 e))
    -> (forall a1 a2 (e1 : eqa a1 a2) (e : eqa a1 a1),
          eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e))
    -> cequivc lib t1 t2
    -> per_product_eq lib eqa eqb t1 t1
    -> per_product_eq lib eqa eqb t1 t2.
Proof.
  introv tera terb eqt1 ceq peq.
  allunfold @per_product_eq; exrepnd.
  spcast; computes_to_eqval.
  generalize (cequivc_mkc_pair lib t1 t2 a b); intro k.
  repeat (autodimp k hyp); exrepnd.
  assert (eqa a a') as e' by (apply tera; sp; try (spcast; sp)).
  exists a a' b b' e'; sp; try (complete (spcast; sp)).
  generalize (eqt1 a a' e' e); intro eqt.
  apply eqt in peq0.
  generalize (terb a a' e'); intro k.
  apply k; sp; try (spcast; sp).
Qed.

Lemma close_type_system_product {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         A A' v v' B B' eqa eqb,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_product A v B)
    -> computes_to_valc lib T' (mkc_product A' v' B')
    -> close lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          close lib ts (substc a v B) (substc a' v' B') (eqb a a' e))
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_system lib ts ->
          defines_only_universes lib ts ->
          type_sys_props lib (close lib ts) (substc a v B) (substc a' v' B')
                         (eqb a a' e))
    -> (forall t t' : CTerm, eq t t' <=> per_product_eq lib eqa eqb t t')
    -> per_product lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) A A' eqa
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv X X0 c1 c2 X1 clb recb eqiff per IHX1.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  + SCase "uniquely_valued".
    dclose_lr.

    SSCase "CL_product".
    allunfold @per_product; exrepd.
    generalize (eq_term_equals_type_family lib T T3 eqa0 eqa eqb0 eqb (close lib ts) A v B A' v' B' mkc_product); intro i.
    repeat (autodimp i hyp; try (complete (introv eqp; eqconstr eqp; sp))); repnd.

    unfold eq_term_equals; sp.
    rw e; rw eqiff; split; sp.
    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp.
    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.

  + SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_product;
    clear per;
    allunfold @per_product; exrepd;
    unfold per_product;
    exists eqa0 eqb0; sp;
    allunfold @eq_term_equals; sp;
    allrw <-; sp.

  + SCase "type_value_respecting"; repdors; subst;
    apply CL_product; unfold per_product; exists eqa eqb; sp.

    duplicate c1 as ct.
    apply @cequivc_mkc_product with (T' := T3) in ct; sp.

    apply @type_family_cequivc
          with
          (A1 := A)
          (v1 := v)
          (B1 := B)
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A')
          (v := v')
          (B := B'); sp.

    duplicate c2 as ct.
    apply @cequivc_mkc_product with (T' := T3) in ct; sp.

    apply @type_family_cequivc2
          with
          (A1 := A')
          (v1 := v')
          (B1 := B')
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A)
          (v := v)
          (B := B); sp.

  + SCase "term_symmetric".
    unfold term_equality_symmetric; sp.
    onedtsp e pp p0 p1 c t t0 t3 tygs tygt dum.
    apply eqiff; sp.
    discover.

    generalize (eq_term_equals_sym_tsp2
                  lib (close lib ts) eqa eqb
                  v B v' B'); intro i.
    repeat (autodimp i hyp); repnd.

    apply per_product_eq_sym; sp.

    generalize (recb a1 a2 e0); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.

  + SCase "term_transitive".
    unfold term_equality_transitive; sp.
    apply eqiff; sp.
    assert (eq t1 t2) as eq12 by auto.
    assert (eq t2 t3) as eq23 by auto.
    apply eqiff in eq12; apply eqiff in eq23.

    onedtsp IHX0 IHX2 IHX3 IHX4 IHX5 IHX6 IHX7 IHX8 tygs tygt dum.

    generalize (eq_term_equals_sym_tsp2
                  lib (close lib ts) eqa eqb
                  v B v' B'); intro i.
    repeat (autodimp i hyp); repnd.

    apply @per_product_eq_trans with (t2 := t2); sp;
    try (complete (generalize (recb a1 a2 e); intro tsp;
                   unfold type_sys_props in tsp; sp)).

  + SCase "term_value_respecting".
    unfold term_equality_respecting; sp.
    apply eqiff; sp.
    assert (eq t t) as eqtt by auto.
    apply eqiff in eqtt.

    onedtsp IHX0 IHX2 IHX3 IHX4 IHX5 IHX6 IHX7 IHX8 tygs tygt dum.

    generalize (eq_term_equals_sym_tsp2
                  lib (close lib ts) eqa eqb
                  v B v' B'); intro i.
    repeat (autodimp i hyp); repnd.

    spcast; apply per_product_eq_cequivc; sp.

    generalize (recb a1 a2 e); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.

  + SCase "type_gsymmetric"; repdors; subst; split; sp; dclose_lr;
    apply CL_product;
    clear per;
    allunfold @per_product; exrepd.

    (* 1 *)
    generalize (eq_term_equals_type_family
                  lib T T3 eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_product); intro i.
    repeat (autodimp i hyp; try (complete (introv eqp; eqconstr eqp; sp))).
    repnd.

    exists eqa eqb; sp.

    unfold eq_term_equals; sp.

    rw e; split; intro k; sp.

    apply per_product_eq_preserves_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.

    apply per_product_eq_preserves_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp.

    (* 2 *)
    generalize (eq_term_equals_type_family2
                  lib T3 T eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_product); intro i;
    repeat (autodimp i hyp; try (complete (introv eqp; eqconstr eqp; sp)));
    repnd.

    exists eqa eqb; sp.

    unfold eq_term_equals; sp.

    rw e; split; intro k; sp.

    apply per_product_eq_preserves_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.

    apply per_product_eq_preserves_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp.

  + SCase "type_gtransitive"; sp.

  + SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_product lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_product lib (close lib ts) T' T4 eq2)).

    (* 1 *)
    clear per.
    allunfold @per_product; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T eqa1 eqa eqb1 eqb (close lib ts)
                  A v B A' v' B' mkc_product); intro i.
    repeat (autodimp i hyp; try (complete (introv eqp; eqconstr eqp; sp))).
    repnd.

    generalize (type_family_trans2
                  lib mkc_product (close lib ts) T3 T T4 eqa eqb eqa0 eqb0 A v B A' v' B'); intro j.
    repeat (autodimp j hyp; try (complete (introv eqp; eqconstr eqp; sp))).
    repnd.

    dands; apply CL_product; unfold per_product; exists eqa eqb;
    unfold eq_term_equals; sp; allrw.

    split; intro pp; sp.

    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa1) (eqb1 := eqb1); sp.
    apply eq_term_equals_sym; sp.

    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp.

    split; intro pp; sp.

    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.
    apply eq_term_equals_sym; sp.

    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.

    (* 2 *)
    clear per.
    allunfold @per_product; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T' eqa1 eqa eqb1 eqb (close lib ts)
                  A' v' B' A v B mkc_product); intro i.
    repeat (autodimp i hyp;
            try (complete (introv eqp; eqconstr eqp; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    generalize (type_family_trans2
                  lib mkc_product (close lib ts) T3 T' T4 eqa eqb eqa0 eqb0 A' v' B' A v B); intro j.
    repeat (autodimp j hyp;
            try (complete (introv eqp; eqconstr eqp; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    dands; apply CL_product; unfold per_product; exists eqa eqb;
    unfold eq_term_equals; sp; allrw.

    split; intro pp; sp.

    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa1) (eqb1 := eqb1); sp.
    apply eq_term_equals_sym; sp.

    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
    apply eq_term_equals_sym; sp.

    split; intro pp; sp.

    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa0) (eqb1 := eqb0); sp.
    apply eq_term_equals_sym; sp.
    apply eq_term_equals_sym; sp.

    apply @per_product_eq_preserves_eq_term_equals with (eqa1 := eqa) (eqb1 := eqb); sp.
Qed.


Require Import ssrfun lib Size.

Class MMap (A B: Type) := mmap : (A -> A) -> B -> B.

Class MMapLemmas `(mmap : MMap) := {
  mmap_id : mmap id = id;
  mmap_comp x f g: mmap f (mmap g x) = mmap (f \o g) x
}.

Ltac gen_MMap :=
hnf; match goal with [ |- (?A -> ?A) -> ?B -> ?B] =>
intros f; fix mmap' 1; intros s;
destruct s eqn:E;
let term := type of s in
match goal with
    [E : s = ?s' |- _] =>
    let rec map s :=
        (match s with
             ?s1 ?s2 =>
             let s1' := map s1 in
             let s2_T := type of s2 in
             let s2' := match s2_T with
                         | A => constr:(f s2)
                         | B => constr:(mmap' s2)
                         | bind B => constr:(mmap' s2)
                         | context[B] => constr:(mmap mmap' s2)
                         | context[A] => constr:(mmap f s2)
                         | _ => s2
                       end in
             constr:(s1' s2')
           | _ => s end) in
    let t' := map s' in
    exact t'
end
end.

Ltac gen_MMapLemmas :=
constructor;[
f_ext; induction 0; simpl; now autorew |
let x := fresh "x" in intros x; induction x; intros; simpl; now autorew].
(*
Instance mmap_refl (A : Type) : MMap A A := id.
Arguments mmap_refl _ {_} f /.
Instance mmap_lemmas_refl (A : Type) : MMapLemmas (mmap_refl A).
constructor; intuition. Qed.
*)
Instance mmap_trans (A B C : Type) (mmap1 : MMap A B) (mmap2 : MMap B C) : MMap A C := (fun f => mmap (mmap f)).
Arguments mmap_trans _ _ _ _ _ _ _ /.
Instance mmap_lemmas_trans
(A B C : Type) (mmap1 : MMap A B) (mmap2 : MMap B C)
(l1 : MMapLemmas mmap1) (l2 : MMapLemmas mmap2) : MMapLemmas (mmap_trans A B C mmap1 mmap2).
destruct l1. destruct l2. constructor; cbv; unfold id in *; intros; autorew.
- now trivial.
- f_equal. f_ext. intros. unfold funcomp. now autorew.
Qed.

Hint Rewrite @mmap_id @mmap_comp : mmap.

Ltac msimpl' :=
  unfold mmap;
  simpl;
repeat match goal with [|- appcontext[?s]] =>
  match s with
    | ?s1 _ => let T := typeof s1 in
              match T with MMap _ _ => progress change s1 with (@mmap _ _ s1) end
  end
end.

Ltac msimpl :=
repeat(
     msimpl';
     try(autorewrite with mmap; [idtac | now eauto with typeclass_instances ..])
    ).

Ltac msimpl'H H :=
  unfold mmap in H;
  simpl in H;
repeat (
    let T := typeof H in
    match T with appcontext[?s] =>
      match s with
        | ?s1 _ => let T := typeof s1 in
           match T with MMap _ _ => progress change s1 with (@mmap _ _ s1) in H
           end
      end
    end).

Ltac msimplH H :=
repeat(
     msimpl'H H;
     try(autorewrite with mmap in H; [idtac | now eauto with typeclass_instances ..])
    ).

Instance mmap_list (A : Type) : MMap A (list A).
gen_MMap. Defined.

Instance mmap_lemmas_list (A : Type) : MMapLemmas (mmap_list A).
gen_MMapLemmas. Defined.
(*
Inductive foo :=
  Foo (_ : list (list foo)).

Instance size_foo : Size foo. gen_Size. Defined.

Instance mmap_foo : MMap nat foo.
gen_MMap. Defined.
Instance mmap_lemmas_foo : MMapLemmas (mmap_foo).
constructor.
- f_ext. intros x. msimpl. sind x; destruct x.
  msimpl. f_equal. induction l.
  + reflexivity.
  + repeat msimpl. f_equal. induction a;
 repeat(msimpl; autorew; intuition (try somega)).
 apply IHl. intros. apply IH. somega.
- intros x. sind x. intros.

Defined.*)