From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ReducibilityFacts.
From Undecidability.Shared Require Import Dec.

From FOL Require Import FullSyntax Arithmetics.
From FOL.Proofmode Require Import Theories ProofMode.
From FOL.Incompleteness Require Import fol_utils qdec sigma1.

Require Import String List.
Open Scope string_scope.

From Equations Require Import Equations.
Require Import Lia.

Section value_disjoint.
  Existing Instance PA_funcs_signature.
  Existing Instance PA_preds_signature.
  Context `{pei : peirce}.

  Existing Instance interp_nat.

  Variable P1 P2 : nat -> Prop.
  Hypothesis P_disjoint : forall x, P1 x -> P2 x -> False.

  Section value_disjoint'.
    Variable φ1 φ2 : form.
    Hypothesis (φ1_bounded : bounded 2 φ1) (φ2_bounded : bounded 2 φ2).
    Hypothesis (φ1_qdec : Qdec φ1) (φ2_qdec : Qdec φ2).
    (* varphi1 and varphi2 are weakly representable using with single
        * existential quantifier  over a decidable core *)
    Hypothesis (φ1_syn : forall x, P1 x <-> Qeq ⊢ ∃ φ1[(num x) ..])
               (φ2_syn : forall x, P2 x <-> Qeq ⊢ ∃ φ2[(num x) ..]).

    (* Transating representability assumptions to a semantic level *)
    Local Lemma φ1_sem x ρ : P1 x <-> ρ ⊨ ∃ φ1[(num x) ..].
    Proof.
      rewrite φ1_syn.
      split.
      - intros H. apply Σ1_soundness with (p := ρ) in H.
        + assumption.
        + constructor. apply Σ1_subst. now constructor.
        + constructor. eapply subst_bounded_max; last eassumption.
          intros [|[|k]] Hk; apply num_bound + solve_bounds.
      - intros H. apply Σ1_completeness.
        + do 2 constructor. now apply Qdec_subst.
        + solve_bounds. eapply subst_bounded_max; last eassumption.
          intros [|[|n]] Hn; cbn. 2-3: solve_bounds.
          apply num_bound.
        + intros ρ'. eapply sat_closed; last eassumption.
          constructor. eapply subst_bounded_max; last eassumption.
          intros [|[|k]] Hk; apply num_bound + solve_bounds.
    Qed.

    Local Lemma φ2_sem x ρ : P2 x <-> ρ ⊨ ∃ φ2[(num x) ..].
    Proof.
      rewrite φ2_syn.
      split.
      - intros H. eapply Σ1_soundness in H.
        + eassumption.
        + constructor. apply Σ1_subst. now constructor.
        + constructor. eapply subst_bounded_max; last eassumption.
          intros [|[|k]] Hk; apply num_bound + solve_bounds.
      - intros H. apply Σ1_completeness.
        + do 2 constructor. now apply Qdec_subst.
        + solve_bounds. eapply subst_bounded_max; last eassumption.
          intros [|[|n]] Hk; cbn. 2-3: solve_bounds.
          apply num_bound.
        + intros ρ'. eapply sat_closed; last eassumption.
          constructor. eapply subst_bounded_max; last eassumption.
          intros [|[|k]] Hk; apply num_bound + solve_bounds.
    Qed.

    (* Definition of formulas strongly separating *)
    Definition φ1' := φ1 ∧ ∀ $0 ⧀= $2 → φ2[$1 .: $0 ..] → ⊥.
    Definition φ2' := φ2 ∧ ∀ $0 ⧀= $2 → φ1[$1 .: $0 ..] → ⊥.

    (* Properties of these formulas *)
    Lemma φ1'_bounded : bounded 2 φ1'.
    Proof.
      repeat solve_bounds.
      - assumption.
      - eapply subst_bounded_max; last eassumption.
        intros [|[|n]] H; cbn; solve_bounds.
    Qed.

    Lemma φ2'_bounded : bounded 2 φ2'.
    Proof.
      repeat solve_bounds.
      - assumption.
      - eapply subst_bounded_max; last eassumption.
        intros [|[|n]] H; cbn; solve_bounds.
    Qed.

    Lemma φ1'_qdec : Qdec φ1'.
    Proof.
      apply Qdec_and; first assumption.
      apply (@Qdec_bounded_forall $1).
      apply Qdec_impl.
      - apply Qdec_subst, φ2_qdec.
      - apply Qdec_bot.
    Qed.

    Lemma φ2'_qdec : Qdec φ2'.
    Proof.
      apply Qdec_and; first assumption.
      apply (@Qdec_bounded_forall $1).
      apply Qdec_impl.
      - apply Qdec_subst, φ1_qdec.
      - apply Qdec_bot.
    Qed.

    (* Strong separation *)
    Local Lemma DR1 x : P1 x -> Qeq ⊢ ∃ φ1'[(num x)..].
    Proof.
      intros HP1. eapply Σ1_completeness.
      { constructor. apply Σ1_subst. constructor. apply φ1'_qdec. }
      { constructor. eapply subst_bounded_max; last apply φ1'_bounded.
        intros [|[|n]] H; try solve_bounds. apply num_bound. }
      intros ρ.
      pose proof HP1 as H. erewrite (φ1_sem _ _) in H.
      destruct H as [k Hk]. exists k.
      split; first eassumption.
      cbn. intros k' _ Hk'. apply (@P_disjoint x).
      - eapply φ1_sem. exists k. apply Hk.
      - eapply φ2_sem with (ρ := k .: ρ). exists k'.
        rewrite subst_comp in Hk'.
        erewrite bounded_subst. 1-2: eassumption.
        intros [|[|n]] H; cbn.
        + now rewrite num_subst.
        + easy.
        + lia.
    Qed.

    Local Lemma DR1' x : P2 x -> Qeq ⊢ ∃ φ2'[(num x)..].
    Proof.
      intros HP1. eapply Σ1_completeness.
      { constructor. apply Σ1_subst. constructor. apply φ2'_qdec. }
      { constructor. eapply subst_bounded_max; last apply φ2'_bounded.
        intros [|[|n]] H; try solve_bounds. apply num_bound. }
      intros ρ.
      pose proof HP1 as H. erewrite (φ2_sem _ _) in H.
      destruct H as [k Hk]. exists k.
      split; first eassumption.
      cbn. intros k' _ Hk'. apply (@P_disjoint x).
      - eapply φ1_sem with (ρ := k .: ρ). exists k'.
        rewrite subst_comp in Hk'.
        erewrite bounded_subst. 1-2: eassumption.
        intros [|[|n]] H; cbn.
        + now rewrite num_subst.
        + easy.
        + lia.
      - eapply φ2_sem. exists k. apply Hk.
    Qed.

    Local Lemma DR2 x : P2 x -> Qeq ⊢ ¬∃ φ1'[(num x)..].
    Proof.
      cbn. intros HP2.
      assert (exists k, Qeq ⊢ φ2'[(num x)..][(num k)..]) as [k Hk].
      { apply Σ1_witness.
        - constructor. apply Qdec_subst. apply φ2'_qdec.
        - eapply subst_bounded_max; last apply φ2'_bounded.
          intros [|[|n]] H; try solve_bounds. apply num_bound.
        - apply Σ1_completeness.
          + constructor. apply Σ1_subst. constructor. apply φ2'_qdec.
          + constructor. eapply subst_bounded_max; last apply φ2'_bounded.
            intros [|[|n]] H; try solve_bounds. apply num_bound.
          + apply Σ1_soundness.
            * do 2 constructor. apply Qdec_subst. eapply φ2'_qdec.
            * constructor.
              eapply subst_bounded_max; last eapply φ2'_bounded.
              intros [|[|n]] H; apply num_bound + solve_bounds.
            * apply DR1', HP2. }
      cbn in Hk.

      custom_simpl. unfold "↑". fstart.
      fintros "H". fdestruct "H". fdestruct "H".

      pose proof (Qsdec_le x0 (num_bound k 0)).
      fdestruct H.
      - fapply ("H0" (num k)).
        + ctx.
        + asimpl. fassert (φ2[(num x)..][(num k)..]).
          { fstop. eapply CE1, Weak; eauto; now do 3 right. }
          rewrite !subst_comp. erewrite bounded_subst.
          * fapply "H2".
          * eassumption.
          * intros [|[|[|l]]]; cbn; (now rewrite ?num_subst + lia).
      - rewrite num_subst in Hk.
        fassert (∀ $0 ⧀= num k → ¬ φ1[$1 .: $0..][up (num x)..][up (num k)..]).
        { fstop. eapply CE2, Weak; eauto; now do 3 right. }
        fapply ("H2" x0).
        + rewrite num_subst. fapply "H1".
        + rewrite !subst_comp. pattern (φ1[(num x).. >> subst_term x0..]). erewrite bounded_subst.
          * fapply "H".
          * eassumption.
          * intros [|[|[|l]]]; cbn; (now rewrite ?num_subst + lia).
    Qed.

    Lemma weak_strong' : exists φ, Σ1 φ /\ bounded 1 φ /\
      (forall x, P1 x -> Qeq ⊢ φ[(num x)..]) /\
      (forall x, P2 x -> Qeq ⊢ ¬φ[(num x)..]).
    Proof.
      exists (∃ φ1'[$1 .: $0 ..]). repeat apply conj.
      { do 2 constructor. apply Qdec_subst, φ1'_qdec. }
      { constructor. eapply subst_bounded_max; last apply φ1'_bounded.
        intros [|[|n]]; intros H; solve_bounds. }
      - intros x H%DR1.
        replace ((_)[_]) with (∃ φ1'[(num x)..]); first assumption.
        change (∃ _)[_] with (∃ φ1'[$1 .: $0 ..][up (num x)..]).
        f_equal. rewrite subst_comp. eapply bounded_subst; first apply φ1'_bounded.
        intros [|[|n]] Hn; cbn. 2-3:now asimpl.
        now rewrite num_subst.
      - intros x H%DR2.
        replace ((_)[_]) with (∃ φ1'[(num x)..]); first assumption.
        change (∃ _)[_] with (∃ φ1'[$1 .: $0 ..][up (num x)..]).
        f_equal. rewrite subst_comp. eapply bounded_subst; first apply φ1'_bounded.
        intros [|[|n]] Hn; cbn. 2-3: now asimpl.
        now rewrite num_subst.
    Qed.

  End value_disjoint'.

  Section weak_strong.
    Variable φ1 φ2 : form.
    Hypothesis (φ1_bounded : bounded 1 φ1) (φ2_bounded : bounded 1 φ2).
    Hypothesis (φ1_Σ : Σ1 φ1) (φ2_qdec : Σ1 φ2).
    (* P1 and P2 are weakly Sigma1-representable *)
    Hypothesis (φ1_syn : forall x, P1 x <-> Qeq ⊢ φ1[(num x) ..])
               (φ2_syn : forall x, P2 x <-> Qeq ⊢ φ2[(num x) ..]).

    Lemma iff_iff φ ψ : (Qeq ⊢ φ ↔ ψ) -> Qeq ⊢ φ <-> Qeq ⊢ ψ.
    Proof.
      intros H. split; intros H'; fapply H; exact H'.
    Qed.

    (* Combine above results with compression to yield strong separability from weak representability *)
    Theorem weak_strong : exists φ, Σ1 φ /\ bounded 1 φ /\
      (forall x, P1 x -> Qeq ⊢ φ[(num x)..]) /\
      (forall x, P2 x -> Qeq ⊢ ¬φ[(num x)..]).
    Proof.
      destruct (@Σ1_compression φ1 1) as (ψ1 & HQ1 & Hb1 & Hψ1), (@Σ1_compression φ2 1) as (ψ2 & HQ2 & Hb2 & Hψ2).
      all: try assumption.
      apply weak_strong' with (φ1 := ψ1[$1.:$0..]) (φ2 := ψ2[$1.:$0..]).
      { eapply subst_bounded_max; last eassumption. intros [|[|n]] Hn; solve_bounds. }
      { eapply subst_bounded_max; last eassumption. intros [|[|n]] Hn; solve_bounds. }
      { now apply Qdec_subst. }
      { now apply Qdec_subst. }
      - intros x. rewrite φ1_syn.
        apply iff_iff.
        apply (subst_Weak ((num x)..)) in Hψ1.
        change (map _ _) with Qeq in Hψ1.
        cbn in Hψ1.
        assert (ψ1[$1 .: $0 ..][(num x) ..] = ψ1[up (num x)..]) as ->.
        + rewrite subst_comp. eapply bounded_subst; first eassumption.
          intros [|[|n]] Hn; cbn.
          * reflexivity.
          * now rewrite num_subst.
          * lia.
        + apply prv_intu_peirce, Hψ1.
      - intros x. rewrite φ2_syn.
        apply iff_iff.
        apply (subst_Weak ((num x)..)) in Hψ2.
        change (map _ _) with Qeq in Hψ2.
        cbn in Hψ2.
        assert (ψ2[$1 .: $0 ..][(num x) ..] = ψ2[up (num x)..]) as ->.
        + rewrite subst_comp. eapply bounded_subst; first eassumption.
          intros [|[|n]] Hn; cbn.
          * reflexivity.
          * now rewrite num_subst.
          * lia.
        + apply prv_intu_peirce, Hψ2.
    Qed.

  End weak_strong.

End value_disjoint.


(* Polarity definition *)
Require Import List.

Inductive polarity : Type :=
| Plus
| Minus
| NonMonotonic.

Definition mul_pol (a: polarity) (b: polarity): polarity :=
  match a, b with
    | NonMonotonic, _ => NonMonotonic
    | _, NonMonotonic => NonMonotonic
    | Plus, Plus => Plus
    | Minus, Minus => Plus
    | Plus, Minus => Minus
    | Minus, Plus => Minus
  end.

Lemma mul_pol_nm : forall x : polarity, mul_pol x NonMonotonic = NonMonotonic.
Proof.
  unfold mul_pol in |- *.
  intro x.
  induction x; reflexivity.
Qed.

Lemma mul_pol_pp_mm : forall x: polarity, mul_pol x x = Plus \/ x = NonMonotonic.
Proof.
  unfold mul_pol in |- *.
  intro x.
  induction x; [ left | left | right ]; reflexivity.
Qed.

Inductive typ : Type :=
| Nat : typ
| Fun : (*polarity -> *) typ -> typ -> typ.

Inductive cst : Type :=
| Zero
| Succ
| Addition
| Substraction
| Rec.

Inductive trm : Set :=
| Var : nat -> trm
| Cst : cst -> trm
| App : trm -> trm -> trm
| Abs : polarity -> typ -> trm -> trm.

Definition env := list (option (polarity * typ)).

(* Typing judgement *)

Definition sigma (x: cst) : typ :=
  match x with
    | Zero => Nat
    | Succ => Fun Nat Nat
    | Addition => Fun Nat (Fun Nat Nat)
    | Substraction => Fun Nat (Fun Nat Nat)
    | Rec => Nat (* FIXME: *)
  end.

Definition inv_env (p : polarity) (e : env) : env :=
  match p with
    | Plus => e
    | Minus => map (fun x => option_map
      (fun x : (polarity * typ) => let (p, t) := x in (mul_pol Minus p, t)) x) e
    | NonMonotonic => map (fun x : option (polarity * typ) =>
      match x with
        | Some (NonMonotonic, _) => x
        | Some (Plus, _) | Some (Minus, _) | None => None
      end) e
  end.

Inductive type : env -> trm -> typ -> Prop :=
| type_cst : forall e t,
  match t with
    | Cst c => type e t (sigma c)
    | Var v => match (nth v e None) with
                 | Some (Plus, tau) => type e t tau
                 | Some (NonMonotonic, tau) => type e t tau
                 | Some (Minus, tau) => forall tau, type e t tau (*FIXME: ?? *)
                 | None => forall tau, type e t tau (*FIXME: ?? *)
               end

    | App u v => forall tau1, forall tau2, forall p, type e (Abs p (Fun tau1 tau2) u) (Fun tau1 tau2) ->
      type (inv_env p e) v tau1 -> type e (App u v) tau2

    | Abs p tau1 m => forall tau2, type e m tau2 -> type e (Abs p tau1 m) (Fun tau1 tau2)
  end.


Require Import EqNat.
Require Import Bool.
Require Import String.
Require Import Arith.Bool_nat.
Require Import Coq.Arith.PeanoNat.
Require Import Div2.
Require Import While.
Require Import Heap.
Require Import Refinement.
Require Import Program.Tactics.
Require Import Program.Equality.
Require Import Coq.omega.Omega.

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

                PERSISTENT ARRAYS CASE-STUDY

*************************************************************)

(** Some extra small automation **)

Hint Extern 2 =>
  match goal with
    | [ H1 : (find ?s ?p = Some ?v1), H2 : (find ?s ?p = None) |- _ ] => rewrite H1 in H2; inversion H2
    | [ H1 : (find ?s ?p = Some ?v1), H2 : (None = find ?s ?p) |- _ ] => rewrite H1 in H2; inversion H2
    | [ H1 : (Some ?v1 = find ?s ?p), H2 : (find ?s ?p = None) |- _ ] => rewrite H1 in H2; inversion H2
    | [ H1 : (Some ?v1 = find ?s ?p), H2 : (None = find ?s ?p) |- _ ] => rewrite H1 in H2; inversion H2
  end.

Hint Extern 2 (~ (_ = _)) => unfold not; intros; subst.

(*******************************************************************************
  **** Infrastructure following "A Persistent Union-Find Data Structure" ****
*******************************************************************************)

Set Implicit Arguments.
Require Export Wf_nat.

(* The possible data types present in the heap *)
Inductive PAData : Type :=
  | Arr : (nat -> nat) -> PAData
  | Diff : nat -> nat -> Ptr -> PAData
  | ResultGet : option nat -> PAData. (* used in the Get function *)

(* Updates an array at index i with v. *)
Definition upd (f : nat -> nat) (i : nat) (v : nat) :=
  fun j => if beq_nat j i then v else f j.

Hint Unfold upd.

(*
   pa_model states that, given a pointer "p", we either have:
   1. p points to an array "Arr", with elements given by (N -> N)
   2. p points to different "Diff", which is a change of another valid array,
      in one position only, updating the other array in that position (using upd)
*)
Inductive pa_model (s : heap PAData) : Ptr -> (nat -> nat) -> Type :=
  | pa_model_array :
     forall p f, find s p = Some ((Arr f)) -> pa_model s p f
  | pa_model_diff :
     forall p i v p', find s p = Some (Diff i v p') ->
                   forall f, pa_model s p' f ->
                        pa_model s p (upd f i v).

Hint Constructors PAData pa_model.

Lemma pa_model_find (s : heap PAData) (ptr : Ptr) (f : nat -> nat) :
    pa_model s ptr f -> { x : PAData & find s ptr = Some x }.
Proof. intros H; inversion H; subst; eauto. Qed.

Hint Resolve pa_model_find.

Lemma pa_model_find' (s : heap PAData) (ptr ptr' : Ptr) (f : nat -> nat) (i v : nat) :
    pa_model s ptr f -> find s ptr = Some (Diff i v ptr') -> { x : PAData & find s ptr' = Some x }.
Proof. intros H1 H2; inversion H1; subst; rewrite H2 in H; inversion H; subst; eauto. Qed.

Hint Resolve pa_model_find'.

(** Auxiliary lemmas about pa_model / upd. Taken from puf.v. **)

Axiom upd_ext : forall f g : nat -> nat, (forall i, f i = g i) -> f = g.

Lemma upd_eq : forall f i j v, i = j -> upd f i v j = v.
Proof. unfold upd; intros; subst; now rewrite Nat.eqb_refl. Qed.

Lemma upd_eq_ext :
  forall f i v, f = upd (upd f i v) i (f i).
Proof.
  intros; apply upd_ext.
  intro i'; unfold upd; simpl.
  destruct (Nat.eq_dec i i'); subst. now rewrite <- beq_nat_refl.
  apply Nat.eqb_neq in n; rewrite Nat.eqb_sym in n; now rewrite n.
Qed.

Lemma upd_fun : forall f f', f = f' -> forall i v, upd f i v = upd f' i v.
Proof. intros; rewrite H; reflexivity. Qed.

Hint Resolve upd_eq upd_eq_ext upd_fun.

Lemma pa_model_fun : forall s p f, pa_model s p f -> forall f', pa_model s p f' -> f = f'.
Proof.
  intros s ptr f HModel.
  induction HModel; intros f' HModel'; destruct HModel'; context_simpl; auto.
Qed.

(* Application of pa_model_diff when "f" does not directly read as an upd *)
Lemma pa_model_diff_2 :
  forall p : Ptr, forall i v p', forall f f' s,
  find s p = Some ((Diff i v p')) ->
  pa_model s p' f' ->
  f = upd f' i v ->
  pa_model s p f.
Proof. intros; subst; eauto. Qed.

(* Separation lemma: allocating a new pointer on the heap has no
   effect on existing PAs. *)
Lemma pa_model_sep' :
  forall s t f v t',
    find s t' = None ->
    pa_model s t f -> pa_model (update s t' v) t f.
Proof.
  intros; generalize dependent t'.
  induction X; intros.
  - apply pa_model_array.
    rewrite findNUpdate1 with (x := Some ((Arr f))); auto.
  - apply pa_model_diff with (p' := p'); auto.
Qed.

Inductive PADataOpt : option PAData -> Prop :=
  | PAArr : forall f, PADataOpt (Some (Arr f))
  | PADiff : forall f i v, PADataOpt (Some (Diff f i v)).

Hint Constructors PADataOpt.

(* Separation lemma: a pointer that does not point to a structure
   of a PA, can be safely updated without affecting existing PAs  *)
Lemma pa_model_sep_padata :
  forall s t f v t',
    ~ (PADataOpt (find s t')) ->
    pa_model s t f -> pa_model (update s t' v) t f.
Proof.
  intros.
  intros; generalize dependent t'.
  induction X; intros.
  - apply pa_model_array.
    rewrite findNUpdate1 with (x := Some ((Arr f))); auto.
    unfold not; intros; subst; rewrite e in H; auto.
  - apply pa_model_diff with (p' := p'); auto.
    apply findNUpdate1; auto.
    unfold not; intros; subst; rewrite e in H; auto.
Qed.

Lemma pa_model_alloc :
  forall s t' f v, pa_model s t' f -> pa_model (update s (alloc s) v) t' f.
Proof. intros; apply pa_model_sep'; auto. Qed.

(* decidability of find *)

Lemma find_eqdec : forall {A} s p, sumbool (find s p = None) (exists (c : A), find s p = Some c).
Proof. intros; destruct (find s p); eauto. Qed.

Lemma pa_model_copy_fresh :
  forall s p f, pa_model s p f -> forall v, find s p = Some v ->
           forall t, (forall (p' : M.key) (x : PAData), find s p' = Some x -> p' <> t) ->
                pa_model (update s t v) t f.
Proof.
  intros s p f H1.
  induction H1; intros.
  - context_simpl; auto.
  - context_simpl.
    eapply pa_model_diff with (p' := p'); auto.
    apply pa_model_sep'; auto.
    destruct (find_eqdec s t); auto.
    destruct e; apply H0 in H2; exfalso; auto.
Qed.

Hint Resolve pa_model_fun pa_model_diff_2 pa_model_sep'
             pa_model_sep_padata pa_model_copy_fresh.

Hint Extern 2 =>
  match goal with
    | [ HH : (find ?s ?p = Some ?v1) +
            (find ?s ?p = Some ?v2) |- ~ PADataOpt (find ?s ?p) ] =>
      destruct HH as [HH | HH]; rewrite HH; unfold not; intro HInv; inversion HInv
  end.

(*******************************************************************************
                            **** INIT ****
*******************************************************************************)

Definition initSpec (n : nat) (f : nat -> nat) : WhileL PAData Ptr :=
  Spec (MkPT (fun s => True)
                  (fun s pres v s' => prod (forall p' x, find s p' = Some x -> p' <> v)
                                          (pa_model s' v f))).

Definition newRef (x : PAData) : WhileL PAData Ptr :=
  New x (fun ptr => Return _ ptr).

Definition init (n : nat) (f : nat -> nat) : WhileL PAData Ptr := newRef (Arr f).

Lemma initRefinement : forall n f, wrefines (initSpec n f) (init n f).
Proof.
  intros.
  NEW (Arr f) t.
  RETURN t; eauto.
Qed.

(*******************************************************************************
                             **** SET ****
*******************************************************************************)

(* The original set implementation (i.e. no path compression),
presented in Page 3 *)
Definition set (t : Ptr) (i : nat) (v : nat) : WhileL PAData Ptr :=
  Read t (fun vInT =>
  match vInT with
  | Arr f => New (Arr (upd f i v))
                (fun (res : Ptr) => Write t (Diff i (f i) res) (Return _ res))
  | Diff _ _ _ => newRef (Diff i v t)
  | _ => Return _ t (* absurd! *)
  end).

Definition setSpec (ptr : Ptr) (i : nat) (v : nat) : WhileL PAData Ptr :=
  Spec ( MkPT
   (fun s => { f : nat -> nat & pa_model s ptr f })
   (fun s pres newPtr s' => match pres with
                             | existT _ f _ => prod (pa_model s' newPtr (upd f i v))
                                                   (pa_model s' ptr f)
                           end )).

Lemma setRefinement : forall ptr i v, wrefines (setSpec ptr i v) (set ptr i v).
Proof.
  intros; unfold set, setSpec.
  READ ptr vInPtr.
  destruct vInPtr as [ f | j vInJ t' | ].
  - NEW (Arr (upd f i v)) res.
    WRITE ptr (Diff i (f i) res).
    RETURN res; inversion X; subst; context_simpl; eauto 6.
  - unfold newRef.
    NEW (Diff i v ptr) res.
    RETURN res.
    apply pa_model_diff with (p' := ptr); auto.
    apply pa_model_sep'; auto.
    destruct (find_eqdec pre res); auto; destruct e; exfalso; eapply n; eauto.
    apply pa_model_sep'; auto.
    destruct (find_eqdec pre res); auto; destruct e; exfalso; eapply n; eauto.
  - RETURN ptr; inversion X; subst; context_simpl.
Qed.

(*******************************************************************************
        **** Infrastructure for proving more elaborated functions ****
*******************************************************************************)

(* The list of pointers that together form a Persistent Array, hinting to
   a well-formed relation on pointers *)
Inductive dist (s : heap PAData) : Ptr -> list Ptr -> Type :=
  | dist_sing : forall p f, find s p = Some (Arr f) -> dist s p (p :: nil)
  | dist_cons : forall p p' i v l,
                find s p = Some (Diff i v p') ->
                dist s p' l -> dist s p (p :: l).

Hint Constructors dist.

Inductive InT (p : Ptr) : list Ptr -> Type :=
  | here : forall l, InT p (p :: l)
  | there : forall p' l, InT p l -> InT p (p' :: l).

Hint Constructors InT.

Lemma dist_fun : forall s ptr l1, dist s ptr l1 -> forall l2, dist s ptr l2 -> l1 = l2.
Proof.
  intros s ptr l1 H.
  induction H; intros; inversion X; context_simpl; [ | apply f_equal ]; auto.
Qed.

Lemma dist_InT : forall s ptr l, dist s ptr l -> InT ptr l.
Proof. intros; induction X; auto. Qed.

Hint Resolve dist_fun dist_InT.

Lemma dist_sepT : forall s ptr l, dist s ptr l -> forall ptr', (InT ptr' l -> False) -> forall v, dist (update s ptr' v) ptr l.
Proof. intros s ptr l H; induction H; intros; [ | eapply dist_cons ]; eauto. Qed.

Lemma pa_model_dist : forall s ptr f, pa_model s ptr f -> { l : list Ptr & dist s ptr l }.
Proof. intros; induction X; eauto. destruct IHX; eauto. Qed.

(* Separation lemma: if a pointer does not belong to the a given PA,
   then updating it should not affect that PA *)
Lemma pa_model_sep :
  forall s f v ptr ptr' l,
    pa_model s ptr f ->
    dist s ptr l ->
    (InT ptr' l -> False) ->
    pa_model (update s ptr' v) ptr f.
Proof.
  intros s f v ptr ptr' l HPA Hdist; generalize dependent ptr'; generalize dependent v; generalize dependent l.
  induction HPA; intros.
  - apply pa_model_array; rewrite findNUpdate; auto.
    unfold not; intros; subst.
    apply dist_InT in Hdist; contradiction.
  - apply pa_model_diff with (p' := p').
    rewrite findNUpdate; auto.
    unfold not; intros; subst.
    apply dist_InT in Hdist; contradiction.
    inversion Hdist; subst; rewrite e in H0; inversion H0; subst.
    eapply IHHPA with (l := l0); auto.
Qed.

(* Separation lemma: if a pointer does not belong to the a given PA,
   then updating it to that PA should make it a PA as well *)
Lemma pa_model_sep_copy :
  forall s f v ptr ptr' l,
    pa_model s ptr f ->
    dist s ptr l ->
    (InT ptr' l -> False) ->
    find s ptr = Some v ->
    pa_model (update s ptr' v) ptr' f.
Proof.
  intros s f v ptr ptr' l HPA Hdist HFind; generalize dependent ptr'; generalize dependent v; generalize dependent l.
  induction HPA; intros; rewrite e in H.
  - apply pa_model_array; now rewrite findUpdate.
  - apply pa_model_diff with (p' := p').
    rewrite findUpdate; auto.
    assert (Ha : pa_model s p' f) by assumption.
    apply pa_model_dist in HPA.
    destruct HPA.
    eapply pa_model_sep; eauto.
    assert (Ha1 : l = p :: x) by eauto.
    inversion Hdist; rewrite e in H0; inversion H0; subst; eauto.
Qed.

Lemma dist_wf : forall s p1 l, dist s p1 l -> forall p2, p1 <> p2 -> InT p2 l ->
                      { l' : list Ptr & prod (dist s p2 l') (length l' < length l) }.
Proof.
  intros s p1 l Hdist p2 Heq HIn.
  destruct (M.E.eq_dec p1 p2); try contradiction.
  induction Hdist; intros.
  - inversion HIn; subst; exfalso; now apply n.
  - inversion HIn; subst.
    exfalso; now apply n.
    destruct (M.E.eq_dec p' p2); subst; eauto.
    assert ({l' : list Ptr & (dist s p2 l' * (Datatypes.length l' < Datatypes.length l))%type}).
    apply IHHdist; auto.
    destruct X as [x [H1 H2]]; eexists; split; eauto; simpl; omega.
Qed.

Lemma cons_contra : forall {A} (x : A) l, l <> x :: l.
Proof. intros; induction l; unfold not; intros HInv; inversion HInv; contradiction. Qed.

Lemma dist_no_loop : forall s p l, dist s p (p :: l) -> (InT p l -> False).
Proof.
  intros s p l H.
  dependent induction H.
  - unfold not; intros HInv; inversion HInv; subst.
  - unfold not; intros HH; subst.
    destruct (M.E.eq_dec p' p); subst.
    assert (Ha : l = p :: l).
    eapply dist_fun; eauto. eauto.
    assert (Ha : dist s p (p :: l)) by eauto.
    destruct (dist_wf H n HH) as [x [H1 H2]].
    assert (Ha1 : x = p :: l) by eauto.
    subst; simpl in *; omega.
Qed.

(* A pointer that points to a valid (Diff i v t'),
   will still be valid when updated to whatever t' points to *)
Lemma pa_model_desc : forall s p1 f i v, pa_model s p1 (upd f i v) ->
                                    forall p2 v', pa_model s p2 f ->
                                             find s p1 = Some (Diff i v p2) ->
                                             find s p2 = Some v' ->
                                             pa_model (update s p1 v') p1 f.
Proof.
  intros s p1 f i v HP1 p2 v' HP2 HFind1 HFind2.
  assert (Ha : pa_model s p2 f) by assumption.
  apply pa_model_dist in HP2.
  destruct HP2.
  eapply pa_model_sep_copy; eauto.
  assert (Ha1 : pa_model s p1 (upd f i v)) by assumption.
  apply pa_model_dist in HP1.
  destruct HP1.
  assert (Ha2 : x0 = p1 :: x) by eauto.
  subst; eapply dist_no_loop; eassumption.
Qed.

(* Separation lemma: a pointer that does not point to a structure
   of a PA, can be safely updated without affecting existing PAs  *)
Lemma pa_dist_sep_padata :
  forall s t l v t',
    ~ (PADataOpt (find s t')) ->
    dist s t l -> dist (update s t' v) t l.
Proof.
  intros; generalize dependent t'.
  induction X; intros.
  - eapply dist_sing.
    rewrite findNUpdate1 with (x := Some ((Arr f))); auto.
    unfold not; intros; subst; rewrite e in H; auto.
  - eapply dist_cons with (p' := p'); eauto 2.
    apply findNUpdate1; eauto 2.
    unfold not; intros; subst; rewrite e in H; eauto.
Qed.

Hint Resolve dist_sepT pa_model_dist pa_model_sep pa_model_sep_copy.
Hint Resolve pa_model_desc pa_dist_sep_padata.

(* If a pointer belongs to the indirection list of an array,
   it must point to a PADataOpt. *)
Lemma dist_InT_find_padata :
  forall ptr1 s l, dist s ptr1 l -> forall ptr2, InT ptr2 l -> PADataOpt (find s ptr2).
Proof.
  intros ptr1 s l Hdist.
  induction Hdist; intros ptr2 HInT; inversion HInT; subst; try (rewrite e; auto); eauto; inversion H0.
Qed.

(* If a pointer belongs to the indirection list of an array,
   it must point to a valid pointer in the heap *)
Lemma dist_InT_find : forall ptr1 s l, dist s ptr1 l -> forall ptr2, InT ptr2 l ->
                                  { v : PAData & find s ptr2 = Some v }.
Proof.
  intros ptr1 s l Hdist.
  induction Hdist; intros ptr2 HInT; inversion HInT; subst; eauto; inversion H0.
Qed.

Hint Resolve dist_InT_find dist_InT_find_padata.

(*******************************************************************************
                             **** GET ****
*******************************************************************************)

(* The original spec from Ch.4 *)
(*
Definition get :
  forall m, forall p, pa_valid m p ->
  forall i, { v:Z | forall f, pa_model m p f -> v = f i }.
*)

Definition data_get_eqb_some (h : option PAData) : bool :=
  match h with
    | Some (ResultGet (Some x)) => true
    | _ => false
  end.

(*
Definition get (ptr : Ptr) : WhileL unit :=
  t <- ptr
  done <- newRef Nothing
  while done == Nothing  {
    x <- read t
    match x with
      | Array => write done Just (a.i)
      | Diff (j, v, t') => if i == j
                           then write done (Just v)
                           else read t' >>= \x -> write t x
  }
*)

Definition getSpec (ptr : Ptr) (i : nat) : WhileL PAData nat :=
  Spec ( MkPT
   (fun s => { f : nat -> nat & pa_model s ptr f })
   (fun s pres v s' => match pres with
                        | existT _ f _ => v = f i
                      end )).

(* Given the root pointer "ptr" and an auxiliary traversal pointer "t",
  "t" points to a persistent array (modelled by some f) such that:
   1. (f i) is the same as the function modelled by the original "ptr"
   2. the original array is read-only (i.e. out of the frame/scope)
   3. the result stored in "done" is either "None" or "Some (f i)" *)
Definition Inv ptr t done i si s :=
  { f : nat -> nat &
    (prod (pa_model s t f)
    (prod (forall f', pa_model si ptr f' -> prod (pa_model s ptr f') (f i = f' i)) (
    (prod ({ l : list Ptr & prod (dist s ptr l) (InT t l -> False)})
          (sum (find s done = Some (ResultGet (Some (f i))))
               (find s done = Some (ResultGet None))))))) }.

Definition get (ptr : Ptr) (i : nat) : WhileL PAData nat.
refine (
  Read ptr (fun vInPtr =>
  New vInPtr (fun t =>
  New (ResultGet None) (fun done =>
  While (Inv ptr t done i)
        (fun s => negb (data_get_eqb_some (find s done)))
        (Read t (fun vInT => _ )) (* the body is refined below *)
        (Read done (fun vInDone =>
         match vInDone with
           | ResultGet (Some a) => Return _ a
           | _ => Return _ 0 (* absurd *)
         end)))))).
(* body of the loop *)
destruct vInT as [ f | j v t' | ].
refine (Write done (ResultGet (Some (f i))) (Return _ tt)).
refine (if Nat.eqb i j
        then _
        else _).
refine (Write done (ResultGet (Some v)) (Return _ tt)).
refine (Read t' (fun vInT' => Write t vInT' (Return _ tt))).
refine (Return _ tt). (* absurd: t will never point to a result *)
Defined.

Lemma getRefinement :  forall ptr i, wrefines (getSpec ptr i) (get ptr i).
Proof.
  intros.
  unfold get, getSpec.
  READ ptr vInPtr.
  NEW vInPtr t.
  NEW (ResultGet None) done.
  WHILE (Inv ptr t done i) (fun s : S PAData => negb (data_get_eqb_some (find s done))); unfold Inv.
  - refine_simpl.
    exists s1.
    repeat split; auto.
    * apply pa_model_sep'; eauto.
      destruct (find_eqdec (update s0 t vInPtr) done); eauto;
      destruct e; exfalso; eapply n; eauto.
    * assert (Ha1 : pa_model (update s0 t vInPtr) ptr s1).
      apply pa_model_sep_padata; auto.
      unfold not; intros H; inversion H; symmetry in H1; apply n0 in H1; now apply H1.
      assert (Ha2 : pa_model (update (update s0 t vInPtr) done (ResultGet None)) ptr s1).
      apply pa_model_sep'; auto.
      destruct (find_eqdec (update s0 t vInPtr) done); auto.
      destruct e; apply n in H; exfalso; auto.
      assert (Ha3 : s1 = f') by eauto; now rewrite Ha3.
    * assert (Ha : pa_model s0 ptr s1); auto.
      apply pa_model_dist in X0.
      destruct X0.
      exists x; split.
      repeat apply dist_sepT; auto.
      + intro H; destruct (dist_InT_find d H) as [v HFind]; now apply (n0 _ _ HFind).
      + intro H; destruct (dist_InT_find d H) as [v HFind].
        rewrite <- findNUpdate with (p' := t) (v := vInPtr) in HFind.
        now apply (n _ _ HFind).
        unfold not; intros; subst; now apply (n0 _ _ HFind).
      + intro H; destruct (dist_InT_find d H) as [v HFind]; now apply (n0 _ _ HFind).
  - READ t vInT.
    destruct vInT.
    WRITE done (ResultGet (Some (n i))).
    destruct s3; eauto.
    RETURN tt.
    exists s1; repeat split; auto.
    * destruct (p0 _ X) as [Ha1 Ha2]; auto.
    * inversion p; rewrite H in e0; inversion e0; subst; now destruct (p0 _ X).
    * exists s2; split; auto.
    * rewrite findUpdate; left; repeat apply f_equal.
      inversion p; rewrite e0 in H; inversion H; now subst.
    * IFF (i =? n).
      + WRITE done (ResultGet (Some n0)).
        destruct s3; eauto.
        RETURN tt.
        eexists; split; eauto.
        repeat split; intros.
        apply pa_model_sep_padata; auto; now destruct (p1 _ X).
        now destruct (p1 _ X).
        eauto.
        rewrite findUpdate; left; repeat apply f_equal.
        inversion p0; rewrite e0 in H; inversion H; subst.
        unfold upd; now rewrite <- Heqb.
      + READ p vInT'.
        WRITE t vInT'.
        RETURN tt.
        inversion p0; subst; rewrite e1 in H; inversion H; subst; clear H.
        exists f0; repeat split.
        eauto 2.
        eapply pa_model_sep; eauto 2; now destruct (p1 _ X0).
        destruct (p1 _ X0); rewrite <- e; unfold upd; now rewrite <- Heqb.
        exists s2; split; auto.
        destruct s3.
        left; rewrite findNUpdate; eauto 1.
        rewrite e; repeat apply f_equal; unfold upd; now rewrite <- Heqb.
        unfold not; intros; subst; rewrite e1 in e; inversion e.
        right; rewrite findNUpdate; eauto 1; unfold not; intros; subst;
        rewrite e1 in e; inversion e.
      * RETURN tt; inversion p; subst; rewrite e in H; inversion H.
  - READ done vInDone.
    destruct s3; eauto.
    destruct vInDone.
    * RETURN 0; rewrite e in i0; inversion i0.
    * RETURN 0; rewrite e in i0; inversion i0.
    * destruct o.
      + RETURN n.
        destruct s4.
        rewrite e0 in e; inversion e; subst.
        assert (Ha : (pa_model (update (update s5 t vInPtr) done (ResultGet None)) ptr s6)).
        apply pa_model_sep_padata.
        unfold not; intros HInv.
        destruct (find_eqdec (update s5 t vInPtr) done).
        rewrite e1 in HInv; inversion HInv.
        destruct e1;  apply n0 in H; now apply H.
        apply pa_model_sep'; auto.
        destruct (find_eqdec s5 t); [ | destruct e1; exfalso; apply n1 in H ]; auto.
        now destruct (p0 s6 Ha).
        rewrite e0 in e; inversion e.
      + RETURN 0; rewrite e in i0; inversion i0.
Qed.


Require Export Db.Spec.
Require Export Db.WellScoping.

Require Import Coq.micromega.Lia.

Inductive Ty : Set :=
  | tarr (τ₁ τ₂ : Ty)
  | tunit
  | tbool
  | tprod (τ₁ τ₂: Ty)
  | tsum (τ₁ τ₂: Ty)
  | trec (τ : Ty)
  | tvar (i : Ix).

Notation "A r⊎ B" := (tsum A B) (at level 85, right associativity).
Notation "A r× B" := (tprod A B) (at level 85, right associativity).
Notation "A r⇒ B" := (tarr A B) (at level 85, right associativity).

(** ** Typing environments. *)

Inductive Env : Set :=
  | empty
  | evar (Γ : Env) (τ : Ty).

Fixpoint dom (Γ: Env) : Dom :=
  match Γ with
    | empty    => O
    | evar Γ τ => S (dom Γ)
  end.
Notation "Γ r▻ T" := (evar Γ T) (at level 55, left associativity).

Reserved Notation "Γ₁ r▻▻ Γ₂" (at level 55, left associativity).
Fixpoint ecat (Γ₁ Γ₂ : Env) {struct Γ₂} : Env :=
  match Γ₂ with
    | empty  => Γ₁
    | Γ₂ r▻ τ => (Γ₁ r▻▻ Γ₂) r▻ τ
  end
where "Γ₁ r▻▻ Γ₂" := (ecat Γ₁ Γ₂).

(*  a type is closed with an (type variable) environment of size n *)
Inductive wsTy (γ : Dom) : Ty → Prop :=
    | WsTUnit : wsTy γ tunit
    | WsBool : wsTy γ tbool
    | WsFn {τ τ'} : wsTy γ τ → wsTy γ τ' → wsTy γ (tarr τ τ')
    | WsSum {τ τ'} : wsTy γ τ → wsTy γ τ' → wsTy γ (tsum τ τ')
    | WsProd {τ τ'} : wsTy γ τ → wsTy γ τ' → wsTy γ (tprod τ τ')
    | WsRec {τ} : wsTy (S γ) τ → wsTy γ (trec τ)
    | WsTVar {i} : γ ∋ i → wsTy γ (tvar i).

Section WellScoping.
  Lemma WsTy_mono {n m : nat} {τ} : n <= m -> wsTy n τ -> wsTy m τ.
  Proof.
    intros ineq cτn.
    revert m ineq.
    induction cτn; constructor; eauto.
    - eapply (IHcτn (S m)); lia.
    - revert m ineq.
      induction H.
      + intros.
        destruct m; [exfalso; lia|].
        constructor.
      + intros.
        destruct m; [exfalso; lia|].
        constructor.
        eapply IHwsIx; lia.
  Qed.

End WellScoping.

#[export]
Instance WsTy : Ws Ty := wsTy.

Section Application.

  Context {Y: Type}.
  Context {vrY: Vr Y}.
  Context {wkY: Wk Y}.

  Context {vrTy: Vr Ty}.
  Context {liftYTy: Lift Y Ty}.

  Fixpoint apTy (ζ: Sub Y) (τ: Ty) {struct τ} : Ty :=
    match τ with
      | tarr τ₁ τ₂ => tarr (apTy ζ τ₁) (apTy ζ τ₂)
      | tunit => tunit
      | tbool => tbool
      | tprod τ₁ τ₂ => tprod (apTy ζ τ₁) (apTy ζ τ₂)
      | tsum τ₁ τ₂ => tsum (apTy ζ τ₁) (apTy ζ τ₂)
      | trec τ => trec (apTy (ζ↑) τ)
      | tvar α => lift (ζ α)
    end.

  Global Arguments apTy ζ !τ.
End Application.

Ltac crushRecTypesMatchH :=
  match goal with
    | [ H: S _ = S _             |- _ ] => apply eq_add_S in H
    | [ H: tarr _ _  = tarr _ _  |- _ ] => inversion H; clear H
    | [ H: tprod _ _ = tprod _ _ |- _ ] => inversion H; clear H
    | [ H: tsum _ _  = tsum _ _  |- _ ] => inversion H; clear H
    | [ H: trec _ = trec _ |- _ ] => inversion H; clear H
    | [ H: tvar _ = tvar _ |- _ ] => inversion H; clear H

    | [ |- tarr _ _ = tarr _ _ ] => f_equal
    | [ |- tprod _ _ = tprod _ _ ] => f_equal
    | [ |- tsum _ _ = tsum _ _ ] => f_equal
    | [ |- trec _ = trec _ ] => f_equal
    | [ |- tvar _ = tvar _ ] => f_equal
    | [ |- tunit = tunit ] => reflexivity
    | [ |- tbool = tbool ] => reflexivity

    | [ |- _ r▻ _        = _ r▻ _        ] => f_equal
    | [ |- context[apTy ?ζ ?τ] ] =>
      change (apTy ζ τ) with τ[ζ]
  end.

Reserved Notation "⟪  i : T r∈ Γ  ⟫"
  (at level 0, i at level 98, Γ at level 98).
Inductive GetEvar : Env → Ix → Ty → Prop :=
  | GetEvarHere {Γ T} :
      ⟪   O : T r∈ Γ r▻ T  ⟫
  | GetEvarThere {Γ T T' i} :
      ⟪   i : T r∈ Γ      ⟫ →
      ⟪ S i : T r∈ Γ r▻ T' ⟫
where "⟪  i : T r∈ Γ  ⟫" := (GetEvar Γ i T).
#[export]
Hint Constructors GetEvar : ws.

Definition WtRen (Γ₁ Γ₂: Env) (ξ: Sub Ix) : Prop :=
  ∀ i T, ⟪ i : T r∈ Γ₁ ⟫ → ⟪ (ξ i) : T r∈ Γ₂ ⟫.

Lemma getEvarInvHere { Γ T U } :
  ⟪ 0 : T r∈ (Γ r▻ U) ⟫ → T = U.
Proof. inversion 1; auto. Qed.

Lemma getEvarInvThere {Γ i T U} :
  ⟪ (S i) : T r∈ Γ r▻ U ⟫ → ⟪ i : T r∈ Γ ⟫.
Proof. inversion 1; auto. Qed.
#[export]
Hint Resolve getEvarInvThere : wsi.


From mathcomp Require Import ssreflect ssrfun ssrbool seq eqtype.

Require Import lib.utils.

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

Section Events.

Variables (pT rT : eqType).
Variable can_access : pT -> rT -> bool.

Inductive event :=
| MemRead of pT & rT
| MemWrite of pT & rT.

Definition event_eq e1 e2 :=
  match e1, e2 with
  | MemRead ptr1 reg1, MemRead ptr2 reg2 =>
    (ptr1 == ptr2) && (reg1 == reg2)
  | MemWrite ptr1 reg1, MemWrite ptr2 reg2 =>
    (ptr1 == ptr2) && (reg1 == reg2)
  | _, _ => false
  end.

Lemma event_eqP : Equality.axiom event_eq.
Proof.
move=> [ptr1 reg1|ptr1 reg1] [ptr2 reg2|ptr2 reg2] /=; try by constructor.
  by apply/(equivP andP); split=> [[/eqP -> /eqP ->]|[-> ->]].
by apply/(equivP andP); split=> [[/eqP -> /eqP ->]|[-> ->]].
Qed.

Definition event_eqMixin := EqMixin event_eqP.
Canonical event_eqType := Eval hnf in EqType event event_eqMixin.

End Events.

Structure memory_safety_machine := MSMachine {
  state : eqType;
  pointer : eqType;
  region : eqType;
  can_access : pointer -> region -> bool;
  get_events : state -> seq (event pointer region);
  step : state -> state -> Prop
}.

Section FixMachine.

Variable m : memory_safety_machine.

Local Notation pT := (pointer m).
Local Notation rT := (region m).
Local Notation event := (event pT rT).

Implicit Type e : event.

Definition event_ok e :=
  match e with
  | MemRead ptr reg => can_access ptr reg
  | MemWrite ptr reg => can_access ptr reg
  end.

Definition memory_safety :=
  forall t x y, intermr (@step m) t x y ->
                all event_ok (flatten (map (@get_events m) t)).

End FixMachine.


Require Import Iron.Language.SimplePCF.Ty.
Require Export Iron.Language.SimplePCF.Exp.

(* Substitution of expressions in expressions preserves typing.
   Inductively, we must reason about performing substitutions at any
   depth, hence we must prove a property about (subst' d x2 x1) instead
   of the weaker (subst x2 x1) which assumes the substitution is taking
   place at top level. *)
Theorem subst_exp_exp_ix
 :  forall ix te x1 x2 t1 t2
 ,  get  ix te = Some t2
 -> TYPE te           x1 t1
 -> TYPE (delete ix te) x2 t2
 -> TYPE (delete ix te) (substX ix x2 x1) t1.
Proof.
 intros. gen ix te x2 t1.
 induction x1; rip; simpl; inverts H0; eauto.

 - fbreak_nat_compare; burn.
   eapply TyVar.
   destruct n; burn.
    norm. nnat. down. apply get_delete_below. omega.

 - apply TyLam.
   rewrite delete_rewind.
   apply IHx1; burn using type_tyenv_weaken.

 - apply TyFix.
   rewrite delete_rewind.
   apply IHx1; burn using type_tyenv_weaken.
Qed.

Theorem subst_exp_exp
 :  forall te x1 x2 t1 t2
 ,  TYPE (te :> t2) x1 t1
 -> TYPE te         x2 t2
 -> TYPE te (substX 0 x2 x1) t1.
Proof.
  intros te x1 x2 t1 t2 Ht1 Ht2.
  lets H: subst_exp_exp_ix 0 (te :> t2).
  burn.
Qed.


From Coq Require Import List.
Import ListNotations.

(** * Some complements on [comparison] *)

Set Implicit Arguments.

(** lexicographic product, defined using a notation to keep things lazy *)

Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end.

Lemma lex_Eq u v : lex u v = Eq <-> u=Eq /\ v=Eq.
Proof. now destruct u. Qed.

(** The comparison function in OrderedType are symmetric and
    transitive in the following sense: *)

Definition Sym {A} (cmp:A->A->comparison) :=
  forall x y, cmp y x = CompOpp (cmp x y).

Definition Trans {A} (cmp:A->A->comparison) :=
  forall c x y z, cmp x y = c -> cmp y z = c -> cmp x z = c.

Class SymTrans {A} (cmp:A->A->comparison) := {
  sym :> Sym cmp;
  tra :> Trans cmp
}.

(** [SymTrans] implies the following compatibility rules *)

Definition CompatR {A} (cmp:A->A->comparison) :=
  forall x y y', cmp y y' = Eq -> cmp x y = cmp x y'.

Definition CompatL {A} (cmp:A->A->comparison) :=
  forall x x' y, cmp x x' = Eq -> cmp x y = cmp x' y.

Ltac flipcmp H :=
 match type of H with ?cmp _ _ = _ =>
   match goal with
   | Sy : Sym cmp |- _ => rewrite Sy, CompOpp_iff in H; simpl in H
   | Sy : SymTrans cmp |- _ => rewrite sym, CompOpp_iff in H; simpl in H
   end
 end.

Lemma SymTrans_CompatR {A} (cmp:A->A->comparison) :
  SymTrans cmp -> CompatR cmp.
Proof.
 intros (Sy,Tr) x y y' Hy.
 destruct (cmp x y) eqn:E, (cmp x y') eqn:E'; trivial.
 - erewrite Tr in E'; eauto.
 - erewrite Tr in E'; eauto.
 - erewrite Tr in E; eauto. now flipcmp Hy.
 - flipcmp E. erewrite Tr in Hy; eauto. easy.
 - flipcmp Hy. erewrite Tr in E; eauto.
 - flipcmp E. erewrite Tr in Hy; eauto. easy.
Qed.

Lemma SymTrans_CompatL {A} (cmp:A->A->comparison) :
  SymTrans cmp -> CompatL cmp.
Proof.
 intros ST x x' y Hx. rewrite (sym y x), (sym y x'). f_equal.
 apply SymTrans_CompatR; auto.
Qed.

(** Lexicographic comparison on pairs *)

Section PairComp.
Variable A B : Type.
Variable cmpA : A -> A -> comparison.
Variable cmpB : B -> B -> comparison.
Definition pair_compare '(a,b) '(a',b') := lex (cmpA a a') (cmpB b b').

Lemma pair_compare_sym : Sym cmpA -> Sym cmpB -> Sym pair_compare.
Proof.
 intros HA HB (x,x') (y,y'). simpl.
 rewrite HA, HB. destruct cmpA; simpl; auto.
Qed.

Lemma pair_compare_trans :
  SymTrans cmpA -> Trans cmpB -> Trans pair_compare.
Proof.
 intros HA HB c (x,x') (y,y') (z,z') Hxy Hyz. simpl in *.
 destruct (cmpA x y) eqn:Cxy; simpl.
 - rewrite SymTrans_CompatL; eauto.
   destruct (cmpA y z) eqn:Cyz; simpl; eauto.
 - subst c.
   destruct (cmpA y z) eqn:Cyz; simpl; try easy.
   + flipcmp Cyz. rewrite SymTrans_CompatR, Cxy; eauto.
   + rewrite tra; eauto. easy.
 - subst c.
   destruct (cmpA y z) eqn:Cyz; simpl; try easy.
   + flipcmp Cyz. rewrite SymTrans_CompatR, Cxy; eauto.
   + rewrite tra; eauto. easy.
Qed.

Global Instance pair_compare_st :
  SymTrans cmpA -> SymTrans cmpB -> SymTrans pair_compare.
Proof.
 constructor.
 - apply pair_compare_sym; apply sym.
 - apply pair_compare_trans; auto. apply tra.
Qed.

Lemma pair_compare_eq a a' b b' :
  pair_compare (a,b) (a',b') = Eq <-> cmpA a a' = Eq /\ cmpB b b' = Eq.
Proof.
 apply lex_Eq.
Qed.

End PairComp.

(** Comparison on lists *)

Section ListComp.
Variable A : Type.
Variable cmp : A -> A -> comparison.
Fixpoint list_compare (l1 l2 : list A) :=
  match l1, l2 with
  | [], [] => Eq
  | [], _ => Lt
  | _, [] => Gt
  | x1::l1', x2::l2' => lex (cmp x1 x2) (list_compare l1' l2')
  end.

Lemma list_compare_sym : Sym cmp -> Sym list_compare.
Proof.
 intros HA. red. induction x as [|a x IH]; destruct y as [|a' y]; auto.
 simpl. rewrite HA. destruct cmp; simpl; auto.
Qed.

Lemma list_compare_trans :
  SymTrans cmp -> Trans list_compare.
Proof.
 intros HA c.
 induction x as [|a x IH]; destruct y as [|a' y], z as [|a'' z];
  simpl; auto; try congruence.
 destruct (cmp a a') eqn:E, (cmp a' a'') eqn:E'; simpl; try congruence.
 - rewrite tra; eauto. simpl; eauto.
 - intros _ <-. rewrite SymTrans_CompatL, E'; eauto.
 - intros _ <-. rewrite SymTrans_CompatL, E'; eauto.
 - intros <- _. rewrite SymTrans_CompatR, E; eauto. now flipcmp E'.
 - intros <- _. rewrite tra; eauto. easy.
 - intros <- _. rewrite SymTrans_CompatR, E; eauto. now flipcmp E'.
 - intros <- _. rewrite tra; eauto. easy.
Qed.

Global Instance list_compare_st : SymTrans cmp -> SymTrans list_compare.
Proof.
 constructor. apply list_compare_sym, sym. now apply list_compare_trans.
Qed.

Lemma list_compare_eq l l' :
  list_compare l l' = Eq <-> Forall2 (fun a a' => cmp a a' = Eq) l l'.
Proof.
 split.
 - revert l'.
   induction l as [|a l IH]; destruct l' as [|b l']; simpl; try easy.
    rewrite lex_Eq; intuition.
 - induction 1; simpl; now rewrite ?lex_Eq.
Qed.

End ListComp.

(** Extended comparisons on lists (used in [Tries.MMaps.Positive.compare]).
    An extra flag indicates whether the comparison between two lists
    ended :
    - because (at least) one list was emptied (EOL).
    - or because disequal elements where found (Early).
    In the second case, extending the lists on the right will not
    change the result of the comparison, while the first case is more
    delicate. *)

Inductive flag := EOL | Early.

Notation elex u v :=
  match u with Eq => v | Lt => (Lt,Early) | Gt => (Gt,Early) end.

Section ListExtComp.
Variable A : Type.
Variable cmp : A -> A -> comparison.
Fixpoint list_ecompare (l1 l2 : list A) : comparison*flag :=
  match l1, l2 with
  | [], [] => (Eq,EOL)
  | [], _ => (Lt,EOL)
  | _, [] => (Gt,EOL)
  | x1::l1', x2::l2' => elex (cmp x1 x2) (list_ecompare l1' l2')
  end.

 Lemma list_ecompare_fst l1 l2 :
   fst (list_ecompare l1 l2) = list_compare cmp l1 l2.
 Proof.
  revert l2.
  induction l1; destruct l2; simpl; auto. case cmp; auto.
 Qed.

 Lemma list_ecompare_eq_snd l1 l2 b :
   list_ecompare l1 l2 = (Eq,b) -> b = EOL.
 Proof.
  revert l2.
  induction l1; destruct l2; simpl; auto; try congruence.
  case cmp; try easy. eauto.
 Qed.

 Lemma list_ecompare_eq_app u v u' v' b :
   list_ecompare u u' = (Eq,b) ->
   list_ecompare (u++v) (u'++v') = list_ecompare v v'.
 Proof.
  revert u'; induction u; destruct u'; simpl; try easy.
  destruct cmp; now auto.
 Qed.

 Lemma list_ecompare_app u v u' v' :
   (forall x y, List.In x u' -> List.In y v -> cmp y x = Gt) ->
   (forall x y, List.In x u -> List.In y v' -> cmp x y = Lt) ->
   list_ecompare (u++v) (u'++v') =
   match list_ecompare u u' with
   | (Eq,_) => list_ecompare v v'
   | (c,Early) => (c,Early)
   | (Lt,EOL) => if v then (Lt,EOL) else (Gt,Early)
   | (Gt,EOL) => if v' then (Gt,EOL) else (Lt,Early)
   end.
 Proof.
 revert u'.
 induction u; destruct u'; intros GT LT; cbn; auto.
 - destruct v; simpl in *; auto. rewrite GT; auto.
 - destruct v'; simpl in *; auto. rewrite LT; auto.
 - case cmp; intuition.
 Qed.

End ListExtComp.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import QArith_base Orders QOrderedType GenericMinMax.

(** * Maximum and Minimum of two rational numbers *)

Local Open Scope Q_scope.

(** [Qmin] and [Qmax] are obtained the usual way from [Qcompare]. *)

Definition Qmax := gmax Qcompare.
Definition Qmin := gmin Qcompare.

Module QHasMinMax <: HasMinMax Q_as_OT.
 Module QMM := GenericMinMax Q_as_OT.
 Definition max := Qmax.
 Definition min := Qmin.
 Definition max_l := QMM.max_l.
 Definition max_r := QMM.max_r.
 Definition min_l := QMM.min_l.
 Definition min_r := QMM.min_r.
End QHasMinMax.

Module Q.

(** We obtain hence all the generic properties of max and min. *)

Include MinMaxProperties Q_as_OT QHasMinMax.

(** * Properties specific to the [Q] domain *)

(** Compatibilities (consequences of monotonicity) *)

Lemma plus_max_distr_l : forall n m p, Qmax (p + n) (p + m) == p + Qmax n m.
Proof.
 intros. apply max_monotone.
 intros x x' Hx; rewrite Hx; auto with qarith.
 intros x x' Hx. apply Qplus_le_compat; q_order.
Qed.

Lemma plus_max_distr_r : forall n m p, Qmax (n + p) (m + p) == Qmax n m + p.
Proof.
 intros. rewrite (Qplus_comm n p), (Qplus_comm m p), (Qplus_comm _ p).
 apply plus_max_distr_l.
Qed.

Lemma plus_min_distr_l : forall n m p, Qmin (p + n) (p + m) == p + Qmin n m.
Proof.
 intros. apply min_monotone.
 intros x x' Hx; rewrite Hx; auto with qarith.
 intros x x' Hx. apply Qplus_le_compat; q_order.
Qed.

Lemma plus_min_distr_r : forall n m p, Qmin (n + p) (m + p) == Qmin n m + p.
Proof.
 intros. rewrite (Qplus_comm n p), (Qplus_comm m p), (Qplus_comm _ p).
 apply plus_min_distr_l.
Qed.

End Q.


Require Import Coq.Lists.List.

Fixpoint nthR {A:Type} (l:list A) (n:nat) (a:A) :=
match l with
| nil => False
| cons h t =>
  match n with
  | O => h=a
  | S n' => nthR t n' a
  end
end.

Theorem pigeon : forall (l:list nat) (m:nat),
length l >= 2 ->
length l = S m ->
(forall (i v:nat), nthR l i v -> v < m) ->
exists (i j vi vj:nat), i<>j /\ (nthR l i vi -> nthR l j vj -> vi=vj).

intros l m.

destruct l. intro h. simpl in h. inversion h.
destruct l. intro h. simpl in h. inversion h. inversion H0.
generalize dependent l.
intro l.

destruct m.
intros hge heq hiv. specialize (hiv 0 n). simpl in hiv.
specialize (hiv eq_refl). inversion hiv.

intros hge hl.
intro hiv.

clear hge.

generalize dependent m.
induction l.

intros. exists 0, 1, n, n0. simpl in hl. inversion hl. subst m.
split. auto. simpl.
clear hl. intros. clear H H0.
remember (hiv 0 n) as ha.
remember (hiv 1 n0) as hb.
clear Heqhb Heqha hiv.
simpl in ha, hb.
specialize (ha eq_refl).
specialize (hb eq_refl).
unfold lt in ha, hb.
inversion ha. inversion hb. clear ha hb. reflexivity. inversion H1. inversion H0.

intros.
simpl in hl.
inversion hl.
assert (exists x, m= S x).
destruct m. inversion H0. exists m. reflexivity.
inversion_clear H. subst m.
inversion H1. clear H1.
specialize (IHl x).
apply eq_S in H0.
apply eq_S in H0.
specialize (IHl H0).
clear hl. inversion H0. clear H0.
rewrite H1 in hiv.
rename a into a'.
rename n into a.
rename n0 into b.
rename a' into c.

assert (youpi:forall i v : nat, nthR(a::b::l) i v -> v < S(S x)).
intros i v h.
destruct i.
apply (hiv 0). simpl in h. simpl. assumption.
destruct i. apply (hiv 1). simpl in h. simpl. assumption.
apply (hiv (S (S (S i)))).
simpl. simpl in h. assumption.

(* Stuck :( *)


Require Export GeoCoq.Elements.OriginalProofs.lemma_ray.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_ray1 :
   forall A B P,
   Out A B P ->
   (BetS A P B \/ eq B P \/ BetS A B P).
Proof.
intros.
assert (~ ~ (BetS A P B \/ eq B P \/ BetS A B P)).
 {
 intro.
 assert (neq P B) by (conclude lemma_inequalitysymmetric).
 assert (BetS A B P) by (conclude lemma_ray).
 contradict.
 }
close.
Qed.

End Euclid.