(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Bool Lia Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations utils fol_ops fo_sig fo_terms fo_logic fo_sat.

Import fol_notations.

Set Implicit Arguments.

(* * Removing constant functions from monadic signatures *)

Local Notation ø := vec_nil.

Section remove_constants.

  Variable (Σ : fo_signature) (HΣ : forall s, ar_syms Σ s <= 1).

  Definition Σno_constants : fo_signature.
  Proof.
    exists (syms Σ) (rels Σ).
    + exact (fun _ => 1).
    + apply ar_rels.
  Defined.

  Notation Σ' := Σno_constants.

  Implicit Type (t : fo_term (ar_syms Σ))
                (A : fol_form Σ).

  Let choice : forall a, { a = 0 } + { a = 1 } + { 1 < a }.
  Proof. intros [ | [ | a ] ]; auto; right; lia. Qed.

  Let Fixpoint fot_rem_cst (n : nat) t { struct t } : fo_term (ar_syms Σ').
  Proof.
    refine (match t with
      | in_var i   => in_var i
      | in_fot s v =>
      match choice (ar_syms _ s) with
        | inleft (left _)  => @in_fot _ (ar_syms Σ') s (£n##ø)
        | inleft (right E) => @in_fot _ (ar_syms Σ') s (fot_rem_cst n (vec_pos (cast v E) pos0)##ø)
        | inright H        => _
      end
    end).
    exfalso; abstract (generalize (HΣ s); lia).
  Defined.

  Fixpoint Σrem_constants (n : nat) A { struct A } :=
    match A with
      | ⊥              => ⊥
      | fol_atom r v   => @fol_atom Σ' r (vec_map (fot_rem_cst n) v)
      | fol_bin b A B  => fol_bin b (Σrem_constants n A) (Σrem_constants n B)
      | fol_quant q A  => fol_quant q (Σrem_constants (S n) A)
    end.

  Variable (X : Type).

  Section soundness.

    Variable (M : fo_model Σ X).

    Let M' : fo_model Σ' X.
    Proof.
      split.
      + intros s; simpl in *.
        destruct (choice (ar_syms _ s)) as [ [ H | H ] | H ].
        * exact (fun _ => fom_syms M s (cast ø (eq_sym H))).
        * exact (fun v => fom_syms M s (cast v (eq_sym H))).
        * abstract (intros; exfalso; generalize (HΣ s); lia).
      + apply (fom_rels M).
    Defined.

    Let fot_rem_cst_sound n t φ :
            fo_term_sem M φ t = fo_term_sem M' φ (fot_rem_cst n t).
    Proof.
      induction t as [ i | s v IHv ].
      + simpl; auto.
      + simpl.
        case_eq (choice (ar_syms Σ s)); [ intros [ E | E ] | intros E ]; intros HE;
          simpl; try rewrite HE; clear HE.
        * f_equal.
          clear n IHv; revert E v.
          intros -> v; vec nil v; auto.
        * f_equal; apply vec_pos_ext; intros p; rew vec.
          specialize (IHv p); rewrite IHv; clear IHv.
          revert E p v; intros -> p v.
          analyse pos p; rew vec.
        * exfalso; clear v IHv.
          generalize (HΣ s); lia.
    Qed.

    Local Fact Σrem_constants_sound n A φ : fol_sem M φ A <-> fol_sem M' φ (Σrem_constants n A).
    Proof.
      revert n φ; induction A as [ | r v | b A HA B HB | q A HA ]; intros n φ.
      + simpl; tauto.
      + simpl.
        rewrite vec_map_map.
        apply fol_equiv_ext; f_equal.
        apply vec_pos_ext; intros p; rew vec.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; auto.
    Qed.

    Hypothesis (Xfin : finite_t X)
               (Mdec : fo_model_dec M)
               (φ : nat -> X)
               (A : fol_form Σ)
               (HA : fol_sem M φ A).

    Local Lemma Σrem_constants_soundness : fo_form_fin_dec_SAT_in (Σrem_constants 0 A) X.
    Proof.
      exists M', Xfin, Mdec, φ.
      apply Σrem_constants_sound; auto.
    Qed.

  End soundness.

  Section completeness.

    Variable (M' : fo_model Σ' X)
             (φ : nat -> X).

    Let M : fo_model Σ X.
    Proof.
      split.
      + simpl; intros s.
        destruct (choice (ar_syms _ s)) as [ [ H | H ] | H ].
        * exact (fun _ => fom_syms M' s (φ 0##ø)).
        * exact (fun v => fom_syms M' s (cast v H)).
        * abstract (intros; exfalso; generalize (HΣ s); lia).
      + apply (fom_rels M').
    Defined.

    Let fot_rem_cst_complete n t ψ :
             ψ n = φ 0
          -> fo_term_sem M ψ t = fo_term_sem M' ψ (fot_rem_cst n t).
    Proof.
      intros H0; induction t as [ i | s v IHv ].
      + simpl; auto.
      + simpl.
        destruct (choice (ar_syms Σ s)) as [ [ E | E ] | E ].
        * simpl; now do 2 f_equal.
        * simpl fo_term_sem; f_equal.
          revert E v IHv; intros -> v IHv.
          apply vec_pos_ext; intros p; rew vec.
          analyse pos p; simpl; rew vec.
        * exfalso; clear v IHv.
          generalize (HΣ s); lia.
    Qed.

    Local Fact Σrem_constants_complete n A ψ :
           ψ n = φ 0
        -> fol_sem M ψ A <-> fol_sem M' ψ (Σrem_constants n A).
    Proof.
      revert n ψ; induction A as [ | r v | b A HA B HB | q A HA ]; intros n ψ H.
      + simpl; tauto.
      + simpl; apply fol_equiv_ext; f_equal; rewrite vec_map_map.
        apply vec_pos_ext; intros p; rewrite !vec_pos_map; auto.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; apply HA; simpl; auto.
    Qed.

    Hypothesis (Xfin : finite_t X)
               (M'dec : fo_model_dec M')
               (A : fol_form Σ)
               (HA : fol_sem M' φ (Σrem_constants 0 A)).

    Local Lemma Σrem_constants_completeness : fo_form_fin_dec_SAT_in A X.
    Proof.
      exists M, Xfin, M'dec, φ.
      revert HA; apply Σrem_constants_complete; auto.
    Qed.

  End completeness.

  Theorem Σrem_constants_correct A :
             fo_form_fin_dec_SAT_in A X
         <-> fo_form_fin_dec_SAT_in (Σrem_constants 0 A) X.
  Proof.
    split.
    + intros (M & H1 & H2 & phi & H3).
      apply Σrem_constants_soundness with M phi; auto.
    + intros (M & H1 & H2 & phi & H3).
      apply Σrem_constants_completeness with M phi; auto.
  Qed.

End remove_constants.


From mathcomp Require Import all_ssreflect.
From RegLang Require Import setoid_leq misc nfa dfa minimization languages regexp.

From RegMatch Require Import regexp regmatch.

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

Section RegLangExp.

Variable char : eqType.

Lemma r_eq_dec (e1 e2 : r char) : {e1 = e2} + {e1 <> e2}.
Proof. decide equality; apply: eq_comparable. Qed.

Definition r_eqMixin := EqMixin (compareP r_eq_dec).
Canonical Structure re_eqType := EqType _ r_eqMixin.

Fixpoint regexp2r (r0 : regexp char) : r char :=
  match r0 with
  | Void => r_zero
  | Eps => r_unit
  | Atom c' => r_char c'
  | Star r' => r_star (regexp2r r')
  | Plus r1 r2 => r_plus (regexp2r r1) (regexp2r r2)
  | Conc r1 r2 => r_times (regexp2r r1) (regexp2r r2)
  end.

Fixpoint r2regexp (r : r char) : regexp char :=
  match r with
  | r_zero => Void
  | r_unit => Eps
  | r_char c' => Atom c'
  | r_star r' => Star (r2regexp r')
  | r_plus r1 r2 => Plus (r2regexp r1) (r2regexp r2)
  | r_times r1 r2 => Conc (r2regexp r1) (r2regexp r2)
  end.

Fixpoint re_stars (e : regexp char) : nat :=
  match e with
  | Star s => (re_stars s).+1
  | Plus s t => ((re_stars s)+(re_stars t)).+1
  | Conc s t => ((re_stars s)+(re_stars t)).+1
  | _ => 0
  end.

Lemma cancel_re_regexp : cancel r2regexp regexp2r.
Proof.
rewrite /cancel.
elim => //=.
- move => r IH r' IH'.
  by rewrite IH IH'.
- move => r IH r' IH'.
  by rewrite IH IH'.
- move => r IH.
  by rewrite IH.
Qed.

Lemma cancel_regexp_re : cancel regexp2r r2regexp.
Proof.
rewrite /cancel.
elim => //=.
- move => r IH.
  by rewrite IH.
- move => r IH r' IH'.
  by rewrite IH IH'.
- move => r IH r' IH'.
  by rewrite IH IH'.
Qed.

Lemma regexp_re_in : forall (r : r char) (w : seq char), s_in_regexp_lang _ w r -> w \in re_lang (r2regexp r).
Proof.
move => r w H.
remember r as r0.
remember w as w0.
revert r w Heqr0 Heqw0.
induction H => //=.
- move => r w H_eq H_eq'.
  subst.
  by rewrite inE.
- move => r w H_eq H_eq'.
  subst.
  apply/plusP; left.
  exact: IHs_in_regexp_lang.
- move => r w H_eq H_eq'.
  subst.
  apply/plusP; right.
  exact: IHs_in_regexp_lang.
- move => r w H_eq H_eq'.
  subst.
  apply/concP.
  exists s5, s'.
  split => //.
  split.
  * exact: IHs_in_regexp_lang1.
  * exact: IHs_in_regexp_lang2.
- move => r' w H_eq H_eq'.
  subst.
  apply/star_cat.
  * exact: IHs_in_regexp_lang1.
  * exact: IHs_in_regexp_lang2.
Qed.

Lemma regexp_re_in' : forall (r : regexp char) (w : seq char), s_in_regexp_lang _ w (regexp2r r) -> w \in re_lang r.
Proof.
move => r w H.
remember (regexp2r r) as r0.
remember w as w0.
revert r w Heqr0 Heqw0.
induction H => //=.
- move => r w H_eq H_eq'.
  subst.
  by destruct r.
- move => r w H_eq H_eq'.
  subst.
  destruct r => //.
  rewrite /= in H_eq.
  injection H_eq => H_eq'.
  subst.
  by rewrite inE.
- move => r w H_eq H_eq'.
  subst.
  destruct r => //.
  rewrite /= in H_eq.
  injection H_eq => H_eq1 H_eq2.
  subst.
  apply/plusP.
  left.
  by apply (IHs_in_regexp_lang _ w).
- move => r w H_eq H_eq'.
  subst.
  destruct r => //.
  rewrite /= in H_eq.
  injection H_eq => H_eq1 H_eq2.
  subst.
  apply/plusP.
  right.
  by apply (IHs_in_regexp_lang _ w).
- move => r w H_eq H_eq'.
  subst.
  destruct r => //.
  rewrite /= in H_eq.
  injection H_eq => H_eq1 H_eq2.
  subst.
  apply/concP.
  exists s5, s'.
  split => //.
  split.
  * exact: IHs_in_regexp_lang1.
  * exact: IHs_in_regexp_lang2.
- move => r' w H_eq H_eq'.
  subst.
  by destruct r'.
- move => r' w H_eq H_eq'.
  subst.
  destruct r' => //.
  rewrite /= in H_eq.
  injection H_eq => H_eq'.
  subst.
  apply/star_cat.
  * exact: IHs_in_regexp_lang1.
  * rewrite -/(re_lang _).
    have ->: star (re_lang r') = re_lang (Star r') by [].
    exact: IHs_in_regexp_lang2.
Qed.

Lemma re_lang_ind : forall (char : eqType) (P : seq char -> regexp char -> Prop),
    P [::] Eps ->
    (forall c' : char, P [:: c'] (Atom c')) ->
    (forall (w : seq char) (r1 r2 : regexp char), w \in (re_lang r1) -> P w r1 -> P w (Plus r1 r2)) ->
    (forall (w : seq char) (r1 r2 : regexp char), w \in (re_lang r2) -> P w r2 -> P w (Plus r1 r2)) ->
    (forall (w1 w2 : seq char) (r1 r2 : regexp char),
        w1 \in (re_lang r1) -> P w1 r1 -> w2 \in (re_lang r2) -> P w2 r2 -> P (w1 ++ w2) (Conc r1 r2)) ->
    (forall r : regexp char, P [::] (Star r)) ->
    (forall (w1 w2 : seq char) (r :regexp char),
        w1 \in (re_lang r) -> P w1 r -> w2 \in (re_lang (Star r)) -> P w2 (Star r) -> P (w1 ++ w2) (Star r)) ->
    forall (w : seq char) (r : regexp char), w \in (re_lang r) -> P w r.
Proof.
move => c0 P H_e H_a H_p1 H_p2 H_c H_s1 H_s2.
move => w r.
elim: r w => //=.
- by case.
- move => c' w.
  rewrite inE /=.
  move/eqP => H_eq.
  subst.
  exact: H_a.
- move => r IH w.
  move/starP => [vv H_vv] H_f.
  subst.
  move/allP: H_vv.
  move => IH'.
  elim: vv IH' => //=.
  move => w0 vv' IH' H_in.
  have H_in_vv: w0 \in w0 :: vv'.
    rewrite inE.
    apply/orP.
    by left.
  have H_in_vv' := H_in _ H_in_vv.
  move/andP: H_in_vv' => [H_not_in_vv H_in_vv'].
  apply H_s2 => //.
  * exact: IH.
  * apply/starI.
    move => w H_w.
    rewrite -/(re_lang _).
    have H_w_in: w \in w0 :: vv'.
      rewrite inE.
      apply/orP.
      by right.
    apply H_in in H_w_in.
    move: H_w_in.
    by move/andP => [H_w_in H_w_in'].
  * apply: IH'.
    move => w' H_w'.
    apply: H_in.
    rewrite inE.
    apply/orP.
    by right.
- move => r1 IH1 r2 IH2.
  move => w.
  move/plusP => [H_rp1|H_rp2].
  * apply: H_p1 => //.
    exact: IH1.
  * apply: H_p2 => //.
    exact: IH2.
- move => r1 IH1 r2 IH2.
  move => w.
  move/concP => [w1 [w2 [H_eq [H_w1 H_w2]]]].
  subst.
  apply: H_c => //.
  * exact: IH1.
  * exact: IH2.
Qed.

Lemma regexp_in_re : forall (r : regexp char) (w : seq char), w \in re_lang r  -> s_in_regexp_lang _ w (regexp2r r).
Proof.
move => r w H_st.
remember r as r0.
remember w as w0.
move: H_st r w Heqr0 Heqw0.
elim/re_lang_ind => //=.
- move => r w H_eq H_eq'.
  subst.
  exact: s_in_regexp_lang_unit.
- move => c' r w H_eq H_eq'.
  subst.
  exact: s_in_regexp_lang_char.
- move => w r1 r2 H_in IH r' w1 H_eq H_eq'.
  subst.
  apply: s_in_regexp_lang_plus_1.
  exact: IH.
- move => w r1 r2 H_in IH r' w1 H_eq H_eq'.
  subst.
  apply: s_in_regexp_lang_plus_2.
  exact: IH.
- move => w1 w2 r1 r2 H_in1 IH1 H_in2 IH2 r w H_eq H_eq'.
  subst.
  apply s_in_regexp_lang_times.
  * exact: IH1.
  * exact: IH2.
- move => r r2 w H_eq H_eq'.
  subst.
  exact: s_in_regexp_lang_star_1.
- move => w1 w2 r H_in1 IH1 H_in2 IH2 r1 w H_eq H_eq'.
  subst.
  apply s_in_regexp_lang_star_2.
  * exact: IH1.
  * exact: IH2.
Qed.

Definition residuals_re (r : regexp char) (c : char) (l : seq (regexp char)) :=
  (forall r', r' \in l -> (forall w, w \in re_lang r' -> w \in residual c (re_lang r))) /\
  (forall w, w \in residual c (re_lang r) -> exists r', r' \in l /\ w \in re_lang r').

Definition residuals_t (r : regexp char) (c : char) :=
{ l : seq (regexp char) | residuals_re r c l }.

Lemma s_in_regexp_c_lang_residual : forall r w c',
  s_in_regexp_c_lang char w (regexp2r r) c' ->
  w \in residual c' (re_lang r).
Proof.
move => r w c' H_c.
inversion H_c; subst.
rewrite /= in H.
by apply regexp_re_in'.
Qed.

Lemma residual_s_in_regexp_c_lang : forall r w c',
  w \in residual c' (re_lang r) ->
  s_in_regexp_c_lang char w (regexp2r r) c'.
Proof.
move => r w c' H_c.
apply s_in_regexp_c_lang_cs.
rewrite /=.
by apply regexp_in_re.
Qed.

Definition residuals : forall (r : regexp char) (c : char), residuals_t r c.
refine
  (fun r c =>
     match regexps_no_c (@eq_comparable char) (regexp2r r, c) with
     | exist l H_l => exist _ (map r2regexp l) _
     end).
split.
- move => r' H_in /= w H_w.
  rewrite /residual.
  rewrite inE.
  move: H_l => [H_l H_l'] {H_l'}.
  rewrite /= in H_l.
  apply s_in_regexp_c_lang_residual.
  apply regexp_in_re in H_w.
  apply (H_l (regexp2r r')) => //.
  move: H_in.
  move/mapP => [r0 H_in] H_eq.
  rewrite H_eq {H_eq}.
  rewrite cancel_re_regexp.
  move: H_in.
  clear.
  elim: l => //.
  move => r' l IH.
  rewrite inE.
  move/orP => [H_in|H_in].
  * by left; move/eqP: H_in.
  * right; exact: IH.
- move => w /= H_in.
  apply residual_s_in_regexp_c_lang in H_in.
  move: H_l => [H_l' H_l] {H_l'}.
  rewrite /= in H_l.
  apply H_l in H_in.
  move: H_in => [r' [H_in H_r']].
  exists (r2regexp r').
  split; last exact: regexp_re_in.
  apply List.in_split in H_in.
  rewrite /= in H_in.
  move: H_in => [l1 [l2 H_eq]].
  rewrite H_eq /=.
  rewrite map_cat mem_cat.
  apply/orP.
  right.
  rewrite inE.
  apply/orP.
  by left.
Defined.

Definition accept' : forall (r : regexp char) (w : seq char), {w \in re_lang r}+{w \notin re_lang r}.
refine
  (fun r w =>
     match accept (@eq_comparable char) (regexp2r r, w) with
     | left H_l => left _
     | right H_r => right _
     end).
- exact: regexp_re_in'.
- apply/negP.
  move => H_acc.
  case: H_r.
  exact: regexp_in_re.
Defined.

End RegLangExp.


Require Export P05.

Theorem ins_relate:
 forall k v t cts,
    SearchTree t ->
    Abs t cts ->
    Abs (ins k v t) (t_update cts (int2Z k) v).
Proof. exact FILL_IN_HERE. Qed.

Theorem insert_relate:
 forall k v t cts,
    SearchTree t ->
    Abs t cts ->
    Abs (insert k v t) (t_update cts (int2Z k) v).
Proof.
intros.
unfold insert.
apply makeBlack_relate.
apply ins_relate; auto.
Qed.

(** * Final Correctness Theorem *)

Theorem redblack_correct: forall (l: list (key*D.V)) k,
  lookup k (map_reduce (fun kv tr => insert   (fst kv) (snd kv) tr) empty_tree l) =
           (map_reduce (fun kv tm => t_update tm (int2Z (fst kv)) (snd kv)) (t_empty D.default) l) (int2Z k).
Proof.
  assert (ABS: forall l,
     SearchTree (map_reduce (fun kv tr => insert   (fst kv) (snd kv) tr) empty_tree l) /\
     Abs (map_reduce (fun kv tr => insert   (fst kv) (snd kv) tr) empty_tree l)
         (map_reduce (fun kv tm => t_update tm (int2Z (fst kv)) (snd kv)) (t_empty D.default) l)).
  { intros. induction l; simpl.
    - eauto using empty_tree_SearchTree, empty_tree_relate.
    - destruct IHl.
      eauto using insert_SearchTree, insert_relate.
  }
  intros. eapply lookup_relate, ABS.
Qed.


Require Export PredMonad.Reflection.OrderedType.
Require Export PredMonad.Reflection.OrderedContext.
Require Import Coq.Logic.ProofIrrelevance.

Import EqNotations.
Import ListNotations.
Import ProofIrrelevanceTheory.

(***
 *** Ordered Expressions
 ***)

Inductive OVar A {RA:OTRelation A} : Ctx -> Type :=
| OVar_0 {ctx:Ctx} : OVar A (CtxCons A ctx)
| OVar_S {ctx:Ctx} {B} {RB:OTRelation B} :
    OVar A ctx -> OVar A (CtxCons B ctx)
.

Arguments OVar_0 {A RA ctx}.
Arguments OVar_S {A RA ctx B RB} v.

(* Expressions to represent proper functions *)
Inductive OExpr (ctx:Ctx) : forall A {RA:OTRelation A}, Type :=
| Var {A} {RA:OTRelation A} {valid:ValidCtx ctx} (v:OVar A ctx) : OExpr ctx A
| Embed {A} {RA:OTRelation A} {OA:OType A} {valid:ValidCtx ctx} (a:A) : OExpr ctx A
| App {A B:Type} {RA:OTRelation A} {OA:OType A} {RB:OTRelation B} {OB:OType B}
      (e1 : OExpr ctx (A -o> B)) (e2 : OExpr ctx A) : OExpr ctx B
| Lam {A B:Type} {RA:OTRelation A} {OA:OType A} {RB:OTRelation B} {OB:OType B}
      {valid:ValidCtx ctx}
      (e: OExpr (CtxCons A ctx) B) : OExpr ctx (A -o> B)
.

Arguments Var {ctx} {A RA valid} v.
Arguments Embed {ctx} {A RA OA valid} a.
Arguments App {ctx} {A B RA OA RB OB} e1 e2.
Arguments Lam {ctx} {A B RA OA RB OB valid} e.

(* The type of any OVar in a ValidCtx is always an OType *)
Instance OType_OVar_type A {RA} ctx (v:@OVar A RA ctx) `{ValidCtx ctx}
  : OType A | 5.
Proof.
  revert H; induction v; intro valid; destruct valid; [ | apply IHv ]; assumption.
Qed.

(* The type of any OExpr is always an OType *)
Instance OType_OExpr_type ctx A {RA} (e:@OExpr ctx A RA) : OType A | 5.
Proof.
  induction e; eauto with typeclass_instances.
Qed.

(* The context of any OExpr is always valid *)
Instance ValidCtx_OExpr_ctx ctx A {RA} (e:@OExpr ctx A RA) : ValidCtx ctx | 5.
Proof.
  induction e; assumption.
Qed.

(***
 *** Semantics of Ordered Expressions
 ***)

(* The semantics of a variable *)
Fixpoint varSemantics {A} {RA:OTRelation A} {ctx} (v:OVar A ctx) :
  CtxElem ctx -o> A :=
  match v in OVar _ ctx return CtxElem ctx -o> A with
  | OVar_0 => snd_pfun (A:=CtxElem _)
  | OVar_S v' => compose_pfun fst_pfun (varSemantics v')
  end.
Arguments varSemantics {A RA ctx} !v.

(* The semantics of an ordered expression *)
Fixpoint exprSemantics {ctx A} {RA:OTRelation A} (e:OExpr ctx A) :
  CtxElem ctx -o> A :=
  match e in OExpr _ A return CtxElem ctx -o> A with
  | Var v => varSemantics v
  | Embed a => const_pfun a
  | App e1 e2 =>
    pfun_apply (exprSemantics e1) (exprSemantics e2)
  | Lam e => pfun_curry (exprSemantics e)
  end.
Arguments exprSemantics {ctx A RA} !e.

(***
 *** Relating Ordered Expressions
 ***)

(* Two expressions are related iff their semantics are *)
Definition oexpr_R {ctx A} {RA:OTRelation A} : relation (OExpr ctx A) :=
  fun e1 e2 => exprSemantics e1 <o= exprSemantics e2.
Arguments oexpr_R {ctx A RA} e1 e2 /.

(* oexpr_R is a PreOrder *)
Instance PreOrder_oexpr_R ctx A {RA} : PreOrder (@oexpr_R ctx A RA).
Proof.
  split; intro; intros;
  assert (ValidCtx ctx) as valid; try eauto with typeclass_instances;
    assert (OType A) as OA; try eauto with typeclass_instances;
      unfold oexpr_R.
  - reflexivity.
  - transitivity (exprSemantics y); assumption.
Qed.

(* Two expressions are equivalent iff their semantics are *)
Definition oexpr_eq {ctx A} {RA:OTRelation A} : relation (OExpr ctx A) :=
  fun e1 e2 => exprSemantics e1 =o= exprSemantics e2.
Arguments oexpr_eq {ctx A RA} e1 e2 /.

(* oexpr_eq is an Equivalence *)
Instance Equivalence_oexpr_eq ctx A {RA} : Equivalence (@oexpr_eq ctx A RA).
Proof.
  constructor; intro; intros;
    assert (ValidCtx ctx) as valid; try eauto with typeclass_instances;
      assert (OType A) as OA; try eauto with typeclass_instances;
        unfold oexpr_eq.
  { split; reflexivity. }
  { symmetry; assumption. }
  { transitivity (exprSemantics y); assumption. }
Qed.

Notation "x <e= y" :=
  (oexpr_R x y) (no associativity, at level 70).
Notation "x =e= y" :=
  (oexpr_eq x y) (no associativity, at level 70).

(* The Embed constructor is Proper w.r.t. ot_R and oexpr_R *)
Instance Proper_Embed ctx A {RA OA valid} :
  Proper (ot_R ==> oexpr_R) (@Embed ctx A RA OA valid).
Proof.
  intros a1 a2 Ra. simpl. rewrite Ra. reflexivity.
Qed.

(* The Embed constructor is Proper w.r.t. ot_equiv and oexpr_eq *)
Instance Proper_Embed_eq ctx A {RA OA valid} :
  Proper (ot_equiv ==> oexpr_eq) (@Embed ctx A RA OA valid).
Proof.
  intros a1 a2 Ra. simpl. rewrite Ra. reflexivity.
Qed.

(* The App constructor is Proper *)
Instance Proper_App ctx {A B RA OA RB OB} :
  Proper (oexpr_R ==> oexpr_R ==> oexpr_R) (@App ctx A B RA OA RB OB).
Proof.
  intros f1 f2 Rf a1 a2 Ra. simpl in * |- *.
  apply Proper_pfun_apply; assumption.
Qed.

(* The App constructor is Proper for equivalence *)
Instance Proper_App_eq ctx {A B RA OA RB OB} :
  Proper (oexpr_eq ==> oexpr_eq ==> oexpr_eq) (@App ctx A B RA OA RB OB).
Proof.
  intros f1 f2 Rf a1 a2 Ra. simpl in * |- *.
  apply Proper_pfun_apply_equiv; assumption.
Qed.

(* The Lam constructor is Proper *)
Instance Proper_Lam ctx {A B RA OA RB OB valid} :
  Proper (oexpr_R ==> oexpr_R) (@Lam ctx A B RA OA RB OB valid).
Proof.
  intros e1 e2 Re. simpl in * |- *.
  apply Proper_pfun_curry; assumption.
Qed.

(* The Lam constructor is Proper for equivalence *)
Instance Proper_Lam_eq ctx {A B RA OA RB OB valid} :
  Proper (oexpr_eq ==> oexpr_eq) (@Lam ctx A B RA OA RB OB valid).
Proof.
  intros e1 e2 Re. simpl in * |- *.
  apply Proper_pfun_curry_equiv; assumption.
Qed.

(***
 *** Weakening for Ordered Expressions
 ***)

(* Weakening / lifting of ordered expression variables *)
Fixpoint weakenOVar w W {RW:OTRelation W} :
  forall {ctx A} {RA:OTRelation A}, OVar A ctx -> OVar A (ctxInsert w W ctx) :=
  match w return
        forall ctx A {RA:OTRelation A}, OVar A ctx -> OVar A (ctxInsert w W ctx)
  with
  | 0 =>
    fun _ _ {_} v => OVar_S v
  | S w' =>
    fun ctx A {RA} v =>
      match v in OVar _ ctx return OVar A (ctxInsert (S w') W ctx) with
      | OVar_0 => OVar_0
      | OVar_S v' => OVar_S (weakenOVar w' W v')
      end
  end.

(* Correctness of weakenOVar: it is equivalent to weaken_pfun *)
Lemma weakenOVar_correct w W {RW} {OW:OType W} {ctx A RA}
      {OA:OType A} {valid:ValidCtx ctx} v :
  varSemantics (@weakenOVar w W RW ctx A RA v) =o=
  compose_pfun (weaken_pfun w W ctx) (varSemantics v).
Proof.
  revert ctx valid v; induction w; intros; [ | destruct v; destruct valid ]; simpl.
  - reflexivity.
  - rewrite compose_pair_snd. reflexivity.
  - rewrite compose_compose_pfun. rewrite compose_pair_fst.
    rewrite <- compose_compose_pfun. f_equiv. apply IHw. assumption.
Qed.

(* Weakening / lifting of ordered expressions *)
Fixpoint weakenOExpr w W {RW:OTRelation W} {OW:OType W} {ctx} {A} {RA:OTRelation A}
         (e:OExpr ctx A) : OExpr (ctxInsert w W ctx) A :=
  match e in OExpr _ A return OExpr (ctxInsert w W ctx) A with
  | Var v => Var (weakenOVar w W v)
  | Embed a => Embed a
  | App e1 e2 => App (weakenOExpr w W e1) (weakenOExpr w W e2)
  | Lam e => Lam (weakenOExpr (S w) W e)
  end.

(* Correctness of weakenOExpr: it is equivalent to weaken_pfun *)
Lemma weakenOExpr_correct w W {RW} {OW:OType W} {ctx A RA} e :
  exprSemantics (@weakenOExpr w W RW OW ctx A RA e) =o=
  compose_pfun (weaken_pfun w W ctx) (exprSemantics e).
Proof.
  revert w; induction e; intros; simpl.
  - apply weakenOVar_correct; try assumption.
    apply (OType_OExpr_type _ _ (Var v)).
  - rewrite compose_f_const_pfun; [ reflexivity | typeclasses eauto ].
  - assert (ValidCtx ctx) as valid; [ apply (ValidCtx_OExpr_ctx _ _ e1) | ].
    rewrite compose_pfun_apply; try typeclasses eauto.
    f_equiv; [ apply IHe1 | apply IHe2 ].
  - rewrite compose_pfun_curry; try assumption. Unshelve.
    f_equiv. apply (IHe (S w)).
    typeclasses eauto.
Qed.

(* Proper-ness of weakenOExpr *)
Instance Proper_weakenOExpr w W {RW} {OW:OType W} {ctx A RA} :
  Proper (oexpr_R ==> oexpr_R) (@weakenOExpr w W RW OW ctx A RA).
Proof.
  intros e1 e2 Re. unfold oexpr_R.
  assert (ValidCtx ctx) as valid; [ apply (ValidCtx_OExpr_ctx _ _ e1) | ].
  assert (OType A) as OA; [ eauto with typeclass_instances | ].
  repeat rewrite weakenOExpr_correct. f_equiv. assumption.
Qed.

(* Proper-ness of weakenOExpr *)
Instance Proper_weakenOExpr_equiv w W {RW} {OW:OType W} {ctx A RA} :
  Proper (oexpr_eq ==> oexpr_eq) (@weakenOExpr w W RW OW ctx A RA).
Proof.
  intros e1 e2 Re. destruct Re; split; apply Proper_weakenOExpr; assumption.
Qed.

(***
 *** Substitution for Ordered Expressions
 ***)

(* Substitution for ordered expression variables *)
Fixpoint substOVar n {ctx} {A} {RA:OTRelation A} :
  OVar A ctx ->
  forall {valid:ValidCtx ctx}, OExpr (ctxSuffix n ctx) (ctxNth n ctx) ->
  OExpr (ctxDelete n ctx) A :=
  match n return
        OVar A ctx ->
        ValidCtx ctx -> OExpr (ctxSuffix n ctx) (ctxNth n ctx) ->
        OExpr (ctxDelete n ctx) A
  with
  | 0 =>
    fun v =>
      match v in OVar _ ctx return
            ValidCtx ctx ->
            OExpr (ctxSuffix 0 ctx) (ctxNth 0 ctx) -> OExpr (ctxDelete 0 ctx) A
      with
      | OVar_0 => fun _ s => s
      | OVar_S v' => fun valid _ => Var (valid:=proj2 valid) v'
    end
  | S n' =>
    fun v =>
      match v in OVar _ ctx return
            ValidCtx ctx ->
            OExpr (ctxSuffix (S n') ctx) (ctxNth (S n') ctx) ->
            OExpr (ctxDelete (S n') ctx) A
      with
      | OVar_0 =>
        fun valid _ =>
          Var (valid:=ValidCtx_ctxDelete (S n') (CtxCons _ _)) OVar_0
      | @OVar_S _ _ ctx' B RB v' =>
        fun valid s =>
          weakenOExpr 0 B (OW:=proj1 valid) (A:=A)
                      (substOVar n' v' (valid:=proj2 valid) s)
      end
  end.
Arguments substOVar !n {ctx A RA} !v {valid} s.

(* Correctness of substOVar: it is equivalent to subst_pfun *)
Lemma substOVar_correct n {ctx A RA} v {valid} s :
  exprSemantics (@substOVar n ctx A RA v valid s) =o=
  compose_pfun (subst_pfun ctx n (exprSemantics s)) (varSemantics v).
Proof.
  revert n valid s; induction v; intros; destruct n; destruct valid; simpl.
  - rewrite compose_pair_snd. reflexivity.
  - rewrite compose_pair_snd. reflexivity.
  - assert (OType A) as OA; [ eauto with typeclass_instances | ].
    rewrite compose_compose_pfun. rewrite compose_pair_fst.
    rewrite id_compose_pfun. reflexivity.
  - assert (OType A) as OA; [ eauto with typeclass_instances | ].
    rewrite (weakenOExpr_correct 0). unfold weaken_pfun.
    rewrite compose_compose_pfun. rewrite compose_pair_fst.
    rewrite <- compose_compose_pfun. f_equiv. apply IHv.
Qed.

(* substOVar is Proper in its s argument *)
Instance Proper_substOVar n {ctx A RA} v {valid} :
  Proper (oexpr_R ==> oexpr_R) (@substOVar n ctx A RA v valid).
Proof.
  intros s1 s2; simpl; intro Rs.
  assert (OType A) as OA; [ eauto with typeclass_instances | ].
  repeat rewrite substOVar_correct. rewrite Rs. reflexivity.
Qed.

(* substOVar is Proper w.r.t. equivalence in its s argument *)
Instance Proper_substOVar_equiv n {ctx A RA} v {valid} :
  Proper (oexpr_eq ==> oexpr_eq) (@substOVar n ctx A RA v valid).
Proof.
  intros s1 s2 Rs; destruct Rs; split; apply Proper_substOVar; assumption.
Qed.

(* Substitution for ordered expressions *)
Fixpoint substOExpr n {ctx} {A} {RA:OTRelation A} (e:OExpr ctx A) :
  OExpr (ctxSuffix n ctx) (ctxNth n ctx) -> OExpr (ctxDelete n ctx) A :=
  match e with
  | Var v => fun s => substOVar n v s
  | Embed a => fun _ => Embed a
  | App e1 e2 => fun s => App (substOExpr n e1 s) (substOExpr n e2 s)
  | Lam e => fun s => Lam (substOExpr (S n) e s)
  end.
Arguments substOExpr n {ctx A RA} !e.

(* Correctness of substOExpr: it is equivalent to subst_pfun *)
Lemma substOExpr_correct n {ctx A RA} e s :
  exprSemantics (@substOExpr n ctx A RA e s) =o=
  compose_pfun (subst_pfun ctx n (exprSemantics s)) (exprSemantics e).
Proof.
  revert n s; induction e; intros; simpl.
  - apply substOVar_correct.
  - symmetry. apply compose_f_const_pfun. eauto with typeclass_instances.
  - assert (ValidCtx ctx) as valid; [ apply (ValidCtx_OExpr_ctx _ _ e1) | ].
    rewrite compose_pfun_apply; eauto with typeclass_instances.
    rewrite IHe1. rewrite IHe2. reflexivity.
  - rewrite compose_pfun_curry; eauto with typeclass_instances.
    rewrite (IHe (S n)). reflexivity.
Qed.

(* The Beta rule for ordered expressions *)
Lemma OExpr_Beta ctx `{ValidCtx ctx} A `{OType A} B `{OType B}
      (e1: OExpr (CtxCons A ctx) B) (e2: OExpr ctx A) :
  App (Lam e1) e2 =e= substOExpr 0 e1 e2.
Proof.
  simpl. rewrite pfun_apply_pfun_curry; eauto with typeclass_instances.
  rewrite (substOExpr_correct 0 (ctx:=CtxCons A ctx)). reflexivity.
Qed.

(***
 *** Other OExpr Rewrite Rules
 ***)

Lemma OExpr_fst_pair ctx `{ValidCtx ctx} A `{OType A} B `{OType B}
      (e1: OExpr ctx A) (e2: OExpr ctx B) :
  App (Embed (ofst (A:=A) (B:=B))) (App (App (Embed opair) e1) e2) =e= e1.
Proof.
  split; intros c1 c2 Rc; simpl; apply pfun_Proper; assumption.
Qed.

Lemma OExpr_snd_pair ctx `{ValidCtx ctx} A `{OType A} B `{OType B}
      (e1: OExpr ctx A) (e2: OExpr ctx B) :
  App (Embed (osnd (A:=A) (B:=B))) (App (App (Embed opair) e1) e2) =e= e2.
Proof.
  split; intros c1 c2 Rc; simpl; apply pfun_Proper; assumption.
Qed.

Lemma OExpr_pair_eta ctx `{ValidCtx ctx} A `{OType A} B `{OType B}
      (e: OExpr ctx (A*B)) :
  (App (App (Embed opair) (App (Embed ofst) e)) (App (Embed osnd) e))
  =e= e.
Proof.
  split; intros c1 c2 Rc; split; simpl; rewrite Rc; reflexivity.
Qed.

Hint Rewrite OExpr_fst_pair OExpr_snd_pair OExpr_pair_eta : osimpl.
Opaque ofst osnd opair.

(***
 *** Quoting Tactic for Ordered Expressions
 ***)

(* Specially-marked versions of fst and snd just used for quoting OExprs *)
Definition celem_head ctx A {RA} (celem: CtxElem (@CtxCons A RA ctx)) : A :=
  let (_,head) := celem in head.
Definition celem_rest ctx A {RA} (celem: CtxElem (@CtxCons A RA ctx)) :
  CtxElem ctx :=
  let (rest,_) := celem in rest.

(* Typeclass for incrementally quoting functions into OExpr variables, by
peeling off the celem_rest projections one at a time and adding them as OVar_S
constructors to the input variable to build the output variable *)
Class QuotesToVar {ctx1 ctx2 A} {RA:OTRelation A}
      (f: CtxElem ctx1 -> CtxElem ctx2) (vin: OVar A ctx2)
      (vout: OVar A ctx1) : Prop :=
  quotesToVar :
    forall c, varSemantics vin @o@ (f c) = varSemantics vout @o@ c.

Instance QuotesToVar_Base {ctx A} {RA:OTRelation A} v :
  QuotesToVar (ctx1:=ctx) (fun c => c) v v.
Proof.
  intro; reflexivity.
Qed.

Instance QuotesToVar_Step {ctx1 ctx2 A B} {RA:OTRelation A} {RB:OTRelation B}
         (f: CtxElem ctx1 -> CtxElem (CtxCons B ctx2)) vin vout
         (q: QuotesToVar f (OVar_S vin) vout) :
  QuotesToVar (fun c => celem_rest _ _ (f c)) vin vout.
Proof.
  intro. apply q.
Qed.

(* Class for quoting functions to OExprs *)
Class QuotesTo {ctx A} {RA:OTRelation A}
      (f: CtxElem ctx -> A) (e: OExpr ctx A) : Prop :=
  quotesTo : forall c, f c =o= exprSemantics e @o@ c.

(* Logically the same as QuotesTo, but we never build lambdas in this one, i.e.,
this only builds "atomic" OExprs *)
Class QuotesToAtomic {ctx A} {RA:OTRelation A}
      (f: CtxElem ctx -> A) (e: OExpr ctx A) : Prop :=
  quotesToAtomic : forall c, f c =o= exprSemantics e @o@ c.

(* Quote any term of functional type to a lambda *)
Instance QuotesTo_Lam {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
      (f: CtxElem ctx -> A -o> B) e
      (q: QuotesTo (fun c => f (celem_rest _ _ c) @o@ (celem_head _ _ c)) e) :
  QuotesTo f (Lam e) | 2.
Proof.
  intros c; split; intros a1 a2 Ra; simpl.
  - rewrite <- (q (c, a2)). rewrite Ra. reflexivity.
  - rewrite <- (q (c, a1)). rewrite <- Ra. reflexivity.
Qed.

(* Special case: quote ofuns as lambdas, destructuring the ofun *)
Instance QuotesTo_Lam_ofun {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
         (f: CtxElem ctx -> A -> B) prp e
         (q: QuotesTo (fun c => f (celem_rest _ _ c) (celem_head _ _ c)) e) :
  QuotesTo (fun c => ofun (f c) (prp:=prp c)) (Lam e) | 1.
Proof.
  apply QuotesTo_Lam. assumption.
Qed.

(* Quote any non-function term as an atomic OExpr *)
Instance QuotesTo_Atomic {ctx A} {RA:OTRelation A} (f: CtxElem ctx -> A) e
         (q: QuotesToAtomic f e) :
  QuotesTo f e | 3 := q.

(*
Ltac solve_QuotesTo :=
  first [ apply QuotesTo_Lam_ofun | apply QuotesTo_Lam | apply QuotesTo_Atomic ].

Hint Extern 1 (QuotesTo _ _) => solve_QuotesTo : typeclass_instances.
 *)

(* Quote any use of celem_head as a var *)
Instance QuotesTo_Var {ctx1 ctx2 A} {RA:OTRelation A} {valid:ValidCtx ctx1}
         (f: CtxElem ctx1 -> CtxElem (CtxCons A ctx2)) v
         (q: QuotesToVar f OVar_0 v) :
  QuotesToAtomic (fun c => celem_head ctx2 A (f c)) (Var v) | 1.
Proof.
  assert (OType A) as OA; [ apply (OType_OVar_type _ _ v) | ].
  intro. simpl. rewrite <- (q c). reflexivity.
Qed.

(* Special case for an eta-reduced celem_head application *)
Instance QuotesTo_Var0 {ctx A} `{OType A} {valid:ValidCtx ctx} :
  QuotesToAtomic (celem_head ctx A) (Var OVar_0) | 1.
Proof.
  intro. reflexivity.
Qed.

(* Quote applications as OExpr applications, where the function must still be
atomic but the argument need not  be *)
Instance QuotesTo_App {ctx A B} `{OType A} `{OType B}
         (f1: CtxElem ctx -> A -o> B) (f2: CtxElem ctx -> A) e1 e2
         (q1: QuotesToAtomic f1 e1) (q2: QuotesTo f2 e2) :
  QuotesToAtomic (fun c => (f1 c) @o@ (f2 c)) (App e1 e2) | 1.
Proof.
  intro c. simpl. rewrite <- (q1 c). rewrite <- (q2 c). reflexivity.
Qed.

(* Quote ofuns in atomic position as lambdas *)
Instance QuotesTo_ofun {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
         (f: CtxElem ctx -> A -> B) prp e
         (q: QuotesTo (fun c => f (celem_rest _ _ c) (celem_head _ _ c)) e) :
  QuotesToAtomic (fun c => ofun (f c) (prp:=prp c)) (Lam e) | 1.
Proof.
  apply QuotesTo_Lam. assumption.
Qed.

(* Quote objects that are independent of the context as embedded objects, but at
low priority *)
Instance QuotesTo_Embed {ctx A} `{OType A} {valid:ValidCtx ctx} (a:A) :
  QuotesToAtomic (fun _ => a) (Embed a) | 2.
Proof.
  intro. reflexivity.
Qed.

(* Quote pairs as applications of opair *)
Instance QuotesTo_pair {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
         (a: CtxElem ctx -> A) (b: CtxElem ctx -> B) e1 e2
         (q1: QuotesTo a e1) (q2: QuotesTo b e2) :
  QuotesToAtomic (fun c => (a c, b c)) (App (App (Embed opair) e1) e2) | 1.
Proof.
  intro c. simpl. rewrite <- (q1 c). rewrite <- (q2 c). reflexivity.
Qed.

(* Quote applications of fst as applications of ofst *)
Instance QuotesTo_fst {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
         (f: CtxElem ctx -> A * B) e (q: QuotesTo f e) :
  QuotesToAtomic (fun c => fst (f c)) (App (Embed ofst) e) | 1.
Proof.
  intro c. simpl. rewrite <- (q c). reflexivity.
Qed.

(* Quote applications of fst as applications of ofst *)
Instance QuotesTo_snd {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
         (f: CtxElem ctx -> A * B) e (q: QuotesTo f e) :
  QuotesToAtomic (fun c => snd (f c)) (App (Embed osnd) e) | 1.
Proof.
  intro c. simpl. rewrite <- (q c). reflexivity.
Qed.

(*
Instance QuotesTo_Lam1 {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
         (f: CtxElem ctx -> A -> B) prp e
         (q: QuotesTo (fun c => f (celem_rest _ _ c) (celem_head _ _ c)) e) :
  QuotesTo (fun c => {| pfun_app := f c; pfun_Proper := prp c |}) (Lam e) | 1.
Proof.
  intros c; split; intros a1 a2 Ra; simpl.
  - rewrite <- (q (c, a2)). rewrite Ra. reflexivity.
  - rewrite <- (q (c, a1)). rewrite <- Ra. reflexivity.
Qed.

Instance QuotesTo_Lam2 {ctx A B} `{OType A} `{OType B} `{ValidCtx ctx}
         (f: CtxElem ctx -> A -> B) prp e
         (q: QuotesTo (fun c => f (celem_rest _ _ c) (celem_head _ _ c)) e) :
  QuotesTo (fun c => ofun (f c) (prp:=prp c)) (Lam e)| 1.
Proof.
  unfold ofun. apply QuotesTo_Lam1. assumption.
Qed.
*)

Lemma oquote_R {A} {RA:OTRelation A} {f1 f2 : A} {e1 e2: OExpr CtxNil A}
      {q1: QuotesTo (fun _ => f1) e1} {q2: QuotesTo (fun _ => f2) e2} :
  e1 <e= e2 -> f1 <o= f2.
Proof.
  intro R12. assert (OType A) as OT; [ eauto with typeclass_instances | ].
  rewrite (q1 tt). rewrite (q2 tt). apply R12. reflexivity.
Defined.

Lemma oquote_eq {A} {RA:OTRelation A} {f1 f2 : A} {e1 e2: OExpr CtxNil A}
      {q1: QuotesTo (fun _ => f1) e1} {q2: QuotesTo (fun _ => f2) e2} :
  e1 =e= e2 -> f1 =o= f2.
Proof.
  intros eq12; destruct eq12; split; apply oquote_R; assumption.
Defined.

(* Translate a problem about proper functions into one about OExprs, by
"quoting" both sides *)
Ltac oquote :=
  lazymatch goal with
  | |- ?e1 =o= ?e2 =>
    apply oquote_eq
  | |- ?e1 <o= ?e2 =>
    apply oquote_R
  end.

Ltac oexpr_simpl :=
  rewrite_strat (bottomup (choice (OExpr_Beta ; eval simpl) (hints osimpl))).

(* Translate a problem about proper functions into one about OExprs by calling
oquote, simplify both sides using the osimpl rewrite database, and then try to
use reflexivity, going back to proper functions if that does not work *)
Ltac osimpl := simpl; oquote; try oexpr_simpl; try reflexivity; simpl.

Lemma product_proj1_test A `{OType A} B `{OType B} (a:A) (b:B) :
  ofst @o@ (a ,o, b) =o= a.
  osimpl.
Qed.

(***
 *** Old Version of Quoting Tactic, using Ltac Directly
 ***)

(*
Tactic Notation "unify'" open_constr(t) open_constr(u) :=
  assert(t = u); [refine eq_refl|].
*)

Lemma ltac_oquote_R {A RA} (e1 e2 : @OExpr CtxNil A RA) :
  e1 <e= e2 -> (exprSemantics e1) @o@ tt <o= (exprSemantics e2) @o@ tt.
Proof.
  intro R12. apply R12. reflexivity.
Qed.

Lemma ltac_oquote_eq {A RA} (e1 e2 : @OExpr CtxNil A RA) :
  e1 =e= e2 -> (exprSemantics e1) @o@ tt =o= (exprSemantics e2) @o@ tt.
Proof.
  intro equiv.
  destruct equiv; split; apply ltac_oquote_R; assumption.
Qed.

(* Quote an expression that we think corresponds to a variable *)
Ltac ltac_quote_ovar f :=
  lazymatch f with
  | (fun (celem:_) => @celem_head ?ctx ?A ?RA _) =>
    uconstr:(@OVar_0 A RA ctx)
  | (fun (celem:?ctype) => @celem_rest ?ctx ?B ?RB ?f') =>
    let qv := ltac_quote_ovar (fun (celem:ctype) => f') in
    uconstr:(@OVar_S _ _ B RB ctx qv)
  end.

(* Quote an expression-in-context, returning an OExpr that corresponds to it *)
Ltac ltac_quote_oexpr f :=
  lazymatch f with
  | (fun (celem:?ctype) => ?e1 @o@ ?e2) =>
    let q1 := ltac_quote_oexpr (fun (celem:ctype) => e1) in
    let q2 := ltac_quote_oexpr (fun (celem:ctype) => e2) in
    uconstr:(App q1 q2)
  | (fun (celem:CtxElem ?ctx) => ofun (fun (x:?A) =>?g)) =>
    let e_rec :=
        (eval simpl in
            (fun (celem':CtxElem (CtxCons A ctx)) =>
               (fun (celem:CtxElem ctx) (x:A) => g)
                 (celem_rest ctx A celem') (celem_head ctx A celem')))
    in
    let q := ltac_quote_oexpr e_rec in
    uconstr:(Lam q)
  | (fun (celem:?ctype) => celem_head _ _ _) =>
    let qv := ltac_quote_ovar f in
    uconstr:(Var qv)
  | (fun (celem:?ctype) => celem_rest _ _ _) =>
    let qv := ltac_quote_ovar f in
    uconstr:(Var qv)
  | (fun (celem:?ctype) => ?body) =>
    (* For constants, just make a fresh evar, and let the unification of the
    change tactic used later fill it in *)
    uconstr:(Embed _)
    (*
    lazymatch type of (fun (celem:ctype) => body) with
    | _ -> ?A =>
      let ename := fresh "e" in
      let res1 := evar (ename:_) in
      let e := constr:(?ename) in
      let res := unify' (fun celem => body) (fun _ => e) in
      uconstr:(Embed (ctx:=CtxNil) e)
    end
     *)
  end.

(* Quote an expression at the top level by quoting it in the empty context *)
Ltac ltac_quote_oexpr_top e :=
  ltac_quote_oexpr (fun (celem:CtxElem CtxNil) => e).

(* Translate a problem about proper functions into one about OExprs, by
"quoting" both sides *)
Ltac ltac_oquote :=
  lazymatch goal with
  | |- ?e1 =o= ?e2 =>
    let q1 := ltac_quote_oexpr_top e1 in
    let q2 := ltac_quote_oexpr_top e2 in
    (* idtac q1 "=e=" q2; *)
    apply (ltac_oquote_eq q1 q2)
  | |- ?e1 <o= ?e2 =>
    let q1 := ltac_quote_oexpr_top e1 in
    let q2 := ltac_quote_oexpr_top e2 in
    apply (ltac_oquote_R q1 q2)
  end.

(* Translate a problem about proper functions into one about OExprs by calling
oquote, simplify both sides using the osimpl rewrite database, and then try to
use reflexivity, going back to proper functions if that does not work *)
Ltac ltac_osimpl := ltac_oquote; try oexpr_simpl; try reflexivity; simpl.

(***
 *** Testing the Quote Mechanism
 ***)

Module OQuoteTest.

(* A simple test case for constant terms *)
Lemma simple_quote_test A `{OType A} a : a =o= a.
  osimpl.
Qed.

(* A simple test case with all 4 OExpr constructs, that does beta-reduction *)
Lemma beta_test A `{OType A} a : (ofun (A:=A) (fun x => x)) @o@ a =o= a.
  simpl. osimpl.
Qed.

(* A test case with the first projection of a product *)
Lemma product_proj1_test A `{OType A} B `{OType B} (a:A) (b:B) :
  ofst @o@ (a ,o, b) =o= a.
  osimpl.
Qed.

(* A test case with with beta-reduction and projections + eta for products *)
Lemma beta_product_test A `{OType A} B `{OType B} (p:A*B) :
  ofun (fun p => (osnd @o@ p ,o, ofst @o@ p)) @o@ (osnd @o@ p ,o, ofst @o@ p)
  =o= p.
  (* osimpl *)
  (* NOTE: we write this out to see how long each step takes... *)
  simpl. oquote. oexpr_simpl. reflexivity.
Qed.

Lemma double_lambda_test A `{OType A} :
  (ofun (fun (f : A -o> A) => ofun (fun x => f @o@ x))) @o@ (ofun (fun y => y))
  =o= ofun (fun x => x).
  osimpl.
Qed.

(* A test case with with beta-reduction and projections for products *)
Lemma beta_product_test2 A `{OType A} B `{OType B} :
  ofun (fun a =>
          ofun (fun b =>
                  ofun (fun p => (osnd @o@ p ,o, ofst @o@ p)) @o@ (b ,o, a)))
  =o= opair.
  (* osimpl *)
  (* NOTE: we write this out to see how long each step takes... *)
  simpl. oquote. oexpr_simpl. reflexivity.
Qed.

End OQuoteTest.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Lemmas from the Lambda JAR paper. *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export Cyclone_LN_Types Cyclone_LN_Tactics.
Open Scope cyclone_scope.
Open Scope nat_scope.
Import T.

(* This is the version just for the lemmas about types. *)

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

(* ********************************************************************** *)
(** Variable closing and variable opening are reciprocal of one another *)

(** Showing that [close_var] after [open_var] is the identity is easy *)

Module TP. (* T = Type P = Proof. *)

Lemma close_open : forall alpha t,
  alpha \notin fv t ->
  close alpha (open (ftvar alpha) t ) = t.
Proof.
  introv. unfold close, open. generalize 0.
  induction t; simpl; introv Fr; fequals~.
  case_nat~. simpl. case_var~.
  case_var~.
Qed.

(** The other direction is much harder; First, we first need
    to establish the injectivity of [open_var] *)

Lemma open_var_inj :
  forall alpha t1 t2,
    alpha \notin (fv t1) ->
    alpha \notin (fv t2) ->
    open (ftvar alpha) t1 = open (ftvar alpha) t2 ->
    (t1 = t2).
Proof.
  introv Fr1 Fr2 Eq.
  rewrite~ <- (@close_open alpha t1).
  rewrite~ <- (@close_open alpha t2).
  fequals~.
Qed.

(** We also need one (tricky) auxiliary lemma to handle the binder case *)

Lemma open_close_var_on_open_var :
  forall alpha beta gamma t i j,
    i <> j ->
    beta <> alpha ->
    beta \notin (fv t) ->
    open_rec i (ftvar beta) (open_rec j (ftvar gamma) (close_rec j alpha t))
  = open_rec j (ftvar gamma) (close_rec j alpha (open_rec i (ftvar beta) t)).
Proof.
  induction t; try solve[simpl; intros; try solve [ fequals~ ]];
  intros;
  do 4 (simpl; try case_nat~; try case_nat~; try case_var~).
Qed.

(* Attempt at a stronger version to make inductions work in TTMP. *)
Lemma open_close_on_open_var :
  forall alpha beta z t i j,
    i <> j ->
    beta <> alpha ->
    beta \notin (fv t) ->
    open_rec i (ftvar beta) (open_rec j z (close_rec j alpha t))
  = open_rec j z (close_rec j alpha (open_rec i (ftvar beta) t)).
Proof.
  induction t; try solve[simpl; intros; try solve [ fequals~ ]];

  intros; simpl; try case_nat~; try case_nat~; simpl; try case_nat~; try case_nat~.
  try solve[intros; simpl; try case_nat~; try case_nat~; simpl; try case_nat~; try case_nat~].
  intros; simpl; try case_var~; simpl; try case_nat~.
  assert(beta \notin fv z).
  auto.

  admit.
Admitted.

(** Now we can prove that [open_var] after [close_var] is the identity *)

Lemma open_close_var : forall alpha t,
  lc t ->
  forall n, open_rec n (ftvar alpha) (close_rec n alpha t)  = t.
Proof.
  introv T.
  induction T; try solve[intros; simpl; introv; fequals~];
  try solve[intros; simpl; case_var~; simpl; case_nat~];
  intros;
  simpl;
  fequals~;
  match goal with
   |- ?t = _ => pick_fresh y from (fv t)
  end;
  apply~ (@open_var_inj y);
  lets M: open_close_var_on_open_var;
  unfold open in M;
  unfold open;
  rewrite~ M.
Qed.

(** As a bonus, we get the injectivity of [close_var] *)

Lemma close_var_inj : forall alpha t1 t2,
  lc t1 -> lc t2 ->
  forall n,
    close_rec n alpha t1 = close_rec n alpha t2 ->
    (t1 = t2).
Proof.
  introv T1 T2 Eq.
  rewrite~ <- (@open_close_var alpha t1 T1 n).
  rewrite~ <- (@open_close_var alpha t2 T2 n).
  fequals~.
Qed.

(* ********************************************************************** *)
(** Properties of [body] *)

(** An abstraction is locally closed iff it satifies the predicate [body] *)

Lemma lc_utype_iff_body : forall k t,
  lc (utype k t) <-> body t.
Proof.
  intros.
  unfold body, open.
  iff H;
  inversions* H.
Qed.

Lemma lc_etype_iff_body : forall p k t,
  lc (etype p k t) <-> body t.
Proof.
  intros.
  unfold body, open.
  iff H; inversions* H.
Qed.

(* ********************************************************************** *)
(** Interaction of [fv] with [open_var] and [close_var] *)

(** Opening with [u] adds [fv u] to the set of free variables *)

Lemma fv_open : forall t u n,
  fv (open_rec n u t) \c fv t \u fv u.
Proof.
  intros t u.
  induction t; intros; simpl; try case_nat; try fset.
Qed.

(** In particular, opening with variable [x] adds [x] to the set
    of free variables *)

Lemma open_var_fv : forall x t n,
  fv (open_rec n (ftvar x) t) \c (fv t \u \{x}).
Proof. intros. apply fv_open. Qed.

(** Closing w.r.t variable [x] removes [x] from the set of free variables *)

Lemma close_fv : forall x t n,
  fv (close_rec n x t) \c (fv t \- \{x}).
Proof.
  intros x t.
  induction t; intros l; simpl; try fset.
  case_var; simpl; fset.
Qed.

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

(** Distributivity of [subst] on [open].
    Two (tricky) intermediate lemmas are required *)

Lemma open_rec_lc_ind :
  forall t j v i u,
    i <> j ->
    open_rec i u (open_rec j v t) = open_rec j v t ->
    open_rec i u t = t.
Proof.
  induction t; introv Nq Eq;
   simpls; inversions~ Eq; fequals*.
  case_nat~. case_nat~.
Qed.

Lemma open_rec_lc : forall u t k,
  lc t -> open_rec k u t = t.
Proof.
  introv T. gen k.
  induction T; intros; simpl; fequals~;
  pick_fresh alpha;
  apply~ (@open_rec_lc_ind t0 0 (ftvar alpha));
  apply~ H0.
Qed.

Lemma subst_open_rec :
  forall alpha u t v n,
    lc u ->
    subst u alpha (open_rec n v t) =
    open_rec n (subst u alpha v) (subst u alpha t).
Proof.
  intros. generalize n.
  induction t; intros; simpl; fequals~.
  case_nat~.
  case_var~.
  rewrite~ open_rec_lc.
Qed.

(** In particular, we can distribute [subst] on [open_var] *)

Lemma subst_open_var:
  forall alpha beta u t n,
    alpha <> beta ->
    lc u ->
    subst u alpha (open_rec n (ftvar beta) t) =
    open_rec n (ftvar beta) (subst u alpha t).
Proof.
  introv N U.
  rewrite~ subst_open_rec.
  fequals.
  simpl.
  case_if~.
Qed.

(** For the distributivity of [subst] on [close_var],
    one simple intermediate lemmas is required to
    say that closing on a fresh name is the identity *)

Lemma close_rec_fresh : forall k alpha t,
  alpha \notin fv t -> close_rec k alpha t = t.
Proof.
  introv. gen k. induction t; simpl; intros; fequals*.
  case_var~.
Qed.

(** Distributivity of [subst] on [close_var] *)

Lemma subst_close_rec:
  forall alpha beta u t n,
    alpha <> beta ->
    beta \notin fv u ->
    subst u alpha (close_rec n beta t) = close_rec n beta (subst u alpha t).
Proof.
  introv N F. generalize n.
  induction t; intros l; simpl; fequals~.
  case_var~; simpl.
  case_var~; simpl. case_var~.
  case_var~; simpl.
  rewrite~ close_rec_fresh.
  case_var~.
Qed.

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

Lemma subst_fresh : forall alpha t u,
  alpha \notin fv t -> subst u alpha t = t.
Proof.
  intros.
  induction t; simpls; fequals~. case_var~.
Qed.

(** Substitution can be introduced to decompose an opening *)

Lemma subst_intro :
  forall alpha t u,
    alpha \notin (fv t) ->
    lc u ->
    open_rec 0 u t = subst u alpha (open_rec 0 (ftvar alpha) t).
Proof.
  introv F U.
  rewrite~ subst_open_rec.
  fequals.
  simpl.
  case_var~.
  rewrite~ subst_fresh.
Qed.

(** An alternative, longer proof, but with fewer hypotheses *)

Lemma subst_intro_alternative : forall alpha t u n,
  alpha \notin (fv t) ->
  open_rec n u t = subst u alpha (open_rec n (ftvar alpha) t).
Proof.
  introv H. generalize n. gen H.
  induction t; simpl; intros; fequals*.
  case_nat*.
  simpl. case_var*.
  case_var*.
Qed.

(** Substitution can be introduced to decompose a variable
    closing in terms of another one using a different name *)

Lemma close_rename : forall alpha beta t n,
  alpha \notin fv t ->
  close_rec n beta t =
  close_rec n alpha (subst (ftvar alpha) beta t).
Proof.
  introv.  generalize n.
  induction t; simpl; intros l F; fequals~.
  case_var~; case_var~; simpl; case_var~.
Qed.

(* ********************************************************************** *)
(** Preservation of local closure through substitution and opening *)

(** Substitution of a locally closed terms into another one produces
    a locally closed term *)

Lemma subst_lc : forall alpha u t,
  lc u -> lc t -> lc (subst u alpha t).
Proof.
  introv U T. induction T; simple~;
  try case_var~;
  try apply_fresh lc_utype;
  try apply_fresh lc_etype;
  rewrite~ <- subst_open_var.
Qed.

(* ====================================================================== *)
(** ** An induction principle for locally closed terms *)

(** Interaction of [size] with [open_var] *)

Lemma size_open_var : forall alpha t n,
  size (open_rec n (ftvar alpha) t) = size t.
Proof.
  intros. generalize n.
  induction t; intros; simple~. case_nat~.
Qed.

(** Interaction of [size] with [close_var] *)

Lemma size_close_var : forall alpha t n,
  size (close_rec n alpha t) = size t.
Proof.
  intros. generalize n.
  induction t; intros; simple~. case_var~.
Qed.

(** The induction principle *)

(* Although Dan uses only induction on the size of \Gamma,
 I may find this useful in an LN style proof. *)

Lemma lc_induct_size :
  forall P : Tau -> Prop,
    (forall alpha,  P (ftvar alpha)) ->
    (P cint) ->
    (forall t1 t2, (lc t1) -> (P t1) -> (lc t2) -> (P t2) ->
                   P (cross t1 t2)) ->
    (forall t1 t2, (lc t1) -> (P t1) -> (lc t2) -> (P t2) ->
                   P (arrow t1 t2)) ->
    (forall t1, (lc t1) -> (P t1) -> P (ptype t1)) ->

    (forall k t1,
       body t1 ->
       (forall t2 alpha,
          alpha \notin fv t2 ->
          size t2 = size t1 ->
          lc (open_rec 0 (ftvar alpha) t2) ->
          P (open_rec 0 (ftvar alpha) t2)) ->
       P (utype k t1)) ->

    (forall p k t1,
       body t1 ->
       (forall t2 alpha,
          alpha \notin fv t2 ->
          size t2 = size t1 ->
          lc (open_rec 0 (ftvar alpha) t2) ->
          P (open_rec 0 (ftvar alpha) t2)) ->
       P (etype p k t1)) ->

    (forall t, lc t -> P t).
Proof.
  intros P Hvar Hcint Hcross Harrow Hptype Hutype Hetype t.
  induction t using (@measure_induction _ size).
  introv T.
  inverts T; simpl in H; auto.

  apply~ Hutype.
  try exists_fresh; auto.
  try introv Fr Eq T.
  apply~ H.
  try rewrite~ size_open_var.

  apply~ Hetype.
  try exists_fresh; auto.
  try introv Fr Eq T.
  apply~ H.
  try rewrite~ size_open_var.

Qed.

(* ====================================================================== *)
(** ** Alternative definition for local closure *)

(* ********************************************************************** *)
(** Equivalence of [lc] and [lc'] *)

Lemma lc_rec_open_var_rec : forall x t k,
  lc_at k (open_rec k (ftvar x) t) -> lc_at (S k) t.
Proof.
  induction t; simpl; introv H; autos*.
  case_nat; simpls~.
Qed.

Lemma lc_to_lc' : forall t,
  lc t -> lc' t.
Proof.
  introv T. induction T; unfold lc'; simple~;
  do 2 try solve [pick_fresh x; apply~ (@lc_rec_open_var_rec x); apply~ H0].
Qed.

Lemma lc_at_open_var_rec : forall x t k,
  lc_at (S k) t -> lc_at k (open_rec k (ftvar x) t).
Proof.
  induction t; simpl; introv H; autos*. case_nat; simple~.
Qed.

Lemma lc'_to_lc : forall t,
  lc' t -> lc t.
Proof.
  introv. unfold lc'.
  induction t using (@measure_induction _ size).
  destruct t; simpl; introv T'; simpl in H; autos*.
  apply_fresh lc_utype. apply H. rewrite~ size_open_var.
   apply~ lc_at_open_var_rec.
  apply_fresh lc_etype. apply H. rewrite~ size_open_var.
   apply~ lc_at_open_var_rec.
Qed.

Lemma lc_eq_lc' : lc = lc'.
Proof. extens. split. applys lc_to_lc'. applys lc'_to_lc. Qed.

(** Substitution of a locally closed terms into a body one produces
    another body *)

(* We need a lemma that Arthur only proved for his alternate inductive lc. *)

Lemma open_rec_lc'_ind : forall u t k,
  lc_at k t -> open_rec k u t = t.
Proof.
  introv. gen k. induction t; simpl; introv F; fequals*.
  case_nat~. false. nat_math.
Qed.

Lemma lc'_open_var_rec:
  forall alpha t,
    lc' t -> lc (open_rec 0 (ftvar alpha) t).
Proof.
  introv lct.
  assert(lc' t); auto.
  unfold lc' in *.
  apply open_rec_lc'_ind with (u:= ftvar alpha) in lct.
  rewrite lct.
  apply lc'_to_lc in H.
  assumption.
Qed.

Lemma lc_open_var_rec:
  forall alpha t,
    lc t -> lc (open_rec 0 (ftvar alpha) t).
Proof.
  intros.
  apply lc_to_lc' in H.
  applys~ lc'_open_var_rec.
Qed.

Lemma subst_body :
  forall alpha t u,
    lc u -> body t -> body (subst u alpha t).
Proof.
  introv U [L H].
  exists_fresh.
  unfold open.
  rewrite~ <- subst_open_var.
  apply~ subst_lc.
Qed.

(** Opening of a body with a locally closed terms produces a
    locally closed term *)

Lemma open_rec_preserves_lc : forall t u,
  body t -> lc u -> lc (open_rec 0 u t).
Proof.
  introv [L H] U.
  pick_fresh alpha.
  rewrite~ (@subst_intro alpha).
  apply~ subst_lc.
Qed.

End TP.


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

(*********************************************************************)
(** * List permutations as a composition of adjacent transpositions  *)
(*********************************************************************)

(* Adapted in May 2006 by Jean-Marc Notin from initial contents by
   Laurent Théry (Huffmann contribution, October 2003) *)

Require Import Setoid Compare_dec Morphisms FinFun.
From UnivalentParametricity Require Import FP.
Require Import list.

Notation NoDup := list.NoDup.

Set Implicit Arguments.

(************************************************************************)
(* We need to copy this file in order to get universe polymorphism *)
(************************************************************************)

Set Universe Polymorphism.

Section Permutation.

Variable A:Type.

Inductive Permutation : list A -> list A -> Prop :=
| perm_nil: Permutation [] []
| perm_skip x l l' : Permutation l l' -> Permutation (x::l) (x::l')
| perm_swap x y l : Permutation (y::x::l) (x::y::l)
| perm_trans l l' l'' :
    Permutation l l' -> Permutation l' l'' -> Permutation l l''.

Local Hint Constructors Permutation.

(** Some facts about [Permutation] *)

Theorem Permutation_nil : forall (l : list A), Permutation [] l -> l = [].
Proof.
  intros l HF.
  remember (@nil A) as m in HF.
  induction HF; discriminate || auto.
Qed.

Theorem Permutation_nil_cons : forall (l : list A) (x : A),
 ~ Permutation nil (x::l).
Proof.
  intros l x HF.
  apply Permutation_nil in HF; discriminate.
Qed.

(** Permutation over lists is a equivalence relation *)

Theorem Permutation_refl : forall l : list A, Permutation l l.
Proof.
  induction l; constructor. exact IHl.
Qed.

Theorem Permutation_sym : forall l l' : list A,
 Permutation l l' -> Permutation l' l.
Proof.
  intros l l' Hperm; induction Hperm; auto.
  apply perm_trans with (l':=l'); assumption.
Qed.

Theorem Permutation_trans : forall l l' l'' : list A,
 Permutation l l' -> Permutation l' l'' -> Permutation l l''.
Proof.
  exact perm_trans.
Qed.

End Permutation.

Hint Resolve Permutation_refl perm_nil perm_skip.

(* These hints do not reduce the size of the problem to solve and they
   must be used with care to avoid combinatoric explosions *)

Local Hint Resolve perm_swap perm_trans.
Local Hint Resolve Permutation_sym Permutation_trans.

(* This provides reflexivity, symmetry and transitivity and rewriting
   on morphims to come *)

Instance Permutation_Equivalence A : Equivalence (@Permutation A) | 10 := {
  Equivalence_Reflexive := @Permutation_refl A ;
  Equivalence_Symmetric := @Permutation_sym A ;
  Equivalence_Transitive := @Permutation_trans A }.

Instance Permutation_cons A :
 Proper (Logic.eq ==> @Permutation A ==> @Permutation A) (@cons A) | 10.
Proof.
  repeat intro; subst; auto using perm_skip.
Qed.

Section Permutation_properties.

Variable A:Type.

Implicit Types a b : A.
Implicit Types l m : list A.

(** Compatibility with others operations on lists *)

Theorem Permutation_in : forall (l l' : list A) (x : A),
 Permutation l l' -> In x l -> In x l'.
Proof.
  intros l l' x Hperm; induction Hperm; simpl; tauto.
Qed.

Global Instance Permutation_in' :
 Proper (Logic.eq ==> @Permutation A ==> iff) (@In A) | 10.
Proof.
  repeat red; intros; subst; eauto using Permutation_in.
Qed.

Lemma Permutation_app_tail : forall (l l' tl : list A),
 Permutation l l' -> Permutation (l++tl) (l'++tl).
Proof.
  intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
  eapply Permutation_trans with (l':=l'++tl); trivial.
Qed.

Lemma Permutation_app_head : forall (l tl tl' : list A),
 Permutation tl tl' -> Permutation (l++tl) (l++tl').
Proof.
  intros l tl tl' Hperm; induction l;
   [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
Qed.

Theorem Permutation_app : forall (l m l' m' : list A),
 Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m').
Proof.
  intros l m l' m' Hpermll' Hpermmm';
   induction Hpermll' as [|x l l'|x y l|l l' l''];
    repeat rewrite <- app_comm_cons; auto.
  apply Permutation_trans with (l' := (x :: y :: l ++ m));
   [idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial.
  apply Permutation_trans with (l' := (l' ++ m')); try assumption.
  apply Permutation_app_tail; assumption.
Qed.

Global Instance Permutation_app' :
 Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A) | 10.
Proof.
  repeat intro; now apply Permutation_app.
Qed.

Lemma Permutation_add_inside : forall a (l l' tl tl' : list A),
  Permutation l l' -> Permutation tl tl' ->
  Permutation (l ++ a :: tl) (l' ++ a :: tl').
Proof.
  intros; apply Permutation_app; auto.
Qed.

Lemma Permutation_cons_append : forall (l : list A) x,
  Permutation (x :: l) (l ++ x :: nil).
Proof. induction l; intros; auto. simpl. rewrite <- IHl; auto. Qed.
Local Hint Resolve Permutation_cons_append.

Theorem Permutation_app_comm : forall (l l' : list A),
  Permutation (l ++ l') (l' ++ l).
Proof.
  induction l as [|x l]; simpl; intro l'.
  rewrite app_nil_r; trivial. rewrite IHl.
  rewrite app_comm_cons, Permutation_cons_append.
  now rewrite <- app_assoc.
Qed.
Local Hint Resolve Permutation_app_comm.

Theorem Permutation_cons_app : forall (l l1 l2:list A) a,
  Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2).
Proof.
  intros l l1 l2 a H. rewrite H.
  rewrite app_comm_cons, Permutation_cons_append.
  now rewrite <- app_assoc.
Qed.
Local Hint Resolve Permutation_cons_app.

Lemma Permutation_Add a l l' : Add a l l' -> Permutation (a::l) l'.
Proof.
 induction 1; simpl; trivial.
 rewrite perm_swap. now apply perm_skip.
Qed.

Theorem Permutation_middle : forall (l1 l2:list A) a,
  Permutation (a :: l1 ++ l2) (l1 ++ a :: l2).
Proof.
  auto.
Qed.
Local Hint Resolve Permutation_middle.

Theorem Permutation_rev : forall (l : list A), Permutation l (rev l).
Proof.
  induction l as [| x l]; simpl; trivial. now rewrite IHl at 1.
Qed.

Global Instance Permutation_rev' :
 Proper (@Permutation A ==> @Permutation A) (@rev A) | 10.
Proof.
  repeat intro; now rewrite <- 2 Permutation_rev.
Qed.

Theorem Permutation_length : forall (l l' : list A),
 Permutation l l' -> length l = length l'.
Proof.
  intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l').
Qed.

Global Instance Permutation_length' :
 Proper (@Permutation A ==> Logic.eq) (@length A) | 10.
Proof.
  exact Permutation_length.
Qed.

Theorem Permutation_ind_bis :
 forall P : list A -> list A -> Prop,
   P [] [] ->
   (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
   (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') ->
   forall l l', Permutation l l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans.
  induction 1; auto.
  apply Htrans with (x::y::l); auto.
  apply Hswap; auto.
  induction l; auto.
  apply Hskip; auto.
  apply Hskip; auto.
  induction l; auto.
  eauto.
Qed.

Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A),
 ~ Permutation nil (l++x::l').
Proof.
  intros l l' x HF.
  apply Permutation_nil in HF. destruct l; discriminate.
Qed.

Ltac InvAdd := repeat (match goal with
 | H: Add ?x _ (_ :: _) |- _ => inversion H; clear H; subst
 end).

Ltac finish_basic_perms H :=
  try constructor; try rewrite perm_swap; try constructor; trivial;
  (rewrite <- H; now apply Permutation_Add) ||
  (rewrite H; symmetry; now apply Permutation_Add).

Theorem Permutation_Add_inv a l1 l2 :
  Permutation l1 l2 -> forall l1' l2', Add a l1' l1 -> Add a l2' l2 ->
   Permutation l1' l2'.
Proof.
 revert l1 l2. refine (Permutation_ind_bis _ _ _ _ _).
 - (* nil *)
   inversion_clear 1.
 - (* skip *)
   intros x l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE.
   constructor. now apply IH.
 - (* swap *)
   intros x y l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE.
   rewrite perm_swap; do 2 constructor. now apply IH.
 - (* trans *)
   intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2.
   assert (Ha : In a l). { rewrite <- PE. rewrite (Add_in AD1). simpl; auto. }
   destruct (Add_inv _ _ Ha) as (l',AD).
   transitivity l'; auto.
Qed.

Theorem Permutation_app_inv (l1 l2 l3 l4:list A) a :
  Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4).
Proof.
 intros. eapply Permutation_Add_inv; eauto using Add_app.
Qed.

Theorem Permutation_cons_inv l l' a :
 Permutation (a::l) (a::l') -> Permutation l l'.
Proof.
  intro. eapply Permutation_Add_inv; eauto using Add_head.
Qed.

Theorem Permutation_cons_app_inv l l1 l2 a :
 Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2).
Proof.
  intro. eapply Permutation_Add_inv; eauto using Add_head, Add_app.
Qed.

Theorem Permutation_app_inv_l : forall l l1 l2,
 Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2.
Proof.
  induction l; simpl; auto.
  intros.
  apply IHl.
  apply Permutation_cons_inv with a; auto.
Qed.

Theorem Permutation_app_inv_r l l1 l2 :
 Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2.
Proof.
 rewrite 2 (Permutation_app_comm _ l). apply Permutation_app_inv_l.
Qed.

Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a].
Proof.
  intros a l H; remember [a] as m in H.
  induction H; try (injection Heqm as -> ->);
    discriminate || auto.
  apply Permutation_nil in H as ->; trivial.
Qed.

Lemma Permutation_length_1: forall a b, Permutation [a] [b] -> a = b.
Proof.
  intros a b H.
  apply Permutation_length_1_inv in H; injection H as ->; trivial.
Qed.

Lemma Permutation_length_2_inv :
  forall a1 a2 l, Permutation [a1;a2] l -> l = [a1;a2] \/ l = [a2;a1].
Proof.
  intros a1 a2 l H; remember [a1;a2] as m in H.
  revert a1 a2 Heqm.
  induction H; intros; try (injection Heqm as ? ?; subst);
    discriminate || (try tauto).
  apply Permutation_length_1_inv in H as ->; left; auto.
  apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as [];
    auto.
Qed.

Lemma Permutation_length_2 :
  forall a1 a2 b1 b2, Permutation [a1;a2] [b1;b2] ->
    a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1.
Proof.
  intros a1 b1 a2 b2 H.
  apply Permutation_length_2_inv in H as [H|H]; injection H as -> ->; auto.
Qed.

Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' ->
  (forall x:A, In x l <-> In x l') -> Permutation l l'.
Proof.
 intros N. revert l'. induction N as [|a l Hal Hl IH].
 - destruct l'; simpl; auto.
   intros Hl' H. exfalso. rewrite (H a); auto.
 - intros l' Hl' H.
   assert (Ha : In a l') by (apply H; simpl; auto).
   destruct (Add_inv _ _ Ha) as (l'' & AD).
   rewrite <- (Permutation_Add AD).
   apply perm_skip.
   apply IH; clear IH.
   * now apply (NoDup_Add AD).
   * split.
     + apply incl_Add_inv with a l'; trivial. intro. apply H.
     + intro Hx.
       assert (Hx' : In x (a::l)).
       { apply H. rewrite (Add_in AD). now right. }
       destruct Hx'; simpl; trivial. subst.
       rewrite (NoDup_Add AD) in Hl'. tauto.
Qed.

Lemma NoDup_Permutation_bis l l' : NoDup l -> NoDup l' ->
  length l' <= length l -> incl l l' -> Permutation l l'.
Proof.
 intros. apply NoDup_Permutation; auto.
 split; auto. apply NoDup_length_incl; trivial.
Qed.

Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'.
Proof.
 induction 1; auto.
 * inversion_clear 1; constructor; eauto using Permutation_in.
 * inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *.
   constructor. simpl; intuition. constructor; intuition.
Qed.

Global Instance Permutation_NoDup' :
 Proper (@Permutation A ==> iff) (@NoDup A) | 10.
Proof.
  repeat red; eauto using Permutation_NoDup.
Qed.

End Permutation_properties.

Section Permutation_map.

Variable A B : Type.
Variable f : A -> B.

Lemma Permutation_map l l' :
  Permutation l l' -> Permutation (map f l) (map f l').
Proof.
 induction 1; simpl; eauto.
Qed.

Global Instance Permutation_map' :
  Proper (@Permutation A ==> @Permutation B) (map f) | 10.
Proof.
  exact Permutation_map.
Qed.

End Permutation_map.

(* Lemma nat_bijection_Permutation n f : *)
(*  bFun n f -> *)
(*  Injective f -> *)
(*  let l := seq 0 n in Permutation (map f l) l. *)
(* Proof. *)
(*  intros Hf BD. *)
(*  apply NoDup_Permutation_bis; auto using Injective_map_NoDup, seq_NoDup. *)
(*  * rewrite map_length. *)
(*  * intros x. rewrite in_map_iff. intros (y & <- & Hy'). *)
(*    rewrite in_seq in *. simpl in *. *)
(*    destruct Hy' as (_,Hy'). auto with arith. *)
(* Qed. *)

(* Section Permutation_alt. *)
(* Variable A:Type. *)
(* Implicit Type a : A. *)
(* Implicit Type l : list A. *)

(* (** Alternative characterization of permutation *)
(*     via [nth_error] and [nth] *) *)

(* Let adapt f n := *)
(*  let m := f (S n) in if le_lt_dec m (f 0) then m else pred m. *)

(* Let adapt_injective f : Injective f -> Injective (adapt f). *)
(* Proof. *)
(*  unfold adapt. intros Hf x y EQ. *)
(*  destruct le_lt_dec as [LE|LT]; destruct le_lt_dec as [LE'|LT']. *)
(*  - now apply eq_add_S, Hf. *)
(*  - apply Lt.le_lt_or_eq in LE. *)
(*    destruct LE as [LT|EQ']; [|now apply Hf in EQ']. *)
(*    unfold lt in LT. rewrite EQ in LT. *)
(*    rewrite <- (Lt.S_pred _ _ LT') in LT. *)
(*    elim (Lt.lt_not_le _ _ LT' LT). *)
(*  - apply Lt.le_lt_or_eq in LE'. *)
(*    destruct LE' as [LT'|EQ']; [|now apply Hf in EQ']. *)
(*    unfold lt in LT'. rewrite <- EQ in LT'. *)
(*    rewrite <- (Lt.S_pred _ _ LT) in LT'. *)
(*    elim (Lt.lt_not_le _ _ LT LT'). *)
(*  - apply eq_add_S, Hf. *)
(*    now rewrite (Lt.S_pred _ _ LT), (Lt.S_pred _ _ LT'), EQ. *)
(* Qed. *)

(* Let adapt_ok a l1 l2 f : Injective f -> length l1 = f 0 -> *)
(*  forall n, nth_error (l1++a::l2) (f (S n)) = nth_error (l1++l2) (adapt f n). *)
(* Proof. *)
(*  unfold adapt. intros Hf E n. *)
(*  destruct le_lt_dec as [LE|LT]. *)
(*  - apply Lt.le_lt_or_eq in LE. *)
(*    destruct LE as [LT|EQ]; [|now apply Hf in EQ]. *)
(*    rewrite <- E in LT. *)
(*    rewrite 2 nth_error_app1; auto. *)
(*  - rewrite (Lt.S_pred _ _ LT) at 1. *)
(*    rewrite <- E, (Lt.S_pred _ _ LT) in LT. *)
(*    rewrite 2 nth_error_app2; auto with arith. *)
(*    rewrite <- Minus.minus_Sn_m; auto with arith. *)
(* Qed. *)

(* Lemma Permutation_nth_error l l' : *)
(*  Permutation l l' <-> *)
(*   (length l = length l' /\ *)
(*    exists f:nat->nat, *)
(*     Injective f /\ forall n, nth_error l' n = nth_error l (f n)). *)
(* Proof. *)
(*  split. *)
(*  { intros P. *)
(*    split; [now apply Permutation_length|]. *)
(*    induction P. *)
(*    - exists (fun n => n). *)
(*      split; try red; auto. *)
(*    - destruct IHP as (f & Hf & Hf'). *)
(*      exists (fun n => match n with O => O | S n => S (f n) end). *)
(*      split; try red. *)
(*      * intros [|y] [|z]; simpl; now auto. *)
(*      * intros [|n]; simpl; auto. *)
(*    - exists (fun n => match n with 0 => 1 | 1 => 0 | n => n end). *)
(*      split; try red. *)
(*      * intros [|[|z]] [|[|t]]; simpl; now auto. *)
(*      * intros [|[|n]]; simpl; auto. *)
(*    - destruct IHP1 as (f & Hf & Hf'). *)
(*      destruct IHP2 as (g & Hg & Hg'). *)
(*      exists (fun n => f (g n)). *)
(*      split; try red. *)
(*      * auto. *)
(*      * intros n. rewrite <- Hf'; auto. } *)
(*  { revert l. induction l'. *)
(*    - intros [|l] (E & _); now auto. *)
(*    - intros l (E & f & Hf & Hf'). *)
(*      simpl in E. *)
(*      assert (Ha : nth_error l (f 0) = Some a) *)
(*       by (symmetry; apply (Hf' 0)). *)
(*      destruct (nth_error_split l (f 0) Ha) as (l1 & l2 & L12 & L1). *)
(*      rewrite L12. rewrite <- Permutation_middle. constructor. *)
(*      apply IHl'; split; [|exists (adapt f); split]. *)
(*      * revert E. rewrite L12, !app_length. simpl. *)
(*        rewrite <- plus_n_Sm. now injection 1. *)
(*      * now apply adapt_injective. *)
(*      * intro n. rewrite <- (adapt_ok a), <- L12; auto. *)
(*        apply (Hf' (S n)). } *)
(* Qed. *)

(* Lemma Permutation_nth_error_bis l l' : *)
(*  Permutation l l' <-> *)
(*   exists f:nat->nat, *)
(*     Injective f /\ *)
(*     bFun (length l) f /\ *)
(*     (forall n, nth_error l' n = nth_error l (f n)). *)
(* Proof. *)
(*  rewrite Permutation_nth_error; split. *)
(*  - intros (E & f & Hf & Hf'). *)
(*    exists f. do 2 (split; trivial). *)
(*    intros n Hn. *)
(*    destruct (Lt.le_or_lt (length l) (f n)) as [LE|LT]; trivial. *)
(*    rewrite <- nth_error_None, <- Hf', nth_error_None, <- E in LE. *)
(*    elim (Lt.lt_not_le _ _ Hn LE). *)
(*  - intros (f & Hf & Hf2 & Hf3); split; [|exists f; auto]. *)
(*    assert (H : length l' <= length l') by auto with arith. *)
(*    rewrite <- nth_error_None, Hf3, nth_error_None in H. *)
(*    destruct (Lt.le_or_lt (length l) (length l')) as [LE|LT]; *)
(*     [|apply Hf2 in LT; elim (Lt.lt_not_le _ _ LT H)]. *)
(*    apply Lt.le_lt_or_eq in LE. destruct LE as [LT|EQ]; trivial. *)
(*    rewrite <- nth_error_Some, Hf3, nth_error_Some in LT. *)
(*    assert (Hf' : bInjective (length l) f). *)
(*    { intros x y _ _ E. now apply Hf. } *)
(*    rewrite (bInjective_bSurjective Hf2) in Hf'. *)
(*    destruct (Hf' _ LT) as (y & Hy & Hy'). *)
(*    apply Hf in Hy'. subst y. elim (Lt.lt_irrefl _ Hy). *)
(* Qed. *)

(* Lemma Permutation_nth l l' d : *)
(*  Permutation l l' <-> *)
(*   (let n := length l in *)
(*    length l' = n /\ *)
(*    exists f:nat->nat, *)
(*     bFun n f /\ *)
(*     bInjective n f /\ *)
(*     (forall x, x < n -> nth x l' d = nth (f x) l d)). *)
(* Proof. *)
(*  split. *)
(*  - intros H. *)
(*    assert (E := Permutation_length H). *)
(*    split; auto. *)
(*    apply Permutation_nth_error_bis in H. *)
(*    destruct H as (f & Hf & Hf2 & Hf3). *)
(*    exists f. split; [|split]; auto. *)
(*    intros x y _ _ Hxy. now apply Hf. *)
(*    intros n Hn. rewrite <- 2 nth_default_eq. unfold nth_default. *)
(*     now rewrite Hf3. *)
(*  - intros (E & f & Hf1 & Hf2 & Hf3). *)
(*    rewrite Permutation_nth_error. *)
(*    split; auto. *)
(*    exists (fun n => if le_lt_dec (length l) n then n else f n). *)
(*    split. *)
(*    * intros x y. *)
(*      destruct le_lt_dec as [LE|LT]; *)
(*       destruct le_lt_dec as [LE'|LT']; auto. *)
(*      + apply Hf1 in LT'. intros ->. *)
(*        elim (Lt.lt_irrefl (f y)). eapply Lt.lt_le_trans; eauto. *)
(*      + apply Hf1 in LT. intros <-. *)
(*        elim (Lt.lt_irrefl (f x)). eapply Lt.lt_le_trans; eauto. *)
(*    * intros n. *)
(*      destruct le_lt_dec as [LE|LT]. *)
(*      + assert (LE' : length l' <= n) by (now rewrite E). *)
(*        rewrite <- nth_error_None in LE, LE'. congruence. *)
(*      + assert (LT' : n < length l') by (now rewrite E). *)
(*        specialize (Hf3 n LT). rewrite <- 2 nth_default_eq in Hf3. *)
(*        unfold nth_default in Hf3. *)
(*        apply Hf1 in LT. *)
(*        rewrite <- nth_error_Some in LT, LT'. *)
(*        do 2 destruct nth_error; congruence. *)
(* Qed. *)

(* End Permutation_alt. *)

(* begin hide *)
Notation Permutation_app_swap := Permutation_app_comm (only parsing).
(* end hide *)


Require Import Automation.
Require Import Setoid Classes.Morphisms.
Require Import SepLogic.Mem.Def.

(* [pred A V] is a predicate over [mem A V]; we wrap it in a record to make
judgements explicit rather than mere function applications.

 However, using [pred_prop] to construct a judgement would be tedious; when
 shorthand is desired, we use :> to supply a coercion from pred to Funclass, so
 that predicates can be directly applied to memories to produce propositions.
*)
Record pred A V :=
  mkPred { pred_prop : mem A V -> Prop }.

Section Predicates.

  Context {A V:Type}.
  Implicit Types p q:pred A V.

  (* for shorthand while writing basic lemmas, we allow predicates to be applied
  directly to memories via this coercion (due to the Local modifier it will be
  removed at the end of the section) *)
  Local Coercion pred_prop : pred >-> Funclass.

  (** [lift P] (denoted [|P|]) states that m is empty, and that the proposition
  P holds. *)
  Definition lift (P:Prop) : pred A V :=
    mkPred (fun m => P /\ m = empty_mem).
  Definition emp := lift True.
  Definition exis X (P: X -> pred A V) :=
    mkPred (fun m => exists x, pred_prop (P x) m).

  (** [ptsto a v] (denoted a |-> v) states that address [a] maps to [v], and no
  other addresses map to anything. *)
  Definition ptsto (a:A) (v:V) : pred A V :=
    mkPred (fun m => m a = Some v /\
                  forall a', a <> a' -> m a' = None).

  (** The core connective of separation logic, also called the separating
  conjunction. [star p q] (denoted p * q) says that the heap can be split into
  disjoint pieces which satisfy [p] and [q] respectively. *)
  Definition star p q : pred A V :=
    mkPred (fun m => exists m1 m2, p m1 /\
                           q m2 /\
                           mem_disjoint m1 m2 /\
                           m = mem_union m1 m2).

  Definition pimpl p q :=
    forall m, p m -> q m.

  Definition peq p q :=
    pimpl p q /\ pimpl q p.

  Notation "[| P |]" := (lift P) (at level 0).
  Infix "*" := star.

  Infix "===" := peq (no associativity, at level 70).
  Infix "===>" := pimpl (no associativity, at level 70).

  Lemma pimpl_refl : forall p, p ===> p.
  Proof.
    firstorder.
  Qed.

  Lemma pimpl_trans : forall p q r, p ===> q -> q ===> r -> p ===> r.
  Proof.
    firstorder.
  Qed.

  Global Add Parametric Relation :
    (pred A V) pimpl
      reflexivity proved by pimpl_refl
      transitivity proved by pimpl_trans
        as pimpl_rel.

  Lemma peq_refl : forall p, p === p.
  Proof.
    firstorder.
  Qed.

  Lemma peq_trans : forall p q r, p === q -> q === r -> p === r.
  Proof.
    firstorder.
  Qed.

  Global Add Parametric Relation :
    (pred A V) peq
      reflexivity proved by peq_refl
      transitivity proved by peq_trans
        as peq_rel.

  Hint Resolve mem_disjoint_comm.
  Hint Resolve mem_union_comm.

  Hint Resolve mem_disjoint_from_union_1.
  Hint Resolve mem_disjoint_from_union_2.
  Hint Resolve mem_disjoint_both_to_union.
  Hint Resolve mem_union_assoc.

  Theorem star_comm : forall p q,
      p * q === q * p.
  Proof.
    assert (forall p q, p * q ===> q * p).
    unfold star, pimpl; simpl; intuition.
    repeat deex.
    descend; intuition eauto.

    unfold peq; intuition.
  Qed.

  Theorem star_cancel : forall p1 p2 q1 q2,
      p1 ===> p2 ->
      q1 ===> q2 ->
      p1 * q1 ===> p2 * q2.
  Proof.
    unfold star, pimpl; simpl; intros.
    repeat deex.
    descend; intuition eauto.
  Qed.

  Global Add Parametric Morphism : star
      with signature peq ==> peq ==> peq
        as star_mor.
  Proof.
    unfold peq; intuition auto using star_cancel.
  Qed.

  Global Add Parametric Morphism : star
      with signature pimpl ==> pimpl ==> pimpl
        as star_mor'.
  Proof.
    auto using star_cancel.
  Qed.

  Global Instance pimpl_peq_mor : Proper (peq ==> peq ==> iff) pimpl.
  Proof.
    hnf; intros; hnf; intros.
    unfold peq in *; safe_intuition.
    intuition eauto using pimpl_trans.
  Qed.

  Theorem star_assoc : forall p q r,
      p * (q * r) === (p * q) * r.
  Proof.
    unfold star, peq, pimpl; simpl; intuition.
    - repeat deex.
      exists (mem_union m1 m0), m3; intuition eauto.
      descend; intuition eauto.
      eapply mem_disjoint_comm; eauto.
      rewrite mem_union_assoc; eauto.
    - repeat deex.
      exists m0, (mem_union m3 m2); intuition eauto.
      descend; intuition eauto.
  Qed.

  Lemma pimpl_apply : forall m F F',
      pred_prop F m ->
      F ===> F' ->
      pred_prop F' m.
  Proof.
    unfold pimpl; simpl; eauto.
  Qed.

  Theorem lift_extract : forall m P,
      [|P|] m -> P.
  Proof.
    unfold lift; simpl in *; intuition.
  Qed.

  Theorem lift_star_left : forall (P: Prop) p m,
      (star [|P|] p) m ->
      P /\ p m.
  Proof.
    simpl; intros.
    repeat deex.
    rewrite mem_union_empty; eauto.
  Qed.

End Predicates.

(** * Notation magic to make separation logic easy to write in Coq. *)

Delimit Scope pred_scope with pred.

Notation "[| P |]" := (lift P) (at level 0) : pred_scope.
Notation "p * q" := (star p%pred q%pred) : pred_scope.

Notation "p === q" := (peq p%pred q%pred) (no associativity, at level 70).
Notation "p ===> q" := (pimpl p%pred q%pred) (no associativity, at level 70).

Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p%pred)) ..)) : pred_scope.

Infix "|->" := ptsto (no associativity, at level 30) : pred_scope.

Notation "m |= F" := (pred_prop F%pred m) (at level 20, F at level 50).


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 10 *)

Require Import Frap.

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang (wangpeng@csail.mit.edu) *)

Set Implicit Arguments.
Set Asymmetric Patterns.

(* Programmers who start programming with threads and locks soon realize that it
 * is tricky to avoid *deadlocks*, where thread #1 is waiting to take a lock
 * held by thread #2, and thread #2 is waiting to take a lock held by thread #3,
 * and... thread #N is waiting to take a lock held by thread #1.  That's a wait
 * cycle, and none of the threads will ever make progress.
 *
 * The most common wisdom about avoiding deadlocks is to impose a *total order*
 * on the locks.  A thread is only allowed to acquire a lock that is *less than*
 * all locks it currently holds.  In this pset, we formalize a simple static
 * analysis checking that the total-order rule is obeyed, and we prove that any
 * program accepted by the analysis avoids deadlock. *)

(** * Shared notations and definitions; main material starts afterward. *)

Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).
Notation heap := (fmap nat nat).
Notation locks := (set nat).

Hint Extern 1 (_ <= _) => linear_arithmetic.

(** * Some helpful lemmas to get out of the way *)

Theorem Forall_app_fwd : forall A (P : A -> Prop) ls1 ls2,
    Forall P (ls1 ++ ls2)
    -> Forall P ls1 /\ Forall P ls2.
Proof.
  induct ls1; invert 1; simplify; subst; eauto.
  apply IHls1 in H3; propositional; auto.
Qed.

Theorem Forall_app_bwd : forall A (P : A -> Prop) ls1 ls2,
    Forall P ls1
    -> Forall P ls2
    -> Forall P (ls1 ++ ls2).
Proof.
  induct 1; invert 1; simplify; eauto.
Qed.

Hint Resolve Forall_app_bwd.

Lemma notin_from_order : forall a l,
  (forall a', a' \in l -> a' > a)
  -> ~a \in l.
Proof.
  sets.
  apply H in H0.
  linear_arithmetic.
Qed.

Hint Immediate notin_from_order.

Lemma gt_lt : forall n m, n > m -> m < n.
Proof.
  linear_arithmetic.
Qed.

Hint Resolve gt_lt.

(** * A variant of the object language from lecture *)

(* We'll work with a simpler language that (1) removes [Fail] and (2) only uses
 * a flat nesting structure for multithreading.  In particular, the [cmd] type
 * no longer contains parallel composition. *)

Inductive cmd :=
| Return (r : nat)
| Bind (c1 : cmd) (c2 : nat -> cmd)
| Read (a : nat)
| Write (a v : nat)
| Lock (a : nat)
| Unlock (a : nat).

Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).

(* Instead, we separately define a program as a list of commands, for different
 * threads. *)
Notation prog := (list cmd).

(* The intra-thread step relation looks the same as before. *)
Inductive step0 : heap * locks * cmd -> heap * locks * cmd -> Prop :=
| StepBindRecur : forall c1 c1' c2 h h' l l',
  step0 (h, l, c1) (h', l', c1')
  -> step0 (h, l, Bind c1 c2) (h', l', Bind c1' c2)
| StepBindProceed : forall v c2 h l,
  step0 (h, l, Bind (Return v) c2) (h, l, c2 v)

| StepRead : forall h l a,
  step0 (h, l, Read a) (h, l, Return (h $! a))
| StepWrite : forall h l a v,
  step0 (h, l, Write a v) (h $+ (a, v), l, Return 0)

| StepLock : forall h l a,
  ~a \in l
  -> step0 (h, l, Lock a) (h, l \cup {a}, Return 0)
| StepUnlock : forall h l a,
  a \in l
  -> step0 (h, l, Unlock a) (h, l \setminus {a}, Return 0).

(* The whole-program step relation uses list operations to select a thread and
 * step it. *)
Inductive step : heap * locks * prog -> heap * locks * prog -> Prop :=
| StepThread : forall h l cs1 c cs2 h' l' c',
    step0 (h, l, c) (h', l', c')
    -> step (h, l, cs1 ++ c :: cs2) (h', l', cs1 ++ c' :: cs2).

Definition trsys_of (h : heap) (l : locks) (p : prog) := {|
  Initial := {(h, l, p)};
  Step := step
|}.

(* These properties may come in handy: *)

Lemma StepThread1 : forall h l c cs2 h' l' c',
    step0 (h, l, c) (h', l', c')
    -> step (h, l, c :: cs2) (h', l', c' :: cs2).
Proof.
  simplify.
  apply StepThread with (cs1 := []); auto.
Qed.

Hint Resolve StepThread1.
Hint Constructors step0 step.

Lemma step_cat : forall h l p x a,
    step (h, l, p) x
    -> exists h_l_p', step (h, l, a :: p) h_l_p'.
Proof.
  invert 1.
  exists (h', l', a :: cs1 ++ c' :: cs2).
  change (step (h, l, (a :: cs1) ++ c :: cs2) (h', l', (a :: cs1) ++ c' :: cs2)).
  eauto.
Qed.

Hint Resolve step_cat.

(** * A static analysis for principled use of locks *)

(* If every thread passes the check built into this relation, then we can
 * guarantee lack of deadlock.  (Don't worry, you'll prove it!)
 * A fact [goodCitizen l1 c l2] tells us that when we run [c] in a starting
 * state where it "owns" exactly the locks in [l1], it follows the lock-order
 * rules and terminates in a state where it owns the locks in [l2]. *)
Inductive goodCitizen : locks -> cmd -> locks -> Prop :=
| GcReturn : forall l r,
    goodCitizen l (Return r) l
| GcBind : forall l1 c1 l2 c2 l3,
    goodCitizen l1 c1 l2
    -> (forall r, goodCitizen l2 (c2 r) l3)
    -> goodCitizen l1 (Bind c1 c2) l3
| GcRead : forall l a,
    goodCitizen l (Read a) l
| GcWrite : forall l a v,
    goodCitizen l (Write a v) l
| GcLock : forall l a,
    (forall a', a' \in l -> a' > a)
    (* ^-- Note that this premise enforces the total order on locks!
     *     That is, every lock already held must be greater than the new one. *)
    -> goodCitizen l (Lock a) (l \cup {a})
| GcUnlock : forall l a,
    a \in l
    (* ^-- We also require that a thread only tries to unlock locks that it
     *     owns. *)
    -> goodCitizen l (Unlock a) (l \setminus {a}).

(** * An alternative semantics that tracks lock ownership *)

(* To prove deadlock-freedom from [goodCitizen], we go by way of an alternative
 * semantics that assigns each held lock to an owning thread.  Concretely, we
 * represent a program with a lockset annotated on each command. *)
Definition prog' := list (locks * cmd).

(* These next two functions project back out the baseline components of an
 * instrumented state. *)

Fixpoint progOf (p : prog') : prog :=
  match p with
  | nil => nil
  | (_, c) :: p' => c :: progOf p'
  end.

Fixpoint locksOf (p : prog') : locks :=
  match p with
  | nil => {}
  | (l, _) :: p' => l \cup locksOf p'
  end.
(* That [\cup] is set union.  We also use [\cap] for intersection and
 * [\setminus] for set difference.  There are also binary relations [\in] for
 * membership and [\subseteq] for subset inclusion.  When faced with any goal
 * that seems to follow just from the laws of set theory, try calling the [sets]
 * tactic from the book library. *)

(* You'll likely want to use this lemma in your solution. *)
Lemma progOf_app : forall p1 p2,
    progOf (p1 ++ p2) = progOf p1 ++ progOf p2.
Proof.
  induct p1; simplify; eauto.
  cases a; simplify.
  equality.
Qed.

(* This predicate captures the property that no lock has multiple owners.
 * NOTE: you won't actually need to understand this function in detail, as we
 * will be proving enough starter lemmas to hide all reasoning about it! *)
Fixpoint disjointLocks (p : prog') : Prop :=
  match p with
  | nil => True
  | (l, _) :: p' => l \cap locksOf p' = {}
                    /\ disjointLocks p'
  end.

(** * Proof that the ownership semantics simulates the baseline semantics *)

(* In this section, we prove for you a useful invariant of any program that is
 * full of good citizens.  It's safe to skip ahead to the statement of
 * [a_useful_invariant]. *)

(* But, for the curious: we use this relation to connect a baseline state to an
 * ownership-tracking state. *)
Inductive assign_lock_ownership : heap * locks * prog -> heap * prog' -> Prop :=
| ALO : forall h p',
    Forall (fun l_c => goodCitizen (fst l_c) (snd l_c) {}) p'
    -> disjointLocks p'
    -> assign_lock_ownership (h, locksOf p', progOf p') (h, p').

Fixpoint prog'Of (p : prog) : prog' :=
  match p with
  | nil => nil
  | c :: p' => ({}, c) :: prog'Of p'
  end.

Lemma progOf_prog'Of : forall p,
    progOf (prog'Of p) = p.
Proof.
  induct p; simplify; equality.
Qed.

Lemma locksOf_prog'Of : forall p,
    locksOf (prog'Of p) = {}.
Proof.
  induct p; simplify; eauto.
  rewrite IHp.
  sets.
Qed.

Lemma goodCitizen_prog'Of : forall p,
    Forall (fun c => goodCitizen {} c {}) p
    -> Forall (fun l_c => goodCitizen (fst l_c) (snd l_c) {}) (prog'Of p).
Proof.
  induct 1; simplify; eauto.
Qed.

Lemma disjointLocks_init : forall p, disjointLocks (prog'Of p).
Proof.
  induct p; simplify; propositional.
  sets.
Qed.

Lemma init : forall h p,
    Forall (fun c => goodCitizen {} c {}) p
    -> assign_lock_ownership (h, {}, p) (h, prog'Of p).
Proof.
  simplify.
  rewrite <- (progOf_prog'Of p) at 1.
  rewrite <- (locksOf_prog'Of p).
  constructor.
  eauto using goodCitizen_prog'Of.
  apply disjointLocks_init.
Qed.

Lemma invert_progOf : forall p' cs1 c cs2,
    progOf p' = cs1 ++ c :: cs2
    -> exists p1' l p2',
      p' = p1' ++ (l, c) :: p2'
      /\ progOf p1' = cs1
      /\ progOf p2' = cs2.
Proof.
  induct p'; simplify.

  cases cs1; simplify; equality.

  cases a.
  cases cs1; simplify.

  invert H.
  exists [], s, p'; auto.

  invert H.
  apply IHp' in H2.
  first_order; subst.
  exists ((s, c1) :: x), x0, x1; auto.
Qed.

Lemma locksOf_app : forall p1 p2,
    locksOf (p1 ++ p2) = locksOf p1 \cup locksOf p2.
Proof.
  induct p1; simplify; eauto.
  sets.
  cases a.
  rewrite IHp1.
  sets.
Qed.

Hint Constructors goodCitizen.

Lemma take_step' : forall h l c h' l' c',
    step0 (h, l, c) (h', l', c')
    -> forall l1 l2, goodCitizen l1 c l2
    -> (l' = l
        /\ goodCitizen l1 c' l2)
       \/ (exists a, ~a \in l
                     /\ ~a \in l1
                     /\ l' = l \cup {a}
                     /\ goodCitizen (l1 \cup {a}) c' l2)
       \/ (exists a, a \in l
                     /\ a \in l1
                     /\ l' = l \setminus {a}
                     /\ goodCitizen (l1 \setminus {a}) c' l2).
Proof.
  induct 1; invert 1; simplify; eauto 8.

  apply IHstep0 in H4; auto.
  first_order; subst; eauto 8.

  invert H3.
  eauto.
Qed.

Hint Constructors assign_lock_ownership.

Lemma disjointLocks_unchanged : forall x x0 c x1,
    disjointLocks (x ++ (x0, c) :: x1)
    -> forall c', disjointLocks (x ++ (x0, c') :: x1).
Proof.
  induct x; simplify; propositional.
  cases a; propositional; eauto.
  repeat rewrite locksOf_app in *; auto.
Qed.

Lemma disjointLocks_add : forall a x x0 c x1,
    disjointLocks (x ++ (x0, c) :: x1)
    -> ~a \in locksOf (x ++ (x0, c) :: x1)
    -> forall c', disjointLocks (x ++ (x0 \cup {a}, c') :: x1).
Proof.
  induct x; simplify; propositional.

  sets.

  cases a0; propositional; eauto.
  repeat rewrite locksOf_app in *; simplify; auto.
  sets.
  eapply IHx; eauto.
  sets.
Qed.

Lemma disjointLocks_remove : forall a x x0 c x1,
    disjointLocks (x ++ (x0, c) :: x1)
    -> a \in x0
    -> forall c', disjointLocks (x ++ (x0 \setminus {a}, c') :: x1).
Proof.
  induct x; simplify; propositional.

  sets.

  cases a0; propositional; eauto.
  repeat rewrite locksOf_app in *; simplify; auto.
  sets.
Qed.

Hint Immediate disjointLocks_unchanged disjointLocks_add disjointLocks_remove.

Lemma disjointLocks_middle' : forall s x x0 c x1,
    s \cap locksOf (x ++ (x0, c) :: x1) = { }
    -> x0 \cap s = { }.
Proof.
  induct x; simplify.

  sets.

  cases a.
  repeat rewrite locksOf_app in *.
  simplify.
  sets.
Qed.

Lemma disjointLocks_middle : forall x x0 c x1,
    disjointLocks (x ++ (x0, c) :: x1)
    -> x0 \cap locksOf x = {}
       /\ x0 \cap locksOf x1 = {}.
Proof.
  induct x; simplify.

  propositional.
  sets.

  cases a.
  invert H.
  apply IHx in H1.
  propositional.
  repeat rewrite locksOf_app in *; simplify.
  sets.
Qed.

Lemma take_step : forall s1 s2,
    step s1 s2
    -> forall s1', assign_lock_ownership s1 s1'
    -> exists s2', assign_lock_ownership s2 s2'.
Proof.
  invert 1; invert 1.
  apply invert_progOf in H4; first_order; subst.
  apply Forall_app_fwd in H5; propositional.
  invert H1; simplify.
  eapply take_step' in H0; eauto; first_order; subst.

  exists (h', x ++ (x0, c') :: x1).
  replace (locksOf (x ++ (x0, c) :: x1))
          with (locksOf (x ++ (x0, c') :: x1))
    by (repeat rewrite locksOf_app; simplify; sets).
  replace (progOf x ++ c' :: progOf x1)
          with (progOf (x ++ (x0, c') :: x1))
    by (repeat rewrite progOf_app; simplify; sets).
  eauto.

  exists (h', x ++ (x0 \cup {x2}, c') :: x1).
  replace (locksOf (x ++ (x0, c) :: x1) \cup {x2})
          with (locksOf (x ++ (x0 \cup {x2}, c') :: x1))
    by (repeat rewrite locksOf_app; simplify; sets).
  replace (progOf x ++ c' :: progOf x1)
          with (progOf (x ++ (x0 \cup {x2}, c') :: x1))
    by (repeat rewrite progOf_app; simplify; sets).
  eauto.

  exists (h', x ++ (x0 \setminus {x2}, c') :: x1).
  replace (locksOf (x ++ (x0, c) :: x1) \setminus {x2})
          with (locksOf (x ++ (x0 \setminus {x2}, c') :: x1))
    by (repeat apply disjointLocks_middle in H6; propositional;
        repeat rewrite locksOf_app; simplify; sets).
  replace (progOf x ++ c' :: progOf x1)
          with (progOf (x ++ (x0 \setminus {x2}, c') :: x1))
    by (repeat rewrite progOf_app; simplify; sets).
  eauto.
Qed.

(* Now the invariant proof: starting with good citizens, we always wind up in a
 * baseline state that has a matching ownership-tracking state. *)
Theorem a_useful_invariant : forall h p,
    Forall (fun c => goodCitizen {} c {}) p
    -> invariantFor (trsys_of h {} p) (fun st => exists st', assign_lock_ownership st st').
Proof.
  simplify.
  apply invariant_induction; simplify; first_order; subst.
  eauto using init.
  eauto using take_step.
Qed.

(* OK, now to state the deadlock-freedom property that we ask you to prove! *)

(* This predicate captures when a command is through executing. *)
Inductive finished : cmd -> Prop :=
| Finished : forall r, finished (Return r).

Hint Constructors finished.

(* It has this useful connection to [progOf]: *)
Lemma finished_progOf : forall p,
    Forall (fun l_c => finished (snd l_c)) p
    -> Forall finished (progOf p).
Proof.
  induct 1; simplify; eauto.
  cases x; eauto.
Qed.

Hint Immediate finished_progOf.

Module Type S.
  (* Finally, we prove deadlock-freedom: if all commands are good citizens, then
   * execution never reaches a state where not all threads are finished, but where
   * it also is not possible to take a step. *)
  Axiom deadlock_freedom : forall h p,
      Forall (fun c => goodCitizen {} c {}) p
      -> invariantFor (trsys_of h {} p) (fun h_l_p =>
                                           let '(_, _, p') := h_l_p in
                                           Forall finished p'
                                           \/ exists h_l_p', step h_l_p h_l_p').
End S.


(******************************************************************************)
(* Chapter 1.6.2: Opposite Categories                                         *)
(******************************************************************************)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Require Import Aw_0_Notations.
Require Import Aw_1_3_Categories.
Require Import Aw_1_4_Functors.
Require Import Aw_1_5_Isomorphisms.

Check @Category.

Generalizable Variables Obj Hom a b c d.

Lemma ref_eqv `{C : Category} `(f : a ~> b) `(g : a ~> b) :
  f === g -> g === f.
Proof.
  move=> H.
  rewrite H.
  reflexivity.
Qed.

Program Instance Opposite `(C : @Category Obj Hom) : @Category Obj (fun x y => Hom y x).
Obligation 1.                               (* Hom a a *)
Proof.
    by apply: iid.
Defined.
Obligation 2.                               (* Hom c a *)
Proof.
  Check @comp _ _ C c b a X0 X : Hom c a.
    by apply: (@comp _ _ C c b a X0 X : Hom c a).
Defined.
Obligation 3.
Proof.
  rewrite /Opposite_obligation_2 /=.
  move=> f g H.
  move=> f' g' H' /=.
  Check @comp_respects Obj Hom C c b a f' g' H' f g H.
    by apply (@comp_respects Obj Hom C c b a f' g' H' f g H).
Defined.
Obligation 4.
  rewrite /Opposite_obligation_1 /Opposite_obligation_2 /=.
  Check right_identity.
    by apply right_identity.
Defined.
Obligation 5.
  rewrite /Opposite_obligation_1 /Opposite_obligation_2 /=.
    by apply left_identity.
Defined.
Obligation 6.
  rewrite /Opposite_obligation_2 /=.
  apply ref_eqv.
    by apply associativity.
Defined.

(* Notation "dual C" := (Opposite C)  : category_scope. *)

Generalizable Variables C D Fobj.

(* every functor between two categories determines a functor between their opposites *)
(* 双対の圏どうしの関手を定義する。 *)
Program Instance func_op `(F : @Functor _ _ C _ _ D Fobj) :
  @Functor _ _ (Opposite C) _ _ (Opposite D) Fobj :=
  {|
    fmor := (fun a b f => fmor F f)
  |}.
Obligation 2.
Proof.
  done.
Defined.
Obligation 3.
Proof.
  done.
Defined.

(* we could do this by simply showing that (Opposite (Opposite C)) is
 isomorphic to C, but Coq distinguishes between two categories being
 *equal* versus merely isomorphic, so it's handy to be able to do
 this *)

Program Instance func_opop `(F : @Functor _ _ (Opposite C) _ _ (Opposite D) Fobj) :
  @Functor _ _ C _ _ D Fobj :=
  {|
    fmor := (fun a b f => fmor F f)
  |}.
Obligation 2.
Proof.
  done.
Defined.
Obligation 3.
Proof.
  done.
Defined.

Program Instance func_op1 `(F : @Functor _ _ (Opposite C) _ _ D Fobj) :
  @Functor _ _ C _ _ (Opposite D) Fobj :=
  {|
    fmor := (fun a b f => fmor F f)
  |}.
Obligation 2.
Proof.
  done.
Defined.
Obligation 3.
Proof.
  done.
Defined.

Program Instance func_op2 `(F : @Functor _ _ C _ _ (Opposite D) Fobj) :
  @Functor _ _ (Opposite C) _ _ D Fobj :=
  {|
    fmor := (fun a b f => fmor F f)
  |}.
Obligation 2.
Proof.
  done.
Defined.
Obligation 3.
Proof.
  done.
Defined.

(* END *)