Require Import DataTypes List Tree Coq.Relations.Relation_Operators Omega BaseTree.

Module mkHierProperties (dt: DataTypes).
  Import dt.

  Theorem hasFork:
    forall {c1 c2},
      defined c1 -> defined c2 ->
      ~ descendent c1 c2 -> ~ descendent c2 c1 ->
      exists fork, defined fork /\
                           (exists d1, defined d1 /\ parent d1 fork /\ descendent c1 d1 /\ ~ descendent c2 d1) /\
                           (exists d2, defined d2 /\ parent d2 fork /\ ~ descendent c1 d2 /\ descendent c2 d2).
  Proof.
    unfold defined.
    pose proof @hasFork'.
    intros c1 c2 p1 p2 x1 x2.
    specialize (H c1 c2 x1 x2 hier p1 p2).
    firstorder.
  Qed.

  Theorem hierHasNoParent:
    forall {p}, defined p -> parent hier p -> False.
  Proof.
    intros p defP hier_p.
    pose proof (treeName2 defP) as prop.
    unfold treeNthName in prop.
    unfold parent in hier_p.
    destruct p.
    clear defP.
    assert (prop2: forall n, n < length l0 ->
                             match nth n l0 (C nil nil) with
                               | C x _ => x <> nil
                             end).
    intros n cond; specialize (prop n cond); destruct (nth n l0 (C nil nil)).
    unfold not; intros rew.
    rewrite rew in prop; discriminate.
    clear prop.
    induction l0.
    unfold In in hier_p.
    assumption.
    unfold In in hier_p.
    destruct hier_p as [a_eq_hier | hard].
    rewrite a_eq_hier in *.

    assert (z_lt_S: 0 < length (hier :: l0)) by (unfold length; omega).
    specialize (prop2 0 z_lt_S).
    unfold nth in prop2.
    pose proof (treeName1) as tn1.
    destruct hier.
    firstorder.
    specialize (IHl0 hard).
    assert (forall n, n < length l0 -> match nth n l0 (C nil nil) with
                                         | C x _ => x <> nil
                                       end).
    intros n n_lt_l0.
    specialize (prop2 (S n)).
    assert (S_n_lt_al0: S n < length (a :: l0)).
    unfold length. unfold length in n_lt_l0.
    omega.
    assert (nthEq: nth n l0 (C nil nil) = nth (S n) (a::l0) (C nil nil)).
    unfold nth.
    reflexivity.
    rewrite <- nthEq in prop2.
    firstorder.
    firstorder.
  Qed.
End mkHierProperties.


Require Export Coq.MSets.MSetInterface.
From Coq Require Import OrderedType.
Require Export MSetGenTree.
Require Export RBT.
Require Export Programs.
Require Export Definitions.
Require Export Properties.

Require Import Coq.Logic.Eqdep_dec Coq.Arith.Compare_dec Coq.Arith.PeanoNat.

Definition bcompetitive (b b':order):= (Nat.lt (oprice b') (oprice b)) \/
((Nat.eq (oprice b') (oprice b)) /\ (Nat.le (otime b) (otime b') )).

Definition acompetitive (a a':order):= (Nat.lt (oprice a) (oprice a')) \/
((Nat.eq (oprice a) (oprice a')) /\ (Nat.le (otime a) (otime a') )).

Definition eqcompetitive (a a':order):= ((Nat.eqb (oprice a) (oprice a')) /\ (Nat.eqb (otime a) (otime a') )).

Module OrderedA <: Orders.OrderedType.

Definition t := order.
Definition eq (x y: t) := eqcompetitive x y.

Definition lt (x y: t):= acompetitive y x/\~eqcompetitive x y.

 Lemma eq_refl : forall x : t, eq x x.
Proof. intros. unfold eq. unfold eqcompetitive. auto. Defined.

 Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof. unfold eq. unfold eqcompetitive. intros. destruct H.
move /eqP in H.  move /eqP in H0. split. auto. auto.
Defined.

 Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof. unfold eq. unfold eqcompetitive. intros.
destruct H. move /eqP in H.  move /eqP in H1.
destruct H0. move /eqP in H0.  move /eqP in H2.
split. apply /eqP. lia. apply /eqP. lia. Defined.

Definition eq_equiv: Equivalence eq.
Proof. intros. constructor. unfold Reflexive. apply eq_refl.
unfold Symmetric. apply eq_sym. unfold Transitive.
apply eq_trans.
Defined.

 Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
 unfold lt. unfold eq. intros. destruct H. auto. Qed.

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.  { unfold lt. unfold acompetitive. unfold eqcompetitive.
            intros.  destruct H0 as [H0 Hn1].
            destruct H as [H Hn2]. split.
         { destruct H0;destruct H.
            { left.   lia.  }
            { destruct H. left. lia. }
            { destruct H0. left. lia. }
            { destruct H0;destruct H. lia. }
          }
          { intro. destruct H1.
             move /eqP in H1.
             move /eqP in H2.
             rewrite H1 in H. rewrite H1 in Hn2.
             rewrite H2 in H. rewrite H2 in Hn2.
             destruct H0;destruct H.
             { lia. }
             { destruct H. lia. }
             { destruct H0. lia. }
             { destruct H;destruct H0. destruct Hn1.
                split. apply /eqP. lia. apply /eqP. lia. }
          } } Defined.

Definition lt_strorder: StrictOrder lt.
Proof. constructor. unfold Irreflexive. unfold Reflexive. unfold complement.
intros. apply lt_not_eq in H. destruct H. apply eq_refl.
unfold Transitive. apply lt_trans. Defined.

Definition lt_compat: Proper (eq ==> eq ==> iff) lt.
Proof. unfold Proper. intro. intros. intro. intros. unfold eq in H.
unfold eq in H0. unfold eqcompetitive in H.
unfold eqcompetitive in H0. unfold lt.
unfold acompetitive. unfold eqcompetitive.
destruct H;destruct H0. move /eqP in H.
move /eqP in H0. move /eqP in H1.
move /eqP in H2. rewrite H.
rewrite H0. rewrite H1. rewrite H2. split.
auto. auto. Defined.

 Definition compare (x y:t):= if (Nat.eqb (oprice x) (oprice y) &&(Nat.eqb (otime x) (otime y))) then Eq else (if (Nat.ltb (oprice y) (oprice x) || Nat.eqb (oprice x) (oprice y)&&(Nat.ltb (otime y) (otime x))) then Lt else Gt).

Definition compare_spec :
     forall x y : t,
     CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
 Proof. intros. unfold eq. unfold lt. unfold compare.
          unfold eqcompetitive. unfold acompetitive.
     unfold Nat.lt. unfold Nat.eq. unfold Nat.le.
     destruct ((oprice x =? oprice y) && (otime x =? otime y)) eqn:Heq.
     { constructor. move /andP in Heq. auto. }
     { destruct ((oprice y <? oprice x) ||
        (oprice x =? oprice y) && (otime y <? otime x)) eqn:Hlt.
        constructor. split. move /orP in Hlt. destruct Hlt.
        left. move /ltP in H. auto. right. move /andP in H.
        destruct H. split. move /eqP in H;lia. move /ltP in H0;lia.
        intro. move /andP in H.  move /eqP in H. rewrite Heq in H.
        move /eqP in H. inversion H. constructor.
        apply nat_tr in Heq. case ((oprice y <? oprice x)) eqn:Hp.
        simpl in Hlt. inversion Hlt. simpl in Hlt.
        case (oprice x =? oprice y) eqn:Hp2.
        simpl in Hlt. destruct Heq. move /eqP in Hp2. lia.
        move /eqP in Hp2. split. right. split. auto. move /ltP in Hlt. lia.
        intro. destruct H0. move /eqP in H1. lia. split.
        left. move /eqP in Hp2. move /ltP in Hp. lia.
        intro. destruct H. move /eqP in H.  move /eqP in Hp2. lia.
      } Qed.

Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
intros. unfold eq. auto. destruct (eqP (oprice x) (oprice y));destruct (eqP (otime x) (otime y)).
{ left. unfold eqcompetitive.
split. auto. auto. }
{ right. unfold eqcompetitive. intro.
destruct H.  move /eqP in H0. auto. }
{ right. unfold eqcompetitive. intro.
destruct H.  move /eqP in H. auto. }
{ right. unfold eqcompetitive. intro.
destruct H.  move /eqP in H0. auto. } Qed.

End OrderedA.

Module Ordered_id <: Orders.OrderedType.

Definition t := order.

Definition eq (x y: t) := Nat.eq (id x) (id y).

Definition lt (x y: t):= Nat.lt (id x) (id y).

 Lemma eq_refl : forall x : t, eq x x.
 intros. unfold eq. unfold Nat.eq. auto. Qed.

 Lemma eq_sym : forall x y : t, eq x y -> eq y x.
unfold eq. intros. unfold Nat.eq. auto.
Qed.

 Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
 unfold eq. unfold Nat.eq. intros. lia. Qed.

Definition eq_equiv: Equivalence eq.
Proof. intros. constructor. unfold Reflexive. apply eq_refl.
unfold Symmetric. apply eq_sym. unfold Transitive.
apply eq_trans.
Defined.

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.  { unfold lt. unfold Nat.lt. intros. lia. } Qed.

 Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
 unfold lt. unfold eq. unfold Nat.lt. unfold Nat.eq. intros. lia. Qed.

Definition lt_strorder: StrictOrder lt.
Proof. constructor. unfold Irreflexive. unfold Reflexive. unfold complement.
intros. apply lt_not_eq in H. destruct H. apply eq_refl.
unfold Transitive. apply lt_trans. Defined.

Definition lt_compat: Proper (eq ==> eq ==> iff) lt.
Proof. unfold Proper. intro. intros. intro. intros. unfold eq in H.
unfold eq in H0. unfold Nat.eq in H.
unfold Nat.eq in H0. unfold lt.
unfold Nat.lt. lia. Defined.

 Definition compare (x y:t):= if (Nat.eqb (id x) (id y)) then Eq else
  (if (Nat.ltb (id x) (id y)) then Lt else Gt).

Definition compare_spec :
     forall x y : t,
     CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
     intros. unfold eq. unfold lt. unfold compare.
     unfold Nat.lt. unfold Nat.eq. destruct (id x =? id y) eqn:H.
     move /eqP in H. auto. move /eqP in H.
     case (id x <? id y) eqn:H1. move /ltP in H1. auto.
     move /ltP in H1.  case ((id y <? id x)) eqn:H2.
     move /ltP in H2. auto. move /ltP in H2. lia. Defined.

 Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
 intros. unfold eq. unfold Nat.eq. apply Nat.eq_dec. Qed.

End Ordered_id.

Module OrderedB <: Orders.OrderedType.

Definition t := order.
Definition eq (x y: t) :=  eqcompetitive x y.

Definition lt (x y: t):= bcompetitive y x/\~eqcompetitive x y.

 Lemma eq_refl : forall x : t, eq x x.
Proof. intros. unfold eq. unfold eqcompetitive. auto. Defined.

 Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof. unfold eq. unfold eqcompetitive. intros. destruct H.
move /eqP in H.  move /eqP in H0. split. auto. auto.
Defined.

 Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof. unfold eq. unfold eqcompetitive. intros.
destruct H. move /eqP in H.  move /eqP in H1.
destruct H0. move /eqP in H0.  move /eqP in H2.
split. apply /eqP. lia. apply /eqP. lia. Defined.

Definition eq_equiv: Equivalence eq.
Proof. intros. constructor. unfold Reflexive. apply eq_refl.
unfold Symmetric. apply eq_sym. unfold Transitive.
apply eq_trans.
Defined.

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.  { unfold lt. unfold bcompetitive. unfold eqcompetitive.
            intros.  destruct H0 as [H0 Hn1].
            destruct H as [H Hn2]. split.
         { destruct H0;destruct H.
            { left.   lia.  }
            { destruct H. left. lia. }
            { destruct H0. left. lia. }
            { destruct H0;destruct H. lia. }
          }
          { intro. destruct H1.
             move /eqP in H1.
             move /eqP in H2.
             rewrite H1 in H. rewrite H1 in Hn2.
             rewrite H2 in H. rewrite H2 in Hn2.
             destruct H0;destruct H.
             { lia. }
             { destruct H. lia. }
             { destruct H0. lia. }
             { destruct H;destruct H0. destruct Hn1.
                split. apply /eqP. lia. apply /eqP. lia. }
          } } Qed.

 Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
 Proof. unfold lt. intros x y H. destruct H. unfold eq. auto. Qed.

Definition lt_strorder: StrictOrder lt.
Proof. constructor. unfold Irreflexive. unfold Reflexive. unfold complement.
intros x H. apply lt_not_eq in H. destruct H. apply eq_refl.
unfold Transitive. apply lt_trans. Qed.

Definition lt_compat: Proper (eq ==> eq ==> iff) lt.
Proof. unfold Proper. intro. intros. intro. intros. unfold eq in H.
unfold eq in H0. unfold eqcompetitive in H.
unfold eqcompetitive in H0. unfold lt.
unfold bcompetitive. unfold eqcompetitive.
destruct H;destruct H0. move /eqP in H.
move /eqP in H0. move /eqP in H1.
move /eqP in H2. rewrite H.
rewrite H0. rewrite H1. rewrite H2. split.
auto. auto. Defined.

 Definition compare (x y:t):= if (Nat.eqb (oprice x) (oprice y) &&(Nat.eqb (otime x) (otime y))) then Eq else (if (Nat.ltb (oprice x) (oprice y) || Nat.eqb (oprice x) (oprice y)&&(Nat.ltb (otime y) (otime x))) then Lt else Gt).

Definition compare_spec :
     forall x y : t,
     CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
 Proof. intros. unfold eq. unfold lt. unfold compare.
          unfold eqcompetitive. unfold bcompetitive.
     unfold Nat.lt. unfold Nat.eq. unfold Nat.le.
     destruct ((oprice x =? oprice y) && (otime x =? otime y)) eqn:Heq.
     { constructor. move /andP in Heq. auto. }
     { destruct ((oprice x <? oprice y) ||
        (oprice x =? oprice y) && (otime y <? otime x)) eqn:Hlt.
        constructor. split. move /orP in Hlt. destruct Hlt.
        left. move /ltP in H. auto. right. move /andP in H.
        destruct H. split. move /eqP in H;lia. move /leP in H0. move /eqP in H. lia.
        intro. move /andP in H.  move /eqP in H. rewrite Heq in H.
        move /eqP in H. inversion H. constructor.
        apply nat_tr in Heq. case ((oprice x <? oprice y)) eqn:Hp.
        simpl in Hlt. inversion Hlt. simpl in Hlt.
        case (oprice x =? oprice y) eqn:Hp2.
        simpl in Hlt. destruct Heq. move /eqP in Hp2. lia.
        move /eqP in Hp2. split. right. split. auto. move /ltP in Hlt. lia.
        intro. destruct H0. move /eqP in H1. lia. split.
        left. move /eqP in Hp2. move /ltP in Hp. lia.
        intro. destruct H. move /eqP in H.  move /eqP in Hp2. lia.
      } Qed.

Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
intros. unfold eq. auto. destruct (eqP (oprice x) (oprice y));destruct (eqP (otime x) (otime y)).
{ left. unfold eqcompetitive.
split. auto. auto. }
{ right. unfold eqcompetitive. intro.
destruct H.  move /eqP in H0. auto. }
{ right. unfold eqcompetitive. intro.
destruct H.  move /eqP in H. auto. }
{ right. unfold eqcompetitive. intro.
destruct H.  move /eqP in H0. auto. } Qed.

End OrderedB.


From mathcomp Require Import all_ssreflect.
Require Import all_rs_base.
Require Import FunctionalExtensionality ClassicalChoice.

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

Section USIGPROD.
Definition rep_usig_prod (X: rep_space) phi (xn: nat -> X):=
	forall n, (fun p => (phi (n,p))) \is_name_of (xn n).

Lemma rep_usig_prod_is_rep (X: rep_space):
	(@rep_usig_prod X) \is_representation.
Proof.
split => [ phi xn yn phinxn phinyn | xn ].
	apply functional_extensionality => n.
	by apply/ (rep_sing X); [apply phinxn | apply phinyn ].
pose R n phi:= phi \is_name_of (xn n).
have Rtot: R \is_total.
	by move => n; have [phi phinx]:= (rep_sur X (xn n)); exists phi.
by have [phi phinxn]:= choice R Rtot; exists (fun p => phi p.1 p.2).
Qed.

Canonical rep_space_usig_prod (X: rep_space) := @make_rep_space
	(nat -> space X)
	(nat * questions X)
	(answers X)
	(@rep_usig_prod X)
	((0%nat, some_question X))
	(some_answer X)
  (prod_count nat_count (countable_questions X))
  (countable_answers X)
  (@rep_usig_prod_is_rep X).

Lemma usig_base X (an: nat -> space X) phi:
	phi \is_name_of an -> forall n, (fun q => phi (n,q)) \is_name_of (an n).
Proof. done. Qed.

Definition ptw (X: rep_space) (op: X * X -> X) (fg: (nat -> X) * (nat -> X)) :=
	(fun n => op (fg.1 n, fg.2 n)).

Lemma ptw_rec X (op: rep_space_prod X X -> X):
	op \is_recursive_function -> (ptw op) \is_recursive_function.
Proof.
move => [Mop Mprop].
exists (fun (phi: names (rep_space_prod (rep_space_usig_prod X)(rep_space_usig_prod X))) q =>
	Mop (name_pair (fun q' => lprj phi (q.1, q')) (fun q' => rprj phi (q.1, q'))) q.2).
