Require Import FP.CoreData.
Require Import FP.CoreClasses.
Require Import FP.Classes.
Require Import FP.Data.Type.

Import ClassesNotation.
Import CoreDataNotation.
Import CoreClassesNotation.

Section EqDec.
  Context {A B} `{! EqDec A ,! EqDec B }.

  Definition prod_eq_dec (ab1:A*B) (ab2:A*B) : bool :=
    let '((a1,b1),(a2,b2)) := (ab1,ab2) in
    a1 =! a2 && b1 =! b2.

  Global Instance prod_EqDec : EqDec (A*B) := { eq_dec := prod_eq_dec }.
End EqDec.
Global Instance prod_Bif_EqDec : Bif_EqDec prod := { bif_eq_dec := @prod_EqDec }.

Section Eq_RDC.
  Context {A B} `{! EqDec A ,! Eq_RDC A ,! EqDec B ,! Eq_RDC B }.

  Global Instance prod_Eq_RDC : Eq_RDC (A*B).
  Proof.
    repeat constructor ; intros ; destruct x,y ; simpl in * ; unfold prod_eq_dec in *
    ; repeat
        match goal with
        | [ H : (_,_) = (_,_) |- _ ] => inversion H ; subst ; clear H
        end ; simpl in * ; try congruence.
    - apply bool_conj_true ; constructor ; apply rel_correct ; reflexivity.
    - apply bool_conj_true in H ; destruct H.
      apply dec_correct in H ; rewrite H.
      apply dec_correct in H0 ; rewrite H0.
      reflexivity.
    Qed.
End Eq_RDC.
Global Instance prod_Bif_Eq_RDC : Bif_Eq_RDC prod := { bif_eq_rdc := @prod_Eq_RDC }.

Section Eqv.
  Context {A B} `{! Eqv A ,! Eqv B}.

  Inductive prod_eqv : A*B -> A*B -> Prop :=
    ProdEqv : forall a1 a2 b1 b2, a1 ~= a2 -> b1 ~= b2 -> prod_eqv (a1,b1) (a2,b2).

  Global Instance prod_Eqv : Eqv (A*B) := { eqv := prod_eqv }.
End Eqv.
Global Instance prod_Bif_Eqv : Bif_Eqv prod := { bif_eqv := @prod_Eqv }.

Section PER.
  Context {A B} `{! Eqv A ,! PER_WF A ,! Eqv B ,! PER_WF B}.
  Local Ltac mysimp :=
    match goal with
    | [ |- (_,_) ~= (_,_) ] => constructor
    | [ H : (_,_) ~= (_,_) |- _ ] => inversion H ; subst ; clear H
    end.
  Global Instance prod_PER_WF : PER_WF (A*B).
  Proof.
    constructor ; constructor ; intros.
    - unfold Symmetric ; intros.
      destruct x,y ; repeat mysimp ; symmetry ; auto.
    - unfold Transitive ; intros.
      destruct x,y,z ; repeat mysimp.
      + transitivity a0 ; auto.
      + transitivity b0 ; auto.
    Qed.
End PER.
Global Instance prod_Bif_PER_WF : Bif_PER_WF prod := { bif_per_wf := @prod_PER_WF }.

Section ER.
  Context {A B} `{! Eqv A ,! ER_WF A ,! Eqv B ,! ER_WF B}.
  Local Ltac mysimp :=
    match goal with
    | [ |- (_,_) ~= (_,_) ] => constructor
    | [ H : (_,_) ~= (_,_) |- _ ] => inversion H ; subst ; clear H
    end.
  Global Instance prod_ER_WF : ER_WF (A*B).
  Proof.
    constructor ; constructor ; intros.
    - unfold Reflexive ; intros.
      destruct x ; repeat mysimp ; reflexivity.
    - unfold Symmetric ; intros.
      destruct x,y ; repeat mysimp ; symmetry ; auto.
    - unfold Transitive ; intros.
      destruct x,y,z ; repeat mysimp.
      + transitivity a0 ; auto.
      + transitivity b0 ; auto.
    Qed.
End ER.
Global Instance prod_Bif_ER_WF : Bif_ER_WF prod := { bif_er_wf := @prod_ER_WF }.

Section EqvDec.
  Context {A B} `{! EqvDec A ,! EqvDec B }.

  Definition prod_eqv_dec (ab1:A*B) (ab2:A*B) : bool :=
    let '((a1,b1),(a2,b2)) := (ab1,ab2) in
    a1 ~=! a2 && b1 ~=! b2.

  Global Instance prod_EqvDec : EqvDec (A*B) := { eqv_dec := prod_eqv_dec }.
End EqvDec.
Global Instance prod_Bif_EqvDec : Bif_EqvDec prod := { bif_eqv_dec := @prod_EqvDec }.

Section Eqv_RDC.
  Context {A B} `{! Eqv A ,! EqvDec A ,! Eqv_RDC A ,! Eqv B ,! EqvDec B ,! Eqv_RDC B }.

  Global Instance prod_Eqv_RDC : Eqv_RDC (A*B).
  Proof.
    repeat constructor ; intros ; destruct x,y
    ; repeat
        match goal with
        | [ |- and _ _ ] => constructor
        | [ |- (_,_) ~= (_,_) ] => constructor
        | [ |- (_,_) ~=! (_,_) = true ] => unfold "~=!" ; simpl ; unfold prod_eqv_dec
        | [ |- _ && _ = true ] => apply bool_conj_true
        | [ |- _ = true ] => apply rel_correct
        | [ H : (_,_) ~= (_,_) |- _ ] => inversion H ; subst ; clear H
        | [ H : (_,_) ~=! (_,_) = true |- _ ] => unfold "~=!" in H ; simpl in H ; unfold prod_eqv_dec in H
        | [ H : _ && _ = true |- _ ] => apply bool_conj_true in H ; destruct H
        | [ H : _ = true |- _ ] => apply dec_correct in H
        | _ => auto
        end.
    Qed.
End Eqv_RDC.
Global Instance prod_Bif_Eqv_RDC : Bif_Eqv_RDC prod := { bif_eqv_rdc := @prod_Eqv_RDC }.

Section Lte.
  Context {A B} `{! Lte A ,! Lte B }.

  Inductive prod_lte : A*B -> A*B -> Prop :=
    | FstProdLte : forall a1 a2 b1 b2, a1 < a2 -> prod_lte (a1,b1) (a2,b2)
    | SndProdLte : forall a1 a2 b1 b2, a1 <= a2 -> b1 <= b2 -> prod_lte (a1,b1) (a2,b2).

  Global Instance prod_Lte : Lte (A*B) := { lte := prod_lte }.
End Lte.
Global Instance prod_Bif_Lte : Bif_Lte prod := { bif_lte := @prod_Lte }.

Section PreOrd.
  Context {A B} `{! Lte A ,! PreOrd A ,! Lte B ,! PreOrd B }.

  Global Instance prod_PreOrd : PreOrd (A*B).
  Proof.
    constructor.
    - unfold Reflexive ; intros.
      destruct x.
      apply SndProdLte ; reflexivity.
    - unfold Transitive ; intros.
      destruct x,y,z.
      inversion H ; subst ; clear H ; inversion H0 ; subst ; clear H0.
      + apply FstProdLte ; transitivity a0 ; auto.
      + apply FstProdLte.
        destruct H2 ; constructor ; [transitivity a0|] ; auto.
        unfold "~" ; intros ; apply H0.
        transitivity a1 ; auto.
      + apply FstProdLte.
        destruct H1 ; constructor ; [transitivity a0|] ; auto.
        unfold "~" ; intros ; apply H0.
        transitivity a ; auto.
      + apply SndProdLte ; [transitivity a0|transitivity b0] ; auto.
  Qed.
End PreOrd.
Global Instance prod_Bif_PreOrd : Bif_PreOrd prod := { bif_pre_ord := @prod_PreOrd }.

Section LteDec.
  Context {A B} `{! LteDec A ,! LteDec B }.

  Definition prod_lte_dec (ab1:A*B) (ab2:A*B) : bool :=
    let '((a1,b1),(a2,b2)) := (ab1,ab2) in
    match a1 <=! a2, a2 <=! a1 with
    | true, false => true
    | true, true => b1 <=! b2
    | _, _ => false
    end.
  Global Instance prod_LteDec : LteDec (A*B) := { lte_dec := prod_lte_dec }.
End LteDec.
Global Instance prod_Bif_LteDec : Bif_LteDec prod := { bif_lte_dec := @prod_LteDec }.

Section Lte_RDC.
  Context {A B} `{! Lte A ,! LteDec A ,! Lte_RDC A ,! Lte B ,! LteDec B ,! Lte_RDC B }.

  Global Instance prod_Lte_RDC : Lte_RDC (A*B).
  Proof.
    Local Ltac mysimp :=
      match goal with
      | [ |- (_,_) <=! (_,_) = true ] => unfold "<=!" ; simpl ; unfold prod_lte_dec
      | [ |- _ <=! _ = true ] => apply rel_correct
      | [ H : (_,_) <= (_,_) |- _ ] => inversion H ; subst ; clear H
      | [ H : (_,_) <=! (_,_) = true |- _ ] => unfold "<=!" in H ; simpl in H ; unfold prod_lte_dec in H
      | [ H : _ = _ <=! _ |- _ ] => symmetry in H
      | [ H : _ <=! _ = true |- _ ] => apply dec_correct in H
      | [ H : _ <=! _ = false |- _ ] => apply neg_dec_correct in H
      | _ => auto
      end.
    repeat constructor ; intros.
    - destruct x,y ; repeat mysimp.
      + destruct H1.
        apply rel_correct in H ; rewrite H.
        remember (a0 <=! a) as p ; destruct p ; auto.
        symmetry in Heqp ; apply dec_correct in Heqp.
        contradiction.
      + remember (a <=! a0) as p ; destruct p
        ; remember (a0 <=! a) as p ; destruct p ; repeat mysimp.
    - destruct x,y ; repeat mysimp.
      remember (a <=! a0) as p ; destruct p
      ; remember (a0 <=! a) as p ; destruct p ; repeat mysimp ; try congruence.
      * apply SndProdLte ; auto.
      * apply FstProdLte ; constructor ; auto.
  Qed.
End Lte_RDC.
Global Instance prod_Bif_Lte_RDC : Bif_Lte_RDC prod := { bif_lte_rdc := @prod_Lte_RDC }.

Section PartialOrd.
  Context {A B} `{! Lte A ,! Eqv A ,! ER_WF A ,! PartialOrd A ,! Lte B ,! Eqv B ,! ER_WF B ,! PartialOrd B }.

  Global Instance prod_PartialOrd : PartialOrd (A*B).
  Proof.
    Local Ltac mysimp :=
      match goal with
      | [ |- (_,_) <=! (_,_) = true ] => unfold "<=!" ; simpl ; unfold prod_lte_dec
      | [ H : (_,_) ~= (_,_) |- _ ] => inversion H ; subst ; clear H
      | [ H : (_,_) <= (_,_) |- _ ] => inversion H ; subst ; clear H
      | [ H : (_,_) <=! (_,_) = true |- _ ] => unfold "<=!" in H ; simpl in H ; unfold prod_lte_dec in H
      | _ => auto
      end.
    constructor ; eauto with typeclass_instances.
    - unfold Antisymmetric ; intros.
      destruct x,y ; repeat mysimp.
      + destruct H1,H2 ; contradiction.
      + destruct H2 ; contradiction.
      + destruct H1 ; contradiction.
      + constructor ; apply antisymmetry ; auto.
    - unfold Proper,"==>",impl,Basics.impl ; intros.
      destruct x,y,x0,y0 ; repeat mysimp.
      + apply FstProdLte ; constructor.
        * rewrite <- H4 ; rewrite <- H5 ; destruct H0 ; auto.
        * unfold "~" ; intros ; destruct H0 as [H01 H02] ; apply H02.
          rewrite H4 ; rewrite H5 ; auto.
      + apply SndProdLte.
        * rewrite <- H4 ; rewrite <- H5 ; auto.
        * rewrite <- H7 ; rewrite <- H8 ; auto.
  Qed.
End PartialOrd.
Global Instance prod_Bif_PartialOrd : Bif_PartialOrd prod := { bif_partial_ord := @prod_PartialOrd }.

