Require Utf8.

Require Import S00_setoid_basics S01_Wty S02_PolyFun S10_Wstd_Obj S11_Wstd_Fam.

Section Algebra_Map.
  Context {A : setoid}(B : setoidfamily A).

  (* Section 3.3 *)

  (*--------------------------------------*)
  (* Algebra and coalgebra structure maps *)
  (*--------------------------------------*)

  Definition SupFnc : PolyObj B (Wstd B) → Wstd B.

    intros [a h]. set (f := λ y, projT1 (h y)).
    exists (sup _ a f).
    apply istExt2Ext. cbn. apply (setoidmapextensionality _ _ h).
  Defined.

  (* Lemma 3.10 *)

  Definition SupMap : PolyObj B (Wstd B) ⇒ Wstd B.

    apply (Build_setoidmap _ _ SupFnc).
    intros [a h] [a' h'] [p o]. cbn in p,o|-.
    set (F := existT _ a h). set (F' := existT _ a' h').
    set (pp := p : node B (SupFnc F) ≈ node B (SupFnc F')).
    apply (easyMatch pp o).
  Defined.

  (* Proposition 3.11 - Start *)

  Definition UnsupMap : Wstd B ⇒ PolyObj B (Wstd B)
    := InPoly (node B) (istCoh B).

  (*--------------------------------------------------*)
  (* Wsetoids are fixed points of polynomial functors *)
  (*--------------------------------------------------*)

  Theorem SupUnsup2Id : SupMap ∘ UnsupMap ≈ idmap.
  Proof.
    intro u. set (a := node B u). set (f := ist u).
    set (p := setoidrefl A a : node B (SupMap (UnsupMap u)) ≈ a).
    apply (easyMatch p). intro b. cbn in b.
    apply (setoidmapextensionality _ _ (ist u)).
    apply setoidfamilyrefgeneralinv.
  Qed.

  Theorem UnsupSup2Id : UnsupMap ∘ SupMap ≈ idmap.
  Proof.
    intros [a h]. set (F := existT _ a h).
    exists (setoidrefl A a). intro b.
    apply (setoidmapextensionality _ _ h). apply setoidfamilyrefgeneralinv.
  Qed.

  (* Proposition 3.11 - End *)

End Algebra_Map.

Lemma AlgSquareAlt {A : setoid}{B : setoidfamily A}{X : setoid}
      (algX : PolyObj B X ⇒ X)(l : Wstd B ⇒ X)
  : isAlgMor (SupMap B) algX l ↔ l ≈ algX ∘ PolyArr B l ∘ UnsupMap B.
Proof.
  split.
  intro H. apply setoidtra with (y := l ∘ (SupMap B) ∘ (UnsupMap B)).
  intro u'. apply (setoidmapextensionality _ _ l).
  apply setoidsym. apply SupUnsup2Id. intro u'. apply H.
  intro H'.
  apply setoidtra with (y := (algX ∘ (PolyArr B l)) ∘ (UnsupMap B) ∘ (SupMap B)).
  intro u. apply H'. intro z. apply (setoidmapextensionality _ _ algX).
  apply setoidmapextensionality. apply UnsupSup2Id.
Qed.


Load List.

Class DecidableBinaryRelation {A} (r : A -> A -> Prop) := {
  decide_binary_relation : A -> A -> bool;
  DecidableBinaryRelation_spec : forall a b, reflect (r a b) (decide_binary_relation a b);
}.

Class TotalOrder {A} (r : A -> A -> Prop) := {
  TotalOrder_DecidableBinaryRelation :> DecidableBinaryRelation r;
  TotalOrder_reflexivity : forall a, r a a;
  TotalOrder_transitivity : forall a b c, r a b -> r b c -> r a c;
  TotalOrder_antisymmetry : forall a b, r a b -> r b a -> a = b;
  TotalOrder_totality : forall a b, r a b \/ r b a;
}.

Coercion TotalOrder_DecidableBinaryRelation : TotalOrder >-> DecidableBinaryRelation.

Class CostTotalOrder {A} (r : A -> A -> Prop) := {
  CostTotalOrder_TotalOrder :> TotalOrder r;
  CostTotalOrder_cost : Cost (Signature [_; _] _) decide_binary_relation;
}.

Coercion CostTotalOrder_TotalOrder : CostTotalOrder >-> TotalOrder.

Class CostConstantTotalOrder {A} (r : A -> A -> Prop) := {
  CostConstantTotalOrder_CostTotalOrder :> CostTotalOrder r;
  CostConstantTotalOrder_cost_constant : binary_cost_constant CostTotalOrder_cost;
}.

Coercion CostConstantTotalOrder_CostTotalOrder : CostConstantTotalOrder >-> CostTotalOrder.

#[export, program] Instance nat_le_DecidableBinaryRelation : DecidableBinaryRelation Nat.le := {
  decide_binary_relation := Nat.leb;
}.
Next Obligation.
  apply Nat.leb_spec0.
Qed.

#[export, program] Instance nat_le_TotalOrder : TotalOrder Nat.le.
Next Obligation.
  lia.
Qed.
Next Obligation.
  lia.
Qed.
Next Obligation.
  lia.
Qed.

#[export, program] Instance nat_leb_Cost : Cost (Signature [_; _] _) Nat.leb := {
  cost_fun := fun _ _ => 1;
}.

#[export, program] Instance nat_le_CostTotalOrder : CostTotalOrder Nat.le.

#[export, program] Instance nat_le_CostConstantTotalOrder : CostConstantTotalOrder Nat.le.
Next Obligation.
  exists 1. intros ?. simpl. destruct a. lia.
Qed.

Fixpoint sorted {A} r {total_order : TotalOrder r} (l : list A) :=
  match l with
  | [] => True
  | x :: l' => (list_forall (fun y => r x y) l') /\ sorted r l'
  end.

Inductive locally_sorted {A} r {total_order : @TotalOrder A r} : list A -> Prop :=
  | locally_sorted_empty : locally_sorted r []
  | locally_sorted_single a : locally_sorted r [a]
  | locally_sorted_next a b l : r a b -> locally_sorted r (b :: l) -> locally_sorted r (a :: b :: l).

Theorem locally_sorted_iff_sorted :
   forall {A} r {total_order : TotalOrder r} (l : list A),
   locally_sorted r l <-> sorted r l.
 Proof.
  intros ? ? ? ?. split.
  - intros ?. induction H.
    + simpl. auto.
    + simpl. auto.
    + simpl. simpl in IHlocally_sorted. destruct IHlocally_sorted as (? & ?). repeat split.
      * auto.
      * eapply list_forall_positive.
        2: apply H1.
        eauto using TotalOrder_transitivity.
      * auto.
      * auto.
  - intros ?. induction l.
    + apply locally_sorted_empty.
    + simpl in H. destruct H as (? & ?). specialize (IHl H0). destruct l.
      * apply locally_sorted_single.
      * simpl in H. apply locally_sorted_next; intuition auto.
Qed.