abstract by move => phi [an bn] [/=phinan phinbn] n/=; rewrite /ptw/=;
	apply ((Mprop (name_pair (fun q' => lprj phi (n, q')) (fun q' => rprj phi (n, q')))) (an n, bn n));
	split; rewrite rprj_pair lprj_pair/=; [apply phinan | apply phinbn].
Defined.

(*
Lemma wiso_usig X:
	wisomorphic (rep_space_usig_prod X) (rep_space_cont_fun rep_space_nat X).
Proof.
have crlzr: forall xn: nat -> X, hcr (F2MF xn).
	move => xn.
	pose R phi psi := psi \is_name_of (xn (phi star)).
	have Rtot: R \is_total by move => phi; apply (rep_sur X).
	have [F icf]:= choice R Rtot.
	exists F; split.
		by apply rlzr_mfrlzr => phi x phinx; rewrite -phinx; apply/icf.
	move => phi q phifd; exists ([::star]) => Fphi /= FphiFphi psi coin.
	have eq: phi = psi.
		by apply functional_extensionality => /= str; elim: str; apply coin.
	by rewrite -eq => Fpsi FpsiFpsi; rewrite -FpsiFpsi -FphiFphi.
Admitted. *)
End USIGPROD.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Bishop.Exp.
Require Import Blech.Category.
Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Typ: Category := {|
  Obj := Type ;
  Mor A B := (A -> B) /~ {| equiv := eq |};

  id _ x := x ;
  compose _ _ _ f g x := f (g  x) ;
|}.


Fixpoint zero (n:nat) : nat :=
  match n with
  | S (S n') => two n'
  | S n' => one n'
  | O => 0
  end
with one (n:nat) : nat :=
  match n with
  | S (S n') => zero n'
  | S n' => two n'
  | O => 1
  end
with two (n:nat) : nat :=
  match n with
  | S (S n') => one n'
  | S n' => zero n'
  | O => 2
  end.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section TruthLemma.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}
        {GammaPD: ProvableDerivable L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {andpSC: AndSequentCalculus L GammaD}
        {orpSC: OrSequentCalculus L GammaD}
        {falsepSC: FalseSequentCalculus L GammaD}
        {inegpSC: IntuitionisticNegSequentCalculus L GammaD}
        {iffpSC: IffSequentCalculus L GammaD}
        {truepSC: TrueSequentCalculus L GammaD}
        {GammaDP: DerivableProvable L GammaP GammaD}
        {minAX: MinimumAxiomatization L GammaP}
        {andpAX: AndAxiomatization L GammaP}
        {orpAX: OrAxiomatization L GammaP}
        {falsepAX: FalseAxiomatization L GammaP}
        {inegpAX: IntuitionisticNegAxiomatization L GammaP}
        {iffpAX: IffAxiomatization L GammaP}
        {truepAX: TrueAxiomatization L GammaP}
        {sepconAX: SepconAxiomatization L GammaP}
        {wandAX: WandAxiomatization L GammaP}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {J: Join (Kworlds M)}
        {SM: Semantics L MD}
        {fsepconSM: SepconSemantics L MD M SM}
        {fwandSM: WandSemantics L MD M SM}.

Context (cP: context -> Prop)
        (rel: bijection (Kworlds M) (sig cP)).

Hypothesis H_R: forall m n Phi Psi, rel m Phi -> rel n Psi -> (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).

Hypothesis H_J: forall m1 m2 m Phi1 Phi2 Phi, rel m1 Phi1 -> rel m2 Phi2 -> rel m Phi -> (join m1 m2 m <-> Included _ (context_sepcon (proj1_sig Phi1) (proj1_sig Phi2)) (proj1_sig Phi)).

Lemma truth_lemma_sepcon
      (AL_DC: at_least derivable_closed cP)
      (LIN_SL: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_l Phi (proj1_sig Psi)) cP)
      (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP)
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x * y <-> proj1_sig Phi (x * y)).
Proof.
  intros.
  rewrite sat_sepcon.
  split; intros.
  + destruct H0 as [m1 [m2 [? [? ?]]]].
    destruct (im_bij _ _ rel m1) as [Phi1 ?].
    destruct (im_bij _ _ rel m2) as [Phi2 ?].
    erewrite IHx in H1 by eauto.
    erewrite IHy in H2 by eauto.
    erewrite H_J in H0 by eauto.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    apply derivable_assum.
    apply H0.
    exists x, y; split; [| split]; auto; apply derivable_assum; auto.
  + apply derivable_assum in H0.
    assert (Included _ (context_sepcon (Union _ empty_context (Singleton _ x))
             (Union _ empty_context (Singleton _ y))) (proj1_sig Phi)).
    {
      hnf; intros z ?.
      destruct H1 as [x0 [y0 [? [? ?]]]].
      rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
      rewrite deduction_theorem, <- provable_derivable in H2, H3.
      subst z; rewrite <- H2, <- H3.
      auto.
    }
    apply LIN_SL in H1.
    destruct H1 as [Phi1 [? ?]].
    apply LIN_SR in H2.
    destruct H2 as [Phi2 [? ?]].
    destruct (su_bij _ _ rel Phi1) as [m1 ?].
    destruct (su_bij _ _ rel Phi2) as [m2 ?].
    exists m1, m2.
    erewrite H_J, IHx, IHy by eauto.
    split; [| split]; auto.
    - apply H1; right; constructor.
    - apply H2; right; constructor.
Qed.

Lemma truth_lemma_wand
      (AL_DC: at_least derivable_closed cP)
      (LIN_CD: forall x, Lindenbaum_constructable (cannot_derive x) cP)
      (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP)
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x -* y <-> proj1_sig Phi (x -* y)).
Proof.
  intros.
  rewrite sat_wand.
  split; intros.
  + rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
    rewrite <- wand_deduction_theorem.
    apply NNPP; intro.
    apply LIN_CD in H1.
    destruct H1 as [Phi2 [? ?]].
    apply H2; clear H2.
    rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi2)); auto.
    apply LIN_SR in H1.
    destruct H1 as [Phi1 [? ?]].
    destruct (su_bij _ _ rel Phi1) as [m1 ?].
    destruct (su_bij _ _ rel Phi2) as [m2 ?].
    erewrite <- IHy by eauto.
    unfold context_sepcon_included_r in H2; erewrite <- H_J in H2 by eauto.
    apply (H0 _ _ H2).
    erewrite IHx by eauto.
    apply H1; right; constructor.
  + destruct (im_bij _ _ rel m1) as [Phi1 ?].
    destruct (im_bij _ _ rel m2) as [Phi2 ?].
    erewrite IHy by eauto.
    erewrite IHx in H2 by eauto.
    erewrite H_J in H1 by eauto.
    rewrite derivable_closed_element_derivable in H0 by (apply AL_DC, (proj2_sig Phi)).
    rewrite derivable_closed_element_derivable in H2 by (apply AL_DC, (proj2_sig Phi1)).
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi2)).
    rewrite <- provable_wand_sepcon_modus_ponens1 with (x0 := x).
    apply derivable_assum; apply H1.
    exists (x -* y), x; split; [| split]; auto.
Qed.

Context {empL: EmpLanguage L}
        {empAX: EmpAxiomatization L GammaP}
        {fempSM: EmpSemantics L MD M SM}.

Lemma truth_lemma_emp
      (AL_DC: at_least derivable_closed cP)
      (LIN_CD: forall x, Lindenbaum_constructable (cannot_derive x) cP)
      (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= emp <-> proj1_sig Phi emp).
Proof.
  intros.
  rewrite sat_emp.
  split; intros.
  + rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
    rewrite <- (provable_wand_sepcon_modus_ponens1 emp).
    rewrite sepcon_emp.
    apply wand_deduction_theorem.
    apply NNPP; intro.
    apply LIN_CD in H1.
    destruct H1 as [Phi2 [? ?]].
    apply H2; clear H2.
    rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi2)); auto.
    apply LIN_SR in H1.
    destruct H1 as [Phi1 [? ?]].
    destruct (su_bij _ _ rel Phi1) as [m1 ?].
    destruct (su_bij _ _ rel Phi2) as [m2 ?].
    unfold context_sepcon_included_r in H2; erewrite <- H_J in H2 by eauto.
    apply H0 in H2.
    erewrite H_R in H2 by eauto.
    apply H2, H1; right; constructor.
  + hnf; intros n1 n2 ?.
    destruct (im_bij _ _ rel n1) as [Phi1 ?].
    destruct (im_bij _ _ rel n2) as [Phi2 ?].
    erewrite H_R by eauto.
    erewrite H_J in H1 by eauto.
    intros x; unfold Ensembles.In; intros.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi2)); auto.
    rewrite derivable_closed_element_derivable in H4 by (apply AL_DC, (proj2_sig Phi1)); auto.
    rewrite derivable_closed_element_derivable in H0 by (apply AL_DC, (proj2_sig Phi)); auto.
    rewrite <- sepcon_emp, sepcon_comm.
    apply derivable_assum; apply H1.
    exists emp, x; split; [| split]; auto.
Qed.

End TruthLemma.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Require Export common.lhs_sha_sel_reduce.rhs_con_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_nil_reduce.

Require Export common.lhs_sha_sel_reduce.rhs_sel_low_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_sel_equ_reduce.

Require Export common.lhs_sha_sel_reduce.rhs_low_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_equ_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_upp_reduce.
Require Export common.lhs_sha_sel_reduce.rhs_nom_reduce.