Section PartialOrdDec.
  Context {A B} `{! PartialOrdDec A ,! PartialOrdDec B }.

  Definition prod_pord_dec (ab1:A*B) (ab2:A*B) : option comparison :=
    let '((a1,b1),(a2,b2)) := (ab1,ab2) in
    match a1 <~>! a2 with
    | Some Lt => Some Lt
    | Some Eq => b1 <~>! b2
    | Some Gt => Some Gt
    | None => None
    end.

  Global Instance prod_PartialOrdDec : PartialOrdDec (A*B) := { pord_dec := prod_pord_dec }.
End PartialOrdDec.
Global Instance prod_Bif_PartialOrdDec : Bif_PartialOrdDec prod := { bif_partial_ord_dec := @prod_PartialOrdDec }.

Section PartialOrd_RDC.
  Context {A B}
    `{! Lte A ,! Eqv A ,! ER_WF A ,! PartialOrd A ,! PartialOrdDec A ,! PartialOrd_RDC A
     ,! Lte B ,! Eqv B ,! ER_WF B ,! PartialOrd B ,! PartialOrdDec B ,! PartialOrd_RDC B
     }.

  Lemma lt_prod_destruct :
    forall (a1 a2:A) (b1 b2:B),
    (a1,b1) < (a2,b2) -> (a1 < a2 \/ (a1 ~= a2 /\ b1 < b2)).
  Proof.
    intros.
    destruct H.
    inversion H ; subst ; clear H ; auto.
    remember (a1 <~>! a2) as p ; destruct p ; [destruct c|] ; symmetry in Heqp
    ; repeat
        match goal with
        | [ H : _ <~>! _ = Some Eq |- _ ] => apply pord_dec_correct_eqv in H
        | [ H : _ <~>! _ = Some Lt |- _ ] => apply pord_dec_correct_lt in H
        | [ H : _ <~>! _ = Some Gt |- _ ] => apply pord_dec_correct_gt in H
        | [ H : _ <~>! _ = None |- _ ] => apply pord_dec_correct_un in H
        end.
    - right ; constructor ; auto.
      constructor ; auto.
      unfold "~" ; intros ; apply H0.
      apply SndProdLte ; auto.
      rewrite Heqp ; reflexivity.
    - left ; auto.
    - destruct Heqp ; contradiction.
    - destruct Heqp ; contradiction.
  Qed.

  Lemma un_prod_destruct :
    forall (a1 a2:A) (b1 b2:B),
    (a1,b1) >< (a2,b2) -> (a1 >< a2) \/ (a1 ~= a2 /\ b1 >< b2).
  Proof.
    intros.
    remember (a1 <~>! a2) as p ; destruct p ; symmetry in Heqp.
    - right.
      destruct H.
      destruct c.
      + apply pord_dec_correct_eqv in Heqp.
        constructor ; auto.
        constructor ; unfold "~" ; intros.
        * apply H.
          apply SndProdLte ; auto ; rewrite Heqp ; reflexivity.
        * apply H0.
          apply SndProdLte ; auto ; rewrite Heqp ; reflexivity.
      + exfalso ; apply H.
        apply pord_dec_correct_lt in Heqp.
        apply FstProdLte ; auto.
      + exfalso ; apply H0.
        apply pord_dec_correct_gt in Heqp.
        apply FstProdLte ; auto.
    - left.
      apply pord_dec_correct_un in Heqp ; auto.
  Qed.

  Global Instance prod_PartialOrd_RDC : PartialOrd_RDC (A*B).
  Proof.
    constructor ; intros ; destruct x,y ; simpl in * ; unfold prod_pord_dec
    ; repeat
        match goal with
        | [ |- (_,_) ~= (_,_) ] => constructor
        | [ H : and _ _ |- _ ] => destruct H
        | [ H : (_,_) ~= (_,_) |- _ ] => inversion H ; subst ; clear H
        | [ H : (_,_) <= (_,_) |- _ ] => inversion H ; subst ; clear H
        | [ H : (_,_) < (_,_) |- _ ] => apply lt_prod_destruct in H ; destruct H
        | [ H : (_,_) >< (_,_) |- _ ] => apply un_prod_destruct in H ; destruct H
        | [ H : _ ~= _ |- _ ] => apply pord_rel_correct_eqv in H ; rewrite H
        | [ H : _ ~= _ |- _ ] => symmetry in H ; apply pord_rel_correct_eqv in H ; rewrite H
        | [ H : _ < _ |- _ ] => apply pord_rel_correct_lt in H ; rewrite H
        | [ H : _ < _ |- _ ] => apply pord_rel_correct_gt in H ; rewrite H
        | [ H : _ >< _ |- _ ] => apply pord_rel_correct_un in H ; rewrite H
        | _ => auto
        end
    ; unfold prod_pord_dec in H ; remember (a <~>! a0) as p ; destruct p ; try destruct c
    ; try congruence ; symmetry in Heqp
    ; repeat
        match goal with
        | [ |- _ < _ ] => constructor
        | [ |- _ >< _ ] => constructor
        | [ |- ~ _ ] => unfold "~" ; intros
        | [ H : (_,_) <= (_,_) |- _ ] => inversion H ; subst ; clear H
        | [ H : _ <~>! _ = Some Eq |- _ ] => apply pord_dec_correct_eqv in H
        | [ H : _ <~>! _ = Some Lt |- _ ] => apply pord_dec_correct_lt in H
        | [ H : _ <~>! _ = Some Gt |- _ ] => apply pord_dec_correct_gt in H
        | [ H : _ <~>! _ = None |- _ ] => apply pord_dec_correct_un in H
        | [ H : _ < _ |- _ ] => destruct H
        | [ H : _ >< _ |- _ ] => destruct H
        | [ H : ?x ~= ?y |- (?x,_) <= (?y,_) ] => apply SndProdLte
        | [ H : ?y ~= ?x |- (?x,_) <= (?y,_) ] => apply SndProdLte
        | [ H1 : ?x <= ?y , H2 : ~ (?y <= ?x) |- (?x,_) <= (?y,_) ] => apply FstProdLte
        | [ H : ?x ~= ?y |- ?x <= ?y ] => rewrite H ; reflexivity
        | [ H : ?x ~= ?y |- ?y <= ?x ] => rewrite H ; reflexivity
        | [ H1 : ?x ~= ?y , H2 : ~ (?x <= ?y) |- False ] => apply H2
        | [ H1 : ?y ~= ?x , H2 : ~ (?x <= ?y) |- False ] => apply H2
        | _ => auto
        end.
  Qed.
End PartialOrd_RDC.
Global Instance prod_Bif_PartialOrd_RDC : Bif_PartialOrd_RDC prod := { bif_partial_ord_rdc := @prod_PartialOrd_RDC }.

Section TotalOrd.
  Context {A B} `{! Lte A ,! Eqv A ,! ER_WF A ,! TotalOrd A ,! Lte B ,! Eqv B ,! ER_WF B ,! TotalOrd B }.

  Global Instance prod_TotalOrd : TotalOrd (A*B).
  Proof.
    Local Ltac mysimp :=
      match goal with
      | _ => auto
      end.
    constructor ; eauto with typeclass_instances.
    intros ; unfold "~" at 1 ; intros H ; destruct H.
    destruct x,y.
    apply (TotalOrd_comparable a a0) ; constructor ; unfold "~" ; intros
    ; apply (TotalOrd_comparable b b0) ; constructor ; unfold "~" ; intros.
    - apply H ; apply SndProdLte ; auto.
    - assert (~~(a0 <= a)).
      { unfold "~" at 1 ; intros.
        apply H ; apply FstProdLte ; constructor ; auto.
      }
      apply H3 ; unfold "~" ; intros.
      apply H0 ; apply SndProdLte ; auto.
    - assert (~~(a <= a0)).
      { unfold "~" at 1 ; intros.
        apply H0 ; apply FstProdLte ; constructor ; auto.
      }
      apply H3 ; unfold "~" ; intros.
      apply H ; apply SndProdLte ; auto.
    - apply H0 ; apply SndProdLte ; auto.
  Qed.
End TotalOrd.
Global Instance prod_Bif_TotalOrd : Bif_TotalOrd prod := { bif_total_ord := @prod_TotalOrd }.

Section TotalOrdDec.
  Context {A B} `{! TotalOrdDec A ,! TotalOrdDec B }.

  Definition prod_tord_dec (ab1:A*B) (ab2:A*B) : comparison :=
    let '((a1,b1),(a2,b2)) := (ab1,ab2) in
    match a1 <=>! a2 with
    | Lt => Lt
    | Eq => b1 <=>! b2
    | Gt => Gt
    end.

  Global Instance prod_TotalOrdDec : TotalOrdDec (A*B) := { tord_dec := prod_tord_dec }.
End TotalOrdDec.
Global Instance prod_Bif_TotalOrdDec : Bif_TotalOrdDec prod := { bif_total_ord_dec := @prod_TotalOrdDec }.

Section TotalOrd_RDC.
  Context {A B}
    `{! Lte A ,! Eqv A ,! ER_WF A ,! TotalOrd A ,! TotalOrdDec A ,! TotalOrd_RDC A
     ,! Lte B ,! Eqv B ,! ER_WF B ,! TotalOrd B ,! TotalOrdDec B ,! TotalOrd_RDC B
     }.

  Global Instance prod_TotalOrd_RDC : TotalOrd_RDC (A*B).
  Proof.
    constructor ; intros ; destruct x,y ; simpl in * ; unfold prod_tord_dec
    ; repeat
        match goal with
        | [ |- (_,_) ~= (_,_) ] => constructor
        | [ H : and _ _ |- _ ] => destruct H
        | [ H : (_,_) ~= (_,_) |- _ ] => inversion H ; subst ; clear H
        | [ H : (_,_) < (_,_) |- _ ] => apply lt_prod_destruct in H ; destruct H
        | [ H : _ ~= _ |- _ ] => apply tord_rel_correct_eqv in H ; rewrite H
        | [ H : _ ~= _ |- _ ] => symmetry in H ; apply tord_rel_correct_eqv in H ; rewrite H
        | [ H : _ < _ |- _ ] => apply tord_rel_correct_lt in H ; rewrite H
        | [ H : _ < _ |- _ ] => apply tord_rel_correct_gt in H ; rewrite H
        | _ => auto
        end
    ; unfold prod_tord_dec in H ; remember (a <=>! a0) as p ; destruct p ; try destruct c
    ; try congruence ; symmetry in Heqp
    ; repeat
        match goal with
        | [ |- _ <=>! _ = Lt ] => apply tord_rel_correct_lt
        | [ |- _ <=>! _ = Gt ] => apply tord_rel_correct_gt
        | [ |- _ < _ ] => constructor
        | [ |- ~ _ ] => unfold "~" ; intros
        | [ H : (_,_) <= (_,_) |- _ ] => inversion H ; subst ; clear H
        | [ H : _ <=>! _ = Eq |- _ ] => apply tord_dec_correct_eqv in H
        | [ H : _ <=>! _ = Lt |- _ ] => apply tord_dec_correct_lt in H
        | [ H : _ <=>! _ = Gt |- _ ] => apply tord_dec_correct_gt in H
        | [ H : _ < _ |- _ ] => destruct H
        | [ H : ?x ~= ?y |- (?x,_) <= (?y,_) ] => apply SndProdLte
        | [ H : ?y ~= ?x |- (?x,_) <= (?y,_) ] => apply SndProdLte
        | [ H1 : ?x <= ?y , H2 : ~ (?y <= ?x) |- (?x,_) <= (?y,_) ] => apply FstProdLte
        | [ H : ?x ~= ?y |- ?x <= ?y ] => rewrite H ; reflexivity
        | [ H : ?x ~= ?y |- ?y <= ?x ] => rewrite H ; reflexivity
        | [ H1 : ?x ~= ?y , H2 : ~ (?x <= ?y) |- _ ] => exfalso ; apply H2
        | [ H1 : ?y ~= ?x , H2 : ~ (?x <= ?y) |- _ ] => exfalso ; apply H2
        | _ => auto
        end ; try contradiction.
    - apply H1 ; apply SndProdLte ; [rewrite Heqp ; reflexivity|] ; auto.
    - apply H1 ; apply SndProdLte ; [rewrite Heqp ; reflexivity|] ; auto.
  Qed.
End TotalOrd_RDC.
Global Instance prod_Bif_TotalOrd_RDC : Bif_TotalOrd_RDC prod := { bif_total_ord_rdc := @prod_TotalOrd_RDC }.

Section Lattice.
  Context {A B} `{! Lattice A ,! Lattice B }.

  Definition prod_meet (s1:A*B) (s2:A*B) : A*B :=
    let '((a1,b1),(a2,b2)) := (s1,s2) in
    (a1 /\ a2, b1 /\ b2).
  Definition prod_join (s1:A*B) (s2:A*B) : A*B :=
    let '((a1,b1),(a2,b2)) := (s1,s2) in
    (a1 \/ a2, b1 \/ b2).

  Global Instance prod_Lattice : Lattice (A*B) :=
    { lmeet := prod_meet
    ; ljoin := prod_join
    }.
End Lattice.
Global Instance prod_Bif_Lattice : Bif_Lattice prod := { bif_lattice := @prod_Lattice }.

Section LatticeWF.
  Context {A B}
    `{! Lte A ,! Eqv A ,! ER_WF A ,! PartialOrd A ,! Lattice A ,! LatticeWF A
     ,! Lte B ,! Eqv B ,! ER_WF B ,! PartialOrd B ,! Lattice B ,! LatticeWF B
     }.

  Global Instance prod_LatticeWF : LatticeWF (A*B).
  Proof.
    constructor ; intros ; destruct t1,t2 ; unfold "/\","\/" ; simpl
    ; unfold prod_meet,prod_join ; constructor
    ; destruct (lmeet_ineq a a0) ; destruct (lmeet_ineq b b0)
    ; destruct (ljoin_ineq a a0) ; destruct (ljoin_ineq b b0)
    ; apply SndProdLte ; auto.
  Qed.
End LatticeWF.
Global Instance prod_Bif_LatticeWF : Bif_LatticeWF prod := { bif_lattice_wf := @prod_LatticeWF }.

Section BoundedLattice.
  Context {A B} `{! BoundedLattice A ,! BoundedLattice B }.

  Definition prod_top : A*B := (ltop,ltop).
  Definition prod_bot : A*B := (lbot,lbot).

  Global Instance prod_BoundedLattice : BoundedLattice (A*B) :=
    { ltop := prod_top
    ; lbot := prod_bot
    }.
End BoundedLattice.
Global Instance prod_Bif_BoundedLattice : Bif_BoundedLattice prod := { bif_bounded_lattice := @prod_BoundedLattice }.

Section BoundedLatticeWF.
  Global Instance prod_BoundedLatticeWF {A B}
    `{! Lte A ,! Eqv A ,! ER_WF A ,! PartialOrd A ,! Lattice A ,! BoundedLattice A ,! LatticeWF A ,! BoundedLatticeWF A
     ,! Lte B ,! Eqv B ,! ER_WF B ,! PartialOrd B ,! Lattice B ,! BoundedLattice B ,! LatticeWF B ,! BoundedLatticeWF B
     } : BoundedLatticeWF (A*B).
  Proof.
    constructor ; eauto with typeclass_instances ; intros ; destruct t
    ; apply SndProdLte ; try apply ltop_ineq ; apply lbot_ineq.
  Qed.
End BoundedLatticeWF.
Global Instance prod_Bif_BoundedLatticeWF : Bif_BoundedLatticeWF prod := { bif_bounded_lattice_wf := @prod_BoundedLatticeWF }.

Definition sequence_fst {t A B} `{! Applicative t } (p:t A*B)  : t (A*B) :=
  let (aT,b) := p in fret pair <@> aT <@> fret b.

