(*************************************************************)
(*   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 Lia.

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.

Require Import Undecidability.Shared.ListAutomation.

Set Default Proof Using "Type".

Set Implicit Arguments.

(* * The syntax and semantics of FO logic *)

Local Notation ø := vec_nil.

Local Infix "∊" := In (at level 70, no associativity).
Local Infix "⊑" := incl (at level 70, no associativity).

Opaque fo_term_subst fo_term_map fo_term_sem.

(* Terms are just variables in Σrel *)

Definition Σrel_var k : fol_term (Σrel k) -> nat.
Proof. intros [ n | [] ]; exact n. Defined.

(* Unscoped (nat) DeBruijn syntax for FOL formulas *)

Inductive fol_form (Σ : fo_signature) : Type :=
  | fol_false : fol_form Σ
  | fol_atom  : forall p, vec (fol_term Σ) (ar_rels Σ p) -> fol_form Σ
  | fol_bin   : fol_bop -> fol_form Σ -> fol_form Σ -> fol_form Σ
  | fol_quant : fol_qop -> fol_form Σ -> fol_form Σ.

Module fol_notations.

  Infix "⤑" := (fol_bin fol_imp) (at level 62, right associativity).
  Infix "⟑" := (fol_bin fol_conj) (at level 60, right associativity).
  Infix "⟇" := (fol_bin fol_disj) (at level 61, right associativity).
  Notation "∀ f" := (fol_quant fol_fa f) (at level 64, right associativity).
  Notation "∃ f" := (fol_quant fol_ex f) (at level 64, right associativity).
  Notation "x ↔ y" := ((x⤑y)⟑(y⤑x)) (at level 63, no associativity).

  Notation "£" := (in_var : nat -> fol_term _).
  Notation "⊥" := (fol_false _).

End fol_notations.

Import fol_notations.

Section fol_subst.

  Variable (Σ : fo_signature).

  Notation 𝕋 := (fol_term Σ).
  Notation 𝔽 := (fol_form Σ).

  Implicit Type A : 𝔽.

  Fixpoint fol_height A :=
    match A with
      | ⊥             => 1
      | fol_atom p v  => 1
      | fol_bin c A B => 1 + max (fol_height A) (fol_height B)
      | fol_quant q A => 1 + fol_height A
    end.

  Fixpoint fol_vars A :=
    match A with
      | ⊥             => nil
      | fol_atom p v  => flat_map fo_term_vars (vec_list v)
      | fol_bin c A B => fol_vars A ++ fol_vars B
      | fol_quant q A => flat_map (fun n => match n with 0 => nil | S n => n::nil end)
                           (fol_vars A)
    end.

  Fact fol_vars_bin b A B : fol_vars (fol_bin b A B) = fol_vars A ++ fol_vars B.
  Proof. trivial. Qed.

  Fact fol_vars_quant q A : fol_vars (fol_quant q A)
                         = flat_map (fun n => match n with 0 => nil | S n => n::nil end) (fol_vars A).
  Proof. trivial. Qed.

  Definition fol_vars_max A := lmax (fol_vars A).

  Fact fol_vars_max_spec A n : n ∊ fol_vars A -> n <= fol_vars_max A.
  Proof. apply lmax_prop. Qed.

  Fixpoint fol_syms (A : 𝔽) :=
    match A with
      | ⊥              => nil
      | fol_atom p v   => flat_map fo_term_syms (vec_list v)
      | fol_bin c A B  => fol_syms A ++ fol_syms B
      | fol_quant q A  => fol_syms A
    end.

  Fact fol_syms_bin b A B : fol_syms (fol_bin b A B) = fol_syms A ++ fol_syms B.
  Proof. trivial. Qed.

  Fact fol_syms_quant q A : fol_syms (fol_quant q A) = fol_syms A.
  Proof. trivial. Qed.

  Fixpoint fol_rels (A : 𝔽) :=
    match A with
      | ⊥              => nil
      | fol_atom p v   => p::nil
      | fol_bin c A B  => fol_rels A ++ fol_rels B
      | fol_quant q A  => fol_rels A
    end.

  Fact fol_rels_bin b A B : fol_rels (fol_bin b A B) = fol_rels A ++ fol_rels B.
  Proof. trivial. Qed.

  Fact fol_rels_quant q A : fol_rels (fol_quant q A) = fol_rels A.
  Proof. trivial. Qed.

  Fixpoint fol_subst σ (A : 𝔽) :=
    match A with
      | ⊥              => ⊥
      | fol_atom _ v   => fol_atom _ (vec_map (fo_term_subst σ) v)
      | fol_bin c A B => fol_bin c (A⦃σ⦄) (B⦃σ⦄)
      | fol_quant q A => fol_quant q (A⦃⇡σ⦄)
    end
  where "A ⦃ σ ⦄" := (fol_subst σ A).

  Fact fol_subst_ext σ ρ A :
         (forall n, n ∊ fol_vars A -> σ n = ρ n)
       -> A⦃σ⦄ = A⦃ρ⦄.
  Proof.
    intros Hfg; revert A σ ρ Hfg.
    induction A as [ | p v | c A IHA B IHB | q A IHA ]; intros f g Hfg; simpl; f_equal; auto.
    + apply vec_map_ext; intros t Ht.
      apply fo_term_subst_ext; intros n Hn.
      apply Hfg, in_flat_map; exists t; split; auto.
      apply in_vec_list; auto.
    + apply IHA; intros n Hn; apply Hfg, in_or_app; auto.
    + apply IHB; intros n Hn; apply Hfg, in_or_app; auto.
    + apply IHA; intros [ | n ] Hn; simpl; auto; rew fot.
      f_equal; apply Hfg; simpl.
      apply in_flat_map; exists (S n); simpl; auto.
  Qed.

  Fact fol_vars_subst σ (A : 𝔽) : fol_vars (A⦃σ⦄) = flat_map (fun x => fo_term_vars (σ x)) (fol_vars A).
  Proof.
    revert σ; induction A as [ | s r | b A HA B HB | q A HA ]; intros phi; auto.
    + simpl fol_vars.
      rewrite vec_list_vec_map.
      rewrite flat_map_flat_map.
      do 2 rewrite flat_map_concat_map.
      rewrite map_map; f_equal.
      apply map_ext; intros x.
      rewrite fo_term_vars_subst; auto.
    + simpl; rewrite flat_map_app; f_equal; auto.
    + simpl; rewrite HA.
      do 2 rewrite flat_map_flat_map.
      do 2 rewrite flat_map_concat_map; f_equal.
      apply map_ext_in; intros [ | x ] Hx; simpl; auto.
      rewrite fo_term_vars_map; rew fot.
      rewrite flat_map_concat_map, map_map.
      rewrite <- flat_map_concat_map.
      rewrite <- app_nil_end.
      rewrite flat_map_single, map_id; auto.
  Qed.

  Fact fol_vars_map σ (A : 𝔽) : fol_vars (A⦃fun n => £(σ n)⦄) = map σ (fol_vars A).
  Proof. rewrite fol_vars_subst, <- flat_map_single; auto. Qed.

  Fact fol_syms_subst P σ (A : 𝔽) :
        (forall n, n ∊ fol_vars A -> Forall P (fo_term_syms (σ n)))
     -> Forall P (fol_syms A) -> Forall P (fol_syms (A⦃σ⦄)).
  Proof.
    revert σ.
    induction A as [ | s r | b A HA B HB | q A HA ]; intros f Hf H; simpl; auto.
    + rewrite Forall_forall in H |- *.
      intros s'; rewrite in_flat_map.
      intros (t & Ht); revert Ht.
      rewrite vec_list_vec_map, in_map_iff.
      intros ((t' & <- & H1) & H2).
      revert s' H2; apply Forall_forall.
      apply fo_term_syms_subst.
      simpl in H, Hf.
      * intros n Hn; apply Hf, in_flat_map.
        exists t'; auto.
      * apply Forall_forall; intros s' Hs'.
        apply H, in_flat_map; exists t'; auto.
    + simpl in H; rewrite Forall_app in H.
      rewrite Forall_app; split.
      * apply HA; try tauto.
        intros; apply Hf, in_or_app; auto.
      * apply HB; try tauto.
        intros; apply Hf, in_or_app; auto.
    + simpl in H; apply HA; auto.
      intros [ | n ]; simpl; rew fot; auto.
      rewrite fo_term_syms_map; intros Hn.
      apply Hf, in_flat_map.
      exists (S n); simpl; auto.
  Qed.

  Fact fol_rels_subst σ (A : 𝔽) : fol_rels (A⦃σ⦄) = fol_rels A.
  Proof.
    revert σ.
    induction A as [ | s r | b A HA B HB | q A HA ]; intros f; simpl; auto.
    rewrite HA, HB; auto.
  Qed.

  Definition fol_bigop c A := fold_right (@fol_bin Σ c) A.

  Fact fol_vars_bigop c l A : fol_vars (fol_bigop c A l) = flat_map fol_vars l++fol_vars A.
  Proof.
    induction l; simpl; auto.
    rewrite app_ass; f_equal; auto.
  Qed.

  Fact fol_syms_bigop c l A : fol_syms (fol_bigop c A l) = flat_map fol_syms l++fol_syms A.
  Proof.
    induction l; simpl; auto.
    rewrite app_ass; f_equal; auto.
  Qed.

  Fact fol_rels_bigop c l A : fol_rels (fol_bigop c A l) = flat_map fol_rels l++fol_rels A.
  Proof.
    induction l; simpl; auto.
    rewrite app_ass; f_equal; auto.
  Qed.

  Fact fol_subst_bigop c l A σ : (fol_bigop c A l)⦃σ⦄ = fol_bigop c (A⦃σ⦄) (map (fol_subst σ) l).
  Proof. induction l; simpl; f_equal; auto. Qed.

  (* ∀ ... ∀ A  and  ∃ ... ∃ A *)

  Fixpoint fol_mquant q n (A : 𝔽) :=
    match n with
      | 0   => A
      | S n => (fol_quant q) (fol_mquant q n A)
    end.

  Fact fol_mquant_plus q a b A : fol_mquant q (a+b) A = fol_mquant q a (fol_mquant q b A).
  Proof. induction a; simpl; f_equal; auto. Qed.

  Fact fol_mquant_S q n A : fol_mquant q (S n) A = fol_mquant q n (fol_quant q A).
  Proof.
    replace (S n) with (n+1) by lia.
    apply fol_mquant_plus.
  Qed.

  (* (Free) variables in ∀ ... ∀ A  and  ∃ ... ∃ A *)

  Fact fol_vars_mquant q n (A : 𝔽) :
        fol_vars (fol_mquant q n A)
      = flat_map (fun i => if le_lt_dec n i then (i-n::nil) else nil) (fol_vars A).
  Proof.
    revert A; induction n as [ | n IHn ]; intros A.
    + simpl; rewrite <- map_id at 1; rewrite <- flat_map_single.
      do 2 rewrite flat_map_concat_map; f_equal; apply map_ext.
      intro a; destruct (le_lt_dec 0 a); f_equal; lia.
    + rewrite fol_mquant_S.
      rewrite IHn; simpl fol_vars; rewrite flat_map_flat_map.
      do 2 rewrite flat_map_concat_map; f_equal; apply map_ext.
      intros [ | a ]; auto; simpl flat_map.
      rewrite <- app_nil_end.
      destruct (le_lt_dec n a); destruct (le_lt_dec (S n) (S a)); auto; lia.
  Qed.

  Fact fol_syms_mquant q n A : fol_syms (fol_mquant q n A) = fol_syms A.
  Proof. induction n; simpl; auto. Qed.

  Fact fol_rels_mquant q n A : fol_rels (fol_mquant q n A) = fol_rels A.
  Proof. induction n; simpl; auto. Qed.

  (* This theorem is the important one that shows substitutions do compose
      hence De Bruijn notation are handled correctly by substitutions *)

  Fact fol_subst_subst σ ρ A : A⦃σ⦄⦃ρ⦄ = A⦃fun n => (σ n)⟬ρ⟭⦄.
  Proof.
    revert σ ρ; induction A
        as [ | p v | b A IHA B IHB | q A IHA ];
        simpl; intros f g; auto.
    + f_equal.
      rewrite vec_map_map.
      apply vec_map_ext.
      intros A w; rew fot; auto.
    + f_equal; auto.
    + f_equal.
      rewrite IHA; auto.
      apply fol_subst_ext.
      intros [ | n ] _; rew fot; simpl; rew fot; simpl; auto.
      do 2 rewrite <- fo_term_subst_map, fo_term_subst_comp.
      apply fo_term_subst_ext.
      intros; rew fot; rewrite fo_term_subst_map; simpl; rew fot; auto.
  Qed.

End fol_subst.

Notation "A ⦃ σ ⦄" := (fol_subst σ A).

Notation fol_lconj := (@fol_bigop _ fol_conj (⊥⤑⊥)).
Notation fol_ldisj := (@fol_bigop _ fol_disj ⊥).

Section fol_semantics.

  Variable (Σ : fo_signature)
           (X : Type) (M : fo_model Σ X).

  Implicit Type φ : nat -> X.

  Notation 𝕋 := (fol_term Σ).
  Notation 𝔽 := (fol_form Σ).

  Notation "⟦ t ⟧" := (fun φ => fo_term_sem M φ t).

  Fixpoint fol_sem φ A : Prop :=
    match A with
      | ⊥              => False
      | fol_atom _ v   => fom_rels M _ (vec_map (fun t => ⟦t⟧ φ) v)
      | fol_bin b A B  => fol_bin_sem b (⟪A⟫ φ) (⟪B⟫ φ)
      | fol_quant q A  => fol_quant_sem q (fun x => ⟪A⟫ x·φ)
    end
  where "⟪ A ⟫" := (fun φ => fol_sem φ A).

  Fact fol_sem_bin_fix φ b A B : fol_sem φ (fol_bin b A B) = fol_bin_sem b (⟪A⟫ φ) (⟪B⟫ φ).
  Proof. reflexivity. Qed.

  Fact fol_sem_quant_fix φ q A : fol_sem φ (fol_quant q A) = fol_quant_sem q (fun x => ⟪A⟫ x·φ).
  Proof. reflexivity. Qed.

  (* Semantics depends only on occuring variables *)

  Fact fol_sem_ext φ ψ A : (forall n, n ∊ fol_vars A -> φ n = ψ n) -> ⟪A⟫ φ <-> ⟪A⟫ ψ.
  Proof.
    intros H; revert A φ ψ H.
    induction A as [ | p v | b A IHA B IHB | q A IHA ]; simpl; intros phi psy H; try tauto.
    + fol equiv rel.
      apply vec_map_ext; intros w Hw.
      apply fo_term_sem_ext; auto.
      intros n Hn; apply H, in_flat_map; exists w; split; auto.
      apply in_vec_list; auto.
    + apply fol_bin_sem_ext.
      * apply IHA; intros; apply H, in_or_app; auto.
      * apply IHB; intros; apply H, in_or_app; auto.
    + apply fol_quant_sem_ext.
      intros x; apply IHA.
      intros [ | n] Hn; simpl; auto; apply H, in_flat_map.
      exists (S n); simpl; auto.
  Qed.

  Section decidable.

    (* REMARK: not requiring the fom_rels M s relation to be decidable
        would allow hiding uncomputability inside the model which
        would be kind of cheating. The semantic relation should be
        decidable, only the (finite) satisfiability relation should
        be undec *)

    (* For the semantics relation to be decidable over a finite domain,
        it is necessary and SUFFICIENT that the sem_pred relation is decidable
        or equivalently, each predicate is interpreted as a map: vec X _ -> bool *)

    Variable (M_fin : finite_t X).
    Variable (rels_dec : fo_model_dec M).

    Theorem fol_sem_dec A φ : { ⟪A⟫ φ } + { ~ ⟪A⟫ φ }.
    Proof using rels_dec M_fin.
      revert φ.
      induction A as [ | p v | b A IHA B IHB | q A IHA ]; intros phi.
      + simpl; tauto.
      + simpl; apply rels_dec.
      + simpl fol_sem; apply fol_bin_sem_dec; auto.
      + simpl fol_sem; apply fol_quant_sem_dec; auto.
    Qed.

  End decidable.

  (* Semantics commutes with substitutions ... good *)

  Theorem fol_sem_subst φ σ A : ⟪ A⦃σ⦄ ⟫ φ <-> ⟪A⟫ (fun n => ⟦σ n⟧ φ).
  Proof.
    revert φ σ; induction A as [ | p v | b A IHA B IHB | q A IHA ]; simpl; intros phi f; try tauto.
    + fol equiv rel.
      rewrite vec_map_map; apply vec_map_ext.
      intros; rewrite fo_term_sem_subst; auto.
    + apply fol_bin_sem_ext; auto.
    + apply fol_quant_sem_ext.
      intros x; rewrite IHA.
      apply fol_sem_ext.
      intros [ | n ] _; simpl; rew fot; simpl; auto.
      rewrite <- fo_term_subst_map; rew fot.
      apply fo_term_sem_ext; intros; rew fot; auto.
  Qed.

  Definition fol_lift t n : 𝕋 := match n with 0 => t | S n => £n end.

  Corollary fol_sem_lift φ t A : ⟪A⦃fol_lift t⦄⟫ φ <-> ⟪A⟫ (⟦t⟧ φ)·φ.
  Proof.
    rewrite fol_sem_subst.
    apply fol_sem_ext; intros [ | n ] _; simpl; rew fot; auto.
  Qed.

  (* Bigops, ie finitary conjunction and disjunction *)

  Fact fol_sem_lconj lf φ : ⟪fol_lconj lf⟫ φ <-> forall f, f ∊ lf -> ⟪f⟫ φ.
  Proof.
    induction lf as [ | f lf IHlf ]; simpl.
    + split; tauto.
    + rewrite IHlf.
      split.
      * intros [] ? [ -> | ]; auto.
      * intros H; split; intros; apply H; auto.
  Qed.

  Fact fol_sem_lconj_app l m φ :
         ⟪fol_lconj (l++m)⟫ φ <-> ⟪fol_lconj l⟫ φ /\ ⟪fol_lconj m⟫ φ.
  Proof.
    rewrite !fol_sem_lconj; split.
    + intros H; split; intros; apply H, in_app_iff; firstorder.
    + intros (H1 & H2) f; rewrite in_app_iff; firstorder.
  Qed.

  Fact fol_sem_ldisj lf φ : ⟪fol_ldisj lf⟫ φ <-> exists f, f ∊ lf /\ ⟪f⟫ φ.
  Proof.
    induction lf as [ | f lf IHlf ]; simpl.
    + split; try tauto; intros ( ? & [] & _).
    + rewrite IHlf.
      split.
      * intros [ H | (g & H1 & H2) ].
        - exists f; auto.
        - exists g; auto.
      * intros (g & [ <- | Hg ] & ?); auto.
        right; exists g; auto.
  Qed.

  Fact fol_sem_ldisj_app l m φ :
         ⟪fol_ldisj (l++m)⟫ φ <-> ⟪fol_ldisj l⟫ φ \/ ⟪fol_ldisj m⟫ φ.
  Proof.
    rewrite !fol_sem_ldisj; split.
    + intros (f & H1 & H2); revert H1; rewrite in_app_iff; firstorder.
    + intros [ (? & ? & ?) | (? & ? & ?) ]; firstorder auto with *.
  Qed.

  Definition fol_vec_fa n (A : vec 𝔽 n) := fol_lconj (vec_list A).

  Fact fol_vars_vec_fa n A : fol_vars (@fol_vec_fa n A) = flat_map (@fol_vars _) (vec_list A).
  Proof.
    unfold fol_vec_fa; rewrite fol_vars_bigop; simpl.
    rewrite app_nil_end; auto.
  Qed.

  Fact fol_syms_vec_fa n A : fol_syms (@fol_vec_fa n A) = flat_map (@fol_syms _) (vec_list A).
  Proof.
    unfold fol_vec_fa; rewrite fol_syms_bigop; simpl.
    rewrite app_nil_end; auto.
  Qed.

  Fact fol_rels_vec_fa n A : fol_rels (@fol_vec_fa n A) = flat_map (@fol_rels _) (vec_list A).
  Proof.
    unfold fol_vec_fa; rewrite fol_rels_bigop; simpl.
    rewrite app_nil_end; auto.
  Qed.

  Fact fol_sem_vec_fa n A φ : ⟪@fol_vec_fa n A⟫ φ <-> forall p, ⟪vec_pos A p⟫ φ.
  Proof.
    unfold fol_vec_fa; rewrite fol_sem_lconj; split.
    + intros H p; apply H, in_vec_list, in_vec_pos.
    + intros H f Hf.
      apply vec_list_inv in Hf.
      destruct Hf as (p & ->); auto.
  Qed.

  (* [x1;...;xn] · φ := x1 · x2 ... · xn · φ *)

  Fixpoint env_vlift φ n (v : vec X n) :=
    match v with
      | ø    => φ
      | x##v => x·(env_vlift φ v)
    end.

  Fact env_vlift_fix0 φ n (v : vec X n) p : env_vlift φ v (pos2nat p) = vec_pos v p.
  Proof.
    revert φ p; induction v as [ | n x v IHv ]; intros phi p; auto.
    + invert pos p.
    + invert pos p.
      * rewrite pos2nat_fst; auto.
      * rewrite pos2nat_nxt; simpl; auto.
  Qed.

  Fact env_vlift_fix1 φ n (v : vec X n) k : env_vlift φ v (k+n) = φ k.
  Proof.
    revert φ k; induction v as [ | x n v IHv ]; intros phi k; simpl; auto.
    replace (k+S n) with (S (k+n)) by lia; simpl; auto.
  Qed.

  (* The semantics of ∀ ... ∀ A *)

  Fact fol_sem_mforall n A φ : ⟪fol_mquant fol_fa n A⟫ φ
                           <-> forall v : vec X n, ⟪A⟫ (env_vlift φ v).
  Proof.
    revert A φ; induction n as [ | n IHn ]; intros A phi.
    + split.
      * intros H v; vec nil v; simpl; auto.
      * intros H; apply (H ø).
    + rewrite fol_mquant_S, IHn; split.
      * intros H v; vec split v with x; apply (H v).
      * intros H v; intros x; apply (H (x##v)).
  Qed.

  (* The semantics of ∃ ... ∃ A *)

  Fact fol_sem_mexists n A φ : ⟪fol_mquant fol_ex n A⟫ φ
                           <-> exists v : vec X n, ⟪A⟫ (env_vlift φ v).
  Proof.
    revert A φ; induction n as [ | n IHn ]; intros A phi.
    + split.
      * intros H; exists ø; auto.
      * intros (v & Hv); revert Hv; vec nil v; auto.
    + rewrite fol_mquant_S, IHn; split.
      * intros (v & x & Hv).
        exists (x##v); auto.
      * intros (v & Hv); revert Hv; vec split v with x.
        exists v, x; auto.
  Qed.

End fol_semantics.

(*
Notation fol_sem_big_conj := fol_sem_lconj.
Notation fol_sem_big_disj := fol_sem_ldisj.
*)

Definition fot_vec_env Σ n p :
        { w : vec (fo_term (ar_syms Σ)) n | (forall X (M : fo_model Σ X) v φ q x,
             fo_term_sem M x·(env_vlift φ v) (vec_pos w q)
           = vec_pos (vec_change v p x) q)
         /\ forall q, fo_term_syms (vec_pos w q) = nil }.
Proof.
  exists (vec_change (vec_set_pos (fun q => £(S (pos2nat q)))) p (£0)); split.
  * intros X M v phi q x;rew fot; rew vec; rew fot.
    destruct (pos_eq_dec p q) as [ H | H ].
    + rewrite !vec_change_eq; auto.
    + rewrite !vec_change_neq; auto; rew vec; rew fot; simpl.
      rewrite env_vlift_fix0; auto.
  * intros q; destruct (pos_eq_dec p q) as [ H | H ].
    + rewrite !vec_change_eq; auto.
    + rewrite !vec_change_neq; auto; rew vec.
Qed.

Section fo_model_simulation.

  (* We state a general simulation result for models on a given
      formula build on a bounded list of symbols. The statement
      is so general that the proof is just obvious ;-) *)

  Variables  (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ))
             (X : Type) (M : fo_model Σ X)
             (Y : Type) (N : fo_model Σ Y).

  (* We assume that ⋈ is a simulation, ie a congruence for all operators in ls
      and all relations in lr *)

  Record fo_simulation := Mk_fo_simulation {
    fos_simul :> X -> Y -> Prop;
    fos_syms  : forall s v w, s ∊ ls
                          -> (forall p, fos_simul (vec_pos v p) (vec_pos w p))
                          -> fos_simul (fom_syms M s v) (fom_syms N s w);
    fos_rels  : forall r v w, r ∊ lr
                          -> (forall p, fos_simul (vec_pos v p) (vec_pos w p))
                          -> fom_rels M r v <-> fom_rels N r w;
    fos_total : forall x, exists y, fos_simul x y;
    fos_surj  : forall y, exists x, fos_simul x y;
  }.

  Record fo_projection := Mk_fo_projection {
    fop_surj :> X -> Y;
    fop_inj  : Y -> X;
    fop_eq   : forall x, fop_surj (fop_inj x) = x;
    fop_syms : forall s v, s ∊ ls -> fop_surj (fom_syms M s v) = fom_syms N s (vec_map fop_surj v);
    fop_rels : forall r v, r ∊ lr -> fom_rels M r v <-> fom_rels N r (vec_map fop_surj v);
  }.

  Fact fo_proj_simul : fo_projection -> fo_simulation.
  Proof.
    intros [ i j E Hs Hr ].
    exists (fun x y => i x = y); auto.
    + intros s v w H1 H2; rewrite Hs; auto.
      f_equal; apply vec_pos_ext; intro; rew vec.
    + intros s v w H1 H2; rewrite Hr; auto.
      apply fol_equiv_ext; f_equal.
      apply vec_pos_ext; intro; rew vec.
    + intros x; exists (i x); auto.
    + intros y; exists (j y); auto.
  Defined.

  Variable R : fo_simulation.

  Infix "⋈" := R (at level 70, no associativity).

  Notation "⟦ t ⟧" := (fun φ => fo_term_sem M φ t).
  Notation "⟦ t ⟧'" := (fun φ => fo_term_sem N φ t) (at level 1, format "⟦ t ⟧'").

  Notation "⟪ A ⟫" := (fun φ => fol_sem M φ A).
  Notation "⟪ A ⟫'" := (fun φ => fol_sem N φ A) (at level 1, format "⟪ A ⟫'").

  (* The simulation lifts from variables to terms *)

  Let fo_term_simulation t φ ψ :
           (forall n, n ∊ fo_term_vars t -> φ n ⋈ ψ n)
        -> fo_term_syms t ⊑ ls
        -> ⟦t⟧ φ ⋈ ⟦t⟧' ψ.
  Proof.
    revert φ ψ.
    induction t as [ k | s v IH ];
      intros phi psi Hv Hls; rew fot; auto.
    + apply Hv; simpl; auto.
    + apply fos_syms.
      * apply Hls; simpl; auto.
      * intros p; do 2 rewrite vec_pos_map.
        apply IH; auto.
        - intros n Hn; apply Hv; rew fot.
          apply in_flat_map.
          exists (vec_pos v p); split; auto.
          apply in_vec_list, in_vec_pos.
        - apply incl_tran with (2 := Hls).
          intros s' Hs'; rew fot.
          right; apply in_flat_map.
          exists (vec_pos v p); split; auto.
          apply in_vec_list, in_vec_pos.
  Qed.

  (* We assume the simulation to be total and surjective *)

  Theorem fo_model_simulation A φ ψ :
           fol_syms A ⊑ ls
        -> fol_rels A ⊑ lr
        -> (forall n, n ∊ fol_vars A -> φ n ⋈ ψ n)
        -> ⟪A⟫ φ <-> ⟪A⟫' ψ.
  Proof.
    revert φ ψ.
    induction A as [ | r v | b A HA B HB | q A HA ]; intros phi psi Hs1 Hr1 Hp; simpl; try tauto.
    + apply (fos_rels R).
      * apply Hr1; simpl; auto.
      * intros p; do 2 rewrite vec_pos_map.
        apply fo_term_simulation.
        - intros n Hn; apply Hp; simpl.
          apply in_flat_map.
          exists (vec_pos v p); split; auto.
          apply in_vec_list, in_vec_pos.
        - apply incl_tran with (2 := Hs1).
          intros s' Hs'; simpl.
          apply in_flat_map.
          exists (vec_pos v p); split; auto.
          apply in_vec_list, in_vec_pos.
    + apply fol_bin_sem_ext; [ apply HA | apply HB ].
      3,6: intros; apply Hp; simpl; apply in_or_app; auto.
      1,3: apply incl_tran with (2 := Hs1); intros ? ?; apply in_or_app; auto.
      1,2: apply incl_tran with (2 := Hr1); intros ? ?; apply in_or_app; auto.
    + destruct q; simpl; split.
      1: intros (x & Hx); destruct (fos_total R x) as (y & Hy); exists y; revert Hx; apply HA; eauto.
      2: intros (y & Hy); destruct (fos_surj R y) as (x & Hx); exists x; revert Hy; apply HA; eauto.
      3: intros H y; destruct (fos_surj R y) as (x & Hx); generalize (H x); apply HA; eauto.
      4: intros H x; destruct (fos_total R x) as (y & Hy); generalize (H y); apply HA; eauto.
      all: intros []; simpl; auto; intros; apply Hp, in_flat_map; exists (S n); simpl; auto.
  Qed.

End fo_model_simulation.

Theorem fo_model_projection Σ ls lr X M Y N (p : @fo_projection Σ ls lr X M Y N) A φ ψ :
           (forall n, n ∊ fol_vars A -> p (φ n) = ψ n)
        -> fol_syms A ⊑ ls
        -> fol_rels A ⊑ lr
        -> fol_sem M φ A <-> fol_sem N ψ A.
Proof.
  intros H1 H2 H3.
  apply fo_model_simulation with (R := fo_proj_simul p); auto.
  destruct p; simpl; auto.
Qed.

Section fo_model_projection.

  (* We specialize the previous simulation result on simulation
      obtained as surjective projections *)

  Variable (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ))
           (X : Type) (M : fo_model Σ X) (φ : nat -> X)
           (Y : Type) (N : fo_model Σ Y) (ψ : nat -> Y)
           (i : X -> Y) (j : Y -> X) (E : forall x, i (j x) = x)
           (Hs : forall s v, s ∊ ls -> i (fom_syms M s v) = fom_syms N s (vec_map i v))
           (Hr : forall r v, r ∊ lr -> fom_rels M r v <-> fom_rels N r (vec_map i v)).

  Let p : fo_projection ls lr M N.
  Proof. exists i j; auto. Defined.

  Theorem fo_model_projection' A :
           (forall n, n ∊ fol_vars A -> i (φ n) = ψ n)
        -> fol_syms A ⊑ ls
        -> fol_rels A ⊑ lr
        -> fol_sem M φ A <-> fol_sem N ψ A.
  Proof using Hs Hr E. apply fo_model_projection with (p := p). Qed.

End fo_model_projection.

Section fo_model_nosyms.

  Variable (Σ : fo_signature)
           (X : Type) (M M' : fo_model Σ X) (φ : nat -> X)
           (A : fol_form Σ)
           (HA : fol_syms A = nil)
           (H : forall r v, r ∊ fol_rels A -> fom_rels M r v <-> fom_rels M' r v).

  Theorem fo_model_nosyms : fol_sem M φ A <-> fol_sem M' φ A.
  Proof using HA H.
    apply fo_model_projection' with (ls := nil) (lr := fol_rels A) (i := fun x => x) (j := fun x => x); auto.
    + intros; rewrite H; auto.
      apply fol_equiv_ext; f_equal.
      apply vec_pos_ext; intro; rew vec.
    + rewrite HA; apply incl_refl.
  Qed.

End fo_model_nosyms.


From mathcomp Require Import all_ssreflect.

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

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import FunctionalExtensionality.
Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Definition monotone {X Y : Type} (f : (X -> Prop) -> (Y -> Prop)) : Prop :=
  forall (π1 π2: X -> Prop), (π1 ⊆ π2) -> (f π1 ⊆ f π2).

Definition idempotent {X : Type} (f : (X -> Prop) -> (X -> Prop)) : Prop :=
  forall π: X -> Prop, f (f π) = f π.

Definition extensive {X : Type} (f : (X -> Prop) -> (X -> Prop)) : Prop :=
  forall π: X -> Prop, π ⊆ (f π).

Definition lift {X Y : Type} (f :(X -> Prop) -> (Y -> Prop))
                            (H : (X -> Prop) -> Prop) : ((Y -> Prop) -> Prop) :=
  fun (b1 : Y -> Prop) => exists b2, (H b2) /\ b1 = f b2.

(* Definition of the adjunction law *)

Definition Adjunction_law {A C : Type}
           (α : (C -> Prop) -> (A -> Prop))
           (γ : (A -> Prop) -> (C -> Prop)) :=
  forall (a: A -> Prop) (c: C -> Prop),  (α c) ⊆ a <-> c ⊆ (γ a).

(* We define Galois connection between powersets ordered by set inclusion:
     (2^X, ⊆) ⇆ (2^Y, ⊆)
   *)
Structure Galois_Connection (A C : Type) := {
    α : (C -> Prop) -> (A -> Prop);
    γ : (A -> Prop) -> (C -> Prop);
    adjunction_law : Adjunction_law α γ
  }.

Definition Galois_fst {A C : Type}
           (α: (C -> Prop) -> (A -> Prop))
           (γ: (A -> Prop) -> (C -> Prop)) :=
  forall (c: C -> Prop),  c ⊆ (γ (α c)).

Definition Galois_snd {A C : Type}
           (α: (C -> Prop) -> (A -> Prop))
           (γ: (A -> Prop) -> (C -> Prop)) :=
  forall (a : A -> Prop), (α (γ a)) ⊆ a.

Lemma Galois_equiv {A C: Type}
      (α: (C -> Prop) -> (A -> Prop))
      (γ: (A -> Prop) -> (C -> Prop)) :
  Adjunction_law α γ <-> ( monotone α /\ monotone γ /\ Galois_fst α γ  /\ Galois_snd α γ).
Proof.
  split.
  - move => H_adj. split.
    + move => c1 c2 H_sub. rewrite H_adj.
      apply: (subset_trans H_sub). by rewrite -H_adj.
    + split.
      ++ move => a1 a2 H_sub. rewrite -H_adj.
         apply: subset_trans. rewrite H_adj. by apply: subset_ref.
         assumption.
      ++ split; move => x; [by rewrite -H_adj | by rewrite H_adj].
  - move => [mono_α [mono_γ [G1 G2]]] a c. split => H.
    + apply: subset_trans. apply: (G1 c). by apply: mono_γ.
      apply: subset_trans. apply: mono_α. exact H. by apply: G2.
Qed.

(* Galois Insertion (α (γ a)) = a *)
Definition Insertion_snd {A C : Type}
           (α: (C -> Prop) -> (A -> Prop))
           (γ: (A -> Prop) -> (C -> Prop)) :=
  forall (a : A -> Prop), (α (γ a)) = a.

Structure Galois_Insertion (A C : Type) := {
            α__i : (C -> Prop) -> (A -> Prop);
            γ__i : (A -> Prop) -> (C -> Prop);
            mono_α : monotone α__i;
            mono_γ : monotone γ__i;
            G1 : Galois_fst α__i γ__i;
            I2 : Insertion_snd α__i γ__i
          }.

Lemma Insertion_coercion_Connection {A C : Type} :
  Galois_Insertion A C -> Galois_Connection A C.
Proof.
  move => [α γ mono_alpha mono_gamma H1 H2].
  have H_adj: Adjunction_law α γ.
  rewrite Galois_equiv. repeat split; auto.
  move => a. rewrite (H2 a). now apply: subset_ref.
  exact (Build_Galois_Connection H_adj).
Qed.

Coercion Insertion_coercion_Connection  : Galois_Insertion >-> Galois_Connection.

(* Galois Reflection (γ (α c)) = c *)

Definition Reflection_fst {A C : Type}
           (α: (C -> Prop) -> (A -> Prop))
           (γ: (A -> Prop) -> (C -> Prop)) :=
  forall (c : C -> Prop), (γ (α c)) = c.

Structure Galois_Reflection (A C : Type) := {
            α__r : (C -> Prop) -> (A -> Prop);
            γ__r : (A -> Prop) -> (C -> Prop);
            mono_α__r : monotone α__r;
            mono_γ__r: monotone γ__r;
            R1 : Reflection_fst α__r γ__r;
            G2 : Galois_snd α__r γ__r
          }.

Lemma Reflection_coercion_Connection {A C : Type} :
  Galois_Reflection A C -> Galois_Connection A C.
Proof.
  move => [α γ mono_alpha mono_gamma H1 H2].
  have H_adj: Adjunction_law α γ.
  rewrite Galois_equiv. repeat split; auto.
  move => a. rewrite (H1 a). now apply: subset_ref.
  exact (Build_Galois_Connection H_adj).
Qed.

Coercion Reflection_coercion_Connection  : Galois_Reflection >-> Galois_Connection.

  (* Given ∼ ⊆ 2^C × 2^A there is a pair of maps
     α : 2^C -> 2^A,  γ : 2^A -> 2^C, that is a Galois connection
     between (2^C, ⊆) and (2^A, ⊆).
   *)

Definition low_rel  {A C : Type} (rel : C -> A -> Prop) : (C -> Prop) -> (A -> Prop) :=
  fun (c : C -> Prop) =>
    (fun (x : A) => exists (y : C), (c y) /\ rel y x).

Definition up_rel {A C : Type} (rel : C -> A -> Prop) : (A -> Prop) -> (C -> Prop) :=
  fun (a : A -> Prop) =>
    (fun (y : C) => forall (x : A), (rel y x -> a x)).

Lemma induced_adj_law {A C : Type} (rel : C -> A -> Prop) :
  Adjunction_law (low_rel rel) (up_rel rel).
Proof.
  move => a c. rewrite /low_rel /up_rel. split.
  + move => H t h_t t' rel_t_t'. apply: H. by exists t.
                                               + move => H x [y [c_y rel_y_x]]. by apply: (H y).
Qed.

Definition induced_connection {A C : Type} (rel : C -> A -> Prop) : Galois_Connection A C :=
  Build_Galois_Connection (induced_adj_law rel).

 (*
    We can also build a connection such that C is the abstract domain and A the concrete one

  *)

Definition swap_rel {A C : Set} (rel : C -> A -> Prop) : A -> C -> Prop := fun a c => rel c a.

Definition induced_connection_swap {A C : Set} (rel : C -> A -> Prop) : Galois_Connection C A :=
  Build_Galois_Connection (induced_adj_law (swap_rel rel)).

(*
  motivation:
    we have in mind a scenario in which more observations are possible in the
    target language, but no really "new" computations happen.
    So that we relate a source trace with all the target traces that insert
    extra observations between source events.
 *)

Definition total_fun_A_C {A C : Set} (rel : C -> A -> Prop) : Prop :=
  forall a, exists! c, rel c a.

Definition total {A C : Type} (rel : C -> A -> Prop) : Prop :=
  forall c, exists a, rel c a.

Definition more_obs_rel {A C : Set} (rel : C -> A -> Prop) :=
  total_fun_A_C rel /\ total rel.

Definition swap_low {A C : Set} (rel : C -> A -> Prop) : (A -> Prop) -> (C -> Prop) :=
  low_rel (swap_rel rel).

Definition swap_up {A C : Set} (rel : C -> A -> Prop) : (C -> Prop) -> (A -> Prop) :=
  up_rel (swap_rel rel).

Lemma monotone_swap_low {A C : Set} (rel : C -> A -> Prop) :
  @monotone A C (swap_low rel).
Proof.
   have: Adjunction_law (swap_low rel) (swap_up rel)
    by apply: adjunction_law (induced_connection (swap_rel rel)).
   rewrite Galois_equiv. by move => [H1 [H2 [G1 G2]]].
Qed.

Lemma monotone_swap_up {A C : Set} (rel : C -> A -> Prop) :
  @monotone C A (swap_up rel).
Proof.
   have: Adjunction_law (swap_low rel) (swap_up rel)
    by apply: adjunction_law (induced_connection (swap_rel rel)).
   rewrite Galois_equiv. by move => [H1 [H2 [G1 G2]]].
Qed.

Lemma G1_swap_up_low_leq {A C : Set} (rel : C -> A -> Prop):
  Galois_fst (swap_low rel) (swap_up rel).
Proof.
  have: Adjunction_law (swap_low rel) (swap_up rel)
    by apply: adjunction_law (induced_connection (swap_rel rel)).
  rewrite Galois_equiv. by move => [H1 [H2 [G1 G2]]].
Qed.

Lemma I2_swap_low_up_id {A C : Set} (rel : C -> A -> Prop):
  more_obs_rel rel ->
  Insertion_snd (swap_low rel) (swap_up rel).
Proof.
  move => [rel_fun rel_total].
  rewrite /Insertion_snd /swap_low /swap_up /low_rel /up_rel /swap_rel /=.
  move => π__a. apply: functional_extensionality => c.
  apply: prop_extensionality. split.
  + move => [a [Ha rel_c_a]]. by apply: Ha.
  + move => π_c. destruct (rel_total c) as [a rel_c_a].
    exists a. split; auto.
    move => c' rel_c'_a. destruct (rel_fun a) as [c_unique [rel_cunique Hunique]].
    have H1: c_unique = c by apply: Hunique.
    have H2: c_unique = c' by apply: Hunique.
    by subst.
Qed.

Definition induced_insertion_swap {A C : Set}
                                  (rel : C -> A -> Prop)
                                  (H_obs_rel : more_obs_rel rel) : Galois_Insertion C A :=
  @Build_Galois_Insertion C A (swap_low rel) (swap_up rel)
                              (@monotone_swap_low A C rel)
                              (@monotone_swap_up A C rel)
                              (@G1_swap_up_low_leq A C rel)
                              (@I2_swap_low_up_id A C rel H_obs_rel).

(** *upper closure operator  \cite{giacobazzi2018abstract} (pag 7) *)
Record Uco {X: Type} :=
  {
    uco: (X -> Prop) -> (X -> Prop);
    mono: monotone uco;
    idmp: idempotent uco;
    ext : extensive uco
  }.

(* for simplicity defined only on insertions *)
Definition best_approximation {A C : Set} (gal : Galois_Insertion C A)
                                          (f : (C -> Prop) -> (C -> Prop)) : (A -> Prop) -> (A -> Prop) :=
  (γ__i gal) ∘ f ∘ (α__i gal).

Lemma composition_mono {A B C : Set} (f : (A -> Prop) -> (B -> Prop)) (g : (B -> Prop) -> (C -> Prop))
      (mono_f : monotone f) (mono_g : monotone g) : monotone (g ∘ f).
Proof.
  move => π1 π2 H_sub. apply: mono_g. by apply: mono_f.
Qed.

Lemma best_approximation_mono {A C : Set} (ins : Galois_Insertion C A)
                                          (ϕ : @Uco C) :
                                          monotone (best_approximation ins (uco ϕ)).
Proof.
  rewrite /best_approximation.
  apply: composition_mono.
   apply: composition_mono.
   exact (@mono_α C A ins). exact (@mono C ϕ).
  exact (@mono_γ C A ins).
Qed.

Lemma best_approximation_idmp {A C : Set} (ins : Galois_Insertion C A)
                                          (ϕ : @Uco C) :
                                          idempotent (best_approximation ins (uco ϕ)).
Proof.
  rewrite /best_approximation /idempotent => π.
    by rewrite (@I2 C A) (@idmp C ϕ).
Qed.

Lemma best_approximation_ext {A C : Set}  (ins : Galois_Insertion C A)
                                          (ϕ : @Uco C) :
                                          extensive (best_approximation ins (uco ϕ)).
Proof.
  rewrite /best_approximation /extensive => π.
  apply: subset_trans.
  exact: (@G1 C A). apply: (@mono_γ C A).
  exact: (@ext C ϕ).
Qed.

Definition uco_sharp {A C : Set} (ϕ : @Uco C)
                                 (ins : Galois_Insertion C A) : @Uco A :=

  @Build_Uco A (@best_approximation A C ins (uco ϕ))
               (@best_approximation_mono A C ins ϕ)
               (@best_approximation_idmp A C ins ϕ)
               (@best_approximation_ext A C ins ϕ).

(************************************)
(*  for relational properties       *)
(************************************)

Definition low_rel_prod  {A C : Type} (rel : C -> A -> Prop) : (C * C -> Prop) -> (A * A -> Prop) :=
  fun c =>
    fun a : A * A => exists x : C * C, c x /\ rel (fst x) (fst a) /\ rel (snd x) (snd a).

Definition up_rel_prod {A C : Type} (rel : C -> A -> Prop) : (A * A -> Prop) -> (C * C -> Prop) :=
  fun a =>
    fun c : C * C => forall y : A * A, rel (fst c) (fst y) -> rel (snd c) (snd y) -> a y.

Lemma induced_adj_law_prod {A C : Type} (rel : C -> A -> Prop) :
  @Adjunction_law (A * A) (C * C) (low_rel_prod rel) (up_rel_prod rel).
Proof.
  move => a c. rewrite /low_rel_prod /up_rel_prod. split.
  + move => H t h_t t' rel_t_t'_fst rel_t_t'_snd.
    apply: H.
    by exists t.
  + move => H x [y [c_y [rel_y_x_1 rel_y_x_2]]]. by apply: (H y).
Qed.

Definition induced_connection_prod {A C : Type} (rel : C -> A -> Prop)
  : Galois_Connection (A * A) (C * C) :=
  Build_Galois_Connection (induced_adj_law_prod rel).

Lemma rel_total_surjective {A C : Set} (rel : C -> A -> Prop):
  more_obs_rel (swap_rel rel) -> (* total and surjective map from A to C *)
  γ (induced_connection rel) = fun (a : A -> Prop) => (fun x : C => exists y : A, rel x y /\ a y).
Proof.
  move => [Hrel1 Hrel2].
  rewrite /γ /= /up_rel.
  apply: functional_extensionality => a.
  apply: functional_extensionality => x.
  apply: prop_extensionality.
  split.
  + firstorder.
  + move => [y [rel_x_y a_y]] y0 rel_x_y0.
    move : (Hrel2 y) => [x0 rel_x0_y].
    move : (Hrel1 x) => [y_u rel_x_yu].
    move: rel_x_yu. rewrite /unique. move => [rel_yu_x Hunique].
    have hfoo0 : (swap_rel rel) y0 x by [].
    move: (Hunique y0 hfoo0) => Heq0. subst.
    have hfoo  : (swap_rel rel) y x by [].
    move: (Hunique y hfoo) => Heq. by subst.
Qed.

Lemma equal_pointwise {X : Set} (π1 π2 : X -> Prop) :
  π1 = π2 -> (forall x : X, π1 x = π2 x).
Proof. move => Heq x. by rewrite Heq. Qed.

Lemma rel_total_surjective_up_inj {A C : Set} (rel : C -> A -> Prop):
  more_obs_rel (swap_rel rel) -> (* total and surjective map from A to C *)
  (forall π1 π2, π1 <> π2 ->
   (γ (induced_connection rel) π1) <> (γ (induced_connection rel) π2)).
Proof.
  move => Hrel π1 π2 Hdiff. rewrite (rel_total_surjective Hrel) => Hf.
  apply: Hdiff.
  apply: functional_extensionality => a.
  apply: prop_extensionality.
  move: Hrel. rewrite /swap_rel /=. move =>  [Hrel1 Hrel2].
  move: (Hrel2 a) => [c rel_a_c]. move: (Hrel1 c) => [unique_a [rel_unique_c Hunique]].
  split => Hπi.
  have [a' [rel_c_a' π2_a']] : exists a': A, rel c a'  /\ (π2 a').
  { move: (equal_pointwise Hf c) => Heq. rewrite -Heq.
    by exists a. }
  move: (Hunique a rel_a_c) (Hunique a' rel_c_a') => Heq1 Heq2. by subst.
  (* symmetric case *)
  have [a' [rel_c_a' π2_a']] : exists a': A, rel c a'  /\ (π1 a').
  { move: (equal_pointwise Hf c) => Heq. rewrite Heq.
    by exists a. }
  move: (Hunique a rel_a_c) (Hunique a' rel_c_a') => Heq1 Heq2. by subst.
Qed.


Load "../SetSpecs/SetPreamble.v".
Load "../SetSpecs/empty_set_correct.v".
Load "../SetSpecs/singleton_set_correct.v".
Load "../SetSpecs/union_correct.v".
Load "../SetSpecs/intersect_correct.v".
Load "../SetSpecs/diff_correct.v".

(* this would normally be kept abstract as a section variable,
   but for testing, we make it concrete *)
Definition K: Type := nat.
Definition V: Type := nat.
Definition keq: forall (k1 k2: K), {k1 = k2} + {k1 <> k2} := Nat.eq_dec.
Definition veq: forall (v1 v2: V), {v1 = v2} + {v1 <> v2} := Nat.eq_dec.

Definition tupleeq: forall (t1 t2: K * V), {t1 = t2} + {t1 <> t2}.
  refine (fun '(k1, v1) '(k2, v2) =>
            match keq k1 k2, veq v1 v2 with
            | left _, left _ => left _
            | _, _ => right _
            end).
  all: congruence.
Defined.

Definition map(K V: Type): Type := list (K * V).

Definition empty_map: map K V := nil.

Definition get(M: map K V)(k: K): option V :=
  match find (fun '(ki, vi) => if keq ki k then true else false) M with
  | Some (_, v) => Some v
  | None => None
  end.

Definition remove(M: map K V)(k: K): map K V :=
  filter (fun '(ki, vi) => if keq k ki then false else true) M.

Definition put(M: map K V)(k: K)(v: V): map K V := (k, v) :: (remove M k).

Definition restrict(M: map K V)(A: set K): map K V :=
  filter (fun '(ki, vi) => if in_dec keq ki A then true else false) M.

Definition domain(M: map K V): set K := List.map fst M.

Definition domain_and_range(M: map K V): set K * set V :=
  fold_left (fun '(d, r) '(ki, vi) =>
               if in_dec keq ki d then (d, r) else (ki :: d, vi :: r)
            ) M (empty_set, empty_set).

Definition preimage(M: map K V)(vs: set V): set K :=
  filter (fun ki => match get M ki with
                    | Some vi => if in_dec veq vi vs then true else false
                    | None => false
                    end)
         (domain M).

Definition remove_keys(M: map K V)(ks: set K): map K V :=
  filter (fun '(ki, vi) => if in_dec keq ki ks then false else true) M.


Require Import VST.msl.msl_direct.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.

Require Import neg_logic.

Open Local Scope logic.

(* MODAL LOGIC *)
Class ModLog (RT : Type) (A: Type) (ND: NatDed A) : Type := mkModLog {
  box : RT -> A -> A;
  modal_N : forall R P, TT |-- P -> TT |-- box R P;
  modal_K : forall R P Q, box R (P --> Q) |-- (box R P) -->  (box R Q);
  (* Sometimes axiom A is called axiom BF, see https://plato.stanford.edu/entries/logic-modal/ *)
  modal_A : forall R B P, ALL b : B, box R (P b) |-- box R (ALL b : B, P b);
}.
Notation " '[' R ']' " := (box R) : logic.

(* Here we are classical... not clear if there is a better/alternative way forward yet... *)
Definition diamond {RT} {A} {ND : NatDed A} {ML: ModLog RT A ND} : RT -> A -> A :=
  fun rt P => ! ([rt] (!P)).
(*
Notation " '<' R '>' " := (diamond R) : logic.
*)

Class ModLogSeq {RT : Type} {A : Type} {ND : NatDed A} (ML : @ModLog RT A ND) : Type := mkModLogSeq {
  seqR : RT -> RT -> RT;
  seqR_box: forall R1 R2 (P : A),
    [seqR R1 R2] P = [R1] ([R2] P);
}.

Class ModLogDual {RT : Type} {A: Type} {ND : NatDed A} (ML : @ModLog RT A ND) : Type := mkModLogDual {
  antiR : RT -> RT;
  antiR_involution : forall R, antiR (antiR R) = R;
  antidiamond_box_adjoint : forall R P Q,
    diamond (antiR R) P |-- Q  <->
    P |-- [R] Q;
}.

(* CORRESPONDENCE CLASSES *)

Section CorrespondenceClasses.

Context {A RT : Type}.
Context {ND : NatDed A}.
Context {ML : ModLog RT A ND}.

(* reflexivity *)
Class Modal_T (R : RT) :=
  modal_T : forall P, [R] P |-- P.

(* transitivity *)
Class Modal_4 (R : RT) :=
  modal_4 : forall P, [R] P |-- [R] ([R] P).

(* density *)
Class Modal_C4 (R : RT) :=
  modal_C4 : forall P, [R] ([R] P) |-- [R] P.

(* serial, i.e. total *)
Class Modal_D (R : RT) :=
  modal_D : forall P, [R] P |-- diamond R P.
  (* I'm not sure what this one is called in the literature. *)

(* functional *)
Class Modal_CD (R : RT) :=
  modal_CD : forall P, diamond R P |-- [R] P.

(* symmetric *)
Class Modal_B (R : RT) :=
  modal_B : forall P, P |-- [R] (diamond R P).

(* finite chains *)
Class Modal_W  (R : RT) :=
  modal_W : forall P, ([R] P |-- P) -> (TT |-- P).

End CorrespondenceClasses.

Section ModalLogic.

Context {A RT : Type}.
Context {ND : NatDed A}.
Context {ML : ModLog RT A ND}.

Section ModalLogic_K.

Lemma box_TT: forall R,
  [R] TT = TT.
Proof.
  intro. apply pred_ext.
  apply TT_right.
  apply modal_N.
  apply TT_right.
Qed.

Lemma box_positive: forall R P (Q : A),
      P |-- Q         ->
  [R] P |-- [R] Q.
Proof.
  intros.
  rewrite <- (TT_andp ([R] P)).
  rewrite imp_andp_adjoint.
  apply derives_trans with ([R] (P --> Q)).
  apply modal_N. rewrite <- imp_andp_adjoint.
  rewrite TT_andp. trivial.
  apply modal_K.
Qed.

Lemma box_andp: forall R (P Q : A),
  [R] (P && Q) = ([R] P) && ([R] Q).
Proof.
  intros. apply pred_ext.
  * apply andp_right; apply box_positive.
    apply andp_left1; auto. apply andp_left2; auto.
  * rewrite imp_andp_adjoint.
    eapply derives_trans.
    apply box_positive.
    rewrite <- imp_andp_adjoint; auto.
    apply modal_K.
Qed.

Lemma box_orp2 {R : RT}: forall P (Q : A),
  ([R] P) || ([R] Q) |-- [R] (P || Q).
Proof.
  intros.
  apply orp_left; apply box_positive.
  apply orp_right1; trivial.
  apply orp_right2; trivial.
Qed.

Lemma box_allp {B}: forall R (P : B -> A),
  [R] (ALL b : B, P b) = ALL b : B, [R] (P b).
Proof.
  intros. apply pred_ext.
  apply allp_right. intro b.
  apply box_positive. apply allp_left with b. apply derives_refl.
  apply modal_A.
Qed.

Lemma box_exp2 {B}: forall R (P : B -> A),
  EX b : B, [R] (P b) |-- [R] (EX b : B, P b).
Proof.
  intros.
  apply exp_left. intro x.
  apply box_positive.
  apply exp_right with x.
  trivial.
Qed.

Lemma deMorgan_box1 `{CND: @ClassicNatDed A ND}: forall R (P : A),
  ! ([R] P) |-- diamond R (! P).
Proof.
  intros. unfold diamond.
  apply notp_derives.
  apply box_positive.
  apply notnot1. (* classical *)
Qed.

Lemma deMorgan_box2: forall R (P : A),
  diamond R (! P) |-- ! ([R] P).
Proof.
  intros. unfold diamond.
  apply notp_derives.
  apply box_positive.
  apply notnot2.
Qed.

Lemma deMorgan_box `{CND: @ClassicNatDed A ND}: forall R (P : A),
  ! ([R] P) = diamond R (! P).
Proof. intros. apply pred_ext. apply deMorgan_box1. apply deMorgan_box2. Qed.

Lemma deMorgan_diamond1 `{CND: @ClassicNatDed A ND}: forall R (P : A),
  ! (diamond R P) |-- [R] (! P).
Proof.
  intros. unfold diamond.
  apply notnot1. (* classical *)
Qed.

Lemma deMorgan_diamond2: forall R (P : A),
  [R] (! P) |-- ! (diamond R P).
Proof.
  intros.
  apply notnot2.
Qed.

Lemma deMorgan_diamond `{CND: @ClassicNatDed A ND}: forall R (P : A),
  ! (diamond R P) = [R] (! P).
Proof. intros. apply pred_ext. apply deMorgan_diamond1. apply deMorgan_diamond2. Qed.

Lemma diamond_FF: forall R,
  diamond R FF = FF.
Proof.
  intro. apply pred_ext.
  * unfold diamond.
    rewrite notp_FF, box_TT, notp_TT. trivial.
  * apply FF_left.
Qed.

Lemma diamond_positive: forall R P (Q : A),
            P |-- Q               ->
  diamond R P |-- diamond R Q.
Proof.
  intros. unfold diamond.
  apply notp_derives.
  apply box_positive.
  apply notp_derives.
  trivial.
Qed.

Definition NTD (R : RT) : A := diamond R TT.
Lemma diamond_WN: forall R (P : A),
     TT |-- P ->
  NTD R |-- diamond R P.
Proof.
  intros.
  apply diamond_positive.
  trivial.
Qed.

Lemma diamond_orp1 `{CND: @ClassicNatDed A ND}: forall R (P Q : A),
  diamond R (P || Q) |-- (diamond R P) || (diamond R Q).
Proof.
  intros. unfold diamond.
  rewrite deMorgan_orp.
  rewrite box_andp.
  apply deMorgan_andp1. (* classic *)
Qed.

Lemma diamond_orp2: forall R (P Q : A),
  (diamond R P) || (diamond R Q) |-- diamond R (P || Q).
Proof.
  intros.
  eapply derives_trans.
  apply deMorgan_andp2.
  rewrite <- box_andp.
  apply notp_derives.
  apply box_positive.
  rewrite deMorgan_orp. trivial.
Qed.

Lemma diamond_orp `{CND: @ClassicNatDed A ND}: forall R (P Q : A),
  diamond R (P || Q) = (diamond R P) || (diamond R Q).
Proof. intros. apply pred_ext. apply diamond_orp1. apply diamond_orp2. Qed.

Lemma diamond_andp1: forall R P (Q : A),
  diamond R (P && Q) |-- (diamond R P) && (diamond R Q).
Proof.
  intros.
  apply andp_right; apply diamond_positive.
  apply andp_left1; trivial.
  apply andp_left2; trivial.
Qed.

Lemma diamond_allp1 {B}: forall R (P : B -> A),
  diamond R (ALL b : B, P b) |-- ALL b : B, diamond R (P b).
Proof.
  intros.
  apply allp_right. intro x.
  apply diamond_positive.
  apply allp_left with x. trivial.
Qed.

Lemma diamond_exp1 `{CND: @ClassicNatDed A ND} {B}: forall R (P : B -> A),
  diamond R (EX b : B, P b) |-- EX b : B, diamond R (P b).
Proof.
  intros. unfold diamond.
  eapply derives_trans.
  2: apply deMorgan_allp1. (* classic *)
  apply notp_derives.
  rewrite <- box_allp.
  apply box_positive.
  apply deMorgan_exp2.
Qed.

Lemma diamond_exp2 {B}: forall R (P : B -> A),
  EX b : B, diamond R (P b) |-- diamond R (EX b : B, P b).
Proof.
  intros.
  apply exp_left. intro x.
  apply diamond_positive.
  apply exp_right with x. trivial.
Qed.

Lemma diamond_exp `{CND: @ClassicNatDed A ND} {B}: forall R (P : B -> A),
  diamond R (EX b : B, P b) = EX b : B, diamond R (P b).
Proof. intros. apply pred_ext. apply diamond_exp1. apply diamond_exp2. Qed.

End ModalLogic_K.

(* reflexivity *)
Section ModalLogic_T.

Context {R : RT}.
Context {MLT : Modal_T R}.

Instance Modal_T_Modal_C4: Modal_C4 R.
Proof.
  intro.
  apply modal_T.
Qed.

Instance Modal_T_Modal_D: Modal_D R.
Proof.
  intro.
  apply notp_right.
  rewrite <- box_andp.
  rewrite contradiction_FF.
  apply modal_T.
Qed.

Lemma diamond_CT: forall P : A,
  P |-- diamond R P.
Proof.
  intro.
  apply notp_right.
  eapply derives_trans.
  apply andp_derives.
  trivial.
  apply modal_T.
  apply notp_left.
Qed.

End ModalLogic_T.

(* transitivity *)
(* density *)
Section ModalLogic_4_C4.

Context {R : RT}.
Context {ML4 : Modal_4 R}.
Context {MLC4 : Modal_C4 R}.

Lemma modal4C4  : forall P,
  [R] P = [R] ([R] P).
Proof. intros. apply pred_ext. apply modal_4. apply modal_C4. Qed.

End ModalLogic_4_C4.

(* serial, i.e. total *)
Section ModalLogic_D.

Context {R : RT}.
Context {MLD : Modal_D R}.

Lemma box_notp1: forall (P : A),
  [R] (! P) |-- ! ([R] P).
Proof.
  intro.
  apply notp_right.
  rewrite <- box_andp.
  rewrite andp_comm.
  rewrite contradiction_FF.
  pattern FF at 2. rewrite <- (diamond_FF R).
  apply modal_D.
Qed.

Lemma diamond_notp2: forall P : A,
  !(diamond R P) |-- diamond R (! P).
Proof.
  intros.
  apply notp_derives.
  eapply derives_trans.
  apply modal_D.
  apply notp_derives.
  apply box_positive.
  apply notnot2.
Qed.

Lemma diamond_N: forall P : A,
  TT |-- P ->
  TT |-- diamond R P.
Proof.
  intros.
  apply derives_trans with (NTD R).
  rewrite <- (box_TT R).
  apply modal_D.
  apply diamond_WN. trivial.
Qed.

Lemma diamond_antiK {CND: @ClassicNatDed A ND}: forall P (Q : A),
  (diamond R P) --> (diamond R Q) |-- diamond R (P --> Q).
Proof.
  intros.
  apply (LEM_cases (diamond R P)).
  * eapply derives_trans.
    apply modus_ponens.
    apply diamond_positive.
    rewrite <- imp_andp_adjoint.
    apply andp_left1. trivial.
  * apply andp_left1.
    eapply derives_trans.
    apply diamond_notp2.
    apply diamond_positive.
    rewrite <- imp_andp_adjoint.
    rewrite andp_comm.
    apply notp_left.
Qed.

End ModalLogic_D.

(* functional *)
Section ModalLogic_CD.

Context {R : RT}.
Context {MLCD : Modal_CD R}.

Lemma box_notp2 {CND: @ClassicNatDed A ND}: forall (P : A),
  ! ([R] P) |-- [R] (! P).
Proof.
  intros.
  eapply derives_trans.
  apply deMorgan_box1. (* classic *)
  apply modal_CD.
Qed.

Lemma diamond_K: forall P (Q : A),
  diamond R (P --> Q) |-- (diamond R P) --> (diamond R Q).
Proof.
  intros.
  eapply derives_trans.
  * apply modal_CD.
  * eapply derives_trans.
    + apply box_positive.
      apply contrapositive2.
    + eapply derives_trans.
      - apply modal_K.
      - apply contrapositive2.
Qed.

Lemma diamond_notp1: forall P : A,
  diamond R (! P) |-- !(diamond R P).
Proof.
  intro. unfold notp at 2.
  rewrite <- (diamond_FF R).
  apply diamond_K.
Qed.

Lemma box_antiK {CND: @ClassicNatDed A ND}: forall P Q : A,
  [R] P --> [R] Q |-- [R] (P --> Q).
Proof.
  intros.
  apply (LEM_cases ([R] P)).
  eapply derives_trans.
  apply modus_ponens.
  apply box_positive.
  rewrite <- imp_andp_adjoint.
  apply andp_left1. trivial.
  apply andp_left1.
  eapply derives_trans.
  apply box_notp2.
  apply box_positive.
  rewrite <- imp_andp_adjoint.
  rewrite andp_comm.
  apply notp_left.
Qed.

Lemma box_K_eq {CND: @ClassicNatDed A ND}: forall P Q : A,
  [R] (P --> Q) = [R] P --> [R] Q.
Proof. intros. apply pred_ext. apply modal_K. apply box_antiK. Qed.

Lemma box_orp1 {CND : ClassicNatDed A}: forall P (Q : A),
  [R] (P || Q) |-- ([R] P) || ([R] Q).
Proof.
  intros.
  apply (LEM_cases ([R] P)).
  apply andp_left1. apply orp_right1. trivial.
  apply orp_right2.
  eapply derives_trans.
  apply andp_derives.
  apply box_notp2.
  trivial.
  rewrite <- box_andp.
  apply box_positive.
  rewrite andp_comm.
  rewrite distrib_orp_andp.
  apply orp_left.
  apply notp_left.
  apply andp_left1. trivial.
Qed.

Lemma box_orp {CND : ClassicNatDed A}: forall P (Q : A),
  [R] (P || Q) = ([R] P) || ([R] Q).
Proof. intros. apply pred_ext. apply box_orp1. apply box_orp2. Qed.

Lemma diamond_andp2 {CND : ClassicNatDed A}: forall P (Q : A),
  diamond R P && diamond R Q |--
  diamond R (P && Q).
Proof.
  intros.
  unfold diamond.
  rewrite <- deMorgan_orp.
  apply notp_derives.
  rewrite deMorgan_andp.
  apply box_orp1.
Qed.

Lemma diamond_andp {CND : ClassicNatDed A}: forall P (Q : A),
  diamond R (P && Q) = diamond R P && diamond R Q .
Proof. intros. apply pred_ext. apply diamond_andp1. apply diamond_andp2. Qed.

Lemma weakD {CND : ClassicNatDed A}: forall (P : A),
  [R] P |-- diamond R P || [R] FF.
Proof.
  intro.
  apply (LEM_cases (diamond R P)).
  apply andp_left1. apply orp_right1. trivial.
  apply orp_right2.
  unfold diamond. rewrite notnot.
  rewrite <- box_andp.
  apply box_positive.
  rewrite andp_comm.
  apply notp_left.
Qed.

Lemma box_exp1 {CND : ClassicNatDed A} {B}: inhabited B -> forall P,
  box R (EX b : B, P b) |-- EX b : B, box R (P b).
Proof.
  intros.
  eapply derives_trans.
  apply weakD.
  apply orp_left.
  rewrite diamond_exp.
  apply exp_derives. intro b.
  apply modal_CD.
  destruct H as [b].
  apply exp_right with b.
  apply box_positive.
  apply FF_left.
Qed.

Lemma diamond_allp2 {CND : ClassicNatDed A} {B}: inhabited B -> forall (P : B -> A),
  ALL b : B, diamond R (P b) |-- diamond R (ALL b : B, P b).
Proof.
  intros. unfold diamond.
  apply PBC.
  rewrite notnot.
  rewrite deMorgan_allp.
  rewrite <- deMorgan_exp.
  rewrite andp_comm.
  rewrite imp_andp_adjoint.
  eapply derives_trans. 2: apply notnot2.
  apply box_exp1. trivial.
Qed.

Lemma diamond_allp {CND : ClassicNatDed A} {B}: inhabited B -> forall (P : B -> A),
  diamond R (ALL b : B, P b) = ALL b : B, diamond R (P b).
Proof. intros. apply pred_ext. apply diamond_allp1. apply diamond_allp2. trivial. Qed.

End ModalLogic_CD.

(* total function *)
Section ModalLogic_D_CD.

Context {R : RT}.
Context {MLD : Modal_D R}.
Context {MLCD : Modal_CD R}.

Lemma box_notp {CND: @ClassicNatDed A ND}: forall (P : A),
  [R] (! P) = ! ([R] P).
Proof. intros. apply pred_ext. apply box_notp1. apply box_notp2. Qed.

Lemma diamond_not: forall P Q : A,
  diamond R (! P) = !(diamond R P).
Proof. intros. apply pred_ext. apply diamond_notp1. apply diamond_notp2. Qed.

Lemma diamond_K_eq {CND: @ClassicNatDed A ND}: forall P Q : A,
  diamond R (P --> Q) = diamond R P --> diamond R Q.
Proof. intros. apply pred_ext. apply diamond_K. apply diamond_antiK. Qed.

End ModalLogic_D_CD.

(* reflexive and functional, i.e. the identity relation *)
Section ModalLogic_T_CD.

Context {R : RT}.
Context {MLT : Modal_T R}.
Context {MLCD : Modal_CD R}.

Lemma diamond_T: forall P : A,
  diamond R P |-- P.
Proof.
  intro.
  eapply derives_trans.
  apply modal_CD.
  apply modal_T.
Qed.

Lemma diamond_T_eq: forall P : A,
  diamond R P = P.
Proof. intro. apply pred_ext. apply diamond_T. apply diamond_CT. Qed.

End ModalLogic_T_CD.

Section ModalLogic_seq.

Context {MLS: ModLogSeq ML}.

Lemma seqR_diamond1 {CND: @ClassicNatDed A ND}: forall R1 R2 (P : A),
    diamond (seqR R1 R2) P |-- diamond R1 (diamond R2 P).
Proof.
  intros. unfold diamond.
  apply notp_derives.
  rewrite seqR_box.
  apply box_positive.
  apply notnot1.
Qed.

Lemma seqR_diamond2 : forall R1 R2 (P : A),
    diamond R1 (diamond R2 P) |-- diamond (seqR R1 R2) P.
Proof.
  intros. unfold diamond.
  apply notp_derives.
  rewrite seqR_box.
  apply box_positive.
  apply notnot2.
Qed.

Lemma seqR_diamond {CND: @ClassicNatDed A ND}: forall R1 R2 (P : A),
    diamond (seqR R1 R2) P = diamond R1 (diamond R2 P).
Proof. intros. apply pred_ext. apply seqR_diamond1. apply seqR_diamond2. Qed.

End ModalLogic_seq.

(* dual *)
Section ModalLogic_dual.

Context {MLD: ModLogDual ML}.

Lemma diamond_antibox_adjoint: forall R (P Q : A),
  diamond R P |-- Q  <->
  P |-- [antiR R] Q.
Proof.
  split; intro.
  rewrite <- antidiamond_box_adjoint.
  rewrite antiR_involution. trivial.
  rewrite <- antidiamond_box_adjoint in H.
  rewrite antiR_involution in H. trivial.
Qed.

Lemma diamond_antibox_left: forall R P,
  diamond R ([antiR R] P) |-- P.
Proof.
  intros.
  rewrite diamond_antibox_adjoint.
  trivial.
Qed.

Lemma antibox_diamond2: forall R P,
  P |-- [antiR R] (diamond R P).
Proof.
  intros.
  apply diamond_antibox_adjoint.
  trivial.
Qed.

Section ModalLogic_CD_dualD.

Context {R : RT}.
Context {MLCD : Modal_CD R}.
Context {MLDD : Modal_D (antiR R)}.

Lemma antibox_diamond_adjoint: forall P Q : A,
  P |-- diamond R Q ->
  [antiR R] P |-- Q.
Proof.
  intros.
  eapply derives_trans.
  apply modal_D.
  rewrite diamond_antibox_adjoint.
  rewrite antiR_involution.
  eapply derives_trans.
  apply H.
  apply modal_CD.
Qed.

Lemma antibox_diamond1: forall P,
  [antiR R] (diamond R P) |-- P.
Proof.
  intros.
  apply antibox_diamond_adjoint.
  trivial.
Qed.

Lemma antibox_diamond_eq: forall P,
  [antiR R] (diamond R P) = P.
Proof. intro. apply pred_ext. apply antibox_diamond1. apply antibox_diamond2. Qed.

Section ModalLogic_CD_dualD_dualCD.

Context {MLDCD : Modal_CD (antiR R)}.

Lemma diamond_antibox_right {CND: @ClassicNatDed A ND}: forall P,
  NTD R && P |-- diamond R ([antiR R] P).
Proof.
  intro. unfold NTD.
  rewrite imp_andp_adjoint.
  rewrite diamond_antibox_adjoint.
  rewrite box_K_eq.
  rewrite antibox_diamond_eq.
  rewrite <-imp_andp_adjoint.
  rewrite TT_andp. trivial.
Qed.

Lemma diamond_MN {CND: @ClassicNatDed A ND}: forall P Q : A,
  [antiR R] P |-- Q ->
  NTD R && P |-- diamond R Q.
Proof.
  intros.
  eapply derives_trans.
  apply diamond_antibox_right.
  apply diamond_positive.
  trivial.
Qed.

Lemma dot_WCK {CND: @ClassicNatDed A ND}: forall P Q,
  NTD R && ((diamond R P) --> (diamond R Q)) |-- diamond R (P --> Q).
Proof.
  intros. apply diamond_MN.
  eapply derives_trans.
  apply modal_K.
  do 2 rewrite antibox_diamond_eq.
  trivial.
Qed.

End ModalLogic_CD_dualD_dualCD.

End ModalLogic_CD_dualD.

End ModalLogic_dual.

(* symmetric *)
Section ModalLogic_B.

End ModalLogic_B.

(* finite chains *)
Section ModalLogic_W.

End ModalLogic_W.

End ModalLogic.


From Tealeaves Require Export
     Classes.DecoratedModule
     Classes.SetlikeMonad
     Classes.RightModule.

Import Monoid.Notations.
Import Sets.Notations.
Import SetlikeFunctor.Notations.
#[local] Open Scope tealeaves_scope.

(** * Set-like right modules *)
(******************************************************************************)
Section setlike_module_class.

  Context
    (F T : Type -> Type)
    `{SetlikeFunctor F}
    `{SetlikeMonad T}
    `{RightAction F T}.

  Class SetlikeModule : Prop :=
    { xrmod_rmod :> RightModule F T;
      xrmod_monad :> SetlikeMonad T;
      xrmod_functor :> SetlikeFunctor F;
      xrmod_action :
        `(toset (A:=A) F ∘ right_action F =
          join set ∘ toset F ∘ fmap F (toset T));
    }.

End setlike_module_class.

(** ** Set-like monads are setlike modules *)
(******************************************************************************)
Section setlike_module_of_monad.

  Existing Instance RightAction_Join.
  Existing Instance RightModule_Monad.

  Instance SetlikeModule_Monad `{SetlikeMonad T} :
    SetlikeModule T T :=
    {| xrmod_action := xmon_join T;
       xrmod_functor := xmon_functor T;
    |}.

End setlike_module_of_monad.

(** ** Basic properties of set-like modules *)
(******************************************************************************)
Section setlike_module_theory.

  Context
    (F T : Type -> Type)
    `{SetlikeModule F T}.

  (** [right_action] acts like a (unary) union operation. *)
  Theorem in_action_iff {A} : forall (t : F (T A)) a,
      a ∈ right_action F t <-> exists t', t' ∈ t /\ a ∈ t'.
  Proof.
    introv. compose near t on left.
    rewrite (xrmod_action F T).
    reassociate -> on left.
    rewrite <- (natural (B:=set A) (G:=(->Prop))).
    unfold transparent tcs; unfold compose.
    intuition (preprocess; eauto).
  Qed.

  Corollary in_sub_iff {A B} : forall t b (f : A -> T B),
      b ∈ sub F f t <->
      exists (a : A), a ∈ t /\ b ∈ f a.
  Proof.
    introv. unfold transparent tcs. unfold compose.
    rewrite (in_action_iff (fmap F f t)).
    setoid_rewrite (in_fmap_iff F).
    intuition (preprocess; eauto).
  Qed.

  Corollary sub_respectful : forall A B (t : F A) (f g : A -> T B),
      (forall a, a ∈ t -> f a = g a) -> sub F f t = sub F g t.
  Proof.
    introv hyp. unfold_ops @Sub_RightAction.
    unfold compose. fequal. now apply (fmap_respectful F).
  Qed.

  Corollary sub_respectful_id : forall A (t : F A) (f : A -> T A),
      (forall a, a ∈ t -> f a = ret T a) -> sub F f t = t.
  Proof.
    introv hyp. replace t with (sub F (ret T) t) at 2
      by now rewrite (RightModule.sub_id F T).
    now apply sub_respectful.
  Qed.

  Corollary sub_respectful_fmap {A} :
    forall (t : F A) (f : A -> T A) (g : A -> A),
      (forall a, a ∈ t -> f a = ret T (g a)) -> sub F f t = fmap F g t.
  Proof.
    intros. rewrite (RightModule.fmap_to_sub F T).
    now apply sub_respectful.
  Qed.

End setlike_module_theory.

(*
(** ** Respectfulness for <<fmap>> and <<sub>> are equivalent. *)
(******************************************************************************)
Section toset_resp_sub_equiv_fmap.

  Context
    F `{RightModule F T} `{Toset F}.

  #[export] Instance toset_sub_resp_of_fmap :
      (forall A B (t : F A), Proper (ext_rel t ++> eq_at t t) (fmap F (B:=B))) ->
      (forall A B (t : F A), Proper (ext_rel t ++> eq_at t t) (sub F (B:=B))).
  Proof.
    intros Hproper. unfold Proper, respectful, ext_rel, eq_at in *.
    intros A B t f g Heq. unfold transparent tcs. unfold compose.
    specialize (Hproper _ _ t f g). rewrite Hproper; auto.
  Qed.

  #[export] Instance toset_fmap_resp_of_sub :
    (forall A B (t : F A), Proper (ext_rel t ++> eq_at t t) (sub F (B:=B))) ->
    (forall A B (t : F A), Proper (ext_rel t ++> eq_at t t) (fmap F (B:=B))).
  Proof.
    unfold transparent tcs. intros Hproper.
    unfold Proper, respectful, ext_rel, eq_at, compose in *.
    intros A B t f g Heq. rewrite 2(fmap_to_sub F T). unfold compose.
    apply Hproper. intros; fequal; auto.
  Qed.

End toset_resp_sub_equiv_fmap.

(** ** Injective <<sub>> implies <<fmap>> if <<ret>> is injective. *)
(** We show elsewhere that <<set>> does not satisfy the converse of
    this statement. *)
(******************************************************************************)
Section toset_fmap_injective_of_sub.

  Context
    F `{RightModule F T} `{Toset F}.

  Hypothesis
    (ret_inj : forall A (x y : A),
        ret T x = ret T y -> x = y).

  Theorem toset_fmap_injective_of_sub :
    (forall A B (t : F A), Proper (ext_rel t <++ eq_at t t) (sub F (B:=B))) ->
    (forall A B (t : F A), Proper (ext_rel t <++ eq_at t t) (fmap F (B:=B))).
  Proof.
    intros hyp A B t f g heq. specialize (hyp A B t (ret T ∘ f) (ret T ∘ g)).
    rewrite <- 2(fmap_to_sub F T) in hyp; unfold compose in hyp.
    unfold Proper, respectful, ext_rel, eq_at in *.
    auto using ret_inj.
  Qed.

End toset_fmap_injective_of_sub.
*)

(** * Decorated set-like right modules *)
(******************************************************************************)

(** ** Basic properties *)
(******************************************************************************)
Section decorated_setlike_properties.

  Context
    (F : Type -> Type)
    `{Monoid W}
    `{Fmap F}  `{RightAction F T} `{Decorate W F} `{Toset F}
    `{Fmap T} `{Return T} `{Join T} `{Decorate W T} `{Toset T}
    `{! DecoratedModule W F T}
    `{! SetlikeModule F T}.

  Theorem ind_subd_iff {A B} : forall t w b (f : W * A -> T B),
      (w, b) ∈d subd F f t <->
      exists (a : A) (w1 w2 : W),
        (w1, a) ∈d t /\ (w2, b) ∈d f (w1, a) /\ w = w1 ● w2.
  Proof.
    introv. unfold tosetd.
    compose near t on left.
    reassociate -> on left.
    rewrite  (dec_subd F).
    unfold subd. unfold compose.
    rewrite (in_sub_iff F T). split; intro hyp.
    - destruct hyp as [[w' a] [hyp1 hyp2]].
      cbn in hyp2; unfold id in hyp2.
      rewrite (in_shift_iff T) in hyp2.
      destruct hyp2 as [w2 [? ?]].
      exists a. exists w'. exists w2. split; auto.
    - destruct hyp as [a [w1 [w2 [? ?]]]].
      exists (w1, a). split; auto. cbn.
      rewrite (in_shift_iff T). exists w2. auto.
  Qed.

  (** *** Corollaries: [tosetd] and [sub] *)
  (******************************************************************************)
  Theorem ind_sub_iff {A B} : forall t w b (f : A -> T B),
      (w, b) ∈d sub F f t <->
      exists (a : A) (w1 w2 : W),
        (w1, a) ∈d t /\ (w2, b) ∈d f a /\ w = w1 ● w2.
  Proof.
    introv. rewrite (DecoratedModule.sub_to_subd F T).
    now rewrite ind_subd_iff.
  Qed.

  (** *** Corollaries: [toset] and [subd] *)
  (******************************************************************************)
  Theorem in_subd_iff {A B} : forall t b (f : W * A -> T B),
      b ∈ subd F f t <->
      exists (a : A) (w1 : W),
        (w1, a) ∈d t /\ b ∈ f (w1, a).
  Proof.
    introv. rewrite (ind_of_in F).
    setoid_rewrite ind_subd_iff. split.
    - intros. preprocess. do 2 eexists.
      split; eauto. eapply (in_of_ind T); eauto.
    - intros [a [w [in1 in2]]]. rewrite (ind_of_in T) in in2.
      destruct in2 as [w2 ?]. exists (w ● w2) a w w2.
      auto.
  Qed.

End decorated_setlike_properties.

(** ** Respectfulness properties *)
(******************************************************************************)
Section decorated_setlike_respectfulness.

  Context
    (F : Type -> Type)
    `{Monoid W}
    `{Fmap F}  `{RightAction F T} `{Decorate W F} `{Toset F}
    `{Fmap T} `{Return T} `{Join T} `{Decorate W T} `{Toset T}
    `{! DecoratedModule W F T}
    `{! SetlikeModule F T}.

    Theorem subd_respectful {A B} : forall (t : F A) (f g : W * A -> T B),
        (forall w a, (w, a) ∈d t -> f (w, a) = g (w, a)) ->
        subd F f t = subd F g t.
    Proof.
      intros. unfold subd, compose.
      eapply (SetlikeModule.sub_respectful F T); auto.
      intros [? ?]; eauto.
    Qed.

    Corollary subd_respectful_id {A} : forall (t : F A) (f : W * A -> T A),
        (forall w a, (w, a) ∈d t -> f (w, a) = ret T a) ->
        subd F f t = t.
    Proof.
      intros. replace t with (subd F (ret T ∘ extract (prod W)) t) at 2
        by (now rewrite (DecoratedModule.subd_id F T)).
      now apply subd_respectful.
    Qed.

    Corollary subd_respectful_fmapd {A B} : forall (t : F A) (f : W * A -> T B) (g : W * A -> B),
        (forall w a, (w, a) ∈d t -> f (w, a) = ret T (g (w, a))) ->
        subd F f t = fmapd F g t.
    Proof.
      introv. rewrite (DecoratedModule.fmapd_to_subd F T).
      intros ?. now apply subd_respectful.
    Qed.

    Corollary subd_respectful_sub {A B} : forall (t : F A) (f : W * A -> T B) (g : A -> T B),
        (forall w a, (w, a) ∈d t -> f (w, a) = g a) ->
        subd F f t = sub F g t.
    Proof.
      introv. rewrite (DecoratedModule.sub_to_subd F T).
      intros ?. now apply subd_respectful.
    Qed.

    Corollary subd_respectful_fmap {A B} : forall (t : F A) (f : W * A -> T B) (g : A -> B),
        (forall w a, (w, a) ∈d t -> f (w, a) = ret T (g a)) ->
        subd F f t = fmap F g t.
    Proof.
      introv. rewrite (DecoratedModule.fmap_to_subd F T).
      intros; now apply subd_respectful.
    Qed.

End decorated_setlike_respectfulness.


Set Implicit Arguments.

(** some default polymorphic functions *)

Section FUNCTIONS.
  Variables A B C : Type.

  Definition id (x : A) := x.

  Definition const (x : A)(y : B) := x.

  Definition uncurry (f : A -> B -> C)(p : A * B) :=
    match p with
    | (x,y) => f x y
    end.

  Definition curry (f : (A * B) -> C)(x : A)(y : B) : C :=
    f (x , y).

  Definition compose (f : B -> C)(g : A -> B)(x : A) : C :=
    f (g x).

  Definition flip (f : B -> A -> C)(x : A)(y : B) := f y x.
End FUNCTIONS.

Notation "f ':@:' g" := (compose f g)(at level 40, left associativity).

(* useful function on sumbool *)

Definition sumbool_to_bool {A B : Prop} (p : {A} + {B}) :=
  if p then true else false.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Fixpoint revflat (revflat_arg0 : tree) : lst
           := match revflat_arg0 with
              | Leaf => Nil
              | Node d l r => append (revflat l) (Cons d (revflat r))
              end.

Fixpoint qrevaflat (qrevaflat_arg0 : tree) (qrevaflat_arg1 : lst) : lst
           := match qrevaflat_arg0, qrevaflat_arg1 with
              | Leaf, x => x
              | Node d l r, x => qrevaflat l (Cons d (qrevaflat r x))
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. lfind. Admitted.


(***************************************************************************
* STLC in locally nameless style, based on formalization in the            *
* library _locally nameless_ *                                             *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Definitions *)

(* ********************************************************************** *)
(** ** Grammars *)

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ.

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_cap  : trm -> trm            (* capsule lambda - closed *)
  | trm_app  : trm -> trm -> trm.

Coercion trm_bvar : nat >-> trm.
Coercion trm_fvar : var >-> trm.

(* ********************************************************************** *)
(** ** Opening *)

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

Definition open t u := open_rec 0 u t.

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

(* ********************************************************************** *)
(** ** Local closure *)

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

(* ********************************************************************** *)
(** ** Semantics *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1)
  | value_cap: forall t1,
      term (trm_cap t1) -> value (trm_cap t1).

Reserved Notation "t --> t'" (at level 68).

Inductive red : trm -> trm -> Prop :=
  | red_beta_abs : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      (trm_app (trm_abs t1) t2) --> (t1 ^^ t2)
  | red_beta_cap : forall t1 t2,
      term (trm_cap t1) ->
      value t2 ->
      (trm_app (trm_cap t1) t2) --> (t1 ^^ t2)
  | red_app_1 : forall t1 t1' t2,
      term t2 ->
      t1 --> t1' ->
      (trm_app t1 t2) --> (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      t2 --> t2' ->
      (trm_app t1 t2) --> (trm_app t1 t2')

where "t --> t'" := (red t t').

(* ********************************************************************** *)
(** ** Environments *)

Definition ctx := env typ.

(* ********************************************************************** *)
(** ** Typing *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : ctx -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
      (forall x, x \notin L ->
        (E & x ~ U) |= t1 ^ x ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_cap: forall L E U T t1,
      ok E ->
      (forall x, x \notin L ->
        (x ~ U) |= t1 ^ x ~: T) ->
      E |= (trm_cap t1) ~: (typ_arrow U T)
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(* ********************************************************************** *)
(** ** Statement of theorems *)

Definition preservation_statement := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress_statement := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Infrastructure *)

(** ** Free variables *)

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

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

Reserved Notation "[ z ~> u ] t" (at level 69).

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs t1    => trm_abs ([ z ~> u ] t1)
  | trm_cap t1    => trm_cap ([ z ~> u ] t1)
  | trm_app t1 t2 => trm_app ([ z ~> u ] t1) ([ z ~> u ] t2)
  end

where "[ z ~> u ] t" := (subst z u t).

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

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

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

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

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

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

Hint Constructors term value red.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Safty *)

(* ********************************************************************** *)
(** ** lemmas *)

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

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

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

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

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

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

(* ********************************************************************** *)
(** ** Preservation of local closure *)

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

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

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

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

Hint Resolve term_abs_to_body term_cap_to_body body_to_term_abs.

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

Hint Resolve subst_term.

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

Hint Resolve open_term.

(* ********************************************************************** *)
(** ** Regularity of relations *)

Lemma typing_regular : forall E e T,
  typing E e T -> ok E /\ term e.
Proof.
  split. induction* H.
  pick_fresh y. forwards~ : (H0 y).

  induction H; autos*.
Qed.

Lemma open_fv_subset: forall e x k,
  fv e \c fv ({k ~> x}e).
Proof. intros. gen k. induction e; intros; simpl.
  apply subset_empty_l.
  apply subset_refl.
  autos.
  autos.
  apply* subset_union_2.
Qed.

Lemma subset_trans: forall (T: Type) (a b c: fset T),
  a \c b -> b \c c -> a \c c.
Proof. unfolds subset. autos. Qed.

Lemma subset_strengthen: forall (T: Type) (a b: fset T) (x: T),
  a \c (b \u \{x}) -> x \notin a -> a \c b.
Proof. unfolds subset. intros. forwards K: (H x0 H1).
  rewrite in_union in K. destruct* K.
  rewrite in_singleton in H2. subst.
  tryfalse.
Qed.

Lemma typing_env_fv : forall E e T,
  typing E e T -> fv e \c dom E.
Proof. intros. induction* H; subst.
  (* var *)
  simpl. forwards~ K:  get_some_inv (binds_get H0).
  unfolds. intros. rewrite in_singleton in H1. subst*.
  (* abs *)
  simpl. pick_fresh x. forwards~ K: (H0 x).
  rewrite dom_concat in K. rewrite dom_single in K.
  assert (HI: fv t1 \c dom E \u \{x}).
    eapply subset_trans with (fv (t1 ^ x)).
    autos* open_fv_subset. autos.
  apply subset_strengthen with x; autos.
  (* cap *)
  simpl. pick_fresh x. forwards~ K: (H1 x).
  rewrite dom_single in K.
  assert (HI: fv t1 \c \{}).
    apply subset_strengthen with x; autos.
    rewrite union_empty_l.
    eapply subset_trans with (fv (t1 ^ x)).
    autos* open_fv_subset. autos.
  apply subset_trans with \{}; autos. apply subset_empty_l.
  (* app *)
  simpl. replace (dom E) with (dom E \u dom E) by (autos* union_same).
  apply subset_union_2; autos.
Qed.

Lemma typing_term_closed : forall e T,
  typing empty e T -> fv e = \{}.
Proof using.
  intros. apply typing_env_fv in H.
  rewrite dom_empty in H.
  apply* fset_extens. apply subset_empty_l.
Qed.

Lemma typing_cap_closed : forall E e T,
  typing E (trm_cap e) T -> fv e = \{}.
Proof.
  intros. inversions H.
  assert (HI: empty |= trm_cap e ~: typ_arrow U T0).
    apply typing_cap with L; autos.
  replace (fv e) with (fv (trm_cap e)) by autos.
  eapply typing_term_closed. exact HI.
Qed.

Lemma value_regular : forall e,
  value e -> term e.
Proof. induction 1; autos*. Qed.

Lemma red_regular : forall e e',
  red e e' -> term e /\ term e'.
Proof. induction 1; autos* value_regular. Qed.

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: typing E _ _ |- _ => apply (proj1 (typing_regular H))
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ t _ |- _ => apply (proj2 (typing_regular H))
  | H: red t _ |- _ => apply (proj1 (red_regular H))
  | H: red _ t |- _ => apply (proj2 (red_regular H))
  | H: value t |- _ => apply (value_regular H)
  end.

(* ********************************************************************** *)
(** ** Checking that the main proofs still type-check *)

Lemma typing_weaken : forall G E F t T,
   (E & G) |= t ~: T ->
   ok (E & F & G) ->
   (E & F & G) |= t ~: T.
Proof.
  introv Typ. gen_eq H: (E & G). gen G.
  induction Typ; intros G EQ Ok; subst.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as y. apply_ih_bind* H0.
  apply* typing_cap.
  apply* typing_app.
Qed.

Lemma typing_subst : forall F E t T z u U,
  (E & z ~ U & F) |= t ~: T ->
  E |= u ~: U ->
  (E & F) |= [z ~> u]t ~: T.
Proof.
  introv Typt Typu. gen_eq G: (E & z ~ U & F). gen F.
  induction Typt; intros G Equ; subst; simpl subst.
  case_var.
    binds_get H0. apply_empty* typing_weaken.
    binds_cases H0; apply* typing_var.
  apply_fresh typing_abs as y.
    rewrite* subst_open_var. apply_ih_bind* H0.
  assert (Hyp: E & G |= (trm_cap t1) ~: typ_arrow U0 T)
      by autos* typing_cap.
  forwards~ K : typing_cap_closed Hyp.
  rewrite* subst_fresh. rewrite* K.
  apply* typing_app.
Qed.

Lemma preservation_result : preservation_statement.
Proof.
  introv Typ. gen t'.
  induction Typ; intros t' Red; inversions Red.
  inversions Typ1. pick_fresh x. rewrite* (@subst_intro x).
   apply_empty* typing_subst.
  inversions Typ1. pick_fresh x. rewrite* (@subst_intro x).
   apply_empty* typing_subst.
   replace E with (empty & E) by (apply* concat_empty_l).
   apply* typing_weaken. rewrite* concat_empty_l.
   rewrite* concat_empty_l.
  apply* typing_app.
  apply* typing_app.
Qed.

Lemma progress_result : progress_statement.
Proof.
  introv Typ. gen_eq E: (empty:ctx). lets Typ': Typ.
  induction Typ; intros; subst.
  false* binds_empty_inv.
  left*. left*.
  right.
    destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
      inversions Typ1; inversions Val1. exists* (t0 ^^ t2).
      exists* (t0 ^^ t2).
      exists* (trm_app t1 t2').
    exists* (trm_app t1' t2).
Qed.


Require Import Setoid Morphisms Term.

Inductive reduction : term -> term -> Prop :=
| reduction_β : forall t u, reduction (app (lam t) u) (subs_term (CONS u ESID) t)
| reduction_η : forall t, reduction (lam (app (lift_term (ELSHFT ELID) t) (var 0))) t
| reduction_ι_l : forall t u1 u2, reduction (cse (lft t) u1 u2) (subs_term (CONS t ESID) u1)
| reduction_ι_r : forall t u1 u2, reduction (cse (rgt t) u1 u2) (subs_term (CONS t ESID) u2)
| reduction_lam : forall t r, reduction t r -> reduction (lam t) (lam r)
| reduction_app_l : forall t u r, reduction t r -> reduction (app t u) (app r u)
| reduction_app_r : forall t u r, reduction u r -> reduction (app t u) (app t r)
| reduction_lft : forall t r, reduction t r -> reduction (lft t) (lft r)
| reduction_rgt : forall t r, reduction t r -> reduction (rgt t) (rgt r)
| reduction_cse_e : forall t u1 u2 r, reduction t r -> reduction (cse t u1 u2) (cse r u1 u2)
| reduction_cse_l : forall t u1 u2 r, reduction u1 r -> reduction (cse t u1 u2) (cse t r u2)
| reduction_cse_r : forall t u1 u2 r, reduction u2 r -> reduction (cse t u1 u2) (cse t u1 r)
.

Inductive convertible : term -> term -> Prop :=
| convertible_refl : forall t, convertible t t
| convertible_sym : forall t u, convertible t u -> convertible u t
| convertible_trans : forall t u r, convertible t u -> convertible u r -> convertible t r
| convertible_step : forall t u, reduction t u -> convertible t u.

Instance Equivalence_convertible : RelationClasses.Equivalence convertible.
Proof.
split.
+ intro; apply convertible_refl.
+ intros x y; apply convertible_sym.
+ intros x y z; apply convertible_trans.
Qed.

Definition convertible_β t u := convertible_step _ _ (reduction_β t u).
Definition convertible_η t := convertible_step _ _ (reduction_η t).

Lemma convertible_app_l : forall t u r,
  convertible t r -> convertible (app t u) (app r u).
Proof.
induction 1.
+ reflexivity.
+ symmetry; assumption.
+ transitivity (app u0 u); assumption.
+ apply convertible_step, reduction_app_l; assumption.
Qed.

Lemma convertible_app_r : forall t u r,
  convertible u r -> convertible (app t u) (app t r).
Proof.
induction 1.
+ reflexivity.
+ symmetry; assumption.
+ transitivity (app t u); assumption.
+ apply convertible_step, reduction_app_r; assumption.
Qed.

Lemma convertible_lam : forall t r,
  convertible t r -> convertible (lam t) (lam r).
Proof.
induction 1.
+ reflexivity.
+ symmetry; assumption.
+ transitivity (lam u); assumption.
+ apply convertible_step, reduction_lam; assumption.
Qed.

Instance Proper_convertible_app : Proper (convertible ==> convertible ==> convertible) app.
Proof.
intros t1 t2 Ht u1 u2 Hu.
transitivity (app t1 u2).
+ apply convertible_app_r; assumption.
+ apply convertible_app_l; assumption.
Qed.

Instance Proper_convertible_lam : Proper (convertible ==> convertible) lam.
Proof.
intros t1 t2 Ht.
apply convertible_lam; assumption.
Qed.

Lemma convertible_lft : forall t r,
  convertible t r -> convertible (lft t) (lft r).
Proof.
induction 1.
+ reflexivity.
+ symmetry; assumption.
+ transitivity (lft u); assumption.
+ apply convertible_step, reduction_lft; assumption.
Qed.

Lemma convertible_rgt : forall t r,
  convertible t r -> convertible (rgt t) (rgt r).
Proof.
induction 1.
+ reflexivity.
+ symmetry; assumption.
+ transitivity (rgt u); assumption.
+ apply convertible_step, reduction_rgt; assumption.
Qed.

Lemma convertible_cse_e : forall t u1 u2 r,
  convertible t r -> convertible (cse t u1 u2) (cse r u1 u2).
Proof.
induction 1.
+ reflexivity.
+ symmetry; assumption.
+ transitivity (cse u u1 u2); assumption.
+ apply convertible_step, reduction_cse_e; assumption.
Qed.

Lemma convertible_cse_l : forall t u1 u2 r,
  convertible u1 r -> convertible (cse t u1 u2) (cse t r u2).
Proof.
induction 1.
+ reflexivity.
+ symmetry; assumption.
+ transitivity (cse t u u2); assumption.
+ apply convertible_step, reduction_cse_l; assumption.
Qed.

Lemma convertible_cse_r : forall t u1 u2 r,
  convertible u2 r -> convertible (cse t u1 u2) (cse t u1 r).
Proof.
induction 1.
+ reflexivity.
+ symmetry; assumption.
+ transitivity (cse t u1 u); assumption.
+ apply convertible_step, reduction_cse_r; assumption.
Qed.

Lemma convertible_cse : forall t u1 u2 r r1 r2,
  convertible t r ->
  convertible u1 r1 ->
  convertible u2 r2 ->
  convertible (cse t u1 u2) (cse r r1 r2).
Proof.
intros t u1 u2 r r1 r2 H H1 H2.
etransitivity; [apply convertible_cse_e; eassumption|].
etransitivity; [apply convertible_cse_l; eassumption|].
etransitivity; [apply convertible_cse_r; eassumption|].
reflexivity.
Qed.

Lemma subs_term_CONS_LFT_n : forall t u e n,
subs_term (LIFTn n (CONS (lift_term e u) ESID)) (lift_term (ELLFTn n (ELLFT e)) t) =
lift_term (ELLFTn n e) (subs_term (LIFTn n (CONS u ESID)) t).
Proof.
induction t; intros u e m; cbn.
+ revert n u e; induction m as [|m]; intros n u e; cbn.
  - rewrite !expand_term_CONS; destruct n as [|n]; reflexivity.
  - rewrite !expand_term_LIFT; destruct n as [|n]; [reflexivity|].
    rewrite IHm, <- !lift_term_compose; f_equal; cbn; f_equal.
    rewrite lift_compose_ELID_r; reflexivity.
+ f_equal; intuition.
+ f_equal; apply (IHt _ _ (S m)).
+ f_equal; intuition.
+ f_equal; intuition.
+ f_equal; intuition.
  - apply (IHt2 _ _ (S m)).
  - apply (IHt3 _ _ (S m)).
Qed.

Lemma subs_term_LFT_CONS : forall t u e,
  subs_term (CONS (lift_term e u) ESID) (lift_term (ELLFT e) t) =
  lift_term e (subs_term (CONS u ESID) t).
Proof.
induction t; intros u e; cbn.
- rewrite !expand_term_CONS; destruct n as [|n]; reflexivity.
- f_equal; intuition.
- f_equal.
  apply subs_term_CONS_LFT_n with (n := 1).
- f_equal; intuition.
- f_equal; intuition.
- f_equal; intuition; apply subs_term_CONS_LFT_n with (n := 1).
Qed.

Lemma reduction_lift : forall t r e,
  reduction t r -> reduction (lift_term e t) (lift_term e r).
Proof.
intros t r e Hr; revert e; induction Hr; intros e; cbn in *.
+ evar (r : term); match goal with [ |- reduction _ ?t ] => replace t with r; [refine (reduction_β _ _)|] end;
  unfold r; clear r.
  apply subs_term_LFT_CONS.
+ rewrite <- lift_term_compose; cbn.
  rewrite lift_compose_ELID_r.
  replace (lift_term (ELSHFT e) t) with (lift_term (ELSHFT ELID) (lift_term e t)).
  - apply reduction_η.
  - rewrite <- lift_term_compose; reflexivity.
+ evar (r : term); match goal with [ |- reduction _ ?t ] => replace t with r; [refine (reduction_ι_l _ _ _)|] end;
  unfold r; clear r.
  apply subs_term_LFT_CONS.
+ evar (r : term); match goal with [ |- reduction _ ?t ] => replace t with r; [refine (reduction_ι_r _ _ _)|] end;
  unfold r; clear r.
  apply subs_term_LFT_CONS.
+ apply reduction_lam; intuition.
+ apply reduction_app_l; intuition.
+ apply reduction_app_r; intuition.
+ apply reduction_lft; intuition.
+ apply reduction_rgt; intuition.
+ apply reduction_cse_e; intuition.
+ apply reduction_cse_l; intuition.
+ apply reduction_cse_r; intuition.
Qed.

Lemma convertible_lift : forall t r e,
  convertible t r -> convertible (lift_term e t) (lift_term e r).
Proof.
induction 1.
+ reflexivity.
+ symmetry; assumption.
+ etransitivity; eassumption.
+ apply convertible_step, reduction_lift; assumption.
Qed.