Require Export common.lhs_sha_sel_reduce.rhs_other_reduce.

Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sha_sel_reduce :
  forall T1 x1 L1 ss1 T1', T1 = t_sha_sel x1 L1 ss1 T1' ->
                      forall T2, subtype T1 T2 = match T2 with
                                            | t_top => true
                                            | t_sel_low x2 L2 T2' => orb (subtype T1 T2')
                                                                        (subtype T1' T2)
                                            | t_sel_equ x2 L2 T2' => orb (subtype T1 T2')
                                                                        (subtype T1' T2)
                                            | t_upp _ _ => false
                                            | t_low _ _ => false
                                            | t_equ _ _ => false
                                            | t_nom _ _ _ => false
                                            | t_nil => false
                                            | t_con _ _ => false

                                            | _ => subtype T1' T2
                                            end.
Proof.
  intros; subst; destruct T2.

  apply subtype_top; crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  eapply subtype_sha_sel_sel_low_reduce; crush.

  eapply subtype_sha_sel_sel_equ_reduce; crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_other_reduce with (x:=x1)(L:=L1)(ss1:=ss1); crush.

  apply subtype_sha_sel_upp_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(L2:=l)(T2':=T2);
    crush.

  apply subtype_sha_sel_low_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(L2:=l)(T2':=T2);
    crush.

  apply subtype_sha_sel_equ_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(L2:=l)(T2':=T2);
    crush.

  apply subtype_sha_sel_nom_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(L2:=l)(t2:=t)(T2':=T2);
    crush.

  apply subtype_sha_sel_nil_reduce
    with
      (x1:=x1)(L1:=L1)
      (T1':=T1')(ss1:=ss1);
    crush.

  apply subtype_sha_sel_con_reduce
    with
      (x1:=x1)(L1:=L1)(ss1:=ss1)
      (T1':=T1')(T2':=T2_1)(Ts2:=T2_2);
    crush.
Qed.


Require Export SepTypes.OrderedType.
Require Export SepTypes.OFuns.

(***
 *** Ordered Type Contexts
 ***)

(* A context here is just a list of type expressions *)
Inductive Ctx : Type :=
| CNil
| CCons (ctx:Ctx) A {RA:OType A}
.

Notation "ctx :> A" := (CCons ctx A) (left associativity, at level 50).

(* An element of a context is a nested tuple of elements of its types *)
Fixpoint CtxElem (ctx:Ctx) : Type :=
  match ctx with
  | CNil => unit
  | ctx' :> A => CtxElem ctx' * A
  end.

(* OTRelation instance for any CtxElem type *)
Instance OType_CtxElem ctx : OType (CtxElem ctx).
Proof.
  induction ctx; typeclasses eauto.
Defined.

(* Typeclasses Transparent OType_CtxElem. *)

(*
Definition ctxHead ctx : Type :=
  match ctx with
  | CNil => unit
  | CCons _ A => A
  end.

Instance OType_ctxHead ctx : OType (ctxHead ctx) :=
  match ctx with
  | CNil => OTunit
  | @CCons _ _ RA => RA
  end.

Definition ctxTail ctx :=
  match ctx with
  | CNil => CNil
  | ctx' :> _ => ctx'
  end.
*)

(***
 *** Ordered Expressions and Variables
 ***)

(* An ordered expression in ctx is just a Proper function from ctx *)
Definition OExpr ctx A `{OType A} : Type := CtxElem ctx -o> A.

Arguments OExpr ctx A {_} : simpl never.

(* Low-level lambda (we use "ofun", below, to give a nice high-level lambda) *)
(* Notation "'olambda' e" := (ofun_curry e) (at level 99, right associativity). *)

Inductive OVar : Ctx -> forall A `{OType A}, Type :=
| OVar_0 {ctx A} `{OType A} : OVar (ctx :> A) A
| OVar_S {ctx B A} `{OType A} `{OType B} (v: OVar ctx A) : OVar (ctx :> B) A
.

(* The last-bound variable in a context *)
Definition var_top {ctx A} `{OType A} : OExpr (ctx :> A) A := snd_ofun.

(* Weaken an OExpr by adding a type to the context *)
Definition weaken1 {ctx A B} `{OType A} `{OType B}
           (e: OExpr ctx A) : OExpr (ctx :> B) A :=
  compose_ofun fst_ofun e.

Fixpoint varSemantics {ctx A} `{OType A} (v:OVar ctx A) : OExpr ctx A :=
  match v in OVar ctx' A' return OExpr ctx' A' with
  | OVar_0 => var_top
  | OVar_S v => weaken1 (varSemantics v)
  end.

Coercion varSemantics : OVar >-> OExpr.

(***
 *** Notation for Application
 ***)

Definition oexpr_apply {ctx A B} `{OType A} `{OType B}
           (f: OExpr ctx (A -o> B)) (g: OExpr ctx A) : OExpr ctx B :=
  ofun_apply f g.

Instance Proper_oexpr_apply {ctx A B} `{OType A} `{OType B} :
  Proper (oleq ==> oleq ==> oleq) (@oexpr_apply ctx A B _ _).
Proof.
  intros f1 f2 Rf g1 g2 Rg. rewrite Rf. rewrite Rg. reflexivity.
Qed.

(* Application *)
Notation "x @o@ y" :=
  (oexpr_apply x y) (left associativity, at level 20).

(***
 *** Notation for Variables, Lambdas, and Top-level Expressions
 ***)

(* Build an A from an OExpr in unit context of type A *)
Definition oexpr {A} `{OType A} (e: OExpr CNil A) : A := ofun_app e tt.
Arguments oexpr {_ _} e : simpl never.

Instance Proper_oexpr {A} `{OType A} : Proper (oleq ==> oleq) (@oexpr A _).
Proof.
  intros c1 c2 Rc. apply Rc. reflexivity.
Qed.

(* Build an OExpr from a constant *)
Definition oconst {ctx A} `{OType A} (a:A) : OExpr ctx A :=
  const_ofun a.

Instance Proper_oconst {ctx A} `{OType A} :
  Proper (oleq ==> oleq) (@oconst ctx A _).
Proof.
  intros a1 a2 Ra c1 c2 Rc. simpl. assumption.
Qed.

(* Helper function to build lambdas *)
(*
Definition mkLam {ctx A B} `{OType A} `{OType B}
           (body : (forall {ctx'} `{WeakensTo (ctx :> A) ctx'}, OVar ctx' A) ->
                   OExpr (ctx :> A) B) :
  OExpr ctx (A -o> B) :=
  ofun_curry (body (fun _ _ => weakenVar OVar_0)).
 *)

(*
Definition mkLam {ctx A B} `{OType A} `{OType B}
           (body : OVar (ctx :> A) A -> OExpr (ctx :> A) B) :
  OExpr ctx (A -o> B) := ofun_curry (body OVar_0).
 *)

Definition mkLam {ctx A B} `{OType A} `{OType B}
           (body : OExpr (ctx :> A) A -> OExpr (ctx :> A) B) :
  OExpr ctx (A -o> B) := ofun_curry (body var_top).

Notation "'ofun' x => e" :=
  (mkLam (fun x => e))
    (right associativity, at level 99).

Notation "'ofun' ( x : A ) => e" :=
  (mkLam (fun (x : OExpr _ A) => e))
    (right associativity, at level 99, x at level 0).

(***
 *** Weakening
 ***)

(* Inductive proof that ctx1 can be extended to ctx2 *)
Inductive extendsTo ctx1 : Ctx -> Type :=
| ExtendsRefl : extendsTo ctx1 ctx1
| ExtendsCons {ctx2} (ext: extendsTo ctx1 ctx2) A `{OType A}  :
    extendsTo ctx1 (ctx2 :> A)
.

Arguments ExtendsRefl {_}.
Arguments ExtendsCons {_ _} ext A {_}.

(* Typeclass version of the above *)
Class ExtendsTo ctx1 ctx2 : Type :=
  extendsProof : extendsTo ctx1 ctx2.

Instance ExtendsToRefl ctx : ExtendsTo ctx ctx := ExtendsRefl.

Instance ExtendsToCons {ctx1 ctx2} (ext: ExtendsTo ctx1 ctx2) A `{OType A} :
  ExtendsTo ctx1 (ctx2 :> A) :=
  ExtendsCons ext A.

(* This is for use with oconst_oexpr, below *)
Instance ExtendsTo_CNil ctx : ExtendsTo CNil ctx | 10.
Proof. induction ctx; typeclasses eauto. Defined.
Typeclasses Transparent ExtendsTo_CNil.

(* Weaken a context by mapping backwards from the weaker to the stronger one *)
Fixpoint weakenContext {ctx1 ctx2} (ext: extendsTo ctx1 ctx2) :
  CtxElem ctx2 -o> CtxElem ctx1 :=
  match ext in extendsTo _ ctx2 return CtxElem ctx2 -o> CtxElem ctx1 with
  | ExtendsRefl => id_ofun
  | ExtendsCons ext' _ => compose_ofun fst_ofun (weakenContext ext')
  end.

(* Weakening for OExprs *)
Definition weakenExpr {ctx1 ctx2} `{ext: ExtendsTo ctx1 ctx2} {A} `{OType A}
           (e: OExpr ctx1 A) : OExpr ctx2 A :=
  compose_ofun (weakenContext ext) e.

Instance Proper_weakenExpr {ctx1 ctx2} `{ext: ExtendsTo ctx1 ctx2} {A} `{OType A} :
  Proper (oleq ==> oleq) (weakenExpr (ext:=ext) (A:=A)).
Proof.
  intros e1 e2 Re. apply Proper_compose_ofun; [ reflexivity | assumption ].
Qed.

Lemma weakenExpr_App {ctx1 ctx2} (ext: ExtendsTo ctx1 ctx2)
      {A B} `{OType A} `{OType B} (e1: OExpr ctx1 (A -o> B)) (e2: OExpr ctx1 A) :
  weakenExpr (e1 @o@ e2) =o= weakenExpr e1 @o@ weakenExpr e2.
  unfold weakenExpr, oexpr_apply. rewrite compose_ofun_apply.
  reflexivity.
Qed.

(* Weakening for variables *)
Fixpoint weakenVar_h {ctx1 ctx2} (ext: extendsTo ctx1 ctx2) :
  forall {A} `{OType A}, OVar ctx1 A -> OVar ctx2 A :=
  match ext in extendsTo _ ctx2
        return forall {A} `{OType A}, OVar ctx1 A -> OVar ctx2 A
  with
  | ExtendsRefl => fun _ _ v => v
  | ExtendsCons ext' _ => fun _ _ v => OVar_S (weakenVar_h ext' v)
  end.

Definition weakenVar {ctx1 ctx2} `{ext:ExtendsTo ctx1 ctx2} {A} `{OType A}
           (v:OVar ctx1 A) : OVar ctx2 A :=
  weakenVar_h ext v.

(* Weakening is the same whether we do it before or after varSemantics *)
Lemma weakenVar_weakenExpr {ctx1 ctx2} `{ext:ExtendsTo ctx1 ctx2} {A} `{OType A}
      (v:OVar ctx1 A) : weakenExpr (ext:=ext) v =o= weakenVar v.
Proof.
  revert v; induction ext; intro v; simpl.
  { apply id_compose_ofun. }
  { unfold weaken1. rewrite <- IHext. unfold weakenExpr. simpl.
    rewrite compose_compose_ofun. reflexivity. }
Qed.

(* Convert a "variable" (an OExpr in a shorter context) into an expression in
the current context *)
Definition ovar {ctx A} `{OType A} {ctx'} `{ext:ExtendsTo ctx ctx'}
           (e:OExpr ctx A) : OExpr ctx' A := weakenExpr e.

(***
 *** Substitution
 ***)

Inductive CtxSubst : Ctx -> Ctx -> Type :=
| CtxSubstBase {ctx A} `{OType A} (e: OExpr ctx A) : CtxSubst (ctx :> A) ctx
| CtxSubstCons {ctx1 ctx2} (s: CtxSubst ctx1 ctx2) A `{OType A} :
    CtxSubst (ctx1 :> A) (ctx2 :> A)
.

(* Use a substitution like a mapping *)
Fixpoint substContext {ctx1 ctx2} (s: CtxSubst ctx1 ctx2)
  : CtxElem ctx2 -o> CtxElem ctx1 :=
  match s in CtxSubst ctx1 ctx2
        return CtxElem ctx2 -o> CtxElem ctx1
  with
  | CtxSubstBase e => pair_ofun id_ofun e
  | CtxSubstCons s' _ =>
    pair_ofun (compose_ofun fst_ofun (substContext s')) snd_ofun
  end.

Definition substExpr {ctx1 ctx2 A} `{OType A} (e: OExpr ctx1 A)
           (s: CtxSubst ctx1 ctx2) : OExpr ctx2 A :=
  compose_ofun (substContext s) e.

(***
 *** Typeclasses for Weakening
 ***)

Inductive PreExtendsTo : Ctx -> Ctx -> Type :=
| PreExtendsToBase {ctx1 ctx2} (ext: ExtendsTo ctx1 ctx2) :
    PreExtendsTo ctx1 ctx2
| PreExtendsToCons {ctx1 ctx2} (pext: PreExtendsTo ctx1 ctx2) A `{OType A} :
    PreExtendsTo (ctx1 :> A) (ctx2 :> A)
.

Fixpoint weakenPreContext {ctx1 ctx2} (pext: PreExtendsTo ctx1 ctx2) :
  CtxElem ctx2 -o> CtxElem ctx1 :=
  match pext in PreExtendsTo ctx1 ctx2 return CtxElem ctx2 -o> CtxElem ctx1 with
  | PreExtendsToBase ext => weakenContext ext
  | PreExtendsToCons pext' _ =>
    pair_ofun (compose_ofun fst_ofun (weakenPreContext pext')) snd_ofun
  end.

Class WeakensTo {ctx ctx_e A} `{OType A} (e: OExpr ctx_e A)
      (pext: PreExtendsTo ctx_e ctx) (res: OExpr ctx A) :=
  weakensTo :
    compose_ofun (weakenPreContext pext) e =o= res.

Instance WeakensTo_Const {ctx ctx_e A} `{OType A}
         (a:A) (pext: PreExtendsTo ctx_e ctx) :
  WeakensTo (oconst a) pext (oconst a).
Proof.
  apply funOExt; intro celem. reflexivity.
Qed.

Instance WeakensTo_Refl {ctx A} `{OType A} (e: OExpr ctx A) :
  WeakensTo e (PreExtendsToBase (ExtendsToRefl ctx)) e.
Proof.
  apply id_compose_ofun.
Qed.

Instance WeakensTo_Trivial {ctx_e ctx A} `{OType A} (e: OExpr ctx_e A)
         (ext: ExtendsTo ctx_e ctx) :
  WeakensTo e (PreExtendsToBase ext) (ovar e) | 10.
Proof.
  apply id_compose_ofun.
Qed.

Instance WeakensTo_App {ctx_e ctx A B} `{OType A} `{OType B}
         (e1: OExpr ctx_e (A -o> B)) e2
         (pext: PreExtendsTo ctx_e ctx) res1 res2 :
  WeakensTo e1 pext res1 -> WeakensTo e2 pext res2 ->
  WeakensTo (e1 @o@ e2) pext (res1 @o@ res2).
Proof.
  unfold WeakensTo. intros. rewrite <- H1. rewrite <- H2.
  unfold oexpr_apply. rewrite compose_ofun_apply.
  reflexivity.
Qed.

Instance WeakensTo_Lam {ctx_e ctx A B} `{OType A} `{OType B}
         (body: OExpr (ctx_e :> A) A -> OExpr (ctx_e :> A) B)
         (pext: PreExtendsTo ctx_e ctx) body_res :
  (forall v v_res,
      WeakensTo v (PreExtendsToCons pext A) v_res ->
      WeakensTo (body v) (PreExtendsToCons pext A) (body_res v_res)) ->
  WeakensTo (mkLam body) pext (mkLam body_res).
Proof.
  unfold WeakensTo, mkLam.
  intro pf. rewrite <- (pf var_top var_top).
  { rewrite compose_ofun_curry. reflexivity. }
  { simpl. apply compose_pair_snd. }
Qed.

Class WeakensToVar {ctx_e ctx_e_res ctx ctx_res A} `{OType A}
      (e: OExpr ctx_e A) (ext_v: ExtendsTo ctx_e ctx)
      (pext: PreExtendsTo ctx ctx_res)
      (res: OExpr ctx_e_res A) (ext_res: ExtendsTo ctx_e_res ctx_res) :=
  weakensToVar :
    compose_ofun (weakenPreContext pext) (ovar e) =o= (ovar res).

Instance WeakensToVar_Refl {ctx_e ctx A} `{OType A}
         (e: OExpr ctx_e A) (pext: PreExtendsTo ctx_e ctx) res :
  WeakensTo e pext res ->
  WeakensToVar e (ExtendsToRefl _) pext res (ExtendsToRefl _).
Proof.
  intro pf; apply pf.
Qed.

Instance WeakensToVar_Const {ctx_e ctx A} `{OType A}
         (e: OExpr ctx_e A) (ext_v: ExtendsTo ctx_e ctx) :
  WeakensToVar e ext_v (PreExtendsToBase (ExtendsToRefl _)) e ext_v.
Proof.
  apply id_compose_ofun.
Qed.

Instance WeakensToVar_Cons1 {ctx_e ctx ctx_res ctx_e_res A B} `{OType A} `{OType B}
         (e: OExpr ctx_e A) (ext_v: ExtendsTo ctx_e ctx)
         (pext: PreExtendsTo ctx ctx_res)
         (res: OExpr ctx_e_res A) (ext_res : ExtendsTo ctx_e_res ctx_res) :
  WeakensToVar e ext_v pext res ext_res ->
  WeakensToVar e (ExtendsToCons ext_v B)
               (PreExtendsToCons pext B) res (ExtendsToCons ext_res B).
Proof.
  unfold WeakensToVar, ovar, ovar, weakenExpr. simpl.
  intro pf. repeat rewrite <- compose_compose_ofun. rewrite <- pf.
  apply funOExt; intro celem. reflexivity.
Qed.

Instance WeakensToVar_Cons2 {ctx_e ctx ctx_res ctx_e_res A B} `{OType A} `{OType B}
         (e: OExpr ctx_e A) (ext_v: ExtendsTo ctx_e ctx)
         (ext: ExtendsTo ctx ctx_res)
         (res: OExpr ctx_e_res A) (ext_res : ExtendsTo ctx_e_res ctx_res) :
  WeakensToVar e ext_v (PreExtendsToBase ext) res ext_res ->
  WeakensToVar e ext_v (PreExtendsToBase (ExtendsToCons ext B))
               res (ExtendsToCons ext_res B).
Proof.
  unfold WeakensToVar, ovar, ovar, weakenExpr. simpl.
  intro pf. repeat rewrite <- compose_compose_ofun. rewrite <- pf.
  apply funOExt; intro celem. reflexivity.
Qed.

Instance WeakensTo_Var {ctx_e ctx ctx_e_res ctx_res A} `{OType A}
         (e: OExpr ctx_e A) (ext_v: ExtendsTo ctx_e ctx)
         (pext: PreExtendsTo ctx ctx_res)
         (res: OExpr ctx_e_res A) (ext_res: ExtendsTo ctx_e_res ctx_res) :
  WeakensToVar e ext_v pext res ext_res ->
  WeakensTo (ovar e) pext (ovar res).
Proof.
  intro pf; apply pf.
Qed.

(***
 *** Typeclasses for Substitution
 ***)

Class SubstsTo {ctx ctx_res A} `{OType A} (e: OExpr ctx A)
      (s: CtxSubst ctx ctx_res) res :=
  substsTo : substExpr e s =o= res.

Instance SubstsTo_Const {ctx ctx_res A} `{OType A} (a:A)
         (s: CtxSubst ctx ctx_res) :
  SubstsTo (oconst a) s (oconst a).
Proof.
  apply funOExt; intro celem. reflexivity.
Qed.

Instance SubstsTo_App {ctx ctx_res A B} `{OType A} `{OType B}
         (e1: OExpr ctx (A -o> B)) (e2: OExpr ctx A)
         (s: CtxSubst ctx ctx_res) res1 res2 :
  SubstsTo e1 s res1 -> SubstsTo e2 s res2 ->
  SubstsTo (e1 @o@ e2) s (res1 @o@ res2).
Proof.
  unfold SubstsTo. unfold substExpr. intros. rewrite <- H1. rewrite <- H2.
  unfold oexpr_apply. rewrite compose_ofun_apply.
  reflexivity.
Qed.

Instance SubstsTo_Lam {ctx ctx_res A B} `{OType A} `{OType B}
         (body: OExpr (ctx :> A) A -> OExpr (ctx :> A) B)
         (s: CtxSubst ctx ctx_res)
         (body_res: OExpr (ctx_res :> A) A -> OExpr (ctx_res :> A) B) :
  (forall v v_res,
      SubstsTo v (CtxSubstCons s A) v_res ->
      SubstsTo (body v) (CtxSubstCons s A) (body_res v_res)) ->
  SubstsTo (mkLam body) s (mkLam body_res).
Proof.
  unfold SubstsTo, substExpr, mkLam. intro pf. rewrite <- (pf var_top var_top).
  { rewrite compose_ofun_curry. reflexivity. }
  { simpl. apply compose_pair_snd. }
Qed.

Class SubstsToVar {ctx ctx_e ctx_res ctx_e_res A} `{OType A}
      (e: OExpr ctx_e A) (ext: ExtendsTo ctx_e ctx)
      (s: CtxSubst ctx ctx_res) (res: OExpr ctx_e_res A)
      (ext_res: ExtendsTo ctx_e_res ctx_res) :=
  substsToVar : substExpr (ovar (ext:=ext) e) s =o= ovar (ext:=ext_res) res.

Instance SubstsToVar_Refl {ctx ctx_res A} `{OType A}
         (e: OExpr ctx A) (s: CtxSubst ctx ctx_res) res :
  SubstsTo e s res -> SubstsToVar e (ExtendsToRefl ctx) s res (ExtendsToRefl _).
Proof.
  unfold SubstsTo, SubstsToVar, ovar, ExtendsToRefl, substExpr, weakenExpr.
  simpl. repeat rewrite id_compose_ofun. intro; assumption.
Qed.

Instance SubstsToVar_VarSubst {ctx A} `{OType A} (e_subst: OExpr ctx A) :
  SubstsToVar var_top (ExtendsToRefl _) (CtxSubstBase e_subst)
              e_subst (ExtendsToRefl _).
Proof.
  unfold SubstsTo, SubstsToVar, ovar, var_top.
  unfold substExpr, weakenExpr, ExtendsToRefl.
  simpl. repeat rewrite id_compose_ofun. rewrite compose_pair_snd.
  reflexivity.
Qed.

Instance SubstsToVar_Const {ctx ctx_e A B} `{OType A} `{OType B}
         (e: OExpr ctx_e A) (ext: ExtendsTo ctx_e ctx)
         (e_subst: OExpr ctx B) :
  SubstsToVar e (ExtendsToCons ext B) (CtxSubstBase e_subst) e ext.
Proof.
  unfold SubstsTo, SubstsToVar, ovar, weakenExpr, substExpr. simpl.
  apply funOExt; intro celem. reflexivity.
Qed.

Instance SubstsToVar_Cons {ctx_e ctx_e_res ctx ctx_res A B} `{OType A} `{OType B}
         (e: OExpr ctx_e A) (ext: ExtendsTo ctx_e ctx)
         (s: CtxSubst ctx ctx_res) (res: OExpr ctx_e_res A) ext_res :
  SubstsToVar e ext s res ext_res ->
  SubstsToVar e (ExtendsToCons ext B) (CtxSubstCons s B)
              res (ExtendsToCons ext_res B).
Proof.
  unfold SubstsTo, SubstsToVar, ovar, ovar, weakenExpr, substExpr. simpl.
  intro pf. repeat rewrite <- compose_compose_ofun. rewrite <- pf.
  apply funOExt; intro celem. reflexivity.
Qed.

Instance SubstsTo_Var {ctx ctx_res ctx_e ctx_e_res A} `{OType A}
         (e: OExpr ctx_e A) (ext: ExtendsTo ctx_e ctx)
         (s: CtxSubst ctx ctx_res)
         (res: OExpr ctx_e_res A) (ext_res: ExtendsTo ctx_e_res ctx_res)
         (res_w: OExpr ctx_res A) :
  SubstsToVar e ext s res ext_res ->
  WeakensTo res (PreExtendsToBase ext_res) res_w ->
  SubstsTo (ovar (ext:=ext) e) s res_w.
Proof.
  unfold SubstsTo, SubstsToVar, WeakensTo. intros.
  etransitivity; eassumption.
Qed.

(***
 *** Beta and Eta Rules for OFuns
 ***)

Lemma ofunEta {ctx A B} `{OType A} `{OType B} (e: OExpr ctx (A -o> B)) :
  (ofun x => ovar e @o@ ovar x) =o= e.
Proof.
  apply funOExt; intro celem. apply funOExt; intro a. reflexivity.
Qed.

Lemma ofunExt {ctx A B} `{OType A} `{OType B} (e1 e2: OExpr ctx (A -o> B))
      (pf: forall arg, e1 @o@ arg =o= e2 @o@ arg) :
  e1 =o= e2.
Proof.
  apply funOExt; intro celem. unfold oexpr_apply in pf.
  apply funOExt; intro a. revert celem.
  rewrite <- (funOExt _ _ (e1 @o@ oconst a) (e2 @o@ oconst a)).
  apply pf.
Qed.

Lemma ofunExt_leq {ctx A B} `{OType A} `{OType B} (e1 e2 : OExpr ctx (A -o> B))
      (pf: forall arg, e1 @o@ arg <o= e2 @o@ arg) :
  e1 <o= e2.
Proof.
  intros c1 c2 Rc a1 a2 Ra. rewrite Rc; rewrite Ra.
  apply (pf (oconst a2)). reflexivity.
Qed.

Lemma ofunEta' {ctx A B} `{OType A} `{OType B} (e: OExpr ctx (A -o> B)) :
  (ofun x => ovar e @o@ x) =o= e.
Proof.
  apply funOExt; intro celem. apply funOExt; intro a. reflexivity.
Qed.

Lemma mkLamExt {ctx A B} `{OType A} `{OType B}
      (body1 body2: OExpr (ctx :> A) A -> OExpr (ctx :> A) B) :
  body1 var_top =o= body2 var_top -> mkLam body1 =o= mkLam body2.
Proof.
  intro pf. apply funOExt; intro celem. unfold mkLam. rewrite pf. reflexivity.
Qed.

Lemma mkLamExt_leq {ctx A B} `{OType A} `{OType B}
      (body1 body2: OExpr (ctx :> A) A -> OExpr (ctx :> A) B) :
  body1 var_top <o= body2 var_top -> mkLam body1 <o= mkLam body2.
Proof.
  intro pf. intros c1 c2 Rc; rewrite Rc. unfold mkLam. rewrite pf. reflexivity.
Qed.

Lemma ofunBeta {ctx A B} `{OType A} `{OType B}
      (body: OExpr (ctx :> A) A -> OExpr (ctx :> A) B) (arg: OExpr ctx A) res
      {st:
         forall v, SubstsTo v (CtxSubstBase arg) arg ->
                   SubstsTo (body v) (CtxSubstBase arg) res} :
  (mkLam body) @o@ arg =o= res.
Proof.
  unfold SubstsTo in st. rewrite <- (st var_top).
  { unfold substExpr, mkLam, oexpr_apply. simpl.
    rewrite ofun_apply_ofun_curry. reflexivity. }
  { apply compose_pair_snd. }
Qed.

(* Perform a beta reduction using the above substitution type classes *)
Ltac obeta := rewrite ofunBeta; [ | typeclasses eauto ].

Lemma oexpr_weakening {ctx1 ctx2 A} `{OType A} (e1: OExpr ctx1 A)
      (e2: OExpr ctx2 A) {ext:ExtendsTo ctx1 ctx2}
      {w:WeakensTo e1 (PreExtendsToBase ext) e2} :
  ovar e1 =o= e2.
Proof.
  apply w.
Qed.

Ltac oweaken := rewrite oexpr_weakening; [ | typeclasses eauto ].

(* Lemma for unfolding a constant *)
(*
Lemma oconst_oexpr {ctx A} `{OType A} (e: OExpr CNil A) res
      {ext: ExtendsTo CNil ctx}
      {w: WeakensTo e (PreExtendsToBase ext) res} :
  oconst (oexpr e) =o= res.
  unfold WeakensTo in w. rewrite <- w.
  unfold oexpr. apply funOExt; intro celem. simpl.
  f_equiv. split; apply I.
Qed.
*)
Lemma oconst_oexpr {ctx A} `{OType A} (e: OExpr CNil A) res
      {w: WeakensTo e (PreExtendsToBase (ExtendsTo_CNil ctx)) res} :
  oconst (oexpr e) =o= res.
  unfold WeakensTo in w. rewrite <- w.
  unfold oexpr. apply funOExt; intro celem. simpl.
  f_equiv. split; apply I.
Qed.

(***
 *** Tests for the obeta Tactic
 ***)
Lemma beta_test {ctx A} `{OType A} (e: OExpr ctx A) :
  (ofun x => ovar x) @o@ e =o= e.
  obeta. reflexivity.
Qed.

Lemma beta_test2 {ctx A B} `{OType A} `{OType B} (e: OExpr ctx (A -o> B)) :
  (ofun f => (ofun x => ovar f @o@ ovar x)) @o@ e =o= e.
  obeta. apply ofunExt; intro. obeta. reflexivity.
Qed.

(***
 *** Ordered Expressions for Unit
 ***)

Notation ott := (oconst tt).

Lemma ott_terminal {ctx} (e: OExpr ctx unit) : e =o= ott.
Proof.
  apply funOExt; intro c. split; apply I.
Qed.

(***
 *** Ordered Expressions for Pairs
 ***)

Notation opair := (oconst (ofun_curry id_ofun)).
Notation ofst := (oconst fst_ofun).
Notation osnd := (oconst snd_ofun).

(*
Definition opair {ctx A B} `{OType A} `{OType B} : OExpr ctx (A -o> B -o> A*B) :=
  oconst (ofun_curry id_ofun).
Definition ofst {ctx A B} `{OType A} `{OType B} : OExpr ctx (A * B -o> A) :=
  oconst fst_ofun.
Definition osnd {ctx A B} `{OType A} `{OType B} : OExpr ctx (A * B -o> B) :=
  oconst snd_ofun.
 *)

Notation "( x ,o, y )" := (opair @o@ x @o@ y : OExpr _ _) (at level 0).

Lemma ofst_opair {ctx A B} `{OType A} `{OType B}
      (e1: OExpr ctx A) (e2: OExpr ctx B) :
  ofst @o@ (e1 ,o, e2) =o= e1.
Proof.
  apply funOExt; intro c. reflexivity.
Qed.

Lemma osnd_opair {ctx A B} `{OType A} `{OType B}
      (e1: OExpr ctx A) (e2: OExpr ctx B) :
  osnd @o@ (e1 ,o, e2) =o= e2.
Proof.
  apply funOExt; intro c. reflexivity.
Qed.

Lemma opair_ext {ctx A B} `{OType A} `{OType B} (e: OExpr ctx (A*B)) :
  opair @o@ (ofst @o@ e) @o@ (osnd @o@ e) =o= e.
Proof.
  apply funOExt; intro c. simpl. destruct (ofun_app e c). reflexivity.
Qed.

(***
 *** Ordered Expressions for Sums
 ***)

Notation oinl := (oconst inl_ofun).
Notation oinr := (oconst inr_ofun).
Notation osumElim := (oconst sum_elim_ofun).

(*
Definition oinl {ctx A B} `{OType A} `{OType B} : OExpr ctx (A -o> A + B) :=
  oconst inl_ofun.
Definition oinr {ctx A B} `{OType A} `{OType B} : OExpr ctx (B -o> A + B) :=
  oconst inr_ofun.
Definition osumElim {ctx A B C} `{OType A} `{OType B} `{OType C} :
  OExpr ctx ((A -o> C) -o> (B -o> C) -o> A + B -o> C) :=
  oconst sum_elim_ofun.
*)

Lemma osumElim_oinl {ctx A B C} `{OType A} `{OType B} `{OType C}
      (f1 : OExpr ctx (A -o> C)) (f2 : OExpr ctx (B -o> C)) e :
  osumElim @o@ f1 @o@ f2 @o@ (oinl @o@ e) =o= f1 @o@ e.
Proof.
  apply funOExt; intro c. reflexivity.
Qed.

Lemma osumElim_oinr {ctx A B C} `{OType A} `{OType B} `{OType C}
      (f1 : OExpr ctx (A -o> C)) (f2 : OExpr ctx (B -o> C)) e :
  osumElim @o@ f1 @o@ f2 @o@ (oinr @o@ e) =o= f2 @o@ e.
Proof.
  apply funOExt; intro c. reflexivity.
Qed.

(***
 *** Ordered Expressions for Propositions
 ***)

Notation oTrue := (oconst True).
Notation oFalse := (oconst False).

Notation oforall := (oconst forall_ofun).
Notation oexists := (oconst exists_ofun).
Notation oexists2 := (oconst exists2flip_ofun).

Notation oand := (oconst and_ofun).
Notation oor := (oconst or_ofun).
Notation oimpl := (oconst impl_ofun).
Notation oappr := (oconst oleq_ofun).

(*
Definition oTrue {ctx} : OExpr ctx Prop := oconst True.
Definition oFalse {ctx} : OExpr ctx Prop := oconst False.

Definition oforall {ctx A} `{OType A} : OExpr ctx ((A -o> Prop) -o> Prop) :=
  oconst forall_ofun.
Definition oexists {ctx A} `{OType A} : OExpr ctx ((A -o> Prop) -o> Prop) :=
  oconst exists_ofun.
Definition oexists2 {ctx A} `{OType A} :
  OExpr ctx ((A -o> Prop) -o> (Flip A -o> Prop) -o> Prop) :=
  oconst exists2flip_ofun.

Definition oand {ctx} : OExpr ctx (Prop -o> Prop -o> Prop) :=
  oconst and_ofun.
Definition oor {ctx} : OExpr ctx (Prop -o> Prop -o> Prop) :=
  oconst or_ofun.
Definition oimpl {ctx} : OExpr ctx (Flip Prop -o> Prop -o> Prop) :=
  oconst impl_ofun.
Definition oappr {ctx A} `{OType A} : OExpr ctx (Flip A -o> A -o> Prop) :=
  oconst oleq_ofun.
*)

Lemma oor_leq1 {ctx} (P Q: OExpr ctx Prop) : P <o= oor @o@ P @o@ Q.
Proof.
  intros c1 c2 Rc; rewrite Rc. intro pf; left; assumption.
Qed.

Lemma oor_leq2 {ctx} (P Q: OExpr ctx Prop) : Q <o= oor @o@ P @o@ Q.
Proof.
  intros c1 c2 Rc; rewrite Rc. intro pf; right; assumption.
Qed.

Lemma oor_lub {ctx} (P Q R: OExpr ctx Prop) :
  (P <o= R) -> (Q <o= R) -> oor @o@ P @o@ Q <o= R.
Proof.
  intros RPR RQR c1 c2 Rc; rewrite Rc. intro pf.
  destruct pf; [ apply (RPR c2) | apply (RQR c2) ]; try assumption; reflexivity.
Qed.

Lemma oand_leq1 {ctx} (P Q: OExpr ctx Prop) : oand @o@ P @o@ Q <o= P.
Proof.
  intros c1 c2 Rc; rewrite Rc. intro pf; destruct pf; assumption.
Qed.

Lemma oand_leq2 {ctx} (P Q: OExpr ctx Prop) : oand @o@ P @o@ Q <o= Q.
Proof.
  intros c1 c2 Rc; rewrite Rc. intro pf; destruct pf; assumption.
Qed.

Lemma oand_glb {ctx} (P Q R: OExpr ctx Prop) :
  (P <o= Q) -> (P <o= R) -> P <o= oand @o@ Q @o@ R.
Proof.
  intros RPQ RPR c1 c2 Rc; rewrite Rc. intro pf.
  split; [ apply (RPQ c2) | apply (RPR c2) ]; try assumption; reflexivity.
Qed.

(***
 *** Flip and Equiv Types
 ***)

Fixpoint flipCtx (ctx : Ctx) :=
  match ctx with
  | CNil => CNil
  | ctx' :> A => flipCtx ctx' :> Flip A
  end.

Fixpoint flipCtxElem {ctx} : CtxElem ctx -> CtxElem (flipCtx ctx) :=
  match ctx return CtxElem ctx -> CtxElem (flipCtx ctx) with
  | CNil => fun celem => celem
  | ctx' :> A => fun celem => (flipCtxElem (fst celem), flip (snd celem))
  end.

Instance Proper_flipCtxElem ctx : Proper (oleq --> oleq) (@flipCtxElem ctx).
Proof.
  induction ctx; intros c1 c2 Rc.
  - destruct c1; destruct c2; reflexivity.
  - destruct Rc. split; [ apply IHctx | ]; assumption.
Qed.

Fixpoint unflipCtxElem {ctx} : CtxElem (flipCtx ctx) -> CtxElem ctx :=
  match ctx return CtxElem (flipCtx ctx) -> CtxElem ctx with
  | CNil => fun celem => celem
  | ctx' :> A => fun celem => (unflipCtxElem (fst celem), unflip (snd celem))
  end.

Instance Proper_unflipCtxElem ctx : Proper (oleq --> oleq) (@unflipCtxElem ctx).
Proof.
  induction ctx; intros c1 c2 Rc.
  - destruct c1; destruct c2; reflexivity.
  - destruct Rc. split; [ apply IHctx | ]; assumption.
Qed.

Lemma flipCtxElem_unflipCtxElem ctx (celem: CtxElem ctx) :
  unflipCtxElem (flipCtxElem celem) =o= celem.
Proof.
  revert celem; induction ctx; intros; [ reflexivity | ].
  destruct celem. destruct (IHctx c).
  split; split; try reflexivity; assumption.
Qed.

Lemma unflipCtxElem_flipCtxElem ctx (celem: CtxElem (flipCtx ctx)) :
  flipCtxElem (unflipCtxElem celem) =o= celem.
Proof.
  revert celem; induction ctx; intros; [ reflexivity | ].
  destruct celem. destruct (IHctx c). simpl. rewrite flip_unflip.
  split; split; try reflexivity; assumption.
Qed.

(* A "flipped" ordered expression *)
Definition OExprFlip ctx A `{OType A} : Type := OExpr (flipCtx ctx) A.

Arguments OExprFlip ctx A {_} : simpl never.

Program Definition oflip {ctx A} `{OType A} (e: OExprFlip ctx A)
  : OExpr ctx (Flip A) :=
  {| ofun_app := fun celem => flip (e @@ flipCtxElem celem) |}.
Next Obligation.
  intros c1 c2 Rc. simpl. rewrite Rc. reflexivity.
Defined.

Program Definition ounflip {ctx A} `{OType A} (e: OExpr ctx (Flip A))
  : OExprFlip ctx A :=
  {| ofun_app := fun celem => unflip (e @@ unflipCtxElem celem) |}.
Next Obligation.
  intros c1 c2 Rc. simpl. rewrite Rc. reflexivity.
Defined.

Lemma oflip_ounflip {ctx A} `{OType A} (e: OExprFlip ctx A) :
  ounflip (oflip e) =o= e.
  revert e; induction ctx; intros; apply funOExt; intro c; [ reflexivity | ].
  simpl. rewrite flip_unflip. rewrite unflipCtxElem_flipCtxElem.
  destruct c; reflexivity.
Qed.

Lemma ounflip_oflip {ctx A} `{OType A} (e: OExpr ctx (Flip A)) :
  oflip (ounflip e) =o= e.
  revert e; induction ctx; intros; apply funOExt; intros c; simpl;
    rewrite flip_unflip; [ reflexivity | ].
  rewrite flipCtxElem_unflipCtxElem. destruct c; reflexivity.
Qed.

Program Definition oflip' {ctx A} `{OType A} (e: OExpr ctx A)
  : OExprFlip ctx (Flip A) :=
  {| ofun_app := fun celem => flip (e @@ unflipCtxElem celem) |}.
Next Obligation.
  intros c1 c2 Rc. simpl. rewrite Rc. reflexivity.
Defined.

Program Definition ounflip' {ctx A} `{OType A} (e: OExprFlip ctx (Flip A))
  : OExpr ctx A :=
  {| ofun_app := fun celem => unflip (e @@ flipCtxElem celem) |}.
Next Obligation.
  intros c1 c2 Rc. simpl. rewrite Rc. reflexivity.
Defined.

Lemma oflip'_ounflip' {ctx A} `{OType A} (e: OExpr ctx A) :
  ounflip' (oflip' e) =o= e.
  revert e; induction ctx; intros; apply funOExt; intro c; [ reflexivity | ].
  simpl. rewrite flipCtxElem_unflipCtxElem.
  destruct c; reflexivity.
Qed.

Lemma ounflip'_oflip' {ctx A} `{OType A} (e: OExprFlip ctx (Flip A)) :
  oflip' (ounflip' e) =o= e.
  revert e; induction ctx; intros; apply funOExt; intros c; simpl;
    rewrite flip_unflip; [ reflexivity | ].
  rewrite unflipCtxElem_flipCtxElem. rewrite flip_unflip.
  destruct c; reflexivity.
Qed.

Definition ounequiv {ctx A} `{OType A} (e : OExpr ctx (Equiv A)) :
  OExpr ctx A :=
  compose_ofun e unequiv_ofun.

Program Definition ounequiv' {ctx A} `{OType A} (e : OExpr ctx (Equiv A)) :
  OExprFlip ctx A :=
  ounflip (compose_ofun e unequiv'_ofun).


(* (c) Copyright Christian Doczkal and Joachim Bard                       *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations Omega.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base modular_hilbert.
Require Import PDL_def demo.

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

Implicit Types (C D : clause).

(** * Hilbert Refutations *)

Section HilbertRef.
  Variable (F : {fset form}).
  Hypothesis (sfc_F : sf_closed F).

  Local Notation S0 := (S0 F).
  Local Notation PU := (PU F).
  Local Notation xaf := (fun C => [af C]).

  Definition href C := prv ([af C] ---> Bot).

  Lemma refI1n s C : prv ([af C] ---> s) -> href (s^- |` C).
  Proof.
    move => H. rewrite /href. rewrite -> andU,H,bigA1,axAC.
    rule axAcase. exact: axContra.
  Qed.

  Lemma refE1n s C : href (s^- |` C) -> prv ([af C] ---> s).
  Proof.
    move => H. rewrite /href in H. rewrite -> andU,bigA1 in H.
    Intro. ApplyH axDN. Intro. ApplyH H. by ApplyH axAI.
  Qed.

  Lemma ax_lcons C : ~~ lcons C -> prv ([af C] ---> Bot).
  Proof.
    rewrite negb_and -has_predC negbK.
    case/orP => [inC|/hasP [s sinC /=]].
    - rewrite -> (bigAE _ inC). exact: axI.
    - rewrite negbK => nsinC.
      rewrite -> (axA2 [af C]). rewrite -> (bigAE _ sinC) at 2.
      rewrite -> (bigAE _ nsinC). simpl. rule axAcase. case: s sinC nsinC => s [|] _ _ /=.
      exact: axI. exact: axContra.
  Qed.

  Section ContextRefutations.
    Variable S : {fset clause}.
    Hypothesis sub_S : S `<=` S0.
    Hypothesis coref_S : coref F href S.

    (* Lemma 6.1 *)
    Lemma not_hint_max C : C \in PU -> maximal F C -> ~~ hintikka C -> prv ([af C] ---> Bot).
    Proof.
      move/powersetP => Csub /allP => M.
      rewrite negb_and. case/orP; first exact: ax_lcons.
      case/allPn => s inC /=. move: (Csub _ inC). move/flip_drop_sign.
      case: s inC. case => [|x|s t|[a|p0 p1|p0 p1|p|s] t] [|] //= inC inF.
      - move: (sfc_F inF) => /=. case/andP => sinF tinF.
        rewrite negb_or. case/andP => /negbTE sninC /negbTE tninC. move: (M s sinF).
        rewrite sninC orbF => sinC. move: (M t tinF). rewrite tninC /= => tinC.
        do 2 rule axDup. rewrite -> (bigAE _ inC) at 1. rewrite -> (bigAE _ tinC) at 1.
        rewrite -> (bigAE _ sinC) => /=. exact: ax_contraNN.
      - move: (sfc_F inF) => /=. case/andP => sinF tinF. rewrite negb_and.
        case/orP => [/negbTE sninC | /negbTE tninC].
        + move: (M s sinF). rewrite sninC /= => sinC. rule axDup.
          rewrite -> (bigAE _ inC) at 1. rewrite -> (bigAE _ sinC). do 2 Intro. Apply* 1. Intro.
          rewrite <- (axBE t). by Apply* 1.
        + move: (M t tinF). rewrite tninC orbF => tinC. rule axDup. rewrite -> (bigAE _ inC) at 1.
          rewrite -> (bigAE _ tinC). do 2 Intro. Apply* 1. Intro. by Asm.
      - move: (sfc_F inF) => /=. case/and3P => inF0 inF1 _. rewrite negb_and.
        case/orP => [/negbTE ninC0 | /negbTE ninC1].
        + move: (M _ inF0). rewrite ninC0 /= => inC0. rule axDup. rewrite -> (bigAE _ inC0) at 1.
          rewrite -> (bigAE _ inC) => /=. rewrite -> axChEl. exact: axI.
        + move: (M _ inF1). rewrite ninC1 /= => inC1. rule axDup. rewrite -> (bigAE _ inC1) at 1.
          rewrite -> (bigAE _ inC) => /=. rewrite -> axChEr. exact: axI.
      - move: (sfc_F inF). case/and3P => inF0 inF1 _. rewrite negb_or.
        case/andP => /negbTE ninC0 /negbTE ninC1. move: (M _ inF0) (M _ inF1).
        rewrite ninC0 ninC1 !orbF => inC0 inC1. do 2 rule axDup. rewrite -> (bigAE _ inC0) at 1.
        rewrite -> (bigAE _ inC1) at 1. rewrite -> (bigAE _ inC) => /=.
        rewrite -> (axDNE [p0 + p1]t). exact: axCh.
      - move/negbTE => ninC. move: (sfc_F inF). case/andP => inF' _. move: (M _ inF').
        rewrite ninC /= => inC'. rule axDup. rewrite -> (bigAE _ inC') at 1.
        rewrite -> (bigAE _ inC) => /=. rewrite -> axConE. exact: axI.
      - move/negbTE => ninC. move: (sfc_F inF). case/andP => inF' _. move: (M _ inF').
        rewrite ninC orbF => inC'. rule axDup. rewrite -> (bigAE _ inC') at 2.
        rewrite -> (bigAE _ inC) => /=. rewrite <- axCon. exact: axI.
      - move: (sfc_F inF). case/andP => pinF sinF. rewrite negb_and.
        case/orP => [/negbTE sninC | /negbTE pninC].
        + move: (M _ sinF). rewrite sninC /= => sinC. rule axDup. rewrite -> (bigAE _ sinC) at 1.
          rewrite -> (bigAE _ inC) => /=. rewrite -> axStarEl. exact: axI.
        + move: (M _ pinF). rewrite pninC /= => pinC. rule axDup.
          rewrite -> (bigAE _ inC) at 2 => /=. rewrite -> axStarEr.
          rewrite -> (bigAE _ pinC) => /=. exact: axI.
      - move: (sfc_F inF). case/andP => pinF sinF. rewrite negb_or.
        case/andP => /negbTE sninC /negbTE pninC. move: (M _ pinF) (M _ sinF).
        rewrite sninC pninC !orbF => pinC sinC. do 2 rule axDup.
        rewrite -> (bigAE _ inC) at 3 => /=. rewrite -> (axDNE [p^*]t).
        rewrite -> (bigAE _ sinC) at 1. rewrite -> (bigAE _ pinC). exact: axStar.

      (* Essentially the same as the implication cases *)
      - move: (sfc_F inF) => /=. case/andP => sinF tinF.
        rewrite negb_or. case/andP => /negbTE sninC /negbTE tninC. move: (M s sinF).
        rewrite sninC orbF => sinC. move: (M t tinF). rewrite tninC /= => tinC.
        do 2 rule axDup. rewrite -> (bigAE _ inC) at 1. rewrite -> (bigAE _ tinC) at 1.
        rewrite -> (bigAE _ sinC) => /=. rewrite -> axTestE. exact: ax_contraNN.
      - move: (sfc_F inF) => /=. case/andP => sinF tinF. rewrite negb_and.
        case/orP => [/negbTE sninC | /negbTE tninC].
        + move: (M s sinF). rewrite sninC /= => sinC. rule axDup.
          rewrite -> (bigAE _ inC) at 1. rewrite -> (bigAE _ sinC). rewrite /=.
          rewrite <- axTestI. do 2 Intro. Apply* 1. Intro. rewrite <- (axBE t). by Apply* 1.
        + move: (M t tinF). rewrite tninC orbF => tinC. rule axDup. rewrite -> (bigAE _ inC) at 1.
          rewrite /=. rewrite <- axTestI. rewrite -> (bigAE _ tinC). do 2 Intro. Apply* 1. Intro. by Asm.
    Qed.

    Lemma bigxm C s : prv ([af C] ---> [af s^+ |` C] :\/: [af s^- |` C]).
    Proof.
      apply: (rMP (s := s :\/: ~~:s)); last exact: axI. rule axOE.
      - rewrite <- axOIl. do 2 Intro. apply: bigAI => t /fsetU1P [->|inC]; first by Asm.
        Rev. drop. exact: bigAE.
      - rewrite <- axOIr. do 2 Intro. apply: bigAI => t /fsetU1P [->|inC]; first by Asm.
        Rev. drop. exact: bigAE.
    Qed.

    Lemma extension0 C : C \in PU ->
      prv ([af C] ---> \or_(D <- [fset D in S0 | C `<=` D]) [af D]).
    Proof.
      rewrite powersetE. apply: (slack_ind (P := fun C => prv ([af C] ---> _))) => D IH sub.
      case (boolP (maximal F D)).
      - case (boolP (hintikka D)).
        + move => H M. apply: bigOI. by rewrite !inE powersetE sub H M /= subxx.
        + move: sub. rewrite -powersetE => sub nH M. rewrite -> (not_hint_max sub M nH).
          exact: axBE.
      - case/allPn => s inF /=. rewrite negb_or. case/andP => sninD fsninD.
        rewrite -> (bigxm D s). rule axOE; (rewrite -> IH; last by rewrite fproper1).
        + apply: or_sub. move => E. rewrite !inE. case/andP => /and3P [-> -> ->] /=.
          by case/fsubUsetP.
        + rewrite fsubUset sub fsub1 /= andbT. apply/cupP. exists s. by rewrite inF !inE eqxx.
        + apply: or_sub. move => E. rewrite !inE. case/andP => /and3P [-> -> ->] /=.
          by case/fsubUsetP.
        + rewrite fsubUset sub fsub1 /= andbT. apply/cupP. exists s. by rewrite inF !inE eqxx.
    Qed.

    (* Lemma 6.2 (Extension) *)
    Lemma extension C : C \in PU ->
      prv ([af C] ---> \or_(D <- [fset D in S | C `<=` D]) [af D]).
    Proof.
      move => Csub. rewrite -> extension0 => //. apply: bigOE => D. rewrite !inE.
      case/andP => /and3P [Dsub M H] CsubD.
      case inS: (D \in S).
      - apply: bigOI. by rewrite !inE inS CsubD.
      - rewrite -> coref_S; first exact: axBE. by rewrite !inE Dsub M H inS.
    Qed.

    (* Lemma 6.3 (Admissibility of P1 *)
    Lemma adm_P1 C : C \in PU -> ~~ S |> C -> href C.
    Proof.
      rewrite /href => H1 H2. rewrite -> extension => //.
      apply: bigOE => D. rewrite inE => /andP [D1 D2]. case: notF.
      apply: contraNT H2 => _. by apply/hasP; exists D.
    Qed.

    Lemma nsub_contra C D :
      C \in S -> D \in S -> ~~ (C `<=` D) -> prv ([af C] ---> [af D] ---> fF).
    Proof.
      move => /(subP sub_S). rewrite inE powersetE. case/and3P => sub _ _.
      move/(subP sub_S). rewrite inE. case/and3P => _ _ /allP maxD. case/subPn.
      case => s [|]; move => inC ninD; move: (maxD s); rewrite (negbTE ninD) ?orbF /=;
      rewrite -> (bigAE _ inC); move: inC => /(subP sub) => inF;
      rewrite (flip_drop_sign inF) => inD; rule axC; (rewrite -> bigAE;
      last exact: inD); [done| by rule axC].
    Qed.

    (* Lemma 6.4 *)
    Lemma neq_contra C D : C \in S -> D \in S -> C != D -> prv ([af C] ---> [af D] ---> fF).
    Proof.
      move => CinS DinS. rewrite eqEsub negb_and.
      case/orP => H; [exact: nsub_contra | rule axC; exact: nsub_contra].
    Qed.

    (* Lemma 6.5 (1) *)
    Lemma or_S : prv (\or_(C <- S) [af C]).
    Proof.
      apply (rMP (s := [af fset0])).
      - rewrite -> extension; last by rewrite powersetE sub0x. apply: bigOE => C. rewrite inE.
        case/andP => inS _. exact: bigOI.
      - mp; last exact: axT. apply: bigAI => s. by rewrite inE.
    Qed.

    (* Lemma 6.5 (2) *)
    Lemma neg_or A : A `<=` S -> prv ((~~: \or_(C <- A) [af C]) ---> \or_(C <- S `\` A) [af C]).
    Proof.
      move => sub. mp; last exact: or_S. apply: bigOE => C inS. case inA: (C \in A).
      - rewrite <- (bigOI _ inA). exact: axContra.
      - rule axC. drop. apply: bigOI. by rewrite inE inS inA.
    Qed.

    Lemma maxS0 C s b : C \in S -> (s,b) \notin C -> s \in F -> (s,~~ b) \in C.
    Proof.
      move/(subP sub_S). rewrite inE => /and3P[_ _ /allP] H inC /H.
      case: b inC => /negbTE-> //=. by rewrite orbF.
    Qed.

    Ltac adm_P2_aux_tac :=
      try match goal with
            [ Hu : is_true (_ \in F) |- _] =>
              by [move/sfc_F : Hu => /and3P[]|move/sfc_F : Hu => /andP[]]
          end.

    (* Lemma 6.7 *)
    Lemma adm_P2_aux C D p u : [p]u \in F ->
      C \in S -> D \in S -> ~~ reach_demo S p C D -> prv ([af C] ---> [p]~~:[af D]).
    Proof with adm_P2_aux_tac.
      elim: p u C D => [a|p0 IH0 p1 IH1|p0 IH0 p1 IH1|p IHp|s] u C D Hu CinS DinS /=.
      - rewrite -has_predC. case/hasP. case => s [|]; last by rewrite (negbTE (Rpos _ _ _)).
        rewrite RE /= => inC ninD.
        have inD : s^- \in D.
        { apply: maxS0 DinS ninD _. move: CinS => /(subP sub_S).
          rewrite inE powersetE. case/and3P => /subP sub _ _.
          apply: (@flip_drop_sign _ (s^+)).
          apply: flipcl_refl. move/sub : inC. by move/flip_drop_sign/sfc_F. }
        rewrite <- (axDN ([pV a](~~: [af D]))).
        rewrite -> (dmAX (pV a) (~~: [af D])). rewrite -> rEXn; last exact: axDN.
        rewrite -> (bigAE _ inC). rewrite -> (rEXn (pV a) (t:= ~~: s)).
        + rule axC. do 2 Intro. rule axB; last by do 2 Rev; exact: axDBD.
          rewrite -> rEXn; first exact: axnEXF. rewrite -> (axDNE (~~: s ---> ~~: s)). exact: axI.
        + rewrite -> bigAE; last exact: inD. exact: axI.
      - rewrite negb_or. case/andP => H0 H1. rewrite <- axDup. rewrite -> (IH0 u) at 1 => //...
        rewrite -> (IH1 u C D) => //... exact: axCh.
      - rewrite -all_predC. move/allP => H. rewrite <- axCon.
        rewrite <- (axDN ([p0][p1](~~: [af D]))).
        rewrite -> (dmAX p0 ([p1](~~: [af D]))).
        rewrite -> (rEXn p0 (t:= (\or_(E <- S) [af E]) :/\: EX p1 [af D])); last
          by apply: (rMP _ or_S); exact: axAI.
        rewrite -> rEXn; last by rewrite -> bigODr; exact: axI. rewrite -> bigEOOE.
        rule axC. apply: bigOE => E inS. move: (H E inS) => /=. rewrite negb_and.
        case/orP => [H0|H1].
        + rewrite -> (IH0 [p1]u C E) => //... do 2 Intro. rule axB; last by do 2 Rev; exact: axDBD.
          rewrite -> rEXn; first exact: axnEXF. do 2 rule axAcase. rule axC. drop.
          exact: axContra.
        + rule axC. drop. rewrite -> rEXn; first exact: axnEXF.
          rule axDup. rewrite -> axAEl at 2. rewrite -> axAEr. rewrite -> (IH1 u E D) => //...
      - move => H.
        set I := [fset E in S | reach_demo S (p^*) C E].
        set v := \or_(E <- I)[af E].
        suff X : prv (v ---> [p]v).
        { Cut v; first by apply: bigOI;rewrite !inE CinS /= connect_in0.
          rewrite -> (rStar_ind' X). apply: rNorm. apply: bigOE => E inI.
          apply: neq_contra => //; first by apply/(subP subsep); exact: inI.
          apply: contraTN inI => /eqP->. by rewrite inE DinS /= (negbTE H). }
        rewrite /v. rewrite <- (axDN ([p](\or_(E<-I) [af E]))), -> (dmAX p (\or_(E<-I) [af E])).
        apply: bigOE => E EinI. rewrite -> rEXn; last by apply: neg_or; exact: subsep.
        rewrite -> bigEOOE. rule axC. apply: bigOE => G GninI. rewrite -> (IHp [p^*]u E G) => //...
        * apply: (subP subsep). exact: EinI.
        * apply: (subP (fsubDl _ _)). exact: GninI.
        * apply/negP => ERG. move: GninI. rewrite inE. case/andP => GinS. apply/negP.
          apply/negPn. rewrite inE GinS /=. apply: connect_in_trans. move: EinI.
          case/sepP => _ CE. exact: CE. apply: connect_in1 => //. apply: (subP subsep).
          exact: EinI.
      - rewrite <- axTestI. case: (boolP (C == D)) => /= [/eqP-> A|].
        + suff X : s^- \in D. { rewrite -> (bigAE _ X) => /=. do 3 Intro. by Apply. }
          move/sfc_F : Hu => /andP [B _]. exact: (maxS0 DinS A).
        + move => A _. do 3 Intro. by ApplyH (neq_contra CinS DinS A).
    Qed.

    Lemma sfc_box p s : [p]s \in F -> s \in F.
    Proof. by case: p => [a|p1 p2|p1 p2|p|t] /sfc_F => /=; case:(s \in F); rewrite ?andbF. Qed.

    (* Lemma 6.8 (Admissibility of P2 *)
    Lemma adm_P2 C p s :
      C \in S -> [p]s^- \in C -> ~~[some D in S, reach_demo S p C D && (s^- \in D)]
        -> href C.
    Proof.
      move => inS inC. rewrite -all_predC. move/allP => nR.
      set X := [fset D in S | [fset s^-] `<=` D].
      have AAX: prv ([af C] ---> [p]\and_(D <- X) ~~:[af D]).
      { rewrite <- bigABBA. apply: bigAI => D. rewrite inE fsub1. case/andP => DinS inD.
        apply: (adm_P2_aux (u := s)) => //.
        - move/(subP sub_S) : inS inC.
          by rewrite inE powersetE => /andP [/subP H _] /H /flip_drop_sign.
        - move: (nR D DinS) => /=. by rewrite negb_and inD orbF.
      }
      have EOX: prv ([af C] ---> EX p (\or_(D <- X) [af D])).
      { rewrite <- rEXn; first by rewrite <- dmAX; exact: (bigAE _ inC).
        rewrite /X. rewrite <- (extension (C:= [fset s^-])).
        - apply: bigAI => t. rewrite inE. move/eqP => -> /=. exact: axI.
        - rewrite powersetE fsub1. apply: flipcl_refl.
          move/(subP sub_S) : inS inC.
          by rewrite inE powersetE => /andP [/subP H _] /H /flip_drop_sign /sfc_box.
      }
      rule axDup. rewrite -> EOX at 1. rewrite -> AAX. do 2 Intro.
      rule axB; last by do 2 Rev; exact: axDBD.
      rewrite -> rEXn; first exact: axnEXF.
      rewrite <- (axAcase (\or_(D<-X) [af D]) (\and_(D<-X) ~~: [af D]) Bot).
      apply: bigOE => D inX. rule axC. exact: bigAE.
    Qed.

  End ContextRefutations.

  (* Lemma 6.9 *)
  Theorem href_of C : pref F C -> href C.
  Proof. elim => *;[ apply: adm_P1 | apply: adm_P2 ]; eassumption. Qed.

End HilbertRef.

(** ** Completeness *)

(* Theorem 6.10 (Informative Completeness) *)
Theorem informative_completeness t :
    prv (fImp t fF)
  + ({ M: fmodel & #|M| <= 2^(2 * sizef t) & { w: M | eval t w}}).
Proof.
  set F := FL t. have sfc_s := @FL_closed t.
  case: (@pruning_completeness F _ [fset t^+]) => //.
  - by rewrite powersetE fsub1 flipcl_refl // FL_refl.
  - move => /href_of H. left. rewrite /href in H. rewrite <- H => //. apply: bigAI => u.
    by rewrite inE => /eqP ->.
  - move => H. right. move: H => [M] [w] /(_ (t^+) (fset11 _)) /= ? S.
    exists M; last by exists w.
    apply: leq_trans S _. by rewrite leq_exp2l ?leq_mul ?FL_size.
Qed.

(** ** Main Results *)

(* Corollary 6.11 *)
Corollary completeness s : valid s -> prv s.
Proof.
  case: (informative_completeness (~~: s)) => [H|[M] _ [w] H] V.
  - by rule axDN.
  - exfalso. apply: H. exact: (V (cmodel_of_fmodel M)).
Qed.

(* Corollary 6.12 (Decidability) *)
Corollary prv_dec s : decidable (prv s).
Proof.
  case: (informative_completeness (~~: s)) => H; [left|right].
  - by rule axDN.
  - move => prv_s. case: H => M _ [w]. apply. exact: (@soundness _ prv_s M).
Qed.

Corollary sat_dec s : decidable (exists (M: cmodel) (w: M), eval s w).
Proof.
  case: (informative_completeness s) => H; [right|left].
  - case => M [w] Hw. exact: (@soundness _ H M).
  - case: H => M _ [w] ?. by exists M; exists w.
Qed.

Corollary valid_dec s : decidable (forall (M: cmodel) (w: M), eval s w).
Proof.
  case (sat_dec (fImp s fF)) => /= H; [by firstorder|left => M w].
  apply: modelP => A. apply: H. by exists M;exists w.
Qed.

(* Corollary 6.13 (Small-Model Property) *)
Corollary small_models s:
  (exists (M: cmodel) (w: M), eval s w) ->
  (exists2 M: fmodel, #|M| <= 2^(2 * sizef s) & exists w: M, eval s w).
Proof.
  case: (informative_completeness s); last by firstorder.
  move => /(soundness) H [M] [w] w_s. exfalso. exact: H w_s.
Qed.


Require Import Coq.NArith.NArith
  Verigen.Domainpar
  Znumtheory Lia
  Zdiv Zpow_facts.
From Coq Require Import String Ascii.
Open Scope N_scope.

(* 1024 bit prime*)

Module Pins <: Prime.

Definition p : N := 0xfbdf34147bf5d8a45671c906923c1dbe86e9123fae5750d6c1986e00a9946f7f833372a436f98f75dc798bb454825eb625d49011d1e4401baacb653bb9dac6cc8ac91e61ba4310458ff6d6ddabcba29db025eedba6e2f837344dee4814e2a7e2e92ceb1e6e665ee08ce187ffd420fee7a99e046a4af719fa8c689630e88f8729.
Definition q : N := 0x93db61194cb0b9236eea63617d149cd6dd8e2bf1.
Definition domain_parameter_seed : N := 0x75709e9ca555a80cb7ab154e9d29d2775fe215d8.
Definition index: N := 0xae.
Definition k : N := Eval vm_compute in N.div (p - 1) q.
Definition ggen : N := 0x6767656e.

Theorem prime_p : prime (Z.of_N p).
Proof.
Admitted.

Theorem p_len : 1024 <= N.size p.
Proof.
  simpl. lia.
Qed.

Theorem prime_q : prime (Z.of_N q).
Proof.
Admitted.

Theorem q_len : 160 <= N.size q.
Proof.
  simpl. lia.
Qed.

Theorem k_gteq_2 : 2 <= k.
Proof.
  vm_compute; intro Hf.
  inversion Hf.
Qed.

Theorem safe_prime : p = k * q + 1.
Proof.
  vm_compute.
  reflexivity.
Qed.

Theorem ggen_hyp : ggen =  0x6767656e.
Proof.
  unfold ggen.
  reflexivity.
Qed.

Theorem index_8bit : 0 <= index < 255.
Proof.
  vm_compute.
  split.
  intros Hf; inversion Hf.
  reflexivity.
Qed.

End Pins.

(* get a concrete instance *)
Module genr := Comp Pins.

Definition G : N := 0x7db10e27fffe43fc9582367a449f7be217130cdf89a5eff65fbebefc9478ba39ad03d1b0d0254c0f1b8246d914c0d1df25f55a5dabbb51caa1942403fdc22c832e4d7048ce0ad64cb76252fdcfaecd78722c2e10417495ee9d4e0d8376f891a3042b103de915355c0e60e168cf48c0fa232a13bf9b58a0f9b3ad7db7ad39c536.

Theorem G_is_gen : genr.Valid G = genr.compute_generator.
Proof.
  Time vm_compute.
  reflexivity.
Qed.

Time Eval vm_compute in genr.compute_generator.
(*
Finished transaction in 51.232 secs (50.885u,0.334s) (successful)
	 = genr.Valid
         88263658766223357461869144483248908802431230135321993360469791817434515043095308104988988885613316192808653647560362493809139862324204760674673830428720363991237057673925805011298607088991781235425078687556099730304327702471847840027357950827996311819356543334664389981253439309485633438223355769536120472886
     : genr.Tag
Finished transaction in 0.105 secs (0.104u,0.001s) (successful)

*)

Time Eval vm_compute in (genr.verify_generator 88263658766223357461869144483248908802431230135321993360469791817434515043095308104988988885613316192808653647560362493809139862324204760674673830428720363991237057673925805011298607088991781235425078687556099730304327702471847840027357950827996311819356543334664389981253439309485633438223355769536120472886).

(*
= true
     : bool
Finished transaction in 63.977 secs (63.598u,0.335s) (successful)

*)


Require Import Coq.Setoids.Setoid.

(** Separation Heaps **)
Module Type Memory.

  Parameters addr value : Type.

  Parameter mem : Type.

  Parameter mem_get : mem -> addr -> option value.
  Parameter mem_set : mem -> addr -> value -> option mem.

  (** mem writes persist **)
  Parameter mem_get_set_eq : forall m p v' m',
    mem_set m p v' = Some m' ->
    mem_get m' p = Some v'.

  (** mem_set only modifies p **)
  Parameter mem_get_set_neq : forall m p v m',
    mem_set m p v = Some m' ->
    forall p', p <> p' ->
      mem_get m' p' = mem_get m p'.

  Parameter mem_get_mem_set : forall m p,
    mem_get m p <> None -> forall v, mem_set m p v <> None.

  Parameter addr_dec : forall a b : addr, {a = b} + {a <> b}.

End Memory.

Module Type SeparationMemory.
  Declare Module M : Memory.

  Parameter smem : Type.

  Parameter models : smem -> M.mem -> Prop.

  Parameter memoryIn : M.mem -> smem.

  Parameter smem_emp : smem.

  Parameter smem_get : M.addr -> smem -> option M.value.

  Parameter smem_set : M.addr -> M.value -> smem -> option smem.

  Parameter in_domain : M.addr -> smem -> Prop.

  Definition same_domain (l r : smem) : Prop :=
    forall p, in_domain p l <-> in_domain p r.

  Parameter split : smem -> smem -> smem -> Prop.

  Parameter split_comm : forall a b c,
    split a b c -> split a c b.

  Parameter split_emp : forall a c,
    split a smem_emp c <-> a = c.

  Parameter split_assoc : forall a b c d e,
    split a b c -> split b d e ->
    exists f, split a d f /\ split f e c.

  Parameter split_in_domain : forall a b c,
    split a b c ->
    forall p, in_domain p a <-> (in_domain p b \/ in_domain p c).

  Parameter split_disjoint : forall a b c,
    split a b c ->
      (forall p, in_domain p b -> ~in_domain p c).

  Parameter memoryIn_sound : forall m,
    models (memoryIn m) m.

  Parameter smem_get_sound : forall s m,
    models s m ->
    forall a v, smem_get a s = Some v ->
                M.mem_get m a = Some v.

  Parameter smem_set_sound : forall s m,
    models s m ->
    forall a v s', smem_set a v s = Some s' ->
    same_domain s s' /\
    exists m', M.mem_set m a v = Some m' /\ models s' m'.

  Parameter smem_set_get_eq : forall m p v' m',
    smem_set p v' m = Some m' ->
    smem_get p m' = Some v'.

  Parameter smem_get_set_valid : forall m p v,
    smem_get p m <> None ->
    smem_set p v m <> None.

  Parameter smem_set_get_neq : forall m p v' m',
    smem_set p v' m = Some m' ->
    forall p', p <> p' ->
      smem_get p' m' = smem_get p' m.

  Parameter split_smem_get : forall a b c p v,
    split a b c ->
      smem_get p b = Some v ->
      smem_get p a = Some v.

  Parameter split_smem_set : forall a b c p v b',
    split a b c ->
      smem_set p v b = Some b' ->
      exists a', split a' b' c /\
        smem_set p v a = Some a'.

End SeparationMemory.


Require Import Rdefinitions.
Require Import MathClasses.interfaces.abstract_algebra.

Class CarrierBDefs (CarrierB : Type) : Type :=
  {
    CarrierBz : CarrierB;
    CarrierBe :> Equiv CarrierB;
    CarrierBE :> Equivalence CarrierBe
  }.

Module Type CType.
  Parameter t : Type.
  Parameter CTypeZ : t.
  Declare Instance CTypeEquiv : Equiv t.
  Declare Instance CTypeEquivalence : Equivalence CTypeEquiv.
End CType.

(* SigmaHCOL model *)
Section Sigma.
  (* CarrierB : Type is implicitly defined. We can also
     define it explicitly in this section. *)
  Context `{CBDEFS : CarrierBDefs}.

  Lemma sym_test :
    forall b1 b2 : CarrierB,
      CarrierBe b1 b2 <-> CarrierBe b2 b1.
  Proof.
    now symmetry.
  Qed.

  Definition DynWin_SHCOL := CarrierBz.

End Sigma.

(* MHCOL/DHCOL model
   Note: this is currently closer to DHCOL, but in reality the transition needs
   to happen at SHCOL->MHCOL step.
*)
Module Type DHCOL (CT : CType).

  Inductive operator := const_op : CT.t -> operator.

End DHCOL.

Module AHCOL (CT : CType) <: DHCOL(CT).

  Include DHCOL CT.

  Instance CTasCarrierB : CarrierBDefs CT.t :=
    {
      CarrierBz := CT.CTypeZ;
      CarrierBe := CT.CTypeEquiv;
      CarrierBE := CT.CTypeEquivalence;
    }.

  Lemma sym_test' :
    forall b1 b2 : CT.t,
      CT.CTypeEquiv b1 b2 <-> CT.CTypeEquiv b2 b1.
  Proof.
    pose proof sym_test.
    intros.
    unfold CarrierBe, CTasCarrierB in *.
    eapply H.
  Qed.

End AHCOL.

(* To be generated by MetaCoq (compilation) *)
Module DynWin_AHCOL_MetaMod (CT:CType).

  Include AHCOL CT.
  Definition DynWin' := const_op CT.CTypeZ.

End DynWin_AHCOL_MetaMod.

Module DynWinProofs_Mod (CT:CType).

  (* Include AHCOL CT. *)
  Include DynWin_AHCOL_MetaMod CT.

  Lemma DynWin_correct : eq DynWin' (const_op DynWin_SHCOL).
  Proof.
    reflexivity.
  Qed.

End DynWinProofs_Mod.

(* *)

(* Proofs the old way:
   1) (CarrierBasCT)
   2) Instantiate AHCOL
   3) Open section with CarrierBDefs instance and AHCOL import
   4) Proof inside section

   Translation old way
   1) MetaCoq

   Proofs the new way:
   1) Move proofs from old section into AHCOL

   Translation the new way:
   1) MetaCoq [is the same?]
*)