Definition sequence_snd {t A B} `{! Applicative t } (p:A*t B)  : t (A*B) :=
  let (a,bT) := p in fret pair <@> fret a <@> bT.


(*
The second displayed layer we lay over the bicategory of univalent categories has the purppose of adding the unitors and the associator. In this file we construct the displayed bicategory which adds all the data of the unitors and the associator.

For example:
The total category corresponding to the displayed layer of the associator is the univalent bicategory defined as followed:
- The objects are categories (already equipped with a tensor and unit) together with the data (and naturality) of the associator.
- The morphisms express a preservation condition of the associator.
- The 2-cells are trivial.
 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma.
Require Import  UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.
Require Import UniMath.Bicategories.Core.Univalence.

Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.TensorLayer.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.UnitLayer.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.TensorUnitLayer.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Section LeftUnitorLayer.

  Definition disp_lu_disp_ob_mor : disp_cat_ob_mor tu_cat.
  Proof.
    use tpair.
    - exact (λ C, lunitor (tu C)).
    - exact (λ C D luC luD F, preserves_lunitor (ftu F) luC luD).
  Defined.

  Definition disp_lu_disp_id_comp : disp_cat_id_comp tu_cat disp_lu_disp_ob_mor.
  Proof.
    use tpair.
    - intros C lu.
      apply id_preserves_lunitor.
    - intros C D E F G luC luD luE pluF pluG x.
      apply (comp_preserves_lunitor pluF pluG).
  Defined.

  Definition disp_lu_disp_cat_data : disp_cat_data tu_cat
    := (disp_lu_disp_ob_mor,, disp_lu_disp_id_comp).

  Definition bidisp_lu_disp_bicat : disp_bicat tu_cat
    := disp_cell_unit_bicat disp_lu_disp_cat_data.

  Lemma bidisp_lu_disp_prebicat_is_locally_univalent : disp_univalent_2_1 bidisp_lu_disp_bicat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_1.
    intro ; intros.
    apply isaprop_preserves_lunitor.
  Qed.

  Lemma isaset_lunitor (C : tu_cat) : isaset (lunitor (pr2 C)).
  Proof.
    apply isaset_total2.
    {
      apply impred_isaset ; intro.
      apply homset_property.
    }
    intro.
    repeat (apply impred_isaset ; intro).
    apply isasetaprop.
    apply homset_property.
  Qed.

  Lemma isaprop_lunitor_nat (C : tu_cat) (lu : lunitor (pr2 C)) : isaprop (lunitor_nat (pr1 lu)).
  Proof.
    repeat (apply impred_isaprop ; intro).
    apply homset_property.
  Qed.

  Lemma bidisp_lu_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_lu_disp_bicat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_0.
    - apply bidisp_tensorunit_is_univalent_2.
    - intro ; intros.
      apply isaprop_preserves_lunitor.
    - intro ; apply isaset_lunitor.
    - intros C lu1 lu2 plu.
      use total2_paths_f.
      + apply funextsec ; intro.
        refine (_ @ (pr1 plu x)).
        refine (! id_left _ @ _).
        apply cancel_postcomposition.
        refine (_ @ ! id_right _).
        apply (! tensor_id _ _ _).
      + apply isaprop_lunitor_nat.
  Qed.

  Lemma bidisp_lu_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_lu_disp_bicat.
  Proof.
    apply make_disp_univalent_2.
    - apply bidisp_lu_disp_prebicat_is_globally_univalent.
    - apply bidisp_lu_disp_prebicat_is_locally_univalent.
  Defined.

End LeftUnitorLayer.

Section RightUnitorLayer.

  Definition disp_ru_disp_ob_mor : disp_cat_ob_mor tu_cat.
  Proof.
    use tpair.
    - exact (λ C, runitor (tu C)).
    - exact (λ C D ruC ruD F, preserves_runitor (ftu F) ruC ruD).
  Defined.

  Definition disp_ru_disp_id_comp : disp_cat_id_comp tu_cat disp_ru_disp_ob_mor.
  Proof.
    use tpair.
    - intros C ru.
      apply id_preserves_runitor.
    - intros C D E F G ruC ruD ruE pruF pruG x.
      apply (comp_preserves_runitor pruF pruG).
  Defined.

  Definition disp_ru_disp_cat_data : disp_cat_data tu_cat
    := (disp_ru_disp_ob_mor,, disp_ru_disp_id_comp).

  Definition bidisp_ru_disp_bicat : disp_bicat tu_cat
    := disp_cell_unit_bicat disp_ru_disp_cat_data.

  Lemma bidisp_ru_disp_prebicat_is_locally_univalent : disp_univalent_2_1 bidisp_ru_disp_bicat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_1.
    intro ; intros.
    apply isaprop_preserves_runitor.
  Qed.

  Lemma isaset_runitor (C : tu_cat) : isaset (runitor (pr2 C)).
  Proof.
    apply isaset_total2.
    {
      apply impred_isaset ; intro.
      apply homset_property.
    }
    intro.
    repeat (apply impred_isaset ; intro).
    apply isasetaprop.
    apply homset_property.
  Qed.

  Lemma isaprop_runitor_nat {C : tu_cat} (ru : runitor (pr2 C)) : isaprop (runitor_nat (pr1 ru)).
  Proof.
    repeat (apply impred_isaprop ; intro).
    apply homset_property.
  Qed.

  Lemma bidisp_ru_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_ru_disp_bicat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_0.
    - apply bidisp_tensorunit_is_univalent_2.
    - intro ; intros.
      apply isaprop_preserves_runitor.
    - intro ; apply isaset_runitor.
    - intros C ru1 ru2 pru.
      use total2_paths_f.
      + apply funextsec ; intro.
        refine (_ @ (pr1 pru x)).
        refine (! id_left _ @ _).
        apply cancel_postcomposition.
        refine (_ @ ! id_right _).
        apply (! tensor_id _ _ _).
      + apply isaprop_runitor_nat.
  Qed.

  Lemma bidisp_ru_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_ru_disp_bicat.
  Proof.
    apply make_disp_univalent_2.
    - apply bidisp_ru_disp_prebicat_is_globally_univalent.
    - apply bidisp_ru_disp_prebicat_is_locally_univalent.
  Defined.

End RightUnitorLayer.

Section UnitorsLayer.

  Definition bidisp_unitors_disp_bicat : disp_bicat tu_cat
    := disp_dirprod_bicat bidisp_lu_disp_bicat bidisp_ru_disp_bicat.

End UnitorsLayer.

Section AssociatorLayer.

  Definition disp_ass_disp_ob_mor : disp_cat_ob_mor tu_cat.
  Proof.
    use tpair.
    - exact (λ C, associator (tu C)).
    - exact (λ C D αC αD F, preserves_associator (ftu F) αC αD).
  Defined.

  Definition disp_ass_disp_id_comp : disp_cat_id_comp tu_cat disp_ass_disp_ob_mor.
  Proof.
    use tpair.
    - intros C α.
      apply id_preserves_associator.
    - intros C D E F G aC aD aE paF paG x y z.
      apply (comp_preserves_associator paF paG).
  Qed.

  Definition disp_ass_disp_cat_data : disp_cat_data tu_cat
    := (disp_ass_disp_ob_mor,, disp_ass_disp_id_comp).

  Definition bidisp_ass_disp_bicat : disp_bicat tu_cat
    := disp_cell_unit_bicat disp_ass_disp_cat_data.

  Lemma bidisp_ass_disp_prebicat_is_locally_univalent : disp_univalent_2_1 bidisp_ass_disp_bicat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_1.
    intro ; intros.
    apply isaprop_preserves_associator.
  Qed.

  Lemma isaset_associator (C : tu_cat) : isaset (associator (pr2 C)).
  Proof.
    apply isaset_total2.
    {
      do 3 (apply impred_isaset ; intro).
      apply homset_property.
    }
    intro.
    repeat (apply impred_isaset ; intro).
    apply isasetaprop.
    apply homset_property.
  Qed.

  Lemma isaprop_associator_nat (C : tu_cat) (ass : associator (pr2 C))
    : isaprop (associator_nat (pr1 ass)).
  Proof.
    repeat (apply impred_isaprop ; intro).
    apply homset_property.
  Qed.

  Lemma bidisp_ass_disp_prebicat_is_globally_univalent : disp_univalent_2_0 bidisp_ass_disp_bicat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_0.
    - apply bidisp_tensorunit_is_univalent_2.
    - intro ; intros.
      apply isaprop_preserves_associator.
    - intro ; apply isaset_associator.
    - intros C a1 a2 pa.
      use total2_paths_f.
      + apply funextsec ; intro x1 ;
          apply funextsec ; intro x2 ;
          apply funextsec ; intro x3.

        set (p := pr1 pa x1 x2 x3).
        cbn in p.
        unfold identityfunctor_preserves_tensor_data in p.
        rewrite id_right in p.
        rewrite id_right in p.
        rewrite tensor_id in p.
        rewrite id_left in p.
        rewrite tensor_id in p.
        rewrite id_right in p.
        exact p.
      + apply isaprop_associator_nat.
  Qed.

  Lemma bidisp_ass_disp_prebicat_is_univalent_2 : disp_univalent_2 bidisp_ass_disp_bicat.
  Proof.
    apply make_disp_univalent_2.
    - apply bidisp_ass_disp_prebicat_is_globally_univalent.
    - apply bidisp_ass_disp_prebicat_is_locally_univalent.
  Defined.

End AssociatorLayer.

Section AssociatorUnitorsLayer.

  Definition bidisp_assunitors_disp_bicat : disp_bicat tu_cat
    := disp_dirprod_bicat bidisp_unitors_disp_bicat bidisp_ass_disp_bicat.

  Definition bidisp_assunitors_disp_2cells_isaprop : disp_2cells_isaprop bidisp_assunitors_disp_bicat.
  Proof.
    repeat (apply disp_2cells_isaprop_prod) ; apply disp_2cells_isaprop_cell_unit_bicat.
  Qed.

  Definition bidisp_assunitors_disp_locally_groupoid : disp_locally_groupoid bidisp_assunitors_disp_bicat.
  Proof.
    repeat (apply disp_locally_groupoid_prod) ; apply disp_locally_groupoid_cell_unit_bicat.
  Qed.

  Definition bidisp_unitors_disp_prebicat_is_univalent_2
    : disp_univalent_2 bidisp_unitors_disp_bicat.
  Proof.
    apply is_univalent_2_dirprod_bicat.
    - apply bidisp_tensorunit_is_univalent_2.
    - apply bidisp_lu_disp_prebicat_is_univalent_2.
    - apply bidisp_ru_disp_prebicat_is_univalent_2.
  Qed.

  Definition bidisp_assunitors_is_disp_univalent_2
    : disp_univalent_2 bidisp_assunitors_disp_bicat.
  Proof.
    apply is_univalent_2_dirprod_bicat.
    - apply bidisp_tensorunit_is_univalent_2.
    - apply bidisp_unitors_disp_prebicat_is_univalent_2.
    - apply bidisp_ass_disp_prebicat_is_univalent_2.
  Qed.

  Definition disp_tensor_unit_unitors_associator : disp_bicat bicat_of_univ_cats
    := sigma_bicat _ _ bidisp_assunitors_disp_bicat.

  Definition disp_tensor_unit_unitors_associator_is_disp_univalent_2
    : disp_univalent_2  disp_tensor_unit_unitors_associator.
  Proof.
    apply sigma_disp_univalent_2_with_props.
    - apply univalent_cat_is_univalent_2.
    - apply bidisp_tensorunit_disp_2cells_isaprop.
    - apply bidisp_assunitors_disp_2cells_isaprop.
    - apply bidisp_tensorunit_is_disp_univalent_2 .
    - apply bidisp_assunitors_is_disp_univalent_2.
    - apply bidisp_tensorunit_disp_locally_groupoid.
    - apply bidisp_assunitors_disp_locally_groupoid.
    - apply bidisp_tensorunit_is_disp_univalent_2.
    - apply bidisp_assunitors_is_disp_univalent_2.
  Qed.

  Lemma disp_tensor_unit_unitors_associator_disp_2cells_isaprop
    : disp_2cells_isaprop disp_tensor_unit_unitors_associator.
  Proof.
    apply disp_2cells_isaprop_sigma.
    - apply bidisp_tensorunit_disp_2cells_isaprop.
    - apply bidisp_assunitors_disp_2cells_isaprop.
  Qed.

  Lemma disp_tensor_unit_unitors_associator_disp_locally_groupoid
    : disp_locally_groupoid disp_tensor_unit_unitors_associator.
  Proof.
    intros C D F G α tuuaC tuuaD ptuuaC ptuuaD ptuuac.
    repeat (use tpair) ; try (exact tt).
    - apply bidisp_tensor_disp_locally_groupoid.
      apply ptuuac.
    - apply bidisp_unit_disp_locally_groupoid.
      apply ptuuac.
    - apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop.
    - apply disp_tensor_unit_unitors_associator_disp_2cells_isaprop.
  Qed.

  Definition bidisp_assunitors_total : bicat := total_bicat disp_tensor_unit_unitors_associator.

  Definition bidisp_assunitors_is_univalent_2: is_univalent_2 bidisp_assunitors_total.
  Proof.
    apply total_is_univalent_2.
    - apply disp_tensor_unit_unitors_associator_is_disp_univalent_2.
    - apply univalent_cat_is_univalent_2.
  Qed.

  Definition assunitors_tensor (C : bidisp_assunitors_total)
    : tensor (pr1 C : univalent_category) := pr112 C.

  Definition assunitors_unit (C : bidisp_assunitors_total)
    : ob (pr1 C : univalent_category) := pr212 C.

  Definition assunitors_leftunitor (C : bidisp_assunitors_total)
    : lunitor_data (pr12 C) := pr11 (pr122 C).

  Definition assunitors_rightunitor (C : bidisp_assunitors_total)
    : runitor_data (pr12 C) := pr12 (pr122 C).

  Definition assunitors_associator (C : bidisp_assunitors_total)
    : associator_data (pr12 C) := pr1 (pr222 C).

  (* We now show that the type of displayed objects and 1-cells is as we expect *)
  Definition assunitors_from_layer (C : bicat_of_univ_cats)
    : disp_tensor_unit_unitors_associator C
      -> tensor_unit_unitors_associator (C : univalent_category).
  Proof.
    intro tuua.
    split with (pr1 tuua).
    repeat split.
    + apply (pr112 tuua).
    + apply (pr212 tuua).
    + apply (pr2 tuua).
  Defined.

  Definition assunitors_to_layer (C : bicat_of_univ_cats)
    : tensor_unit_unitors_associator (C : univalent_category)
      -> disp_tensor_unit_unitors_associator C.
  Proof.
    intro tuua.
    split with (pr1 tuua).
    repeat split.
    + apply (pr12 tuua).
    + apply (pr122 tuua).
    + apply (pr222 tuua).
  Defined.

  Definition equality_assunitors_with_layer (C : bicat_of_univ_cats) :
    disp_tensor_unit_unitors_associator C
    ≃ tensor_unit_unitors_associator (C : univalent_category).
  Proof.
    use weq_iso.
    - apply assunitors_from_layer.
    - apply assunitors_to_layer.
    - intro ; apply idpath.
    - intro ; apply idpath.
  Defined.

  Definition functor_assunitors_from_layer
             (C D : bicat_of_univ_cats) (F : bicat_of_univ_cats⟦C,D⟧)
             (tuuaC : disp_tensor_unit_unitors_associator C)
             (tuuaD : disp_tensor_unit_unitors_associator D)
    : tuuaC -->[F] tuuaD
      -> functor_tensor_unit_unitors_associator F
            (assunitors_from_layer C tuuaC) (assunitors_from_layer D tuuaD).
  Proof.
    intro ptuua.
    split with (pr1 ptuua).
    repeat split.
    - apply (pr112 ptuua).
    - apply (pr212 ptuua).
    - apply (pr22 ptuua).
  Defined.

  Definition functor_assunitors_to_layer
             (C D : bicat_of_univ_cats) (F : bicat_of_univ_cats⟦C,D⟧)
             (tuuaC : disp_tensor_unit_unitors_associator C)
             (tuuaD : disp_tensor_unit_unitors_associator D)
    : functor_tensor_unit_unitors_associator F (assunitors_from_layer C tuuaC) (assunitors_from_layer D tuuaD) -> tuuaC -->[F] tuuaD.
  Proof.
    intro ptuua.
    split with (pr1 ptuua).
    repeat split.
    - apply (pr12 ptuua).
    - apply (pr122 ptuua).
    - apply (pr222 ptuua).
  Defined.

  Definition equality_functor_assunitors_with_layer
             (C D : bicat_of_univ_cats) (F : bicat_of_univ_cats⟦C,D⟧)
             (tuuaC : disp_tensor_unit_unitors_associator C)
             (tuuaD : disp_tensor_unit_unitors_associator D)
    : tuuaC -->[F] tuuaD
            ≃ functor_tensor_unit_unitors_associator F (assunitors_from_layer C tuuaC) (assunitors_from_layer D tuuaD).
  Proof.
    use weq_iso.
    - apply functor_assunitors_from_layer.
    - apply functor_assunitors_to_layer.
    - apply idpath.
    - apply idpath.
  Defined.

End AssociatorUnitorsLayer.

Module AssociatorUnitorsNotations.

  Notation "I_{ C }" := (assunitors_unit C).
  Notation "T_{ C }" := (assunitors_tensor C).
  Notation "x ⊗_{ C } y" := (tensor_on_ob T_{C} x y) (at level 31).
  Notation "f ⊗^{ C } g" := (tensor_on_hom T_{C} _ _ _ _ f g) (at level 31).

  Notation "lu^{ C }" := (assunitors_leftunitor C).
  Notation "ru^{ C }" := (assunitors_rightunitor C).
  Notation "ass^{ C }" := (assunitors_associator C).

End AssociatorUnitorsNotations.


Require Import LibLN.
Require Import LibTactics.
Require Import Arith.
Require Import List.
Require Import Program.
Require Import ListSet.

Require Import coercion good unify type tactics subst co_kind subset.

Set Implicit Arguments.

Definition dom_union := set_union domelt_eq_decide.

Fixpoint dom_of_ty (ty : type) : list (var * type) :=
  match ty with
    | TBVar _ => nil
    | TFun f lhs => (f,lhs) :: nil
    | TArrow arg res => dom_union (dom_of_ty arg) (dom_of_ty res)
    | TTycon T => nil
    | TApp t1 t2 => dom_union (dom_of_ty t1) (dom_of_ty t2)
  end.

Definition dom_of_tys t1 t2 : list (var * type) :=
  dom_union (dom_of_ty t1) (dom_of_ty t2).

Definition go_result_type Si t1 t2 n :=
  sigT ( fun n1 : nat =>
  sigT ( fun n2 : nat =>
  sigT ( fun dom : list (var * type) =>
  sig  ( fun subs : (substn Si dom n1 * substn Si dom n2) =>
    apply (fst subs) t1 = apply (snd subs) t2 /\
    n1 <= n /\
    n2 <= n )))).

Inductive Id A : Type :=
| mkId : A -> Id A.

Obligation Tactic := idtac.
Unset Transparent Obligations.
Unset Implicit Arguments.
Program Fixpoint go funs axs tcs g t1 t2
  (Hgood : Good axs)
  (Hck : (funs, axs, tcs) |-co g ~: t1 ~~ t2)
  { measure (size_of_co g) } :
  go_result_type (funs,axs,tcs) t1 t2 (size_of_co g) :=
  match g with
    | CRefl ty => existT _ 0 (existT _ 0 (existT _ nil (nilSubst _, nilSubst _)))
    | CSym g2 =>  _ (* Coq didn't like this case, so it's done in proof mode *)
    | CTrans g1 g2 =>
      let fix trans_unify n Si dom1 n1 n3a dom2 n3b n2
                 (w1 : substn Si dom1 n1) (w3a : substn Si dom1 n1)
                 (w3b : substn Si dom2 n3b) (w2 : substn Si dom2 n2)
                 (t1 t3 t2 : type)
                 (HNoDup1 : NoDup dom1) (HNoDup2 : NoDup dom2)
                 (Heq13 : apply w1 t1 = apply w3a t3)
                 (Heq32 : apply w3b t3 = apply w2 t2)
                 (Hn1 : n1 <= n) (Hn2 : n2 <= n) :
       sigT (fun n1 : nat =>
       sigT (fun n2 : nat =>
       sigT (fun dom : list (var * type) =>
       sigT (fun n3 : nat =>
       sigT (fun dom3 : list (var * type) =>
       sig  (fun subs : (substn Si dom n1 * substn Si dom3 n3 * substn Si dom n2) =>
       apply (fst_of3 subs) t1 = apply (snd_of3 subs) t3 /\
       apply (snd_of3 subs) t3 = apply (thd_of3 subs) t2 /\
       n1 <= n /\ n2 <= n )))))) :=
         let ex_w3a' := fix_dom w3a w3b _ _ in
         match ex_w3a' with
           | existT dom w3a' =>
         let ex_w3b' := fix_dom w3b w3a' _ _ in
         match ex_w3b' with
           | existT dom' w3b' =>
         let doms_equal := (eq_refl : dom = dom') in
         match w3a' with
           | nilSubst => let ex_w1' := fix_dom w1 w2 _ _ in
                         match ex_w1' with
                           | existT out_dom w1' =>
                         let ex_w2' := fix_dom w2 w1' _ _ in
                         match ex_w2' with
                           | existT out_dom' w2' =>
                         let out_doms_equal := (eq_refl : out_dom = out_dom') in
                         existT _ n1 (existT _ n2 (existT _ out_dom (
                         existT _ 0 (existT _ nil (w1', w2')))))
                         end end
           | consSubst coa fa lhsa targeta dom_resta n_resta mxa resta =>
             match w3b' with
               | nilSubst => False_rect _ _
               | consSubst cob fb lhsb targetb dom_restb n_restb mxb restb =>
                 (* we know fa = fb, lhsa = lhsb, dom_resta = dom_restb *)
                 let ex_recur := trans_unify n Si
         end
         end end
      in
        (* this mkId business is because Program dissociated _t1 and t3 from
           the result of coercionKind. This is a bug in Program. *)
      match mkId (coercionKind funs axs tcs g1 _) with
        | mkId (exist (_t1, t3) _) =>
      let res1 := go funs axs tcs g1 t1 t3 Hgood _ in
      let res2 := go funs axs tcs g2 t3 t2 Hgood _ in
      match res1 with
        | existT n1 (existT n3a (existT dom1 (exist (w1, w3a) _))) =>
      match res2 with
        | existT n3b (existT n2 (existT dom2 (exist (w3b, w2) _))) =>
      trans_unify (size_of_co g) (funs,axs,tcs) dom1 n1 n3a dom2 n3b n2
                  w1 w3a w3b w2 t1 t3 t2 _ _ _ _ _ _
      end end end
    | _ => undefined
  end.

Obligation Tactic := program_simpl.

Next Obligation.
  inverts Hck. intuition.
Qed.

Next Obligation.
  (* sym case *)
  unfolds go_result_type.
  specialize (go funs axs tcs g2 t2 t1).
  lapplies go.
  - destruct H. destruct s. destruct s. destruct s. destruct a. destruct H0.
    exists x0. exists x. exists x1. exists (snd x2, fst x2). simpl. intuition.
  - simpl. omega.
  - inverts Hck. auto.
  - auto.
Qed.

Next Obligation. Defined.
Obligation Tactic := idtac.
Next Obligation. program_simpl. Defined.
Next Obligation. program_simpl. Defined.
Next Obligation. program_simpl. Defined.

Ltac flatten hyp :=
  let H1 := fresh in
  let H2 := fresh in
  try match type of hyp with
        | _ /\ _ => destruct hyp as [H1 H2]; flatten H1; flatten H2
        | _ * _ => destruct hyp as [H1 H2]; flatten H1; flatten H2
      end.

Next Obligation.
  intros. destruct w3b'. flatten a. symmetry. apply H2.
  clear_except w3a'. destruct w3a'. flatten a. assumption.
Defined.

Next Obligation. intros. assumption. Defined.
Next Obligation. intros. assumption. Defined.
Next Obligation. intros. assumption. Defined.
Next Obligation. intros. destruct w1'. destruct_pairs. assumption. Defined.

Next Obligation.
  intros. destruct w2'. flatten a. symmetry. apply H2.
  clear_except w1'. destruct w1'. flatten a. assumption.
Defined.

Ltac clear_ugliness :=
  repeat match goal with
           | [ Heq_blah : existT _ _ _ = _ |- _ ] => clear Heq_blah
         end.

Ltac clear_bodies :=
  repeat match goal with
           | [ H : _ |- _ ] => clearbody H
         end.

Next Obligation.
  intros. clear_bodies. clear_ugliness.
  destruct w2'. flatten a. apply H2.
  destruct w1'. flatten a. assumption.
Defined.

Next Obligation.
  intros. simpl. squash_eq_rect. clear_bodies. clear_ugliness.
  destruct w1'. destruct w2'. simpl.
  repeat split.
  - clear ex_w1' ex_w2' ex_w3a' ex_w3b'.
    flatten a. flatten a0. unfolds apply. rewrite H. rewrite H4.
    rewrite Heq13. rewrite <- Heq32.
    destruct w3a'. flatten a. rewrite <- Heq_dom in *. apply subset_of_nil in H13.
    apply subset_of_nil in H12. generalize w3a. generalize w3b.
    rewrite H13. rewrite H12. intros. rewrite apply_w_empty_dom.
    rewrite apply_w_empty_dom. reflexivity.

  - assumption.
  - assumption.
Defined.

Next Obligation. program_simpl. inverts Hck. eauto. Defined.
Next Obligation.
  intros. clear_bodies. simpl in wildcard'. rewrite <- Heq_g in Hck.
  inverts Hck. co_kind_det. clear Heq_anonymous. rewrite H in wildcard'.
  assumption.
Defined.

Next Obligation.

match goal with
      | [ H : _ |- _ ] => match H with
                            | appcontext[_ _] => clearbody H
                          end
    end.

clearbody out_doms_equal. clear_ugliness.

unfold apply. clear Heq_ex_w2'. clear ex_w2'. clear Heq_ex_w1'. clear ex_w1'.
    destruct_pairs. rewrite H5. rewrite H. subst*. clear_ugliness.
    unfolds apply. rewrite Heq13. generalize w3a. clear Heq13. destruct w3a'.
    clear go. destruct w3b'. destruct_pairs. rewrite <- Heq_n1. intro.
    rewrite apply_w_size0. rewrite <- Heq32.

    | CTrans co1 co2 => let t3 := snd (coercionKind funs axs tcs D co1 _) in
                        let (sx1, sx3) := go funs axs tcs D co1 t1 t3 Hgood _ in
                        let (sx3', sx2) := go funs axs tcs D co2 t3 t2 Hgood _ in
                        if elt_in_common_dec sx1 sx2
                        then undefined
                        else combine sx1 sx2 _ *)
    | CArrow co1 co2 => undefined
    | CForAll k co => undefined
    | CApp co1 co2 => undefined
    | CLeft co => undefined
    | CRight co => undefined
    | CFun f co => undefined
    | CAx ax tys => undefined
  end.

Definition element_in_common {Si D m n} (sx1 : substnX Si D m)
                                        (sx2 : substnX Si D n) : Prop :=
  exists xv, xv_in_subx xv sx1 /\ xv_in_subx xv sx2.

Definition decide (P : Prop) :=
  sumbool P (~P).

Definition elt_in_common_dec {Si D m n} (sx1 : substnX Si D m)
                                        (sx2 : substnX Si D n) :
  decide (element_in_common sx1 sx2).
Proof.
  refine (let mxs1 := proj1_sig sx1 in
          let mxs2 := proj1_sig sx2 in
          let fix xv_in_mxs xv mxs : decide (xv_in_mx_list xv mxs) :=
              match mxs with
                | nil => right _
                | mx :: mxs => if xvar_eq_decide xv (fst (fst (proj1_sig mx)))
                               then left _
                               else if xv_in_mxs xv mxs then left _ else right _
              end in
          let fix recur mxs :
                decide (exists xv, xv_in_mx_list xv mxs /\ xv_in_mx_list xv mxs2) :=
              match mxs with
                | nil => right _
                | mx :: mxs => if xv_in_mxs (fst (fst (proj1_sig mx))) mxs2
                               then left _
                               else if recur mxs then left _ else right _
              end in
          if recur mxs1 then left _ else right _);
  unfolds xv_in_mx_list.
  - intro Hcon. inverts Hcon. tauto.
  - exists mx. split. apply in_eq. auto.
  - inverts _H0. exists x. split; try tauto. apply in_cons. tauto.
  - intro Hcon. inverts Hcon. inverts H. apply in_inv in H0. inverts H0.
    auto. unfold not in _H0. lapplies _H0. auto. exists x. tauto.
  - intro Hcon. inverts Hcon. inverts H. inverts H0. tauto.
  - inverts _H. exists (fst (fst (proj1_sig mx))). split. exists mx. split.
    apply in_eq. auto. exists x. auto.
  - inverts _H0. inverts H. inverts H0. inverts H1. exists x. split.
    exists x0. split. apply in_cons. tauto. tauto. exists x1. auto.
  - intro Hcon. inverts Hcon. inverts H. inverts H0. inverts H. apply in_inv in H0.
    inverts H0. apply _H in H1. auto. inverts H1.
    unfold not in _H0. lapplies _H0. auto. exists (fst (fst (proj1_sig x0))). split.
    exists x0. tauto. exists x. auto.
  - unfold element_in_common. inverts _H. unfold xv_in_subx. unfold xv_in_mx_list.
    exists x. auto.
  - auto.
Qed.

Definition combine {Si D m n} (sx1 : substnX Si D m) (sx2 : substnX Si D n)
  (Hdistinct : ~ element_in_common sx1 sx2) : substnX Si D (m + n).
  refine (let mxs1 := proj1_sig sx1 in
          let mxs2 := proj1_sig sx2 in
          exist _ (mxs1 ++ mxs2) _).
  rewrite map_app. rewrite sum_app. pose proof (proj2_sig sx1). pose proof (proj2_sig sx2).
  simpls. unfold mxs1. unfold mxs2. omega.
Qed.

Definition pair x := (x * x)%type.
Definition swap {A} (x : pair A) := let (a,b) := x in (b,a).

Lemma fst_swap : forall {A} (x : pair A),
  fst (swap x) = snd x.
Proof.
  intros. destruct x. auto.
Qed.

Lemma snd_swap : forall {A} (x : pair A),
  snd (swap x) = fst x.
Proof.
  intros. destruct x. auto.
Qed.

Obligation Tactic := Tactics.program_simpl.
Unset Transparent Obligations.
Program Fixpoint go funs axs tcs D g t1 t2
  (Hgood : Good axs)
  (Hck : (funs, axs, tcs); D |-co g ~: t1 ~~ t2)
  { measure (size_of_co g) } :
    sig (fun two_subx : pair (substnX (funs, axs, tcs) D (size_of_co g)) =>
           let sub1 := sub_from_subx (fst two_subx) in
           let sub2 := sub_from_subx (snd two_subx) in
           apply sub1 (flatten t1) = apply sub2 (flatten t2)) :=
  match g with
    | CRefl ty => (nil, nil)
    | CSym co => swap (go funs axs tcs D co t2 t1 Hgood _)
    | CTrans co1 co2 => let t3 := snd (coercionKind funs axs tcs D co1 _) in
                        let (sx1, sx3) := go funs axs tcs D co1 t1 t3 Hgood _ in
                        let (sx3', sx2) := go funs axs tcs D co2 t3 t2 Hgood _ in
                        if elt_in_common_dec sx1 sx2
                        then undefined
                        else combine sx1 sx2 _ *)
    | CArrow co1 co2 => undefined
    | CForAll k co => undefined
    | CApp co1 co2 => undefined
    | CLeft co => undefined
    | CRight co => undefined
    | CFun f co => undefined
    | CAx ax tys => undefined
  end.
Obligation Tactic :=
  Tactics.program_simpl;
  repeat abstract_sig;
  try omega;
  try solve [match goal with
               | [ Hck : _;_ |-co _ ~: _ ~~ _ |- _ ] => inversion Hck
             end; auto].
Solve Obligations.

Ltac abstract_go :=
  let ss := fresh in
  let Hs := fresh in
  match goal with
    | [ |- context[proj1_sig ?blah] ] =>
  match blah with
    | _ _ _ _ _ _ _ _ _ _ _ => generalize blah; intro ss;
                                         pose proof (proj2_sig ss) as Hs;
                                         simpl in Hs
  end end.

(*
Ltac obtac :=
  intros; simpls; try match goal with
                        | [ g : coercion |- _ ] =>
                      match goal with
                        | [ Heq_g : _ = g |- _ ] => rewrite <- Heq_g in *
                      end end.

(* Obligation Tactic := obtac. *)
*)
Next Obligation.
  unfold sub_from_subx. simpl.
  abstract_go.
  unfold sub_from_subx in H0. rewrite fst_swap. rewrite snd_swap.
  symmetry. auto.
Qed.

Next Obligation.
  inverts Hck. eauto.
  Obligation Tactic := idtac. (* for some reason, Coq gets stuck without this *)
Qed.

Next Obligation.
  intros. unfold t3. abstract_sig. clear t3. rewrite <- Heq_g in Hck.
  inverts Hck. apply co_kind_det with (t1 := t1) (t2 := t3) in H0; auto.
  intuition; subst; auto.
Qed.

Next Obligation.
  intros. rewrite <- Heq_g.
  simpl; omega.
Qed.

Next Obligation.
  intros. unfold t3. clear sx3 sx1 t3. abstract_sig. rewrite <- Heq_g in Hck.
  inverts Hck. apply co_kind_det with (t1 := t1) (t2 := t3) in H0; auto.
  intuition; subst; auto.
Qed.

Next Obligation.
  intros. rewrite <- Heq_g. simpl. omega.
Qed.

  Tactics.program_simpl. simpl. omega.
Qed.

Next Obligation.
  intros. auto.
Qed.

Lemma size_of_combine : forall Si D m n (sx1 : substnX Si D m) (sx2 : substnX Si D n) pf,
  sum (map size_of_mxco (proj1_sig (combine sx1 sx2 pf))) <= m + n.
Proof.
  intros. abstract_sig. auto.
Qed.

Next Obligation.
  intros. abstract_sig.

  assert ((size_of_co (CTrans co1 co2)) = (S (size_of_co co1 + size_of_co co2))).
  simpl; auto.

  rewrite H0.
 replace
unfold sx1 in *. unfold sx2 in *. clear sx1 sx2. abstract_go.
admit. (* bug in Coq, I think. The above Lemma proves this case. *)
Qed.

Next Obligation.
  intros. unfold sub_from_subx in sub. unfold proj1_sig in sub. simpl in sub

Theorem dragon : forall axs funs tcs D g t1 t2,
  Good axs ->
  (funs, axs, tcs); D |-co g ~: t1 ~~ t2 ->
  unifies (flatten t1) (flatten t2).
Proof.


(** Copyright (c) 2018 by Swirlds, Inc.
   Implemented by Karl Crary.
*)

Require Import Nat.
Require Import Bool.
Require Import Omega.
Require Import List.
Require Import Permutation.

Require Import Tact.
Require Import Decide.
Require Import Relation.
Require Import Majority.
Require Import Cardinality.
Require Import HashgraphFacts.
Require Import Sees.
Require Import Round.
Require Import Progress.
Require Import Vote.
Require Import Decision.
Require Import Consensus.
Require Import Famous.

Lemma stsees_impl_famous_pre :
  forall s i x y,
    member (global s) y
    -> rwitness i x
    -> (forall j z, parent z y -> round j z -> j <= i)
    -> stsees x y
    -> exists z,
         member (global s) z
         /\ decision s x z true
         /\ rwitness (S first_regular + i) z.
Proof.
intros s i x y Hsy Hwitx Hparentround Hxy.
so first_regular_min as Hd2.
so (all_rounds_inhabited _ (S first_regular + i) (global_nonterminating s)) as (z & Hwitz & Hsz).
exists z.
do2 2 split; auto.
apply (unanimity_impl_decision s (global s) x z i (first_regular + i) true); auto.
  {
  exact (Hwitx andel).
  }

2:{
  omega.
  }

2:{
  replace (S (first_regular + i) - i) with (S first_regular) by omega.
  so coin_freq_min.
  rewrite -> Nat.mod_small; omega.
  }
clear z Hwitz Hsz.
intros w Hsw Hwitw.
eapply vote_first; eauto; try omega.
split.
2:{
  intros _.
  exact I.
  }
intros _.
(** The heart of the proof starts here. *)
destruct Hxy as (y' & Hyy & Hmaj1).
exploit (stsees_many_witnesses (pred (first_regular + i)) w) as Hmaj2.
  {
  force_exact (Hwitw andel).
  f_equal.
  omega.
  }
so (supermajority_intersect_3 _#6 eq_peer_decide supermajority_honest Hmaj1 Hmaj2) as (a & Hhonest & Ha1 & Ha2).
destruct Ha1 as (u & Heqcru & Hxu & Huy).
destruct Ha2 as (v & Heqcrv & Hvw & Hwitv).
apply (star_plus_trans _#3 u).
  {
  apply sees_impl_ancestor; auto.
  }
apply (star_plus_trans _#3 v).
2:{
  apply stsees_impl_strict_ancestor; auto.
  }
apply self_ancestor_impl_ancestor.
destruct (eq_event_decide v u) as [Heq | Hneqvu].
  {
  subst v.
  apply star_refl.
  }
rewrite <- Heqcru in Hhonest.
rewrite <- Heqcrv in Heqcru.
exploit (self_ancestor_total (global s) u v) as H; auto.
  {
  apply (world_closed _ _ y); auto.
  eapply star_trans; eauto.
  apply sees_impl_ancestor; auto.
  }

  {
  apply (world_closed _ _ w); auto.
  apply stsees_impl_ancestor; auto.
  }
destruct H as [| Hvu]; auto.
exfalso.
so (eq_event_decide u y) as [Heq | Hnequy].
  {
  subst u.
  so (plus_plusr _#4 (star_neq_plus _#4 Hvu Hneqvu)) as (z & Hvz & Hzy).
  so (round_defined z) as (j & Hroundz).
  so (Hparentround _ _ (self_parent_impl_parent _ _ Hzy) Hroundz) as Hji.
  so (round_mono _#4 (self_ancestor_impl_ancestor _ _ Hvz) (Hwitv andel) Hroundz).
  omega.
  }

  {
  so (plus_plusr _#4 (star_neq_plus _#4 (star_trans _#5 (sees_impl_ancestor _ _ Huy) Hyy) Hnequy)) as (z & Huz & Hzy).
  so (round_defined z) as (j & Hroundz).
  so (Hparentround _ _ Hzy Hroundz) as Hji.
  so (round_mono _#4 (star_trans _#5 (self_ancestor_impl_ancestor _ _ Hvu) Huz) (Hwitv andel) Hroundz).
  omega.
  }
Qed.

Lemma stsees_impl_famous :
  forall s i x y,
    member (global s) y
    -> rwitness i x
    -> (forall j z, parent z y -> round j z -> j <= i)
    -> stsees x y
    -> famous s (global s) x.
Proof.
intros s i x y Hsy Hwitx Hparentround Hxy.
so (stsees_impl_famous_pre _#4 Hsy Hwitx Hparentround Hxy) as (z & Hz & Hdecision & _).
exists z.
split; auto.
Qed.

Lemma fwitness_finite_nonterm_if :
  forall s W,
    extends W (global s)
    -> nonterminating W
    -> (forall x, member (global s) x -> decidable (member W x))
    -> forall i x, fwitness s W i x -> finite (fwitness s W i).
Proof.
intros s W HsW Hnonterm HdecW i x Hx.
destruct Hx as (Hwitx & Hfamousx).
destruct Hfamousx as (y & Wy & Hdecisionxy).
apply (finite_subset' _ _ (fun z => realtime s z y)).
  { exact eq_event_decide. }

  {
  intros w Hw.
  destruct Hw as (Hwitw & Hfamous).
  destruct Hfamous as (z & Wz & Hdecisionwz).
  apply ancestor_realtime.
    { exact (HsW _ Wy). }
  so (ancestor_decide w y) as [| Hnwy]; auto.
  exfalso.
  so (no_late_fame _#6 Hwitx Hwitw Hdecisionxy Hnwy) as Hdecisionwy.
  so (decision_consistent _#7 Wy Wz Hdecisionwy Hdecisionwz) as H.
  discriminate H.
  }

  {
  intros z Hzy.
  so (HdecW _ (realtime_member _#3 Hzy andel)) as [Wz | Wnz].
  2:{
    right.
    contradict Wnz.
    destruct Wnz as (_ & Hfamous).
    eapply famous_member; eauto.
    }
  apply dec_and_dep.
    {
    apply rwitness_decide.
    }

    {
    intros (_ & Hwitz).
    apply famous_decide_nonterm; auto.
    }
  }

  {
  so (HsW _ Wy) as (m & _ & -> & _).
  assert (exists l, forall n, In n l <-> n < S m) as (l & Hl).
    {
    clear Wy x Hwitx Hdecisionxy.
    generalize (S m).
    intro m'.
    clear m.
    induct m'.
      (* 0 *)
      {
      exists nil.
      intros n.
      split.
        {
        intro H; destruct H.
        }

        {
        intro H; omega.
        }
      }

      (* S *)
      {
      intros m (l & Hl).
      exists (cons m l).
      intros n.
      split.
        {
        intros H.
        destruct H as [H | H].
          {
          omega.
          }

          {
          so (Hl _ andel H).
          omega.
          }
        }

        {
        intro Hnm.
        so (eq_nat_dec m n) as [Heq | Hneq].
          {
          subst.
          left; auto.
          }

          {
          right.
          apply Hl.
          omega.
          }
        }
      }
    }
  exists (map (spawn s) l).
  intros z.
  split.
    {
    intro H.
    destruct H as (n & m' & -> & Heq & Hle).
    so (spawn_inj _#3 Heq); subst m'.
    apply in_map.
    apply Hl.
    omega.
    }

    {
    intro Hz.
    so (in_map_iff _#5 andel Hz) as (n & <- & Hin).
    exists n, m.
    do2 2 split; auto.
    so (Hl _ andel Hin).
    omega.
    }
  }
Qed.

Lemma fwitness_finite_global_if :
  forall s i x, fwitness s (global s) i x -> finite (fwitness s (global s) i).
Proof.
intros s i x Hx.
eapply fwitness_finite_nonterm_if; eauto.
  { unfold extends, incl; auto. }

  { apply global_nonterminating. }

  {
  intros y Hy.
  left; auto.
  }
Qed.

Lemma minimal_witness :
  forall s i,
    exists x,
      member (global s) x
      /\ rwitness i x
      /\ forall j y, parent y x -> round j y -> j < i.
Proof.
intros s i.
so (all_rounds_inhabited _ i (global_nonterminating s)) as (y & Hwity & Hsy).
revert Hwity Hsy.
wfinduct y using strict_ancestor_well_founded.
intros y IH Hwity Hsy.
so (initial_decide y) as [Hinit | (u & v & Hparents)].
  {
  so (round_fun _#3 (Hwity andel) (round_initial Hinit)) as H.
  exists y.
  do2 2 split; auto.
  intros j z Hparent _.
  exfalso.
  eapply initial_no_parent; eauto.
  }
so (round_defined v) as (j & Hroundv).
so (lt_dec j i) as [Hle | Hnle].
  {
  exists y.
  do2 2 split; auto.
  intros k z Hzy Hroundz.
  invert Hzy.
    {
    intros ? Hparents'.
    so (parents_fun _#5 Hparents Hparents') as (<- & <-).
    so (strict_self_ancestor_witness _#4 (Hwity ander) (plus_one _#4 (ex_intro _ _ Hparents)) Hroundz (Hwity andel)).
    omega.
    }

    {
    intros ? Hparents'.
    so (parents_fun _#5 Hparents Hparents') as (<- & <-).
    so (round_fun _#3 Hroundv Hroundz); subst k.
    omega.
    }
  }

  {
  so (ancestor_witness _#3 (le_refl _) Hroundv) as (w & Hwv & Hwitw).
  assert (w @ y) as Hwy.
    {
    eapply star_plus_trans; eauto.
    apply plus_one.
    eapply parent2; eauto.
    }
  apply (IH w); auto.
    {
    force_exact Hwitw.
    f_equal.
    so (round_mono _#4 (plus_star _#4 Hwy) (Hwitw andel) (Hwity andel)).
    omega.
    }

    {
    apply (world_closed _ _ y); auto.
    apply plus_star; auto.
    }
  }
Qed.

Lemma minimal_witness' :
  forall s i,
    exists x,
      member (global s) x
      /\ rwitness (S i) x
      /\ forall j y, parent y x -> round j y -> j <= i.
Proof.
intros s i.
so (minimal_witness s (S i)) as (x & Hx & Hwitx & Hminimal).
exists x.
do2 2 split; auto.
intros j y Hyx Hroundy.
so (Hminimal _ _ Hyx Hroundy).
omega.
Qed.

Theorem fairness :
  forall s i,
    supermajority
      stake
      (fun a => exists w, creator w = a /\ fwitness s (global s) i w)
      every.
Proof.
intros s i.
so (minimal_witness' s i) as (y & Hsy & Hwity & Hparentround).
so (stsees_many_witnesses _ _ (Hwity andel)) as Hmaj.
assert (exists z, fwitness s (global s) i z) as (z & Hz).
  {
  so (supermajority_inhabitant _#4 Hmaj) as (a & Ha).
  destruct Ha as (x & <- & Hxy & Hwitx).
  exists x.
  split; auto.
  eapply stsees_impl_famous; eauto.
  }
eapply supermajority_enlarge; eauto.
  {
  intros a Ha.
  destruct Ha as (x & Heqcr & Hxy & Hwitx).
  exists x.
  split; auto.
  split; auto.
  eapply stsees_impl_famous; eauto.
  }

  {
  intros a _.
  apply (dec_exists_finite _ _ (fwitness s (global s) i)).
    {
    intros x (H1 & H2).
    auto.
    }

    {
    eapply fwitness_finite_global_if; eauto.
    }

    {
    intros x.
    apply dec_and.
      {
      apply eq_peer_decide.
      }

      {
      apply finite_decide.
        {
        exact eq_event_decide.
        }

        {
        eapply fwitness_finite_global_if; eauto.
        }
      }
    }
  }
Qed.

Lemma famous_witness_exists :
  forall s i,
    exists x,
      fwitness s (global s) i x.
Proof.
intros s i.
so (supermajority_inhabitant _#4 (fairness s i)) as (a & Ha).
destruct Ha as (x & _ & Hx).
exists x; auto.
Qed.


(***************************************************************************
* Correctness of the CPS-transformation                                    *
* Arthur Charguéraud, January 2009, Coq v8.1pl4                            *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory.
Implicit Types x : var.

(* ********************************************************************** *)
(** ** Description of the task *)

(* ********************************************************************** *)
(** Grammar of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_cst  : nat -> trm
  | trm_app  : trm -> trm -> trm
  | trm_abs  : trm -> trm.

(* ********************************************************************** *)
(** Operation to open up abstractions. *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => if k === i then u else (trm_bvar i)
  | trm_fvar x    => t
  | trm_cst k     => t
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(* ********************************************************************** *)
(** Definition of well-formedness of a trm *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_cst : forall k,
      term (trm_cst k)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1).

(* ********************************************************************** *)
(** Definition of the body of an abstraction *)

Definition body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(* ********************************************************************** *)
(** Definition of values *)

Inductive value : trm -> Prop :=
  | value_cst : forall k,
      value (trm_cst k)
  | value_abs : forall t1,
      term (trm_abs t1) ->
      value (trm_abs t1).

(* ********************************************************************** *)
(** Definition of the big-step reduction *)

Inductive eval : trm -> trm -> Prop :=
  | eval_val : forall t1,
      value t1 ->
      eval t1 t1
  | eval_red : forall v2 t3 v3 t1 t2,
      eval t1 (trm_abs t3) ->
      eval t2 v2 ->
      eval (t3 ^^ v2) v3 ->
      eval (trm_app t1 t2) v3.

(* ********************************************************************** *)
(** Computing free variables of a trm *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i    => {}
  | trm_fvar x    => {{x}}
  | trm_cst k     => {}
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  | trm_abs t1    => (fv t1)
  end.

(* ********************************************************************** *)
(** Abstracting a name out of a trm *)

Fixpoint close_var_rec (k : nat) (z : var) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => if x == z then (trm_bvar k) else t
  | trm_cst k     => t
  | trm_app t1 t2 => trm_app (close_var_rec k z t1) (close_var_rec k z t2)
  | trm_abs t1    => trm_abs (close_var_rec (S k) z t1)
  end.

Definition close_var z t := close_var_rec 0 z t.

(* ********************************************************************** *)
(** Substitution for a name *)

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => t
  | trm_fvar x    => if x == z then u else (trm_fvar x)
  | trm_cst k     => t
  | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2)
  | trm_abs t1    => trm_abs (subst z u t1)
  end.

Notation "[ z ~> u ] t" := (subst z u t) (at level 68).

(* ********************************************************************** *)
(** ** Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => {{ x }}) in
  let C := gather_vars_with (fun x : trm => fv x) in
  constr:(A \u B \u C).

Ltac pick_fresh X :=
  let L := gather_vars in (pick_fresh_gen L X).

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.
Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto_star.
Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.
Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; auto_star.

(*
Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.
Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; autos*.
*)

Hint Constructors trm.

(* ********************************************************************** *)
(** ** Properties of substitution *)

(* begin hide *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ; simpls; inversion* Equ; fequals*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; fequals*. unfolds open.
  pick_fresh x. apply* (@open_rec_term_core t1 0 (trm_fvar x)).
Qed.

(* end hide *)

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin fv t ->  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; fequals*.
  case_var*. notin_false.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ ([x ~> u]t2).
Proof.
  intros. unfold open. generalize 0.
  induction t1; intros; simpl; fequals*.
  case_nat*. case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_var : forall x y u t, y <> x -> term u ->
  ([x ~> u]t) ^ y = [x ~> u] (t ^ y).
Proof.
  introv Neq Wu. rewrite* subst_open. simpl. case_var*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_intro : forall x t u,
  x \notin (fv t) -> term u ->
  t ^^ u = [x ~> u](t ^ x).
Proof.
  introv Fr Wu. rewrite* subst_open.
  rewrite* subst_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

Hint Constructors term.

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpls*.
  case_var*.
  apply_fresh term_abs. rewrite* subst_open_var.
Qed.

Hint Resolve subst_term.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> body t1.
Proof. intros. unfold body. inversion* H. Qed.

Lemma body_to_term_abs : forall t1,
  body t1 -> term (trm_abs t1).
Proof. intros. inversion* H. Qed.

Hint Resolve term_abs_to_body body_to_term_abs.

(** ** Opening a body with a term gives a term *)

Lemma open_term : forall t u,
  body t -> term u -> term (t ^^ u).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro y).
Qed.

Hint Resolve open_term.

(* ********************************************************************** *)
(** ** Additional results on primitive operations *)

(** Open_var with fresh names is an injective operation *)

Lemma open_var_inj : forall x t1 t2,
  x \notin (fv t1) -> x \notin (fv t2) ->
  (t1 ^ x = t2 ^ x) -> (t1 = t2).
Proof.
  intros x t1. unfold open. generalize 0.
  induction t1; intro k; destruct t2; simpl; intros; inversion H1;
  try solve [ f_equal*
  | do 2 try case_nat; inversions* H1; try notin_false ].
Qed.

(* begin hide *)

(** Close var commutes with open with some freshness conditions,
  this is used in the proofs of [close_var_body] and [close_var_open] *)

Lemma close_var_rec_open : forall x y z t1 i j,
  i <> j -> y <> x -> y \notin (fv t1) ->
    {i ~> trm_fvar y} ({j ~> trm_fvar z} (close_var_rec j x t1) )
  = {j ~> trm_fvar z} (close_var_rec j x ({i ~> trm_fvar y}t1) ).
Proof.
  induction t1; simpl; intros; try solve [ f_equal* ].
  do 2 (case_nat; simpl); try solve [ case_var* | case_nat* ].
  case_var*. simpl. case_nat*.
Qed.

(* end hide *)

(** Close var is an operation returning a body of an abstraction *)

Lemma close_var_fresh : forall x t,
  x \notin fv (close_var x t).
Proof.
  introv. unfold close_var. generalize 0.
  induction t; intros k; simpls; notin_simpl; auto.
  case_var; simple*.
Qed.

(** Close var is an operation returning a body of an abstraction *)

Lemma close_var_body : forall x t,
  term t -> body (close_var x t).
Proof.
  introv W. exists {{x}}. intros y Fr.
  unfold open, close_var. generalize 0. gen y.
  induction W; intros y Fr j; simpls.
  case_var; simple*. case_nat*.
  autos*.
  autos*.
  apply_fresh* term_abs as z.
   unfolds open. rewrite* close_var_rec_open.
Qed.

(** Close var is the right inverse of open_var *)

Lemma close_var_open : forall x t,
  term t -> t = (close_var x t) ^ x.
Proof.
  introv W. unfold close_var, open. generalize 0.
  induction W; intros j; simpls; f_equal*.
  case_var*. simpl. case_nat*.
  let L := gather_vars in match goal with |- _ = ?t =>
    destruct (var_fresh (L \u fv t)) as [y Fr] end.
  apply* (@open_var_inj y).
  unfolds open. rewrite* close_var_rec_open.
Qed.

(** An abstract specification of close_var, which packages the
  result of the operation and all the properties about it. *)

Lemma close_var_spec : forall t x, term t ->
  exists u, t = u ^ x /\ body u /\ x \notin (fv u).
Proof.
  intros. exists (close_var x t). splits 3.
  apply* close_var_open.
  apply* close_var_body.
  apply* close_var_fresh.
Qed.

(* ********************************************************************** *)
(** Automation *)

Hint Extern 1 (term ?t) => skip.
(* match goal with
  | H: value t |- _ => skip
  | H: eval t _ |- _ => skip
  | H: eval _ t |- _ => skip
  end.*)

Hint Constructors value.

Lemma open_rec_term_core' : forall t j v i u, i <> j ->
  {i ~> u}({j ~> v}t) = {j ~> v}t -> {i ~> u}t = t.
Proof.
  induction t; introv Neq Equ; simpls; inversion* Equ; fequals*.
  case_nat*. case_nat*.
Qed.

Lemma open_lc : forall t u k,
  term t -> {k ~> u}t = t.
Proof.
  introv H. gen k. induction H; intros; simpl; fequals*.
  unfolds open. pick_fresh x.
   apply* (@open_rec_term_core' t1 0 (trm_fvar x)).
Qed.

(* ********************************************************************** *)
(** Equivalence *)

Lemma eval_value_only : forall v v',
  eval v v' -> value v -> v' = v.
Proof.
  introv E V. inverts V; inverts~ E.
Qed.

Definition trm_undefined := trm_bvar 0.

(* todo: make an inductive instead ! or well-founded recursion .. *)

Inductive cps : trm -> trm -> Prop :=
  | cps_var : forall x,
      cps (trm_fvar x)
          (trm_abs (trm_app (trm_bvar 0) (trm_fvar x)))
  | cps_cst : forall k,
      cps (trm_cst k)
          (trm_abs (trm_app (trm_bvar 0) (trm_cst k)))
  | cps_abs : forall L t1 t1',
      (forall x, x \notin L -> cps (t1^x) (t1'^x)) ->
      cps (trm_abs t1)
         (trm_abs (trm_app (trm_bvar 0) (trm_abs t1')))
  | cps_app : forall t1 t2 t1' t2',
      cps t1 t1' ->
      cps t2 t2' ->
      cps (trm_app t1 t2)
          (let k := trm_abs (trm_app (trm_app (trm_bvar 1) (trm_bvar 0)) (trm_bvar 2)) in
           trm_abs (trm_app t1' (trm_abs (trm_app t2' k)))).

Lemma eval_value : forall t v,
  eval t v -> value v.
Proof.
  introv H. induction H; auto.
Qed.

Hint Constructors cps.
Lemma cps_function : forall t, term t ->
  exists t', cps t t'.
Proof.
  introv T. induction T.
  eauto.
  eauto.
  destruct IHT1 as [t1' ?]. destruct IHT2 as [t2' ?].
   exists~ (let k := trm_abs (trm_app (trm_app (trm_bvar 1) (trm_bvar 0)) (trm_bvar 2)) in
            trm_abs (trm_app t1' (trm_abs (trm_app t2' k)))).
  exists __. apply_fresh cps_abs.
 skip. (* close again ! *)
Admitted.

Hint Resolve eval_value.
Hint Constructors cps.
Lemma cps_subst_var : forall x y t t',
  cps t t' ->
  cps (subst x (trm_fvar y) t) (subst x (trm_fvar y) t').
Proof.
  introv C. induction C; simpl.
  case_var~.
  auto.
  apply_fresh cps_abs. do 2 rewrite~ subst_open_var.
  auto.
Qed.

Lemma cps_functional : forall t t1' t2',
  cps t t1' -> cps t t2' -> t1' = t2'.
Admitted.

Inductive cps_value : trm -> trm -> Prop :=
  | cps_value_cst : forall k,
      cps_value (trm_cst k) (trm_cst k)
  | cps_value_abs : forall L t1 t1',
      (forall x, x \notin L -> cps (t1^x) (t1'^x)) ->
      cps_value (trm_abs t1) (trm_abs t1').

Lemma cps_value_functional : forall v v1' v2',
  cps_value v v1' -> cps_value v v2' -> v1' = v2'.
Admitted.

Lemma cps_value_function : forall v, value v ->
  exists v', cps_value v v'.
Admitted.

Lemma cps_value_abs_exists : forall x t1 t1',
  cps (t1 ^ x) (t1' ^ x) ->
  x \notin fv t1 \u fv t1' ->
  cps_value (trm_abs t1) (trm_abs t1').
Proof.
  introv C Fr. apply_fresh cps_value_abs.
  rewrite~ (@subst_intro x t1).
  rewrite~ (@subst_intro x t1').
  apply~ cps_subst_var.
Qed.

Lemma cps_of_value : forall v' v,
  value v ->
  cps_value v v' ->
  cps v (trm_abs (trm_app (trm_bvar 0) v')).
Proof.
  introv V C. inverts C.
  auto.
  apply_fresh* cps_abs.
Qed.

Hint Rewrite
 union_empty_r
 union_empty_l
 union_assoc
 union_same : set.
Tactic Notation "calc_set" :=
  autorewrite with set.
Tactic Notation "calc_set" "*" :=
  calc_set; autos*.

Lemma cps_fv : forall t t',
  cps t t' -> fv t' = fv t.
Proof.
  introv C. induction C; simpl.
  calc_set*.
  calc_set*.
  calc_set. skip.
  calc_set. congruence.
Qed.

Lemma cps_subst : forall x v v' t t',
  value v ->
  cps_value v v' ->
  cps t t' ->
  cps (subst x v t) (subst x v' t').
Proof.
  introv V CV CT.
  induction CT; simpl.
  case_var.
    apply~ cps_of_value.
    auto.
  auto.
  apply_fresh cps_abs. do 2 rewrite~ subst_open_var.
  auto.
Qed.

Lemma cps_open : forall v v' t t',
  value v ->
  cps_value v v' ->
  cps_value (trm_abs t) (trm_abs t') ->
  cps (t ^^ v) (t' ^^ v').
Proof.
  introv V CV CT. inverts CT.
  pick_fresh x.
  rewrite~ (@subst_intro x t).
  rewrite~ (@subst_intro x t').
  apply~ cps_subst.
Qed.

Lemma cps_value_value : forall v v',
  cps_value v v' -> value v'.
Proof.
  introv V. inverts~ V.
Qed.

Ltac prove_term :=
  match goal with |- term _ => skip end.
Ltac calc_open :=
  unfold open; simpl; rewrite_all open_lc; try prove_term.

Check eval_red.

Hint Resolve eval_val.
Lemma eval_red_values : forall t1 v2 r,
  term t1 -> value v2 ->
  eval (t1 ^^ v2) r ->
  eval (trm_app (trm_abs t1) v2) r.
Proof.
  intros. apply~ eval_red.
Qed.
Hint Resolve eval_red_values.
Hint Resolve cps_value_value.

Lemma eval_red_values_bis : forall t1 v2 v3 r,
  term t1 -> value v2 -> value v3 ->
  eval (trm_app (t1 ^^ v2) v3) r ->
  eval (trm_app (trm_app (trm_abs t1) v2) v3) r.
Proof.
  introv T1 V2 V3 E. inverts E. inverts H.
  apply~ eval_red.
  apply* eval_red_values.
  rewrite~ <- (eval_value_only H2).
Qed.

Lemma cps_value_abs_of : forall t3, body t3 ->
  exists t3', cps_value (trm_abs t3) (trm_abs t3').
Proof.
  introv B. pick_fresh x.
  forwards~ H: (@cps_function (t3^x)). destruct H as [t3x C].
  exists (close_var x t3x).
  apply~ (@cps_value_abs_exists x).
  rewrite~ <- close_var_open.
  notin_simpl. auto. apply close_var_fresh.
Qed.

Lemma cps_correct_ind : forall v v' t t' k r,
  eval t v ->
  cps_value v v' ->
  eval (trm_app k v') r ->
  value k ->
  cps t t' ->
  eval (trm_app t' k) r.
Proof.
  introv E. gen v' t' k r. induction E; introv CV EV V CT.
  (* case: value *)
  lets CT': (cps_of_value H CV).
  rewrite (cps_functional CT CT').
  apply~ eval_red_values. calc_open. auto.
  (* case: red *)
  inverts CT as CT1 CT2.
  forwards~ H: (@cps_value_abs_of t3). destruct H as [t3' T3].
  apply~ eval_red_values. calc_open.
  apply~ IHE1; clear IHE1. eauto.
  apply~ eval_red_values. calc_open.
  forwardv H: (@cps_value_function v2). eauto. destruct H as [v2' T2].
  apply~ IHE2; clear IHE2. eauto.
  apply~ eval_red_values. eauto. calc_open.
  apply~ eval_red_values_bis. eauto.
  apply~ IHE3; clear IHE3. eauto. eauto.
  apply~ cps_open. eauto.
Qed.

Definition trm_id := trm_abs (trm_bvar 0).

Lemma cps_correct : forall v v' t t',
   eval t v ->
   cps t t' ->
   cps_value v v' ->
   eval (trm_app t' trm_id) v'.
Proof.
  introv E CT CV. unfold trm_id.
  apply* (@cps_correct_ind v).
Qed.

(*------------------*)

Require Import SuperFix.

Definition Cps_body (Cps:trm->trm) (t:trm) : trm :=
  match t with
  | trm_bvar _ => trm_undefined
  | trm_fvar _ =>
      trm_abs (trm_app (trm_bvar 0) t)
  | trm_cst _ =>
      trm_abs (trm_app (trm_bvar 0) t)
  | trm_abs t1 =>
      let x := var_gen (fv t1) in
      let t1' := close_var x (Cps (t1 ^ x)) in
      trm_abs (trm_app (trm_bvar 0) (trm_abs t1'))
  | trm_app t1 t2 =>
      let k := trm_abs (trm_app (trm_app (trm_bvar 1) (trm_bvar 0)) (trm_bvar 2)) in
           trm_abs (trm_app (Cps t1) (trm_abs (trm_app (Cps t2) k)))
  end.

Fixpoint trm_size (t:trm) :=
  match t with
  | trm_bvar _ => 1
  | trm_fvar _ => 1
  | trm_cst _ => 1
  | trm_abs t1 => 1+(trm_size t1)
  | trm_app t1 t2 => 1+(trm_size t1)+(trm_size t2)
  end.

Require Import Omega.

Lemma trm_size_rename : forall x y t,
  trm_size ([x ~> trm_fvar y]t) = trm_size t.
Proof.
  induction t; simpl; fequals. case_var~.
Qed.

Lemma trm_size_open : forall x t,
  trm_size (t^x) = trm_size t.
Proof.
  intros. unfold open. generalize 0.
  induction t; intros; simpl; fequals.
  case_nat~.
  rewrite IHt1. rewrite~ IHt2.
  rewrite~ IHt.
Qed.

Definition Cps := fixmu trm_undefined Cps_body trm_size.

Lemma fixCps : forall x:trm,
  Cps x = Cps_body Cps x.
Proof.
  prove_fixf. destruct x; fequals.
  rewrite IH. rewrite IH. auto. simpl; omega. simpl; omega.
  rewrite IH. auto. simpl. rewrite trm_size_open. omega.
Qed.
Hint Resolve fixCps.

Lemma Cps_cps : forall t,
  term t -> cps t (Cps t).
Proof.
  introv H. induction H; simpl_fix~ Cps.
  sets x: (var_gen (fv t1)). apply_fresh cps_abs.
  applya_in H0 (>>> y __). auto.
  rewrite~ (@subst_intro y t1 (trm_fvar x)).
  skip_rewrite (Cps ([y ~> trm_fvar x](t1 ^ y))
    = [y ~> trm_fvar x](Cps (t1^y))).
  skip_rewrite (forall t, close_var x ([y ~> trm_fvar x]t)
    = close_var y t).
  skip_rewrite (forall t, (close_var y t)^y = t).
  auto.
Qed.


Require Import Terms.

(** * Syntax *)

(** This is shared by LambdaBracket and LambdaThrow *)

(** ** Values *)

(** We tell Coq not (to try) to generate induction principles for val.
   The generated induction principles are too weak to be useful anyway *)
Unset Elimination Schemes.

(** The type of values. *)
Inductive Val : Type :=
| VConst : Const -> Val
| VInx : Dir -> (Val * Lab) -> Val
| VClos : list (Var * (Val * Lab)) -> Var -> Tm -> Val.

Set Elimination Schemes.

Fixpoint fv_val (v : Val) : list Var :=
  match v with
  | VConst c => []
  | VInx _ (v,_) => fv_val v
  | VClos rho x t => remove eq_var_dec x (fv_tm t)
    (* TODO: Don't I also have to remove dom rho? *)
  end.

Definition tag_of (v : Val) : Tag :=
  match v with
  | VConst c => tag_of_const c
  | VInx _ _ => TagSum
  | VClos _ _ _ => TagFun
  end.

(** ** Atoms and Environments *)

Definition Atom := prod Val Lab.
Definition Env := list (Var * Atom).

Definition atom_lab: Atom -> Lab := @snd Val Lab.
Definition atom_val: Atom -> Val := @fst Val Lab.

Definition fv_atom (a : Atom) : list Var := fv_val (fst a).

(** We produce an induction principle, that Coq cannot define by itself. *)
(* We start with an induction principle in Type,
   but we later specialize it to Prop and Set *)
Section atom_val_env_rect.
  Variable Pval : Val -> Type.
  Variable Patom : Atom -> Type.
  Variable Penv : Env -> Type.
  Hypothesis H_v_const : forall c, Pval (VConst c).
  Hypothesis H_v_inx : forall d a,
    Patom a -> Pval (VInx d a).
  Hypothesis H_v_clos : forall r x t,
    Penv r -> Pval (VClos r x t).
  Hypothesis H_atom : forall u l,
    Pval u -> Patom (u, l).
  Hypothesis H_nil : Penv nil.
  Hypothesis H_cons : forall x a r,
    Patom a -> Penv r -> Penv ((x,a) :: r).

  Fixpoint val_rect (v : Val) {struct v} : Pval v :=
    match v as v0 return Pval v0 with
      | VConst c => H_v_const c
      | VInx d (v,l) => H_v_inx d (v,l) (H_atom v l (val_rect v))
      | VClos r x t => H_v_clos r x t
        ((fix env_rect' (r : Env) {struct r} : Penv r :=
          match r as r0 return Penv r0 with
            | nil => H_nil
            | (x,a)::r' => H_cons x a r'
              ((fix atom_rect' (a : Atom) {struct a} : Patom a :=
                match a as a0 return Patom a0 with
                  | (v, l) => H_atom v l (val_rect v)
                end
              ) a) (env_rect' r')
          end
        ) r)
    end.

(* once we have val_rect, we can easily obtain the two nested ones *)

  Definition atom_rect (a : Atom) : Patom a :=
    match a with
      | (v,l) => H_atom v l (val_rect v)
    end.

  Fixpoint env_rect (r : Env) {struct r} : Penv r :=
    match r as r0 return Penv r0 with
      | nil => H_nil
      | (x,a)::r' => H_cons x a r'
        (atom_rect a) (env_rect r')
    end.

End atom_val_env_rect.

Definition val_ind
         (Pval: Val->Prop) (Patom: Atom->Prop) (Penv: Env->Prop) :=
  val_rect Pval Patom Penv.

Definition atom_ind
         (Pval: Val->Prop) (Patom: Atom->Prop) (Penv: Env->Prop) :=
  atom_rect Pval Patom Penv.

Definition env_ind
          (Pval: Val->Prop) (Patom: Atom->Prop) (Penv: Env->Prop) :=
  env_rect Pval Patom Penv.

Combined Scheme val_atom_env_mutind from val_ind, atom_ind, env_ind.

Tactic Notation "val_atom_env_mutind_cases" tactic(first) ident(c) :=
  first; [
    Case_aux c "lab" |
    Case_aux c "clos" |
    Case_aux c "val" |
    Case_aux c "nil" |
    Case_aux c "cons"
  ].
(** End of the (uninteresting) definition of the induction principle. *)

(** * Derived forms (values) *)

(** ** Constant values *)

Definition vUnit := VConst CUnit.
Definition vLab l := VConst (CLab l).
Definition vTag T := VConst (CTag T).
Definition vExcp e := VConst (CExcp e).

(** ** Sums *)

Definition vInl : Atom -> Val := VInx DLeft.
Definition vInr : Atom -> Val := VInx DRight.

(** ** Booleans *)

Definition vTrue : Val := vInl (vUnit, bot).
Definition vFalse : Val := vInr (vUnit, bot).


(***************************************************************************
* Tactics to Automate Reasoning about Freshness                            *
* Brian Aydemir & Arthur Charguéraud, July 2007, Coq v8.1                  *
***************************************************************************)

Set Implicit Arguments.
Require Import Lib_Tactic List Metatheory_Var.

Ltac fresh_simpl_to_notin_in_context :=
  repeat (match goal with H: fresh _ _ _ |- _ =>
    progress (simpl in H; destructs H) end).

(* ********************************************************************** *)
(** ** Tactics for notin *)

(** For efficiency, we avoid rewrites by splitting equivalence. *)

Lemma notin_singleton_r : forall x y,
  x \notin {{y}} -> x <> y.
intros. rewrite* <- notin_singleton.
Qed.

Lemma notin_singleton_l : forall x y,
  x <> y -> x \notin {{y}}.
intros. rewrite* notin_singleton.
Qed.

Lemma notin_singleton_swap : forall x y,
  x \notin {{y}} -> y \notin {{x}}.
intros. apply notin_singleton_l.
apply sym_not_eq. apply* notin_singleton_r.
Qed.

Lemma notin_union_r : forall x E F,
  x \notin (E \u F) -> (x \notin E) /\ (x \notin F).
intros. rewrite* <- notin_union.
Qed.

Lemma notin_union_l : forall x E F,
  x \notin E -> x \notin F -> x \notin (E \u F).
intros. rewrite* notin_union.
Qed.

(** Tactics to deal with notin. It interacts with union
    singleton and empty, but not inclusion. *)

Ltac notin_solve_from x E H :=
  match type of H with x \notin ?L =>
    match L with context[E] =>
      match L with
      | E => exact H
      | ?F \u ?G =>
        let P := constr:(@notin_union_r x F G H) in
        let PF := eval simpl in (proj1 P) in
        let PG := eval simpl in (proj2 P) in
        solve [ notin_solve_from x E PF
              | notin_solve_from x E PG ]
      end
    end
  end.

Ltac notin_solve_from_context x E :=
  match goal with H: x \notin _ |- _ =>
    notin_solve_from x E H end.

Ltac notin_solve_one :=
  match goal with
  | |- _ \notin {} =>
    apply notin_empty
  | |- ?x \notin {{?y}} => (* by x <> y or y <> x *)
    apply notin_singleton_l; solve
    [ assumption | apply sym_not_eq; assumption ]
  | |- ?x \notin {{?y}} => (* by y \notin {{x}} *)
    apply notin_singleton_swap; notin_solve_from_context y ({{x}})
  | |- ?x \notin ?E  =>    (* default search *)
    notin_solve_from_context x E
  end.

Ltac notin_simpl :=
  try match goal with |- _ \notin (_ \u _) =>
    apply notin_union_l; notin_simpl end.

Ltac notin_simpl_hyps := (* forward-chaining *)
  try match goal with
  | H: _ \notin {} |- _ =>
     clear H; notin_simpl_hyps
  | H: ?x \notin {{?y}} |- _ =>
     puts (@notin_singleton_r x y H);
     clear H; notin_simpl_hyps
   | H: ?x \notin (?E \u ?F) |- _ =>
     let H1 := fresh "Fr" in let H2 := fresh "Fr" in
     destruct (@notin_union_r x E F H) as [H1 H2];
     clear H; notin_simpl_hyps
  end.

Ltac notin_simpls :=
  notin_simpl_hyps; notin_simpl.

Ltac notin_solve :=
  fresh_simpl_to_notin_in_context;
  notin_simpl; notin_solve_one.

Ltac notin_contradiction :=
  match goal with H: ?x \notin ?E |- _ =>
    match E with context[x] =>
      let K := fresh in assert (K : x \notin {{x}});
        [ notin_solve_one
        | contradictions; apply (notin_same K) ]
    end
  end.

Ltac notin_neq_solve :=
  apply notin_singleton_r; notin_solve.

(* ********************************************************************** *)
(** Demo for notin *)

Lemma test_notin_solve_1 : forall x E F G,
  x \notin E \u F -> x \notin G -> x \notin (E \u G).
intros. notin_solve.
Qed.

Lemma test_notin_solve_2 : forall x y E F G,
  x \notin E \u {{y}} \u F -> x \notin G ->
  x \notin {{y}} /\ y \notin {{x}}.
intros. split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_3 : forall x y,
  x <> y -> x \notin {{y}} /\ y \notin {{x}}.
intros. split. notin_solve. notin_solve.
Qed.

Lemma test_notin_contradiction : forall x y E F G,
  x \notin (E \u {{x}} \u F) -> y \notin G.
intros. notin_contradiction.
Qed.

Lemma test_neq_solve : forall x y E F,
  x \notin (E \u {{y}} \u F) -> y \notin E ->
  y <> x /\ x <> y.
intros. split. notin_neq_solve. notin_neq_solve.
Qed.

(***************************************************************************)
(** Automation: hints to solve "notin" subgoals automatically. *)

Hint Extern 1 (_ \notin _) => notin_solve.

Hint Extern 1 (_ \in _ -> False) =>
  repeat match goal with
  | H: context [?x \in ?E -> False] |- _ =>
    fold (not (x \in E)) in H
  | |- context [?x \in ?E -> False] =>
    fold (not (x \in E)) end.

Hint Extern 1 (_ <> _ :> var) => notin_neq_solve.
Hint Extern 1 (_ <> _ :> S.elt) => notin_neq_solve.

(* ********************************************************************** *)
(** ** Tactics for fresh *)

Hint Extern 1 (fresh _ _ _) => simpl.

Lemma fresh_union_r : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs /\ fresh L2 n xs.
Proof.
  induction xs; simpl; intros; destruct n;
  try solve [ contradictions* ]. auto.
  destruct H. splits~.
  forward* (@IHxs (L1 \u {{a}}) L2 n).
   rewrite union_comm.
   rewrite union_comm_assoc.
   rewrite* union_assoc.
  forward* (@IHxs L1 (L2 \u {{a}}) n).
   rewrite* union_assoc.
Qed.

Lemma fresh_union_l : forall xs L1 L2 n,
  fresh L1 n xs -> fresh L2 n xs -> fresh (L1 \u L2) n xs.
Proof.
  induction xs; simpl; intros; destruct n;
  try solve [ contradictions* ]. auto.
  destruct H. destruct H0. split~.
  forward~ (@IHxs (L1 \u {{a}}) (L2 \u {{a}}) n).
  intros K.
  rewrite <- (union_same {{a}}).
  rewrite union_assoc.
  rewrite <- (@union_assoc L1).
  rewrite (@union_comm L2).
  rewrite (@union_assoc L1).
  rewrite* <- union_assoc.
Qed.

Lemma fresh_empty : forall L n xs,
  fresh L n xs -> fresh {} n xs.
Proof.
  intros. rewrite <- (@union_empty_r L) in H.
  destruct* (fresh_union_r _ _ _ _ H).
Qed.

Lemma fresh_length : forall xs L n,
  fresh L n xs -> n = length xs.
Proof.
  induction xs; simpl; intros L n Fr; destruct n;
   try solve [contradictions*]. auto.
  rewrite* <- (@IHxs (L \u {{a}}) n).
Qed.

Lemma fresh_resize : forall n xs L,
  fresh L n xs -> fresh L (length xs) xs.
Proof.
  introv Fr. rewrite* <- (fresh_length _ _ _ Fr).
Qed.

Ltac fresh_solve_from xs n E H :=
  match type of H with fresh ?L _ _ =>
    match L with context[E] =>
      match L with
      | E => exact H
      | ?F \u ?G =>
        let P := constr:(@fresh_union_r xs F G n H) in
        let PF := eval simpl in (proj1 P) in
        let PG := eval simpl in (proj2 P) in
        solve [ fresh_solve_from xs n E PF
              | fresh_solve_from xs n E PG ]
      end
    end
  end.

Ltac fresh_solve_from_context xs n E :=
  match goal with H: fresh _ n xs |- _ =>
    fresh_solve_from xs n E H end.

Ltac fresh_solve_one :=
  match goal with
  | |- fresh {} ?n ?xs =>
    match goal with H: fresh ?L n xs |- _ =>
      apply (@fresh_empty L n xs H) end
  | |- fresh ?E ?n ?xs =>
    fresh_solve_from_context xs n E
  | |- fresh _ (length ?xs) ?xs =>
    match goal with H: fresh _ ?n xs |- _ =>
      progress (apply (@fresh_resize n)); fresh_solve_one end
  end.

Ltac fresh_simpl :=
  try match goal with |- fresh (_ \u _) _ _ =>
    apply fresh_union_l; fresh_simpl end.

Ltac fresh_simpl_to_notin_in_goal :=
  simpl; splits.

Ltac fresh_simpl_to_notin_solve :=
  fresh_simpl_to_notin_in_context;
  fresh_simpl_to_notin_in_goal;
  notin_solve.

Ltac fresh_solve :=
  try fresh_simpl;
  (fresh_solve_one || fresh_simpl_to_notin_solve).

(* ********************************************************************** *)
(** Demo for notin *)

Lemma test_fresh_solve_1 : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs.
Proof.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_2 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh L2 n xs.
Proof.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_3 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh {} n xs.
Proof.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_4 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh L1 (length xs) xs.
Proof.
  intros. fresh_solve.
Qed.

(***************************************************************************)
(** Automation: hints to solve "fresh" subgoals automatically. *)

Hint Extern 1 (fresh _ _ _) => fresh_solve.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Disjoint_Union.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** Author: Cristina Cornes
    From : Constructing Recursion Operators in Type Theory
           L. Paulson  JSC (1986) 2, 325-355 *)

Require Import Relation_Operators.

Section Wf_Disjoint_Union.
  Variables A B : Type.
  Variable leA : A -> A -> Prop.
  Variable leB : B -> B -> Prop.

  Notation Le_AsB := (le_AsB A B leA leB).

  Lemma acc_A_sum : forall x:A, Acc leA x -> Acc Le_AsB (inl B x).
  Proof.
    induction 1.
    apply Acc_intro; intros y H2.
    inversion_clear H2.
    auto with sets.
  Qed.

  Lemma acc_B_sum :
    well_founded leA -> forall x:B, Acc leB x -> Acc Le_AsB (inr A x).
  Proof.
    induction 2.
    apply Acc_intro; intros y H3.
    inversion_clear H3; auto with sets.
    apply acc_A_sum; auto with sets.
  Qed.

  Lemma wf_disjoint_sum :
    well_founded leA -> well_founded leB -> well_founded Le_AsB.
  Proof.
    intros.
    unfold well_founded in |- *.
    destruct a as [a| b].
    apply (acc_A_sum a).
    apply (H a).

    apply (acc_B_sum H b).
    apply (H0 b).
  Qed.

End Wf_Disjoint_Union.


(* Check compilation of multiple pattern-matching on terms non
   apparently of inductive type *)

(* Check that the non dependency in y is OK both in V7 and V8 *)
Check
  (fun x (y : Prop) z =>
   match x, y, z return (x = x \/ z = z) with
   | O, y, z' => or_introl (z' = z') (refl_equal 0)
   | _, y, O => or_intror _ (refl_equal 0)
   | x, y, _ => or_introl _ (refl_equal x)
   end).

(* Suggested by Pierre Letouzey (PR#207) *)
Inductive Boite : Set :=
    boite : forall b : bool, (if b then nat else (nat * nat)%type) -> Boite.

Definition test (B : Boite) :=
  match B return nat with
  | boite true n => n
  | boite false (n, m) => n + m
  end.

(* Check lazyness of compilation ... future work
Inductive I : Set := c : (b:bool)(if b then bool else nat)->I.

Check [x]
  Cases x of
    (c (true as y) (true as x)) => (if x then y else true)
  | (c false O) => true | _ => false
  end.

Check [x]
  Cases x of
    (c true true) => true
  | (c false O) => true
  | _ => false
  end.

(* Devrait produire ceci mais trouver le type intermediaire est coton ! *)
Check
  [x:I]
   Cases x of
     (c b y) =>
      (<[b:bool](if b then bool else nat)->bool>if b
       then [y](if y then true else false)
       else [y]Cases y of
              O => true
            | (S _) => false
            end y)
   end.
*)


(**

 Ahrens, Lumsdaine, Voevodsky, 2015

 Contents:

  - Definition of a Comprehension precategory from a precategory with Display maps

*)

Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.TypeCat.TypeCat.
Require Import TypeTheory.OtherDefs.DM.
Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.Pullbacks.

(** * Construction of Comprehension precategory from Display map precategory *)

Section DM_to_TypeCat.

Variable CC : category.
Variable C : DM_structure CC.

Definition type_cat_structure1_from_DM : typecat_structure1 CC.
Proof.
  unfold typecat_structure1.
  exists (DM_over C).
(*  exists (fun X => ∑ (Yf : ∑ Y, X --> Y), DM_type C (pr2 Yf)). *)
  refine (tpair _ _ _ ).
  - intros Γ H. exact (ob_from_DM_over H).
  - intros Γ Δ'γH Γ' f.
    simpl in *.
    unshelve refine (tpair _ _ _ ).
    + exists ( (DM_from_DM_over Δ'γH) ⋆ f).
      apply pb_mor_of_DM.
    + simpl.
      refine (pr2 (pb_DM_of_DM _ _ )).
Defined.

Definition type_cat_structure2_from_DM : typecat_structure2 type_cat_structure1_from_DM.
Proof.
  unfold typecat_structure2.
  unshelve refine (tpair _ _ _ ).
  - intros Γ A; simpl.
    unfold ext_typecat. simpl.
    unfold type_cat_structure1_from_DM in A. simpl in *.
    apply (pr2 (pr1 A)).
  - simpl.
    unshelve refine (tpair _ _ _ ).
    + intros Γ A Δ f.
      unfold ext_typecat; simpl.
      apply pb_arrow_of_arrow.
    + {
        unshelve refine (tpair _ _ _ ).
        - intros Γ A Γ' f.
          unshelve refine (sqr_comm_of_DM (( DM_from_DM_over A)) _ ).
        - intros.
          apply @is_symmetric_isPullback.
          refine (@isPullback_of_DM  _ _ _ _ _ _ _ ).
      }
Defined.

Definition type_cat_struct_from_DM : typecat_structure CC.
Proof.
  exists type_cat_structure1_from_DM.
  exact type_cat_structure2_from_DM.
Defined.

Lemma is_type_saturated_type_cat_from_DM : is_type_saturated_typecat type_cat_struct_from_DM.
Proof.
  unfold is_type_saturated_typecat.
  intro Γ. unfold type_cat_struct_from_DM.
  simpl.
  unfold ext_typecat. simpl.
  unfold dpr_typecat. simpl.
  assert (
      (λ A : DM_over C Γ,
      tpair (λ X : CC, X --> Γ) (ob_from_DM_over A) (pr2 (pr1 A)))
      = pr1).
  { apply funextfun.
    intro x.
    destruct x as [t p]. simpl.
    destruct t; apply idpath.
  }
  rewrite X.
  apply isinclpr1.
  intros. apply (pr2 (pr2 C)).
Qed.

(* this seems to require (at least!) that the objects of the underlying category form a set *)
(*
Lemma is_split_type_cat_from_DM : is_split_type_cat type_cat_struct_from_DM.
Proof.
  repeat split.
  - admit. (* this is probably false when objects don't form a set *)
  - simpl.
    refine (tpair _ _ _ ).
    + unfold reind_type_cat; simpl.
*)

End DM_to_TypeCat.