Definition locally_sortedb {A} r {total_order : TotalOrder r} :=
  fix locally_sortedb (l : list A) :=
    match l with
    | [] => true
    | [_] => true
    | x :: ((y :: _) as l') => (@decide_binary_relation _ r _) x y && locally_sortedb l'
    end.

Theorem locally_sortedb_spec :
  forall {A} r {total_order : TotalOrder r} (l : list A),
  reflect (locally_sorted r l) (locally_sortedb r l).
Proof.
  intros ? ? ? ?. induction l.
  - simpl. apply ReflectT. apply locally_sorted_empty.
  - simpl. destruct l.
    + apply ReflectT. apply locally_sorted_single.
    + rename a0 into b. destruct (@DecidableBinaryRelation_spec _ r _ a b), IHl.
      * apply ReflectT. apply locally_sorted_next; auto.
      * apply ReflectF. intros ?. inversion H. auto.
      * apply ReflectF. intros ?. inversion H. auto.
      * apply ReflectF. intros ?. inversion H. auto.
Qed.

(*Definition simple_sortedb_cost {A} r {total_order : CostTotalOrder r} :=
  ltac2:(
    Cost.refine_compute_cost
    [
      (
        ('(@decide_binary_relation _ _ total_order), 2),
        '(@cost_fun _ _ (@CostTotalOrder_cost _ _ total_order))
      )
    ]
    1
    (eval red in (@simple_sortedb A r total_order))
    []
  ).

Theorem simple_sortedb_cost_linear_on_cost_constant_total_order :
  forall {A} r {total_order : CostConstantTotalOrder r},
  big_o
    (simple_sortedb_cost r)
    (fun (l : list A) => 1 + length l).
Proof.
  intros ? ? ?. destruct total_order as (total_order & (c & H)). exists (c + 18). intros l. induction l.
  - simpl. lia.
  - simpl. destruct l.
    + lia.
    + rename a0 into b. unfold CostConstantTotalOrder_CostTotalOrder in IHl.
      specialize (H (a, b)). simpl in H. lia.
Qed.*)

Definition is_sorter {A} r {total_order : TotalOrder r} f :=
  forall (l : list A), is_permutation (f l) l /\ sorted r (f l).

Theorem sorted_equal :
  forall {A} r {total_order : TotalOrder r} (l1 l2 : list A),
  sorted r l1 ->
  sorted r l2 ->
  is_permutation l1 l2 ->
  l1 = l2.
Proof.
  intros ? ? ? ? ? ? ? ?. rewrite <- locally_sorted_iff_sorted in H, H0.
  generalize dependent l1. induction H0; intros l1 ? ?.
  - inversion H; clear H; subst l1.
    + auto.
    + apply permutation_empty_inversion in H1. discriminate H1.
    + apply permutation_empty_inversion in H1. discriminate H1.
  - inversion H; clear H; subst l1.
    + apply is_permutation_sym in H1. apply permutation_empty_inversion in H1. discriminate.
    + apply permutation_single_inversion' in H1. subst a0. auto.
    + apply permutation_single_inversion in H1. discriminate.
  - inversion H1; clear H1; subst l1.
    + apply is_permutation_sym in H2. apply permutation_empty_inversion in H2. discriminate.
    + apply is_permutation_sym in H2. apply permutation_single_inversion in H2. discriminate.
    + specialize (IHlocally_sorted (b0 :: l0) H4).

  setoid_rewrite -> (locally_sorted_iff_sorted r).
  intros ? ? ? l1 l2 ? ? ?. generalize dependent l1. induction H0; intros l1 ? ?.
  - inversion H; clear H; subst l1.
    + auto.
    + apply permutation_empty_inversion in H1. discriminate H1.
    + apply permutation_empty_inversion in H1. discriminate H1.
  - inversion H; clear H; subst l1.
    + apply is_permutation_sym in H1. apply permutation_empty_inversion in H1. discriminate.
    + apply permutation_single_inversion' in H1. subst a0. auto.
    + apply permutation_single_inversion in H1. discriminate.
  - inversion H1; clear H1; subst l1.
    + apply is_permutation_sym in H2. apply permutation_empty_inversion in H2. discriminate.
    + apply is_permutation_sym in H2. apply permutation_single_inversion in H2. discriminate.
    + specialize (IHsorted (b0 :: l0) H4).

  - subst l1. apply is_permutation_alt_is_permutation in H1. inversion H1.
  - subst l1. apply is_permutation_alt_is_permutation in H1. inversion H1. destruct l1; discriminate.
  - subst l1.
apply app_permutation_inversion with (l3 := []) (l4 := []) in H1. admit. apply permutation_same_head in H1.
  intros ? ? ? l1 l2 ? ? ?. induction H; inversion H0.
  - auto.
  - subst l2. inversion H1. subst.

Lemma sorted_equal_cons :
  forall {A} r {total_order : TotalOrder r} a b (l1 l2 : list A),
  sorted r (a :: l1) ->
  sorted r (b :: l2) ->
  is_permutation (a :: l1) (b :: l2) ->
  a = b /\ is_permutation l1 l2.
Proof.
  intros ? ? ? a b l1 l2 ? ? ?.
  destruct H as (? & ?), H0 as (? & ?). clear H2 H3.
  assert (r a b). {
    apply is_permutation_alt_is_permutation in H1.
    inversion H1. subst a0 l4. destruct l0.
    - simpl in H2. injection H2 as -> ->. apply TotalOrder_reflexivity.
    - injection H2 as -> <-. apply list_forall_app in H. simpl in H. intuition auto.
  }
  assert (r b a). {
    apply is_permutation_sym in H1. apply is_permutation_alt_is_permutation in H1.
    inversion H1. subst a0 l4. destruct l0.
    - simpl in H3. injection H3 as -> ->. apply TotalOrder_reflexivity.
    - injection H3 as -> <-. apply list_forall_app in H0. simpl in H0. intuition auto.
  }
  assert (a = b) by (apply (@TotalOrder_antisymmetry _ r _); auto).
  split.
  - apply H4.
  - subst b. apply permutation_same_head with a. auto.
Qed.

Theorem sorted_equal :
  forall {A} r {total_order : TotalOrder r} (l1 l2 : list A),
  sorted r l1 ->
  sorted r l2 ->
  is_permutation l1 l2 ->
  l1 = l2.
Proof.
  intros ? ? ? l1 l2 ? ? ?. generalize dependent l2. induction l1; intros l2 ? ?.
  - symmetry. apply permutation_empty. apply is_permutation_sym. auto.
  - destruct l2.
    + apply permutation_empty. auto.
    + rename a0 into b. specialize (sorted_equal_cons _ _ _ _ _ H H0 H1) as (? & ?). f_equal.
      * auto.
      * destruct H as (? & ?), H0 as (? & ?). apply IHl1; auto.
Qed.

Theorem sorter_fully_defined :
  forall {A} r {total_order : TotalOrder r} f1 f2,
  is_sorter r f1 ->
  is_sorter r f2 ->
  forall (l : list A), f1 l = f2 l.
Proof.
  unfold is_sorter. intros ? ? ? ? ? ? ? ?.
  specialize (H l). specialize (H0 l). destruct H as (? & ?), H0 as (? & ?).
  apply (sorted_equal r).
  - auto.
  - auto.
  - apply is_permutation_trans with l.
    + auto.
    + apply is_permutation_sym. auto.
Qed.

Definition insert_sorted {A} r {total_order : TotalOrder r} :=
  fix insert_sorted a (l : list A) :=
    match l with
    | [] => [a]
    | x :: l' =>
      if (@decide_binary_relation _ r _) a x
      then a :: x :: l'
      else x :: (insert_sorted a l')
    end.

Theorem insert_sorted_correct :
  forall {A} r {total_order : TotalOrder r} a (l : list A),
  sorted r l ->
  is_permutation (insert_sorted r a l) (a :: l) /\ sorted r (insert_sorted r a l).
Proof.
  intros ? ? ? ? ? ?. induction l.
  - simpl. split.
    + apply is_permutation_add. apply is_permutation_empty.
    + auto.
  - rename a0 into b. destruct H as (? & ?). apply IHl in H0 as ?. destruct H1 as (? & ?).
    simpl. destruct (@DecidableBinaryRelation_spec _ r _ a b).
    + split.
      * apply is_permutation_refl.
      * simpl. repeat split.
        -- auto.
        -- eapply list_forall_positive.
           2: apply H.
           eauto using TotalOrder_transitivity.
        -- auto.
        -- auto.
    + split.
      * apply is_permutation_trans with (b :: a :: l).
        -- apply is_permutation_add. auto.
        -- apply is_permutation_swap.
      * simpl. split.
        -- apply list_forall_permutation with (a :: l).
           ++ apply is_permutation_sym. auto.
           ++ simpl. split.
              ** destruct (@TotalOrder_totality _ r _ a b); intuition auto.
              ** auto.
        -- auto.
Qed.

Definition insert_sorted_cost {A} r {total_order : CostTotalOrder r} :=
  ltac2:(
    Cost.refine_compute_cost
    [
      (
        ('(@decide_binary_relation _ _ total_order), 2),
        '(@cost_fun _ _ (@CostTotalOrder_cost _ _ total_order))
      )
    ]
    2
    (eval red in (@insert_sorted A r total_order))
    []
  ).

Theorem insert_sorted_cost_linear_on_cost_constant_total_order :
  forall {A} r {total_order : CostConstantTotalOrder r},
  big_o
    (fun '(a, l) => insert_sorted_cost r a l)
    (fun '(_, l) => 1 + length (l : list A)).
Proof.
  intros ? ? ?. destruct total_order as (total_order & (c & H)). exists (c + 19). intros (a, l). induction l.
  - simpl. lia.
  - rename a0 into b. unfold CostConstantTotalOrder_CostTotalOrder in IHl. simpl. specialize (H (a, b)).
    destruct (@DecidableBinaryRelation_spec _ r _ a b); lia.
Qed.

Theorem insert_sorted_cost_constant_on_cost_constant_total_order_and_first_place :
  forall {A} r {total_order : CostConstantTotalOrder r},
  constant
    (fun (p : {'(a, l) | list_forall (fun b => r a b) (l : list A)}) =>
      let 'exist _ (a, l) _ := p in
        insert_sorted_cost r a l
    ).
Proof.
  intros ? ? ?. destruct total_order as (total_order & (c & H0)). exists (c + 21). intros ((a, l), H). destruct l.
  - simpl. lia.
  - rename a0 into b. simpl. specialize (H0 (a, b)). destruct (@DecidableBinaryRelation_spec _ r _ a b).
    + lia.
    + simpl in H. intuition auto.
Qed.

Definition insertion_sort {A} r {total_order : TotalOrder r} :=
  fix insertion_sort (l : list A) :=
    match l with
    | [] => []
    | x :: l' => insert_sorted r x (insertion_sort l')
    end.

Theorem insertion_sort_correct :
  forall {A} (r : A -> A -> Prop) {total_order : TotalOrder r}, is_sorter r (insertion_sort r).
Proof.
  unfold is_sorter. intros ? ? ? ?. induction l.
  - simpl. auto using is_permutation_empty.
  - simpl. destruct IHl as (IHl1 & IHl2).
    specialize (insert_sorted_correct r a (insertion_sort r l) IHl2) as (? & ?).
    split.
    + apply is_permutation_trans with (a :: (insertion_sort r l)).
      * auto.
      * apply is_permutation_add. auto.
    + auto.
Qed.

Definition insertion_sort_cost {A} r {total_order : CostTotalOrder r} :=
  ltac2:(
    Cost.refine_compute_cost
    [
      (
        ('(@insert_sorted A r total_order), 2),
        '(@insert_sorted_cost A r total_order)
      )
    ]
    1
    (eval red in (@insertion_sort A r total_order))
    ['(@insertion_sort A r total_order)]
  ).

Theorem insertion_sort_cost_quadratic_on_cost_constant_total_order :
  forall {A} r {total_order : CostConstantTotalOrder r},
  big_o
    (insertion_sort_cost r)
    (fun (l : list A) => 1 + (length l) * (length l)).
Proof.
  intros ? ? ?. destruct (insert_sorted_cost_linear_on_cost_constant_total_order r) as (c & H).
  exists (c + 10). intros l. induction l.
  - simpl. lia.
  - simpl.
    specialize (H (a, insertion_sort r l)). simpl in H.
    replace (length (insertion_sort r l))
      with (length l)
      in H
      by (apply permutation_length; apply insertion_sort_correct).
    lia.
Qed.

Theorem insertion_sort_cost_linear_on_cost_constant_total_order_and_list :
  forall {A} r {total_order : CostConstantTotalOrder r},
  big_o
    (fun (p : {l | sorted r l}) => let 'exist _ l _ := p in insertion_sort_cost r l)
    (fun p => let 'exist _ l _ := p in 1 + length (l : list A)).
Proof.
  intros ? ? ?. destruct (insert_sorted_cost_constant_on_cost_constant_total_order_and_first_place r) as (c & H).
  exists (c + 10). intros (l, H0). induction l.
  - simpl. lia.
  - simpl in H0. destruct H0 as (? & ?). apply IHl in H1. clear IHl. simpl.
    apply list_forall_permutation with (l2 := insertion_sort r l) in H0.
    + specialize (H ltac:(exists (a, (insertion_sort r l)); auto)). simpl in H. lia.
    + apply is_permutation_sym. apply insertion_sort_correct.
Qed.

Section Example.

Compute insertion_sort_cost _ [1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1].
Compute insertion_sort_cost _ [1; 2; 3; 4; 5; 6; 7; 8; 9; 10].
Compute insertion_sort_cost _ [10; 9; 8; 7; 6; 5; 4; 3; 2; 1].
Compute insertion_sort_cost _ [20; 19; 18; 17; 16; 15; 14; 13; 12; 11; 10; 9; 8; 7; 6; 5; 4; 3; 2; 1].

End Example.


Require Import Rel.Definitions.
Require Import Lang.BindingsFacts.

Section section_compat_val_var.

Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (P : HV → F).
Context (Γ : V → ty EV HV ∅).
Context (x : V).

Lemma compat_val_var n :
n ⊨ ⟦ Ξ P Γ ⊢ (val_var x) ≼ˡᵒᵍᵥ (val_var x) : (Γ x) ⟧.
Proof.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hρ ; iintro Hγ.

ispecialize Hγ x.
repeat erewrite V_bind_map_hd, V_bind_hd_id, V_map_hd_id ; crush.
Qed.

End section_compat_val_var.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import Language Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.

Set Printing Parentheses.

(** * Definitions *)

(** ** Arguments *)

Inductive arg :=
| Avt : type -> arg
| Alt : label -> arg.

(** ** Applicative Subtyping (Binary) *)

Inductive auxas : option arg -> type -> Prop :=
| Aas_Refl : forall A,
    auxas None A
| Aas_Arr : forall A B C,
    sub C A ->
    auxas (Some (Avt C)) (Arr A B)
| Aas_Lbl : forall A l,
    auxas (Some (Alt l)) (Rcd l A)
| Aas_And_L : forall A B S,
    auxas (Some S) A ->
    auxas (Some S) (And A B)
| Aas_And_R : forall A B S,
    auxas (Some S) B ->
    auxas (Some S) (And A B).

Hint Constructors auxas : core.
Notation "appsub? S A" := (auxas S A) (at level 40).

(** ** Applicative Subtyping *)

Inductive appsub : option arg -> type -> type -> Prop :=
| As_Refl : forall A,
    appsub None A A
| As_Arr : forall A B C,
    sub C A ->
    appsub (Some (Avt C)) (Arr A B) B
| As_Lbl : forall A l,
    appsub (Some (Alt l)) (Rcd l A) A
| As_And_L : forall A B S C,
    appsub (Some S) A C ->
    not (auxas (Some S) B) ->
    appsub (Some S) (And A B) C
| As_And_R : forall A B S C,
    appsub (Some S) B C ->
    not (auxas (Some S) A) ->
    appsub (Some S) (And A B) C
| As_And_P : forall A B S C1 C2,
    appsub (Some S) A C1 ->
    appsub (Some S) B C2 ->
    appsub (Some S) (And A B) (And C1 C2).

Hint Constructors appsub : core.
Notation "S ⊢ A <: B" := (appsub S A B) (at level 40).

(** * Automations *)

(** ** Structural Inversions *)

Ltac solve_auxas :=
  match goal with
  | [H: auxas _ Int |- _] => (inversion H)
  | [H: auxas _ Top |- _] => (inversion H)
  | [H: auxas (Some (Avt _)) (Rcd _ _) |- _] => (inversion H)
  | [H: auxas (Some (Alt _)) (Arr _ _) |- _] => (inversion H)
  end.

Ltac solve_appsub :=
  match goal with
  | [H: appsub _ Int _ |- _] => (inversion H)
  | [H: appsub _ Top _ |- _] => (inversion H)
  | [H: appsub (Some (Avt _)) (Rcd _ _) _ |- _] => (inversion H)
  | [H: appsub (Some (Alt _)) (Arr _ _) _ |- _] => (inversion H)
  end.

Hint Extern 5 => solve_auxas : core.
Hint Extern 5 => solve_appsub : core.

(** ** Contradictions *)

Lemma appsub_to_auxas :
  forall A B S,
    appsub S A B ->
    auxas S A.
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Hint Resolve appsub_to_auxas : core.

Lemma auxas_false :
  forall A B S,
    not (auxas S A) ->
    appsub S A B ->
    False.
Proof.
  intros.
  eapply appsub_to_auxas in H0.
  contradiction.
Qed.

Ltac contra_appsub :=
  match goal with
  | [H1: not (auxas ?S ?A), H2: appsub ?S ?A _ |- _] =>
      (pose proof (auxas_false _ _ _ H1 H2) as Contra; inversion Contra)
  | [H1: not (auxas ?S ?A), H2: auxas ?S ?A |- _] =>
      (contradiction)
  end.

Hint Extern 5 => contra_appsub : core.

(** * Properties *)

(** ** Determinism *)

Lemma appsub_determinism :
  forall A B1 B2 S,
    appsub S A B1 ->
    appsub S A B2 ->
    B1 = B2.
Proof.
  introv As1 As2. gen B2.
  dependent induction As1; intros;
    dependent destruction As2; eauto.
  pose proof (IHAs1_1 _ As2_1).
  pose proof (IHAs1_2 _ As2_2).
  congruence.
Qed.

(** * Appsub & Isomorphic Subtyping *)

(** ** Inversion Lemmas *)

Lemma appsub_split_inversion :
  forall A B C B1 B2,
    appsub (Some A) B C ->
    splitable B B1 B2 ->
    (appsub (Some A) B1 C) /\ (not (auxas (Some A) B2)) \/
      (appsub (Some A) B2 C) /\ (not (auxas (Some A) B1)) \/
      (exists C1 C2, (appsub (Some A) B1 C1) /\ (appsub (Some A) B2 C2) /\ (isosub (And C1 C2) C)).
Proof.
  introv Has Hspl.
  gen A C B1 B2.
  proper_ind B; intros; eauto. subst_splitable.
  dependent destruction Hspl; eauto.
  - Case "And".
    dependent destruction Has; eauto.
    right. right. exists C1. exists C2.
    split; eauto.
  - Case "Arr".
    right. right.
    dependent destruction Has.
    pose proof (As_Arr _ B1 _ H) as As1.
    pose proof (As_Arr _ B2 _ H) as As2.
    pose proof (IHPr1 _ _ As1).
    pose proof (IHPr2 _ _ As2).
    dependent destruction Hspl.
    * exists A0. exists B. split; eauto.
    * exists (Arr A0 B1). exists (Arr A0 B2). split; eauto.
    * exists (Rcd l A1). exists (Rcd l A2). split; eauto.
  - Case "Rcd".
    right. right.
    dependent induction Has.
    exists A1. exists A2. split; eauto.
Qed.

(** ** Arguments *)

Lemma auxas_iso_v1 :
  forall A B H,
    auxas (Some (Avt A)) B ->
    isosub A H ->
    auxas (Some (Avt H)) B.
Proof.
  introv Aas Isub.
  gen A H.
  proper_ind B; intros; eauto.
  - Case "Arr".
    dependent destruction Aas.
    pose proof (isosub_sound _ _ Isub) as Isub'.
    destruct Isub'.
    eapply Aas_Arr.
    eapply sub_transitivity; eauto.
  - Case "Split".
    dependent destruction Aas.
    + econstructor.
      eapply isosub_to_sub2 in Isub.
      eapply sub_transitivity; eauto.
    + dependent destruction H; eauto.
    + dependent destruction H; eauto.
Qed.

Lemma appsub_iso_v1 :
  forall A B C H,
    appsub (Some (Avt A)) B C ->
    isosub H A ->
    exists D, appsub (Some (Avt H)) B D /\ isosub D C.
Proof.
  introv As Isub.
  pose proof (isosub_to_sub1 _ _ Isub).
  exists C. split; eauto.
  dependent induction As.
  - eapply As_Arr; eauto.
    eapply sub_transitivity; eauto.
  - eapply As_And_L; eauto.
    intros Contra. eapply auxas_iso_v1 in Contra; eauto.
  - eapply As_And_R; eauto.
    intros Contra. eapply auxas_iso_v1 in Contra; eauto.
  - eapply As_And_P; eauto.
Qed.

(** ** Functions *)

Lemma auxas_iso_v2 :
  forall A B H,
    auxas (Some (Avt A)) B ->
    isosub B H ->
    auxas (Some (Avt A)) H.
Proof.
  introv As Isub. gen A H.
  proper_ind B; intros; eauto.
  - Case "Arr".
    dependent destruction Isub. eauto.
  - Case "Split".
    dependent destruction H.
    + SCase "And".
      dependent destruction Isub.
      * SSCase "Refl".
        assumption.
      * SSCase "Split".
        (* H have two cases: arrow and intersection *)
        dependent destruction H.
        ** SSSCase "And".
           dependent destruction As.
           *** pose proof (IHPr1 _ As _ Isub1). eauto.
           *** pose proof (IHPr2 _ As _ Isub2). eauto.
        ** SSSCase "Arr".
           eapply Aas_Arr; eauto.
           dependent destruction As.
           *** pose proof (IHPr1 _ As _ Isub1).
               dependent destruction H0; eauto.
           *** pose proof (IHPr2 _ As _ Isub2).
               dependent destruction H0; eauto.
        ** dependent destruction As.
           *** pose proof (IHPr1 _ As _ Isub1) as IH1. inversion IH1.
           *** pose proof (IHPr2 _ As _ Isub2) as IH2. inversion IH2.
    + SCase "Arr".
      dependent destruction Isub; eauto.
    + SCase "Rcd".
      inversion As.
Qed.

Lemma auxas_iso_l2 :
  forall A l H,
    auxas (Some (Alt l)) A ->
    isosub A H ->
    auxas (Some (Alt l)) H.
Proof.
  Proof.
  introv As Isub. gen l H.
  proper_ind A; intros; eauto.
  - Case "Fld".
    dependent destruction As.
    dependent destruction Isub; eauto.
  - Case "Split".
    dependent destruction H.
    + SCase "And".
      dependent destruction Isub.
      * SSCase "Refl".
        assumption.
      * SSCase "Split".
        (* H have two cases: arrow and intersection *)
        dependent destruction H.
        ** SSSCase "And".
           dependent destruction As.
           *** pose proof (IHPr1 _ As _ Isub1). eauto.
           *** pose proof (IHPr2 _ As _ Isub2). eauto.
        ** SSSCase "Arr".
           dependent destruction As.
           *** pose proof (IHPr1 _ As _ Isub1) as IH1. inversion IH1.
           *** pose proof (IHPr2 _ As _ Isub2) as IH2. inversion IH2.
        ** SSSCase "Lbl".
           dependent destruction As.
           *** pose proof (IHPr1 _ As _ Isub1) as IH1.
               dependent destruction IH1; eauto.
           *** pose proof (IHPr2 _ As _ Isub2) as IH2.
               dependent destruction IH2; eauto.
    + SCase "Arr".
      dependent destruction Isub; eauto.
    + SCase "Rcd".
      dependent destruction As; eauto.
      dependent destruction Isub; eauto.
Qed.

Lemma appsub_iso_v2 :
  forall A B C H,
    appsub (Some (Avt A)) B C ->
    isosub H B ->
    (exists D, appsub (Some (Avt A)) H D /\ isosub D C).
Proof.
  introv As Isub. gen A C H.
  proper_ind B; intros; eauto.
  - Case "Arrow".
    dependent destruction Isub; eauto.
  - Case "Split".
    dependent destruction Isub; eauto.
    subst_splitable.
    eapply appsub_split_inversion in H0; eauto.
    destruct H0.
    + SCase "L".
      destruct H.
      pose proof (IHPr1 _ _ H _ Isub1).
      destruct H1. destruct H1.
      exists x. split; eauto. eapply As_And_L; eauto.
      intros Hcontra. eapply auxas_iso_v2 in Hcontra; eauto.
    + destruct H.
      * SCase "R".
        destruct H.
        pose proof (IHPr2 _ _ H _ Isub2).
        destruct H1. destruct H1.
        exists x. split; eauto. eapply As_And_R; eauto.
        intros Hcontra. eapply auxas_iso_v2 in Hcontra; eauto.
      * SCase "P".
        destruct H. destruct H. destruct H. destruct H0.
        pose proof (IHPr1 _ _ H _ Isub1).
        pose proof (IHPr2 _ _ H0 _ Isub2).
        destruct H2. destruct H2. destruct H3. destruct H3.
        exists (And x1 x2). split.
        ** eapply As_And_P; eauto.
        ** assert (isosub (And x1 x2) (And x x0)) by eauto.
           eapply isosub_transitivity; eauto.
Qed.

Lemma appsub_iso_l2 :
  forall A B H l,
    appsub (Some (Alt l)) A B ->
    isosub H A ->
    (exists C, appsub (Some (Alt l)) H C /\ isosub C B).
Proof.
  introv As Isub. gen B H l.
  proper_ind A; intros; eauto.
  - Case "Fld".
    dependent destruction As; eauto.
    dependent destruction Isub; eauto.
  - Case "Split".
    dependent destruction Isub; eauto.
    dependent destruction As; eauto.
    subst_splitable.
    eapply appsub_split_inversion in H0; eauto.
    destruct H0.
    + SCase "L".
      destruct H.
      pose proof (IHPr1 _ _ Isub1 _ H).
      destruct H1. destruct H1.
      exists x. split; eauto. eapply As_And_L; eauto.
      intros Hcontra. eapply auxas_iso_l2 in Hcontra; eauto.
    + destruct H.
      * SCase "R".
        destruct H.
        pose proof (IHPr2 _ _ Isub2 _ H).
        destruct H1. destruct H1.
        exists x. split; eauto. eapply As_And_R; eauto.
        intros Hcontra. eapply auxas_iso_l2 in Hcontra; eauto.
      * SCase "P".
        destruct H. destruct H. destruct H. destruct H0.
        pose proof (IHPr1 _ _ Isub1 _ H).
        pose proof (IHPr2 _ _ Isub2 _ H0).
        destruct H2. destruct H2. destruct H3. destruct H3.
        exists (And x1 x2). split.
        ** eapply As_And_P; eauto.
        ** assert (isosub (And x1 x2) (And x x0)) by eauto.
           eapply isosub_transitivity; eauto.
Qed.

(** ** Generalization *)

Lemma appsub_iso_v :
  forall A B C H1 H2,
    appsub (Some (Avt A)) B C ->
    isosub H1 A ->
    isosub H2 B ->
    (exists D, appsub (Some (Avt H1)) H2 D /\ isosub D C).
Proof.
  introv As Isub1 Isub2.
  pose proof (appsub_iso_v1 A B C H1 As Isub1) as Iso1.
  destruct Iso1. destruct H.
  pose proof (appsub_iso_v2 _ _ _ _ H Isub2).
  destruct_conjs. eexists. split; eauto.
  eapply isosub_transitivity; eauto.
Qed.

Lemma appsub_iso_l :
  forall A B H l,
    appsub (Some (Alt l)) A B ->
    isosub H A ->
    (exists C, appsub (Some (Alt l)) H C /\ isosub C B).
Proof.
  eapply appsub_iso_l2.
Qed.

(** * Function Definition *)

(** psub can be viewed as a simplified func version of appsub *)

Axiom dec_sub : forall A B, sumbool (sub A B) (not (sub A B)).

Fixpoint psub (A : type) (S : arg) : option type :=
  match A, S with
  | Arr A1 A2, (Avt B) => if dec_sub B A1 then Some A2 else None
  | Rcd l1 A1, (Alt l2) => if eq_nat_dec l1 l2 then Some A1 else None
  | And A1 A2, _ =>
    match psub A1 S, psub A2 S with
    | Some C1, Some C2 => Some (And C1 C2)
    | Some C1, _       => Some C1
    | _, Some C2       => Some C2
    | _,_              => None
    end
  | _, _ => None
  end.

Require Import FunInd FMapInterface.
Functional Scheme psub_ind := Induction for psub Sort Prop.

(** ** Soundness *)

Lemma psub_none_auxas1:
  forall A S,
    psub A S = None ->
    ~ auxas (Some S) A.
Proof.
  introv Ps.
  functional induction (psub A S); eauto; try (inversion Ps).
  - intros Contra. dependent destruction Contra. contradiction.
  - intros Contra. dependent destruction Contra; eauto.
    + pose proof (IHo e0). contradiction.
    + pose proof (IHo0 e1). contradiction.
  - intros Contra. dependent destruction Contra. contradiction.
Qed.

Lemma auxas_not_and :
  forall S A1 A2,
    ~ auxas (Some S) (And A1 A2) ->
    ~ auxas (Some S) A1 /\ ~ auxas (Some S) A2.
Proof.
  introv nAux.
  split.
  - intros Contra.
    assert (auxas (Some S) (And A1 A2)) by eauto. contradiction.
  - intros Contra.
    assert (auxas (Some S) (And A1 A2)) by eauto. contradiction.
Qed.

Lemma psub_none_auxas2:
  forall A S,
    ~ auxas (Some S) A ->
    psub A S = None.
Proof.
  induction A; introv nAux; simpl; eauto.
  - induction S; eauto.
    destruct (dec_sub t A1); eauto.
    destruct nAux. auto.
  - eapply auxas_not_and in nAux. destruct nAux; eauto.
    pose proof (IHA1 _ H).
    pose proof (IHA2 _ H0).
    rewrite H1. rewrite H2. auto.
  - induction S; eauto.
    destruct (eq_nat_dec l l0); eauto. subst.
    destruct nAux. eauto.
Qed.

Lemma psub_sound_appsub :
  forall A S B,
    psub A S = Some B ->
    appsub (Some S) A B.
Proof.
  introv Ps. gen B.
  functional induction (psub A S); intros; try (inversion Ps).
  - dependent destruction Ps. eauto.
  - dependent destruction Ps. eauto.
  - dependent destruction Ps; eauto.
    eapply As_And_L; eauto. eapply psub_none_auxas1; eauto.
  - dependent destruction Ps; eauto.
    eapply As_And_R; eauto. eapply psub_none_auxas1; eauto.
  - dependent destruction Ps; eauto.
Qed.

Lemma psub_sound_auxas :
  forall A S,
    psub A S <> None ->
    auxas (Some S) A.
Proof.
  introv Ps.
  functional induction (psub A S); intros; try solve [inversion Ps | destruct Ps; eauto | eauto].
  - eapply Aas_And_L. eapply IHo. unfold not. intros. destruct (psub A1 S). inversion H. inversion e0.
  - eapply Aas_And_L. eapply IHo. unfold not. intros. destruct (psub A1 S). inversion H. inversion e0.
  - eapply Aas_And_R. eapply IHo0. unfold not. intros. destruct (psub A2 S). inversion H. inversion e1.
Qed.

(** ** Completeness *)

Lemma psub_complete_appsub :
  forall A S B,
    appsub (Some S) A B ->
    psub A S = Some B.
Proof.
  introv As.
  dependent induction As.
  - simpl. destruct (dec_sub C A); eauto. contradiction.
  - simpl. destruct (eq_nat_dec l l); eauto. contradiction.
  - simpl. pose proof (IHAs _ eq_refl). rewrite H0.
    eapply psub_none_auxas2 in H. rewrite H. auto.
  - simpl. pose proof (IHAs _ eq_refl). rewrite H0.
    eapply psub_none_auxas2 in H. rewrite H. auto.
  - simpl. pose proof (IHAs1 _ eq_refl). rewrite H.
    simpl. pose proof (IHAs2 _ eq_refl). rewrite H0.
    auto.
Qed.

(** ** Automations *)

Lemma psub_appsub_false :
  forall A S B,
    psub A S = None ->
    appsub (Some S) A B ->
    False.
Proof.
  introv Ps As.
  eapply psub_none_auxas1 in Ps.
  eauto.
Qed.

Lemma psub_auxas_false :
  forall A S,
    psub A S <> None ->
    ~ auxas (Some S) A ->
    False.
Proof.
  introv Ps nAux.
  destruct nAux.
  now eapply psub_sound_auxas.
Qed.

Ltac contra_psub :=
  match goal with
  | H1: psub ?A ?S = None, H2: appsub (Some ?S) ?A _ |- _ =>
      (pose proof (psub_appsub_false _ _ _ H1 H2) as Contra; inversion Contra)
  | H1: psub ?A ?S <> None, H2: ~ auxas (Some ?S) ?A |- _ =>
      (pose proof (psub_auxas_false _ _ H1 H2) as Contra; inversion Contra)
  end.

Hint Extern 5 => contra_psub : core.


Require Import List Peano_dec.

Require Import bigstep.
Require Import datatypes.

(**************** Preliminary definitions and proofs ***************)

Fixpoint proj_source (T:Spec) {struct T}: (list State) :=
         match T with | nil => nil
                      | (cons A T') =>
         match A with (p, a, r, x) => (cons p (proj_source T'))
         end end.

Fixpoint proj_target (T:Spec) {struct T}: (list State) :=
         match T with | nil => nil
                      | (cons A T') =>
         match A with (p, a, r, x) => (cons r (proj_target T'))
         end end.

Lemma eq_sym: forall a, (eqsym a a)=true.
induction a.
auto. auto. auto.
Qed.

Lemma neq_sym: forall a b, a<>b -> (eqsym a b)=false.
double induction a b; auto; intros.
contradiction H; auto. contradiction H; auto. contradiction H; auto.
Qed.

Lemma eq_sym_dec: forall a b:Sym, {a=b} + {a<>b}.
destruct a; destruct b; auto.
right; discriminate. right; discriminate.
right; discriminate. right; discriminate.
right; discriminate. right; discriminate.
Qed.

Lemma eq_state: forall p, (eqstate p p)=true.
induction p.
auto. simpl. assumption.
Qed.

Lemma neq_state: forall p q, p<>q -> (eqstate p q)=false.
double induction p q; auto; intros.
contradiction H; auto.
simpl. apply H0. auto.
Qed.

(**************** Join properties about CONVERGENCE ***************)

(* Auxiliary lemma 1: if M stops with the current configuration C,
                      then M::N makes the same first step as N with C
*)

Lemma move_preserves_halt_app: forall M p a,
      tr M p a = None ->
      forall N,
      tr N p a = tr (app M N) p a.
induction M; intros.

simpl. reflexivity.

destruct a. destruct p0. destruct p0. simpl in H |- *.
elim (PeanoNat.Nat.eq_dec p s0); intro.
elim (eq_sym_dec a0 s1); intro.

rewrite a, a1 in H.
rewrite eq_state in H. rewrite eq_sym in H.
inversion H.

rewrite <- a in H |- *.
rewrite eq_state in H |- *. rewrite neq_sym in H |- *.
apply IHM. assumption. auto. auto.

rewrite neq_state in H |- *.
apply IHM. assumption. assumption. assumption.
Qed.

(* Auxiliary lemma 2: if M does not stop with the current C,
                      then M::N the same first step as M with C
*)

Lemma move_preserves_app: forall M p a,
      tr M p a <> None ->
      forall N,
      tr M p a = tr (app M N) p a.
induction M; intros.

simpl in H. contradiction H. reflexivity.

destruct a. destruct p0. destruct p0. simpl in H |-*.
elim (PeanoNat.Nat.eq_dec p s0); intro.
elim (eq_sym_dec a0 s1); intro.

rewrite a, a1.
rewrite eq_state. rewrite eq_sym. reflexivity.

rewrite a in H |- *.
rewrite eq_state in H |- *. rewrite neq_sym in H |- *.
apply IHM. assumption. auto. auto.

rewrite neq_state in H |- *.
apply IHM. assumption. assumption. assumption.
Qed.

(* Auxiliary lemma 3: if M stops with the current configuration C
                      and its source states are not reachable from C,
                      then M::N makes the same computation as N with C
*)

Lemma derive_not_source: forall M i a,
      ~ In i (proj_source M) -> tr M i a=None.
induction M; intros.

simpl. reflexivity.

destruct a. destruct p. destruct p. simpl in H |- *.
assert (~s0=i /\ ~In i (proj_source M)). tauto.
inversion_clear H0; clear H.
elim (PeanoNat.Nat.eq_dec i s0); intro.

contradiction H1. auto.

rewrite neq_state.
apply IHM. assumption. assumption.
Qed.

Lemma derive_target: forall M p a i x,
      tr M p a=(Some (i, x)) -> In i (proj_target M).
induction M; intros.

simpl in H. inversion H.

destruct a. destruct p0. destruct p0. simpl in H |- *.
elim (PeanoNat.Nat.eq_dec p s0); intro.
elim (eq_sym_dec a0 s1); intro.

rewrite a, a1 in H.
rewrite eq_state in H. rewrite eq_sym in H.
inversion_clear H. tauto.

rewrite a in H.
rewrite eq_state in H. rewrite neq_sym in H.
right. apply IHM with s0 a0 x. assumption. auto.

rewrite neq_state in H.
right. apply IHM with p a0 x. assumption. assumption.
Qed.

Lemma bf_preserves_halt_app: forall M p s N,
      tr M p (read s) = None ->
      (forall i, In i (proj_target N) ->
                 ~In i (proj_source M)) ->
      forall t q,
      bf N s p t q -> bf (app M N) s p t q.
induction 3; intros.

(* halt *)

apply bfH.
unfold is_value. rewrite <- move_preserves_halt_app.
assumption. assumption.

(* move R *)

apply bfR with i.

rewrite <- move_preserves_halt_app.
assumption. assumption.

apply IHbf; clear IHbf.

assert (In i (proj_target T)).
apply derive_target with p (read (pair l r)) R. assumption.
assert (~ In i (proj_source M)). apply H0. assumption.
apply derive_not_source. assumption.
assumption.

(* move L *)

apply bfL with i.

rewrite <- move_preserves_halt_app.
assumption. assumption.

apply IHbf; clear IHbf.

assert (In i (proj_target T)).
apply derive_target with p (read (pair l r)) L. assumption.
assert (~ In i (proj_source M)). apply H0. assumption.
apply derive_not_source. assumption.
assumption.

(* write *)

apply bfW with i a.

rewrite <- move_preserves_halt_app.
assumption. assumption.

apply IHbf; clear IHbf.

assert (In i (proj_target T)).
apply derive_target with p (read (pair l r)) (W a). assumption.
assert (~ In i (proj_source M)). apply H0. assumption.
apply derive_not_source. assumption.
assumption.
Qed.

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

(* Main result: M and N may be joined
                provided M's source states cannot be reached from N
                once M has stopped
*)

Theorem join_stop: forall M p s t q N u r,
      bf M p s t q -> bf N t q u r ->
      (forall i, In i (proj_target N) ->
                 ~In i (proj_source M)) ->
      bf (app M N) p s u r.
induction 1; intros.

(*************** stop ***************)

apply bf_preserves_halt_app.
assumption. assumption. assumption.

(************* move R ***************)

apply bfR with i.

(* tr *)

rewrite <- move_preserves_app.
assumption.
rewrite H. discriminate.

(* induction *)

apply IHbf; assumption.

(************* move L ***************)

apply bfL with i.

(* tr *)

rewrite <- move_preserves_app.
assumption.
rewrite H. discriminate.

(* induction *)

apply IHbf; assumption.

(************* write ***************)

apply bfW with i a.

(* transition *)

rewrite <- move_preserves_app.
assumption.
rewrite H. discriminate.

(* induction *)

apply IHbf; assumption.
Qed.

(**************** Join properties about DIVERGENCE ***************)

(* Auxiliary lemma: similar to the convergence case
*)

Lemma bi_preserves_halt_app: forall M p s N,
      tr M p (read s) = None ->
      (forall i, In i (proj_target N) ->
                 ~In i (proj_source M)) ->
      bi N s p -> bi (app M N) s p.
cofix co_hp; intros.
inversion_clear H1 in H.

(* move R *)

apply biR with q.

rewrite <- move_preserves_halt_app.
assumption. assumption.

apply co_hp; clear co_hp.

assert (In q (proj_target N)).
apply derive_target with p (read (pair l r)) R. assumption.
assert (~ In q (proj_source M)). apply H0. assumption.
apply derive_not_source. assumption.
assumption.
assumption.

(* move L *)

apply biL with q.

rewrite <- move_preserves_halt_app.
assumption. assumption.

apply co_hp; clear co_hp.

assert (In q (proj_target N)).
apply derive_target with p (read (pair l r)) L. assumption.
assert (~ In q (proj_source M)). apply H0. assumption.
apply derive_not_source. assumption.
assumption.
assumption.

(* write *)

apply biW with q a.

rewrite <- move_preserves_halt_app.
assumption. assumption.

apply co_hp; clear co_hp.

assert (In q (proj_target N)).
apply derive_target with p (read (pair l r)) (W a). assumption.
assert (~ In q (proj_source M)). apply H0. assumption.
apply derive_not_source. assumption.
assumption.
assumption.
Qed.

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

(* Main result: M and N may be joined
                provided M's source states cannot be reached from N
                once M has stopped
*)

Theorem join_loop: forall M p s t q N,
      bf M p s t q -> bi N t q ->
      (forall i, In i (proj_target N) ->
                 ~In i (proj_source M)) ->
      bi (app M N) p s.
cofix co_hp; intros.
inversion_clear H in H0.

(*************** stop ***************)

apply bi_preserves_halt_app.
assumption. assumption. assumption.

(************* move R ***************)

apply biR with i.

(* transition *)

rewrite <- move_preserves_app.
assumption.
rewrite H2. discriminate.

(* coinduction *)

apply co_hp with t q; assumption.

(************* move L ***************)

apply biL with i.

(* transition *)

rewrite <- move_preserves_app.
assumption.
rewrite H2. discriminate.

(* coinduction *)

apply co_hp with t q; assumption.

(************* write ***************)

apply biW with i a.

(* transition *)

rewrite <- move_preserves_app.
assumption.
rewrite H2. discriminate.

(* coinduction *)

apply co_hp with t q; assumption.
Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

Require Import Ensembles.
Require Import Relations_1.
Require Import Partial_Order.
Require Import Cpo.
Require Import algpodefs.
Require Import Powerset.
Require Import lpo.
Require Import Constructive_sets.
Require Import Finite_sets.
Section more_lemmas.
Variable U : Type.
Variable B : Ensemble U.
Variable D : PO U.

Theorem Upper_Bound_is_in_Carrier :
 forall (X : Ensemble U) (bound : U),
 Included U X (Carrier_of U D) ->
 Upper_Bound U D X bound -> In U (Carrier_of U D) bound.
intros X bound H' H'0; elim H'0; auto with sets.
Qed.

Theorem Lower_Bound_is_in_Carrier :
 forall (X : Ensemble U) (bound : U),
 Included U X (Carrier_of U D) ->
 Lower_Bound U D X bound -> In U (Carrier_of U D) bound.
intros X bound H' H'0; elim H'0; auto with sets.
Qed.

Theorem Lub_is_unique :
 Conditionally_complete U D ->
 forall (C : Ensemble U) (bsup1 bsup2 : U),
 Lub U D C bsup1 -> Lub U D C bsup2 -> bsup1 = bsup2.
intros H' C bsup1 bsup2 H'0 H'1.
apply (Rel_of_antisymmetric U D); (elim H'1; elim H'0; auto with sets).
Qed.

Theorem Upper_Bound_Couple_intro :
 forall x y z : U,
 In U (Carrier_of U D) x ->
 In U (Carrier_of U D) y ->
 In U (Carrier_of U D) z ->
 Rel_of U D x z -> Rel_of U D y z -> Upper_Bound U D (Couple U x y) z.
intros x y z H' H'0 H'1 H'2 H'3.
apply Upper_Bound_definition; auto with sets.
intros y0 H'4; elim H'4; auto with sets.
Qed.
Hint Resolve Upper_Bound_Couple_intro.

Theorem Upper_Bound_Couple_inv :
 forall x y z : U,
 Upper_Bound U D (Couple U x y) z ->
 Rel_of U D x z /\ Rel_of U D y z /\ In U (Carrier_of U D) z.
intros x y z H'; elim H'; auto with sets.
Qed.

Theorem Upper_Bound_Singleton_intro :
 forall x z : U,
 In U (Carrier_of U D) x ->
 In U (Carrier_of U D) z -> x = z -> Upper_Bound U D (Singleton U x) z.
intros x z H' H'0 H'1; rewrite <- H'1.
apply Upper_Bound_definition; auto with sets.
intros y H'2; elim H'2; auto with sets.
Qed.
Hint Resolve Upper_Bound_Singleton_intro.

Theorem Upper_Bound_Singleton_inv :
 forall x z : U, Upper_Bound U D (Singleton U x) z -> Rel_of U D x z.
intros x z H'; elim H'; auto with sets.
Qed.
Hint Resolve Upper_Bound_Singleton_inv.

Theorem Non_empty_has_glb :
 Conditionally_complete U D ->
 forall X : Ensemble U,
 Included U X (Carrier_of U D) ->
 Inhabited U X -> exists binf : U, Glb U D X binf.
Proof.
intro H'; elim H'; clear H'.
intros H'0 X H'1 H'2.
generalize (Lower_Bound_is_in_Carrier X); intro L.
elim (H'0 (fun z : U => Lower_Bound U D X z)); auto with sets.
intros bsup H'3; elim H'3; intros H'4 H'6.
exists bsup; auto with sets.
apply Glb_definition; auto with sets.
apply Lower_Bound_definition; auto with sets.
apply Lub_is_in_Carrier with (X := fun z : U => Lower_Bound U D X z);
 auto with sets.
intros y H'7; apply H'6.
apply Upper_Bound_definition; auto with sets.
intros y0 H'8; elim H'8; auto with sets.
intros y H'7; elim H'7; auto with sets.
intros H'8 H'9; elim H'4; auto with sets.
elim H'2; intros x0 H'3; exists x0.
apply Upper_Bound_definition; auto with sets.
intros y H'4; elim H'4; auto with sets.
Qed.

Theorem Bounded_implies_consistent :
 forall X : Ensemble U,
 Included U X (Carrier_of U D) ->
 ex (fun maj : U => Upper_Bound U D X maj) -> Consistent U D X.
intros X H' H'0; elim H'0; intros maj E; try exact E; clear H'0.
red in |- *; simpl in |- *.
intros H'0 x y H'1; red in |- *; simpl in |- *.
intros H'2 H'3; exists maj; split.
elim E; auto with sets.
elim E; auto with sets.
Qed.

Theorem Consistent_downward_stable :
 forall B : Ensemble U,
 Included U B (Carrier_of U D) ->
 Consistent U D B ->
 forall A : Ensemble U, Included U A B -> Consistent U D A.
Proof.
auto 6 with sets.
Qed.

Lemma Consistent_triple_intro :
 forall x y z : U,
 Compatible U D x y ->
 Compatible U D y z -> Compatible U D x z -> Consistent U D (Triple U x y z).
intros x y z H' H'0 H'1; red in |- *; simpl in |- *.
intros H'2 x0 y0 H'3; try assumption.
red in H'3.
lapply (H'3 x0); [ intro H'5 | try assumption ]; auto with sets.
lapply (H'3 y0); [ intro H'6 | idtac ]; auto with sets.
clear H'3.
elim H'6; elim H'5; auto with sets.
Qed.
End more_lemmas.
Hint Resolve Upper_Bound_Couple_intro.
Hint Resolve Upper_Bound_Singleton_intro.
Hint Resolve Upper_Bound_Singleton_inv.
Hint Resolve Bounded_implies_consistent.


From mathcomp Require Import all_ssreflect all_fingroup all_algebra zmodp.
Import GroupScope Order.TTheory GRing.Theory Num.Theory.
Require Import utils algebra_ext matrix_ext.

(******************************************************************************)
(*  Linear rational arithmetic and Fourier-Motzkin variable elimination       *)
(******************************************************************************)

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

Section LRA.

Variable (R : realFieldType).

Section QFLRA.

Variable (dim : nat).

Inductive QFLRA_formula :=
  | QFLRA_neg   of QFLRA_formula
  | QFLRA_and   of QFLRA_formula & QFLRA_formula
  | QFLRA_or    of QFLRA_formula & QFLRA_formula
  | QFLRA_leq   of 'cV[R]_dim.

Fixpoint eq_QFLRA_formula (f1 f2 : QFLRA_formula) :=
  match f1, f2 with
    | QFLRA_neg f1', QFLRA_neg f2' => eq_QFLRA_formula f1' f2'
    | QFLRA_and f1l f1r, QFLRA_and f2l f2r =>
      eq_QFLRA_formula f1l f2l && eq_QFLRA_formula f1r f2r
    | QFLRA_or f1l f1r, QFLRA_or f2l f2r =>
      eq_QFLRA_formula f1l f2l && eq_QFLRA_formula f1r f2r
    | QFLRA_leq t1, QFLRA_leq t2 => t1 == t2
    | _, _ => false
  end.

Lemma eq_QFLRA_formulaP : Equality.axiom eq_QFLRA_formula.
Proof.
move=> f1 f2; apply/(iffP idP) => [| <-].
- by elim: f1 f2 =>
    [f1' IH | f1l IHl f1r IHr | f1l IHl f1r IHr | t1]
    [//= f2' /IH -> | | | //= t2 /eqP ->]
    //= f2l f2r /andP [] /IHl -> /IHr ->.
- by elim: f1 => //= [f1l -> | f1l ->] *; rewrite ?eqxx.
Defined.

Canonical QFLRA_formula_eqMixin := EqMixin eq_QFLRA_formulaP.
Canonical QFLRA_formula_eqType :=
  Eval hnf in EqType QFLRA_formula QFLRA_formula_eqMixin.

End QFLRA.

Inductive LRA_formula (dim : nat) :=
  | LRA_forall  of LRA_formula (1 + dim)
  | LRA_exists  of LRA_formula (1 + dim)
  | LRA_neg     of LRA_formula dim
  | LRA_and     of LRA_formula dim & LRA_formula dim
  | LRA_or      of LRA_formula dim & LRA_formula dim
  | LRA_imply   of LRA_formula dim & LRA_formula dim
  | LRA_leq     of 'cV[R]_dim.

Definition LRA_literal dim := [eqType of bool * 'cV[R]_dim].

Definition LRA_interpret_af dim (I f : 'cV[R]_dim) := ((f^T *m I) 0 0)%R.

Definition LRA_interpret_literal dim (I : 'cV_dim) (f : LRA_literal dim) :=
  (0%R < LRA_interpret_af I f.2 ?<= if f.1)%O.

Lemma LRA_af_recl dim (I f : 'cV_(1 + dim)) :
  LRA_interpret_af I f =
  (f 0 0 * I 0 0 + LRA_interpret_af (dsubmx I) (dsubmx f))%R.
Proof.
by rewrite /LRA_interpret_af -{1}(hsubmxK f^T) -{1}(vsubmxK I) mul_row_col
           2!mxE big_ord_recl big_ord0 3!mxE addr0 lshift0 trmx_dsub.
Qed.

Lemma LRA_interpret_af_add dim (I f1 f2 : 'cV_dim) :
  (LRA_interpret_af I (f1 + f2) =
   LRA_interpret_af I f1 + LRA_interpret_af I f2)%R.
Proof. by rewrite /LRA_interpret_af linearD mulmxDl mxE. Qed.

Lemma LRA_interpret_af_opp dim (I f : 'cV_dim) :
  (LRA_interpret_af I (- f) = - LRA_interpret_af I f)%R.
Proof. by rewrite /LRA_interpret_af linearN mulNmx mxE. Qed.

Fixpoint LRA_interpret_formula'
  dim (f : LRA_formula dim) : 'cV[R]_dim -> Prop :=
  match f with
  | LRA_forall f' => fun I =>
    forall x, LRA_interpret_formula' f' (col_mx (const_mx x) I)
  | LRA_exists f' => fun I =>
    exists x, LRA_interpret_formula' f' (col_mx (const_mx x) I)
  | LRA_neg f' => fun I => ~ LRA_interpret_formula' f' I
  | LRA_and f1 f2 => fun I =>
    LRA_interpret_formula' f1 I /\ LRA_interpret_formula' f2 I
  | LRA_or f1 f2 => fun I =>
    LRA_interpret_formula' f1 I \/ LRA_interpret_formula' f2 I
  | LRA_imply f1 f2 => fun I =>
    LRA_interpret_formula' f1 I -> LRA_interpret_formula' f2 I
  | LRA_leq t => fun I => (0 <= \sum_i t i 0 * I i 0)%R
  end.

Notation LRA_interpret_formula I f := (@LRA_interpret_formula' _ f I).

Fixpoint QFLRA_interpret_formula
  dim (I : 'cV_dim) (f : QFLRA_formula dim) : bool :=
  match f with
    | QFLRA_neg f       => ~~ QFLRA_interpret_formula I f
    | QFLRA_and f1 f2   => QFLRA_interpret_formula I f1 &&
                           QFLRA_interpret_formula I f2
    | QFLRA_or f1 f2    => QFLRA_interpret_formula I f1 ||
                           QFLRA_interpret_formula I f2
    | QFLRA_leq t       => (0 <= (t^T *m I) 0 0)%R
  end.

Definition QFLRA_top dim : QFLRA_formula dim := QFLRA_leq 0%R.
Arguments QFLRA_top {dim}.

Lemma QFLRA_top_true dim (I : 'cV_dim) : QFLRA_interpret_formula I QFLRA_top.
Proof. by rewrite /= trmx0 mul0mx mxE. Qed.

Definition QFLRA_bot dim : QFLRA_formula dim := QFLRA_neg QFLRA_top.
Arguments QFLRA_bot {dim}.

Lemma QFLRA_bot_false dim (I : 'cV_dim) :
  QFLRA_interpret_formula I QFLRA_bot = false.
Proof. by move: (QFLRA_top_true I) => /= ->. Qed.

Definition NF_neg dim (fss : seq (seq (LRA_literal dim))) :=
  [seq [seq (negb f.1, - f.2)%R | f : LRA_literal dim <- fs] |
   fs <- fss].

Lemma NF_neg_CNF dim (I : 'cV_dim) lss :
  has (all (LRA_interpret_literal I)) (NF_neg lss) =
  ~~ all (has (LRA_interpret_literal I)) lss.
Proof.
rewrite /NF_neg /LRA_interpret_literal -has_predC has_map.
apply/eq_in_has => /= afs _; rewrite -all_predC all_map.
apply/eq_in_all => -[f t] _ /=; rewrite lteifNE -lteif_opp2 oppr0.
by congr (~~ (_ < _ ?<= if _)%O); rewrite /LRA_interpret_af linearN mulNmx mxE.
Qed.

Lemma NF_neg_DNF dim (I : 'cV_dim) lss :
  all (has (LRA_interpret_literal I)) (NF_neg lss) =
  ~~ has (all (LRA_interpret_literal I)) lss.
Proof.
rewrite /NF_neg /LRA_interpret_literal -all_predC all_map.
apply/eq_in_all => /= afs _; rewrite -has_predC has_map.
apply/eq_in_has => -[f t] _ /=; rewrite lteifNE -lteif_opp2 oppr0.
by congr (~~ (_ < _ ?<= if _)%O); rewrite /LRA_interpret_af linearN mulNmx mxE.
Qed.

Fixpoint
  QFLRA_DNF dim (f : QFLRA_formula dim) : seq (seq (LRA_literal dim)) :=
  match f with
    | QFLRA_neg f' => NF_neg (QFLRA_CNF f')
    | QFLRA_and f1 f2 =>
      [seq fs1 ++ fs2 | fs1 <- QFLRA_DNF f1, fs2 <- QFLRA_DNF f2]
    | QFLRA_or f1 f2 => QFLRA_DNF f1 ++ QFLRA_DNF f2
    | QFLRA_leq f' => [:: [:: (true, f')]]
  end with
  QFLRA_CNF dim (f : QFLRA_formula dim) : seq (seq (LRA_literal dim)) :=
  match f with
    | QFLRA_neg f' => NF_neg (QFLRA_DNF f')
    | QFLRA_and f1 f2 => QFLRA_CNF f1 ++ QFLRA_CNF f2
    | QFLRA_or f1 f2 =>
      [seq fs1 ++ fs2 | fs1 <- QFLRA_CNF f1, fs2 <- QFLRA_CNF f2]
    | QFLRA_leq f' => [:: [:: (true, f')]]
  end.

Lemma QFLRA_NF_correctness dim (I : 'cV_dim) (f : QFLRA_formula dim) :
  (has (all (LRA_interpret_literal I)) (QFLRA_DNF f) =
     QFLRA_interpret_formula I f) *
  (all (has (LRA_interpret_literal I)) (QFLRA_CNF f) =
     QFLRA_interpret_formula I f).
Proof.
elim: f => /=.
- by move=> q [] {3}<- <-; rewrite NF_neg_CNF NF_neg_DNF.
- move=> q1 [] {2}<- <- q2 [] {2}<- <-; split; last by rewrite all_cat.
  elim: (QFLRA_DNF q1) => //= qs qss IH.
  rewrite has_cat {}IH andb_orl; congr orb.
  elim: (QFLRA_DNF q2); rewrite /= ?andbF => // qs' qss' IH.
  by rewrite all_cat {}IH andb_orr.
- move=> q1 [] {2}<- <- q2 [] {2}<- <-; split; first by rewrite has_cat.
  elim: (QFLRA_CNF q1) => //= qs qss IH.
  rewrite all_cat {}IH orb_andl; congr andb.
  elim: (QFLRA_CNF q2); rewrite /= ?orbT => // qs' qss' IH.
  by rewrite has_cat {}IH orb_andr.
- by move=> f; rewrite !andbT !orbF /=.
Qed.

Definition QFLRA_DNF_correctness dim (I : 'cV_dim) (f : QFLRA_formula dim) :=
  (QFLRA_NF_correctness I f).1.

Definition QFLRA_CNF_correctness dim (I : 'cV_dim) (f : QFLRA_formula dim) :=
  (QFLRA_NF_correctness I f).2.

Definition QFLRA_l2f dim (l : LRA_literal dim) :=
  if l.1 then QFLRA_leq l.2 else QFLRA_neg (QFLRA_leq (- l.2)%R).

Lemma QFLRA_l2f_correctness dim (I : 'cV_dim) (l : LRA_literal dim) :
  LRA_interpret_literal I l = QFLRA_interpret_formula I (QFLRA_l2f l).
Proof.
rewrite /QFLRA_l2f /LRA_interpret_literal; case: l.1 => //=.
rewrite -ltNge -subr_lt0 sub0r; congr (_ < _)%R.
by rewrite /LRA_interpret_af linearN mulNmx (mxE oppmx_key).
Qed.

Definition QFLRA_unDNF dim (lss : seq (seq (LRA_literal dim))) :=
  foldr (fun ls => QFLRA_or
                     (foldr (fun l => QFLRA_and (QFLRA_l2f l)) QFLRA_top ls))
        QFLRA_bot lss.

Lemma QFLRA_unDNF_correctness
  dim (I : 'cV_dim) (lss : seq (seq (LRA_literal dim))) :
  has (all (LRA_interpret_literal I)) lss =
  QFLRA_interpret_formula I (QFLRA_unDNF lss).
Proof.
elim: lss; first by rewrite /foldr QFLRA_bot_false.
move=> /= ls lss ->; congr orb.
elim: ls {lss}; first by rewrite /foldr QFLRA_top_true.
move=> /= l ls ->; congr andb; exact: QFLRA_l2f_correctness.
Qed.

Definition exists_conj_elim
  dim (ls : seq (LRA_literal (1 + dim))) : seq (LRA_literal dim) :=
  let lsp := [seq l : LRA_literal (1 + dim) <- ls | (0 < l.2 0 0)]%R in
    (* - (a_1 x_1 + ... + a_n x_n) <<= a_0 x_0 *)
  let lsn := [seq l : LRA_literal (1 + dim) <- ls | (0 > l.2 0 0)]%R in
    (* - b_0 x_0 <<= b_1 x_1 + ... + b_n x_n *)
  [seq (l.1, dsubmx l.2)
    | l : LRA_literal (1 + dim) <- ls & l.2 0 0 == 0]%R ++
  [seq (lp.1 && ln.1, lp.2 0 0 *: dsubmx ln.2 -
                      ln.2 0 0 *: dsubmx lp.2)%R
    | lp : LRA_literal (1 + dim) <- lsp, ln : LRA_literal (1 + dim) <- lsn]
  (*
       - (a_1 x_1 + ... + a_n x_n) <<= a_0 x_0 /\
       - b_0 x_0 <<= b_1 x_1 + ... + b_n x_n
  <=>  b_0 (a_1 x_1 + ... + a_n x_n) <<= a_0 (b_1 x_1 + ... + b_n x_n)
  <=>  0 <= (a_0 b_1 - b_0 a_1) x_1 + ... + (a_0 b_n - b_0 a_n) x_n
  *).

Definition literal_interval dim (I : 'cV_dim) (l : LRA_literal (1 + dim)) :=
  let r := (- LRA_interpret_af I (dsubmx l.2) / l.2 0 0)%R in
  if (l.2 0 0 == 0)%R
  then if LRA_interpret_literal I (l.1, dsubmx l.2) then
         `]-oo, +oo[%O else `]0%R, 0%R[%O
  else if (0 < l.2 0 0)%R then Interval (BSide l.1 r) (BInfty _ false)
                          else Interval (BInfty _ true) (BSide (~~ l.1) r).

Lemma literal_intervalE dim x0 (I : 'cV_dim) (l : LRA_literal (1 + dim)) :
  LRA_interpret_literal (col_mx (const_mx x0) I) l =
  (x0 \in literal_interval I l).
Proof.
rewrite /literal_interval /LRA_interpret_literal LRA_af_recl.
rewrite /LRA_interpret_af trmx_dsub mxE split1 unlift_none /= mxE col_mxKd.
case: (ltrgtP (l.2 0 0) 0)%R => /= H;
  try by rewrite in_itv /= (negbK, andbT) addrC addr_lteif0r
                 (lteif_ndivl_mulr, lteif_pdivr_mulr) // mulrC.
by rewrite H mul0r add0r; case: Order.lteif; rewrite // in_itv lt_asym.
Qed.

Lemma exists_conj_elimP dim I (ls : seq (LRA_literal (1 + dim))) :
  reflect
    (exists x, all (LRA_interpret_literal (col_mx (const_mx x) I)) ls)
    (all (LRA_interpret_literal I) (exists_conj_elim ls)).
Proof.
have af_decomp (l1 l2 : LRA_literal (1 + dim)) :
  LRA_interpret_af I
    (l1.2 0 0 *: dsubmx l2.2 - l2.2 0 0 *: dsubmx l1.2)%R =
  (l1.2 0 0 * LRA_interpret_af I (dsubmx l2.2) -
   l2.2 0 0 * LRA_interpret_af I (dsubmx l1.2))%R.
  by rewrite /LRA_interpret_af mulmx_trl mulmxBr -!scalemxAr
             2!mxE (mxE oppmx_key);
    congr (_ - _)%R; rewrite mulmx_trl !mxE.
apply/(iffP idP); rewrite /exists_conj_elim all_cat.
- case/andP; rewrite all_map => H /all_allpairsP H0.
  suff: itv_nonempty
          (\big[Order.meet/`]-oo, +oo[%O]_(l <- ls) literal_interval I l)
    by case/itv_nonemptyP => /= x; rewrite in_itv_bigI => H1; exists x;
      apply/allP => /= l /(allP H1); rewrite literal_intervalE.
  have H1 (l : LRA_literal dim.+1) :
    (l.2 0 0 == 0)%R -> l \in ls -> literal_interval I l = `]-oo, +oo[%O
    by move=> H1 H2; rewrite /literal_interval H1;
       move: (allP H l); rewrite mem_filter H1 H2 /= => /(_ isT) ->.
  rewrite itv_bigI_pairwise0;
    apply/allP => /= itv /allpairsP [] [] /= l1 l2 [H2 H3 H4]; subst itv.
  case_eq (l1.2 0 0 == 0)%R => H4;
    first rewrite (H1 l1) // meet1x {H4};
    (case_eq (l2.2 0 0 == 0)%R => H5;
     first rewrite (H1 l2) // ?meetx1 {H5});
    rewrite /literal_interval ?H4 ?H5;
    do !case: ifP => //=; move=> H6 H7; try rewrite -negb_and negbK.
  + have {H5 H6} {}H4: (l2.2 0 0 < 0)%R by rewrite ltNge le_eqVlt eq_sym H5 H6.
    move: (H0 l1 l2).
    by rewrite negbK !mem_filter H2 H3 H4 H7 /LRA_interpret_literal /=
               lteif_pdivr_mulr // mulrAC lteif_ndivl_mulr // !mulNr
               -addr_lteif0r af_decomp !(mulrC (LRA_interpret_af _ _))%R => ->.
  + have {H5 H7} {}H4: (l1.2 0 0 < 0)%R by rewrite ltNge le_eqVlt eq_sym H4 H7.
    move: (H0 l2 l1).
    by rewrite negbK !mem_filter H2 H3 H4 H6 /LRA_interpret_literal /=
               lteif_pdivr_mulr // mulrAC lteif_ndivl_mulr // !mulNr
               -addr_lteif0r af_decomp !(mulrC (LRA_interpret_af _ _))%R => ->.
- case=> x H; apply/andP; split.
  + rewrite all_map; apply/allP => /= l; rewrite mem_filter =>
      /andP [/eqP H0 /(allP H)].
    by rewrite /LRA_interpret_literal LRA_af_recl !mxE;
      case: splitP => i // _; rewrite ord1 H0 mul0r add0r col_mxKd.
  + apply/allP => l /allpairsP [] [] /= l1 l2 /= [].
    rewrite !mem_filter => //= /andP [H0] /(allP H) H1
                               /andP [H2] /(allP H) H3 ->.
    move: H0 H2 H1 H3.
    rewrite /LRA_interpret_literal /= !LRA_af_recl !mxE;
      case: splitP => i // _; rewrite ord1 !addr_lteif0r af_decomp subr_lteif0r.
    move=> /(lteif_pmul2l l2.1) <- /(lteif_nmul2l l1.1) <-.
    rewrite !mulrN mulrCA col_mxKd !mxE; exact: lteif_trans.
Qed.

Definition exists_DNF_elim dim (lss : seq (seq (LRA_literal dim.+1))) :
  QFLRA_formula dim :=
  QFLRA_unDNF [seq exists_conj_elim ls | ls <- lss].

Lemma exists_DNF_elimP dim I (lss : seq (seq (LRA_literal (1 + dim)))) :
  reflect (exists x,
             has (all (LRA_interpret_literal (col_mx (const_mx x) I))) lss)
          (QFLRA_interpret_formula I (exists_DNF_elim lss)).
Proof.
rewrite /exists_DNF_elim -QFLRA_unDNF_correctness; apply/(iffP hasP).
- case=> /= ls' /mapP [] /= ls H -> {ls'} /exists_conj_elimP [] x H0.
  by exists x; apply/hasP => /=; exists ls.
- case=> x /hasP [] ls H H0; exists (exists_conj_elim ls); first exact: map_f.
  by apply/exists_conj_elimP; exists x.
Qed.

Fixpoint Fourier_Motzkin dim (f : LRA_formula dim) : QFLRA_formula dim :=
  match f with
    | LRA_forall f' =>
      QFLRA_neg (exists_DNF_elim (QFLRA_DNF (QFLRA_neg (Fourier_Motzkin f'))))
    | LRA_exists f' =>
      exists_DNF_elim (QFLRA_DNF (Fourier_Motzkin f'))
    | LRA_neg f' => QFLRA_neg (Fourier_Motzkin f')
    | LRA_and f1 f2 => QFLRA_and (Fourier_Motzkin f1) (Fourier_Motzkin f2)
    | LRA_or f1 f2 => QFLRA_or (Fourier_Motzkin f1) (Fourier_Motzkin f2)
    | LRA_imply f1 f2 =>
      QFLRA_or (QFLRA_neg (Fourier_Motzkin f1)) (Fourier_Motzkin f2)
    | LRA_leq t => QFLRA_leq (\col_i (t i 0))%R
  end.

Lemma Fourier_MotzkinP dim I (f : LRA_formula dim) :
  reflect (LRA_interpret_formula I f)
          (QFLRA_interpret_formula I (Fourier_Motzkin f)).
Proof.
elim/LRA_formula_rect: dim / f I => //= dim.
- move=> f IH I; apply/(iffP idP) => [/exists_DNF_elimP H x|H].
  + apply/IH/negP => /negP H0; apply: H; exists x.
    by rewrite NF_neg_CNF QFLRA_NF_correctness.
  + apply/negP => /exists_DNF_elimP [x].
    rewrite NF_neg_CNF QFLRA_NF_correctness => /IH; apply; exact: H.
- by move=> f IH l; apply/(iffP (exists_DNF_elimP _ _));
     move=> [x H]; exists x; move: H;
     rewrite QFLRA_NF_correctness => /IH.
- by move=> f IH I; apply/(iffP idP); move/IH.
- by move=> f1 IH1 f2 IH2 I; apply/(iffP andP); case=> /IH1 H /IH2 H0.
- by move=> f1 IH1 f2 IH2 I; apply/(iffP orP);
    (case; [move/IH1; left | move/IH2; right]).
- by move=> f1 IH1 f2 IH2 I;
    rewrite -implybE; apply/(iffP implyP) => H /IH1 /H /IH2.
- move=> t I; rewrite mxE.
  set r1 := (\sum_i _)%R; set r2 := (\sum_i _)%R.
  suff ->: r1 = r2 by exact: idP.
  by subst r1 r2; apply/eq_bigr => /= i _; rewrite !mxE.
Qed.

End LRA.


From stdpp Require Import relations finite.
From Coq Require Import ssreflect.

Section acyclic_wf.
  Context {A : Type} (R : relation A).

  Lemma tc_refl_ex_loop x :
    tc R x x → ex_loop R x.
  Proof.
    intros. apply ex_loop_tc. cofix IH. econstructor; eauto.
  Qed.

  Lemma tc_flip x y :
    tc (flip R) x y → tc R y x.
  Proof.
    induction 1.
    - by apply tc_once.
    - eapply tc_r; eauto.
  Qed.

  Definition acyclic (R : relation A) : Prop := ∀ x, ¬ ex_loop R x.

  Context `{!EqDecision A} `{!Finite A}.

  Lemma finite_acyclic_flip_wf :
    acyclic R → wf (flip R).
  Proof.
    intros Hno x. apply tc_finite_sn.
    - intros y ?. eapply Hno. apply tc_refl_ex_loop; eauto.
    - eexists => ? ?. apply elem_of_enum.
  Qed.

  Lemma finite_acyclic_wf :
    acyclic R → wf R.
  Proof.
    intros Hno x. apply tc_finite_sn.
    - intros y ?. eapply Hno. apply tc_refl_ex_loop, tc_flip; eauto.
    - eexists => ? ?. apply elem_of_enum.
  Qed.

End acyclic_wf.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e224m2e96p1_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


From BV Require Import BVList InvCond.
Require Import List Bool NArith Psatz (*Int63*) ZArith Nnat.

Include RAW2BITVECTOR(RAWBITVECTOR_LIST).

Theorem bvadd_dep: forall (n : N), forall (s t : bitvector n),
    iff
    (exists (x : bitvector n), bv_eq (bv_add x s) t = true)
    True.
Proof. intros n s t.
        split; intro A.
        - easy.
        - exists (bv_subt' t s).
          now rewrite bv_add_subst_opp.
Qed.

Theorem bvand_eq : forall (n : N), forall (s t : bitvector n),
  iff
    (exists (x : bitvector n), bv_eq (bv_and x s) t = true)
    (bv_eq (bv_and t s) t = true).
Proof. intros.
       destruct s as (s, Hs).
       destruct t as (t, Ht).
       unfold bv_and, bv_eq, bv in *. cbn.
       specialize (bvand_eq n s t Hs Ht); intros.
       destruct H as (H, Ha).
       split; intros.
       rewrite RAWBITVECTOR_LIST.bv_eq_reflect. apply H.
       destruct H0 as ((x, Hx), p).
       rewrite RAWBITVECTOR_LIST.bv_eq_reflect in p.
       exists x. split; easy.
       rewrite RAWBITVECTOR_LIST.bv_eq_reflect in H0.
       specialize (Ha H0).
       destruct Ha as (x, (Hx, p)).
       exists (@MkBitvector n x Hx).
       now rewrite RAWBITVECTOR_LIST.bv_eq_reflect.
Qed.

Theorem bvor_eq : forall (n : N), forall (s t : bitvector n),
   iff
    (exists (x : bitvector n), bv_eq (bv_or x s) t = true)
    (bv_eq (bv_or t s) t = true).
Proof. intros.
       destruct s as (s, Hs).
       destruct t as (t, Ht).
       unfold bv_or, bv_eq, bv in *. cbn.
       specialize (bvor_eq n s t Hs Ht); intros.
       destruct H as (H, Ha).
       split; intros.
       rewrite RAWBITVECTOR_LIST.bv_eq_reflect. apply H.
       destruct H0 as ((x, Hx), p).
       rewrite RAWBITVECTOR_LIST.bv_eq_reflect in p.
       exists x. split; easy.
       rewrite RAWBITVECTOR_LIST.bv_eq_reflect in H0.
       specialize (Ha H0).
       destruct Ha as (x, (Hx, p)).
       exists (@MkBitvector n x Hx).
       now rewrite RAWBITVECTOR_LIST.bv_eq_reflect.
Qed.

Theorem bvshl_eq : forall (n : N), forall (s t : bitvector n),
    iff
     (exists (x : bitvector n), bv_eq (bv_shl x s) t = true)
     (bv_eq (bv_shl (bv_shr t s) s) t = true).
Proof. intros.
       destruct s as (s, Hs).
       destruct t as (t, Ht).
       unfold bv_shl, bv_eq, bv in *. cbn.
       specialize (bvshl_eq n s t Hs Ht); intros.
       destruct H as (H, Ha).
       split; intros.
       rewrite RAWBITVECTOR_LIST.bv_eq_reflect. apply H.
       destruct H0 as ((x, Hx), p).
       rewrite RAWBITVECTOR_LIST.bv_eq_reflect in p.
       exists x. split; easy.
       rewrite RAWBITVECTOR_LIST.bv_eq_reflect in H0.
       specialize (Ha H0).
       destruct Ha as (x, (Hx, p)).
       exists (@MkBitvector n x Hx).
       now rewrite RAWBITVECTOR_LIST.bv_eq_reflect.
Qed.

Theorem bvashr_eq : forall (n : N), forall (s t : bitvector n),
   iff
    (exists (x : bitvector n), (bv_eq (bv_ashr_a x s) t = true))
    (((bv_ult s (nat2bv (N.to_nat n) n) = true)
      ->  bv_eq (bv_ashr_a (bv_shl t s) s) t = true)
                        /\
     ((bv_ult s (nat2bv (N.to_nat n) n) = false)
      ->  bv_eq t (bv_not (zeros n)) = true \/ (bv_eq t (zeros n) = true))).
Proof. intros.
       destruct s as (s, Hs).
       destruct t as (t, Ht).
       unfold bv_ult, bv_ashr_a, nat2bv, bv_not, bv_eq, bv, wf. cbn in *.
       rewrite !RAWBITVECTOR_LIST.bv_eq_reflect.
       specialize (InvCond.bvashr_eq n s t Hs Ht); intros.
       rewrite Hs, Ht in H. split; intros.
       apply H.
       destruct H0 as ((x, Hx), p).
       exists x. split. easy.
       now rewrite RAWBITVECTOR_LIST.bv_eq_reflect in p.
       apply H in H0.
       destruct H0 as (x, (Hx, p)).
       exists (@MkBitvector n x Hx).
       now rewrite RAWBITVECTOR_LIST.bv_eq_reflect.
Qed.

Theorem bvshl_ugt : forall (n : N), forall (s t : bitvector n),
  iff
    (bv_ult t (bv_shl (bv_not (zeros n)) s) = true)
    (exists (x : bitvector n), (bv_ugt (bv_shl x s) t = true)).
Proof. intros.
        split; intros;
        destruct s as (s, Hs);
        destruct t as (t, Ht);
        unfold bv_ult, bv_ugt, bv_shl, zeros, bv_not, bits, bv in *;
        cbn in *;
        specialize (bvshl_ugt n s t Hs Ht); intros;
        unfold RAWBITVECTOR_LIST.bv_not, RAWBITVECTOR_LIST.bits in *;
        destruct H0 as (H0a, H0b).
        - rewrite Hs in H0a.
          specialize (H0a H).
          destruct H0a as (x, (Hx, p)).
          now exists (@MkBitvector n x Hx).
        - rewrite Hs in H0b.
          apply H0b.
          destruct H as ((x, Hx), p).
          exists x. split; easy.
Qed.

Theorem bvashr_ult2_ltr : forall (n : N), forall (s t : bitvector n),
    (exists (x : bitvector n), (bv_ult (bv_ashr_a s x) t = true)) ->
    (((bv_ult s t = true) \/ (bv_slt s (zeros n)) = false) /\
    (bv_eq t (zeros n)) = false).
Proof. intros n s t H.
        destruct H as ((x, Hx), H).
        destruct s as (s, Hs).
        destruct t as (t, Ht).
        unfold bv_ult, bv_slt, bv_ashr_a, bv_eq, bv in *. cbn in *.
        specialize (InvCond.bvashr_ult2_ltr n s t Hs Ht); intro STIC.
        rewrite Hs, Ht in STIC. apply STIC.
        now exists x.
Qed.

Theorem bvashr_ult2_rtl : forall (n : N), forall (s t : bitvector n),
     (((bv_ult s t = true) \/ (bv_slt s (zeros n)) = false) /\
     (bv_eq t (zeros n)) = false) ->
     (exists (x : bitvector n), (bv_ult (bv_ashr_a s x) t = true)).
Proof. intros.
        destruct H as (H1, H2).
        destruct s as (s, Hs).
        destruct t as (t, Ht).
        unfold bv_ult, bv_slt, bv_ashr_a, bv_eq, bv in *. cbn in *.
        specialize (InvCond.bvashr_ult2_rtl n s t Hs Ht); intros.
        rewrite Hs, Ht in H.
        assert ((RAWBITVECTOR_LIST.bv_ult s t = true \/
                 RAWBITVECTOR_LIST.bv_slt s (RAWBITVECTOR_LIST.zeros n) = false) /\
                 RAWBITVECTOR_LIST.bv_eq t (RAWBITVECTOR_LIST.zeros n) = false).
        split; easy.
        specialize (H H0).
        destruct H as (x, (Hx, p)).
        exists (@MkBitvector n x Hx). easy.
Qed.

Theorem bvashr_ugt2_ltr: forall (n : N), forall (s t : bitvector n),
    (exists (x : bitvector n), (bv_ugt (bv_ashr_a s x) t = true)) ->
    ((bv_slt s (bv_shr_a s (bv_not t)) = true) \/ (bv_ult t s = true)).
Proof. intros.
        destruct H as (x, H).
        destruct s as (s, Hs).
        destruct t as (t, Ht).
        destruct x as (x, Hx).
        unfold bv_ugt, bv_ult, bv_slt, bv_ashr_a, bv in *. cbn in *.
        specialize (InvCond.bvashr_ugt2_ltr n s t Hs Ht); intro IC.
        apply IC.
        now exists x.
Qed.

Theorem bvashr_ugt2_rtl: forall (n : N), forall (s t : bitvector n),
    ((bv_slt s (bv_shr_a s (bv_not t)) = true) \/ (bv_ult t s = true)) ->
    (exists (x : bitvector n), (bv_ugt (bv_ashr_a s x) t = true)).
Proof. intros.
        destruct s as (s, Hs).
        destruct t as (t, Ht).
        unfold bv_ugt, bv_ult, bv_slt, bv_ashr_a, bv in *. cbn in *.
        specialize (bvashr_ugt2_rtl n s t Hs Ht); intros.
        unfold RAWBITVECTOR_LIST.bv_not, RAWBITVECTOR_LIST.bits in H0.
        specialize (H0 H).
        destruct H0 as (x, (Hx, p)).
        exists (@MkBitvector n x Hx). easy.
Qed.

Theorem bvshr_ugt_rtl : forall (n : N), forall (s t : bitvector n),
    (bv_ult t (bv_shr (bv_not s) s) = true) ->
    (exists (x : bitvector n), bv_ugt (bv_shr x s) t = true).
Proof. intros.
       destruct s as (s, Hs).
       destruct t as (t, Ht).
       unfold bv_ugt, bv_ult, bv_shr, bv in *. cbn in *.
       specialize (bvshr_ugt_rtl n s t Hs Ht); intros.
       unfold RAWBITVECTOR_LIST.bv_not, RAWBITVECTOR_LIST.bits in *.
       rewrite RAWBITVECTOR_LIST.bv_shr_eq in H.
       specialize (H0 H).
       destruct H0 as (x, (Hx, p)).
       exists (@MkBitvector n x Hx).
       now rewrite RAWBITVECTOR_LIST.bv_shr_eq.
Qed.

Theorem bvshr_ugt_ltr : forall (n : N), forall (s t : bitvector n),
    (exists (x : bitvector n), bv_ugt (bv_shr_a x s) t = true) ->
    (bv_ult t (bv_shr_a (bv_not s) s) = true).
Proof. intros.
        destruct s as (s, Hs).
        destruct t as (t, Ht).
        destruct H as ((x, Hx), H).
        unfold bv_ugt, bv_ult, bv_shr_a, bv in *. cbn in *.
        apply bvshr_ugt_ltr with (n := n); try easy.
        exists x. easy.
Qed.

Theorem bvshl_neq_ltr: forall (n : N), forall (s t : bitvector n),
    (exists (x : bitvector n), bv_eq (bv_shl x s) t = false) ->
    bv_eq t (zeros n) = false \/
    bv_ult s (nat2bv (N.to_nat n) n) = true.
Proof. intros.
       destruct s as (s, Hs).
       destruct t as (t, Ht).
       unfold bv_ult, bv_ashr_a, bv_eq, bv in *. cbn in *.
       specialize (bvshl_neq_ltr n s t Hs Ht); intros.
       rewrite Hs, Ht in H0. apply H0.
       destruct H as ((x, Hx), p).
       exists (@MkBitvector n x Hx). cbn in *.
       split. easy. apply p.
Qed.


Require Import
  Coq.setoid_ring.Ring
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.additional_operations
  MathClasses.interfaces.orders MathClasses.interfaces.integers
  MathClasses.orders.semirings MathClasses.theory.shiftl MathClasses.theory.int_pow.

Local Existing Instance pseudo_srorder_semiring.

Section positive_semiring_elements.
Context `{FullPseudoSemiRingOrder R} `{!PropHolds (1 ≶ 0)}.

Add Ring R : (rings.stdlib_semiring_theory R).

(* * Embedding of R₊ into R *)
Global Instance Pos_inject: Cast (R₊) R := @proj1_sig R _.

(* Operations *)
Global Program Instance Pos_plus: Plus (R₊) := λ x y, (`x + `y)↾_.
Next Obligation.
  destruct x as [x Hx], y as [y Hy].
  now apply pos_plus_compat.
Qed.

Global Program Instance Pos_mult: Mult (R₊) := λ x y, (`x * `y)↾_.
Next Obligation with auto.
  destruct x as [x Hx], y as [y Hy].
  now apply pos_mult_compat.
Qed.

Global Program Instance Pos_1: One (R₊) := (1 : R).
Next Obligation. now apply lt_0_1. Qed.

(* * Equalitity *)
Local Ltac unfold_equivs := unfold equiv, sig_equiv in *; simpl in *.

Global Instance: Proper ((=) ==> (=) ==> (=)) Pos_plus.
Proof.
  intros [x1 Ex1] [y1 Ey1] E1 [x2 Ex2] [y2 Ey2] E2. unfold_equivs.
  now rewrite E1, E2.
Qed.

Global Instance: Proper ((=) ==> (=) ==> (=)) Pos_mult.
Proof.
  intros [x1 Ex1] [y1 Ey1] E1 [x2 Ex2] [y2 Ey2] E2. unfold_equivs.
  now rewrite E1, E2.
Qed.

Instance: Proper ((=) ==> (=)) Pos_inject.
Proof. now repeat intro. Qed.

Global Instance: Injective Pos_inject.
Proof. now repeat (split; try apply _). Qed.

Section shiftl.
  Context `{SemiRing B} `{!Biinduction B} `{!ShiftLSpec R B sl}.

  Global Program Instance Pos_shiftl: ShiftL (R₊) B | 5 := λ x n,
    (`x ≪ n)↾_.
  Next Obligation. destruct x. now apply shiftl_pos. Qed.
End shiftl.
End positive_semiring_elements.

Section int_pow.
  Context `{DecField R} `{Apart R} `{!FullPseudoSemiRingOrder Rle Rlt}
    `{!TrivialApart R} `{∀ x y : R, Decision (x = y)} `{Integers B} `{!IntPowSpec R B ipw}.

  Global Program Instance Pos_int_pow: Pow (R₊) B | 5 := λ x n,
    (`x ^ n)↾_.
  Next Obligation. destruct x. now apply int_pow_pos. Qed.
End int_pow.