Instance R_CarrierB : CarrierBDefs R :=
  {
    CarrierBz := R0;
    CarrierBe := eq;
    CarrierBE := eq_equivalence;
  }.

Section DynWinProofs.
  Parameter CarrierB: Type. (* proving forall types as CarrierB *)
  Context {CADEFS: CarrierBDefs CarrierB}. (* as long as it satisfies CarrierBDefs *)

  Fail Lemma S_to_A: DynWin_SHCOL = DynWin'.

End DynWinProofs.


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibProd LibContainer LibSet
     LibRelation LibPer.
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import TLCBuffer LibNatExtra
     UnionFind01Data.

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

(* We now introduce ranks. *)

Section Rank.

Variable V : Type.
Variable D : set V.
Variable F : binary V.

(* We assume every vertex has a rank: that is, there is a total function of
   vertices to ranks. *)

Variable K : V -> nat.

(* If there is an edge from [x] to [y], then the rank of [x] should be less
   than the rank of [y]. In other words, the rank of a vertex is always less
   than the rank of its parent. *)

Definition rank_increases_along_edges :=
  forall x y, F x y -> K x < K y.

(* If [r] is a root of rank [k], then the number of its descendants (including
   itself) is at least [2^k]. This implies that, if the total number of vertices
   in the domain [D] is [N], then [k] is bounded by [log N], i.e., ranks are
   logarithmic. *)

Definition numerous_family :=
  forall r, is_root F r ->
  2^(K r) <= card (descendants F r).

(* For technical reasons, we must keep track of the fact that the domain [D]
   is finite. This means that the cardinal of this set, and the cardinals of
   its subsets, are natural numbers, and enjoy the usual properties of
   cardinals. *)

(* We also keep track of the fact that the rank is zero outside [D]. This
   allows not to update [K] when a new vertex is added, which is quite
   convenient. *)

(* A ranked disjoint set forest is a disjoint set forest that satisfies
   the additional properties about ranks that we have listed above. *)

Definition is_rdsf :=
  is_dsf D F /\
  rank_increases_along_edges /\
  numerous_family /\
  finite D /\
  (forall x, x \notin D -> K x = 0).

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

(* In the following, we assume that [F] is a ranked disjoint set forest with
   domain [D] and ranks [K]. *)

Hypothesis is_rdsf_F:
  is_rdsf.

Definition is_rdsf_is_dsf := proj51 is_rdsf_F.
Definition is_rdsf_numerous_family := proj53 is_rdsf_F.
Definition is_rdsf_finite := proj54 is_rdsf_F.
Definition is_rdsf_zero_rank_outside_domain := proj55 is_rdsf_F.

Hint Resolve is_rdsf_is_dsf : core.

Hint Resolve is_rdsf_finite : finite.

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

(* Every parent of nonzero rank. *)

Lemma parent_has_nonzero_rank:
  forall x y,
  F x y ->
  0 < K y.
Proof using is_rdsf_F.
  intros. assert (K x < K y). { eapply is_rdsf_F. eauto. } lia.
Qed.

(* Because rank increases along edges, if there is a path of length [k] from
   [x] to [y], then [K x + k <= K y] holds. *)

Lemma rank_bounds_height_precise:
  forall k x y,
  kpath F k x y ->
  K x + k <= K y.
Proof using is_rdsf_F.
  induction 1 as [| y x z ].
  lia.
  assert (K x < K y). { eapply is_rdsf_F. eauto. } lia.
Qed.

(* The rank of a vertex is an upper bound on its height in the forest. That is,
   a path that leads to a vertex [y] has length at most [K y]. In the absence
   of path compression, we could actually require an equality. *)

Lemma rank_bounds_height:
  forall k x y,
  kpath F k x y ->
  k <= K y.
Proof using D is_rdsf_F.
  intros. forwards: rank_bounds_height_precise; eauto. lia.
Qed.

(* Rank increases along a path. *)

Lemma rank_increases_along_a_path:
  forall x y,
  path F x y ->
  K x <= K y.
Proof using D is_rdsf_F.
  intros.
  forwards (?&?): rtclosure_kpath. eauto.
  forwards: rank_bounds_height_precise; eauto.
  lia.
Qed.

Lemma ancestor_has_greater_rank:
  forall x y,
  y \in ancestors F x ->
  K x <= K y.
Proof using D is_rdsf_F.
  unfold ancestors. intros. rew_set in *. eauto using rank_increases_along_a_path.
Qed.

(* Rank increases strictly along a nontrivial path. *)

Lemma rank_increases_strictly_along_a_nontrivial_path:
  forall x y,
  tclosure F x y ->
  K x < K y.
Proof using D is_rdsf_F.
  intros.
  forwards: tclosure_kpath. eauto. unpack.
  forwards: rank_bounds_height_precise. eauto.
  lia.
Qed.

(* Rank is logarithmic. *)

Lemma rank_is_logarithmic:
  forall x,
  x \in D ->
  K x <= log2 (card D).
Proof using is_rdsf_F.
  intros.
  (* First, we prove that this holds for every root. *)
  assert (f: forall x, is_root F x -> x \in D -> K x <= log2 (card D)).
  { intros. eapply prove_le_log2.
    eapply Nat.le_trans. eapply is_rdsf_numerous_family; eauto.
    (* card (descendants F x) <= card D *)
    eapply card_le_of_incl. eauto with finite.
    (* descendants F x \c D *)
    eapply descendants_subset_D; eauto. }
  (* Now, this holds for other vertices as well. *)
  intros.
  forwards (r&?&?): is_dsf_defined_is_repr x. eauto.
  transitivity (K r); eauto using rank_increases_along_a_path with sticky.
Qed.

(* The length of every path is logarithmic. *)

Lemma height_is_logarithmic:
  forall k x y,
  kpath F k x y ->
  k <= log2 (card D).
Proof using is_rdsf_F.
  introv h.
  tests: (y \in D).
  { eapply Nat.le_trans.
    eapply rank_bounds_height; eauto.
    eapply rank_is_logarithmic; eauto. }
  { forwards: only_trivial_paths_outside_D; eauto.
    lia. }
Qed.

(* Every rank is less than [card D]. This is not a precise bound, but it
   is sometimes useful. *)

Lemma rank_is_linear:
  forall x,
  x \in D ->
  K x < card D.
Proof using is_rdsf_F.
  intros.
  eapply Nat.le_lt_trans.
    { eapply rank_is_logarithmic. eauto. }
    { applys log2_lt_n. forwards~: card_ge_one D x. eauto with finite. }
Qed.

End Rank.

Hint Resolve is_rdsf_is_dsf : is_dsf.

Hint Unfold is_rdsf : is_rdsf.

Hint Resolve is_rdsf_finite : finite.

Hint Resolve is_rdsf_zero_rank_outside_domain : zero_rank.