(** THIS FILE CONTAINS: *)
(** the definition of semantic types *)
(** the semantic typing rules *)
(** the separation logic for the language *)

From pv Require Import proofmode.

(* Exceptions are natural numbers *)
Definition TEx (t : tag) (v : val) : sepProp := Ex n, @[ v = VNat n ].

Definition ty := val -> sepProp.

Definition TMoved : ty := fun v => EMP.
Definition TUnit : ty := fun v => @[ v = VUnit ].
Definition TNat : ty := fun v => Ex n, @[ v = VNat n ].
Definition TBool : ty := fun v => Ex b, @[ v = VBool b ].

Definition TRef (A : ty) : ty := fun v =>
  Ex l w, @[ v = VRef l ] ** l ~> w ** A w.

Definition TProd (A1 A2 : ty) : ty := fun v =>
  Ex w1 w2, @[ v = VPair w1 w2 ] ** A1 w1 ** A2 w2.
Definition TSum (A1 A2 : ty) : ty := fun v =>
  Ex w, (@[ v = VInjL w ] ** A1 w) \// (@[ v = VInjR w] ** A2 w).

(* RECALL: (abs1 A) expands to (fun v => A v ** TRUE) *)
(* Similarily (abs2 A) expands to (fun t v => A t v ** TRUE) *)
Definition TFun (A1 A2 : ty) : ty := fun v =>
  @[ forall w, A1 w |~ wp (EApp (EVal v) (EVal w)) (abs1 A2) (abs2 TEx) ].
Definition TFunOnce (A1 A2 : ty) : ty := fun v =>
  All w, A1 w -** wp (EApp (EVal v) (EVal w)) (abs1 A2) (abs2 TEx).

Notation ty_ctx := (list (string * ty)).

Definition ctx_dom : ty_ctx -> list string := map fst.

Fixpoint ctx_typed (Gamma : ty_ctx) (vs : stringmap val) : sepProp :=
  match Gamma with
  | [] => EMP
  | (x, A) :: Gamma =>
      (Ex v, @[ StringMap.lookup vs x = Some v ] ** A v) **
      ctx_typed Gamma vs
  end.

Fixpoint subst_map (vs : stringmap val) (e : expr) : expr :=
  match e with
  | EVal _ => e
  | EVar x =>
      match StringMap.lookup vs x with
      | Some v => EVal v
      | None => e
      end
  | ELam x e => ELam x (subst_map (StringMap.delete x vs) e)
  | ERec f x e =>
      ERec f x (subst_map (StringMap.delete x (StringMap.delete f vs)) e)
  | EApp e1 e2 => EApp (subst_map vs e1) (subst_map vs e2)
  | EOp op e1 e2 => EOp op (subst_map vs e1) (subst_map vs e2)
  | EPair e1 e2 => EPair (subst_map vs e1) (subst_map vs e2)
  | EFst e => EFst (subst_map vs e)
  | ESnd e => ESnd (subst_map vs e)
  | EIf e1 e2 e3 => EIf (subst_map vs e1) (subst_map vs e2) (subst_map vs e3)
  | ESeq e1 e2 => ESeq (subst_map vs e1) (subst_map vs e2)
  | EAlloc e => EAlloc (subst_map vs e)
  | ELoad e => ELoad (subst_map vs e)
  | EStore e1 e2 => EStore (subst_map vs e1) (subst_map vs e2)
  | EFree e => EFree (subst_map vs e)
  | EThrow t e => EThrow t (subst_map vs e)
  | ECatch e1 t e2 => ECatch (subst_map vs e1) t (subst_map vs e2)
  end.

(* Recall: abs (A v) expands to (A v ** TRUE) *)
Definition val_typed (v : val) (A : ty) : Prop :=
  EMP |~ abs (A v).

Definition bin_op_typed (op : bin_op) (A1 A2 B : ty) : Prop :=
  forall v1 v2,
    A1 v1 ** A2 v2 |~ Ex v, @[ eval_bin_op op v1 v2 = Some v ] ** B v.

Definition typed (Gamma : ty_ctx) (e : expr) (A : ty) : Prop :=
  forall vs, ctx_typed Gamma vs |~ wp (subst_map vs e) (abs1 A) (abs2 TEx).

Definition copy (A : ty) : Prop :=
  forall v, A v |~ @[ EMP |~ A v ].

Definition ctx_copy Gamma :=
  forall vs, ctx_typed Gamma vs |~ @[ EMP |~ ctx_typed Gamma vs ].

Definition subty (A1 A2 : ty) : Prop :=
  forall v, A1 v |~ abs (A2 v).

Definition subctx (Gamma1 Gamma2 : ty_ctx) : Prop :=
  forall vs, ctx_typed Gamma1 vs |~ abs (ctx_typed Gamma2 vs).

(* ########################################################################## *)
(** * Helper lemmas and tactics *)
(* ########################################################################## *)

Lemma subst_map_empty e :
  subst_map StringMap.empty e = e.
Proof. induction e; simpl; by f_equal. Qed.

Lemma subst_map_insert x v vs e :
  subst_map (StringMap.insert x v vs) e
  = subst x v (subst_map (StringMap.delete x vs) e).
Proof.
  revert vs. induction e; intros vs; simpl; try (by f_equal).
  - (** Case var *)
    rewrite StringMap.lookup_delete, StringMap.lookup_insert.
    destruct (String.eq_dec _ _); simplify_eq.
    + by destruct (String.eq_dec _ _).
    + destruct (StringMap.lookup vs s) eqn:E; simpl; eauto.
      by destruct (String.eq_dec _ _).
  - (** Case lam *)
    destruct (String.eq_dec _ _); simplify_eq.
    + f_equal. f_equal. StringMap.map_solver.
    + f_equal. rewrite StringMap.delete_delete.
      destruct (String.eq_dec _ _); [done|].
      rewrite <-IHe. f_equal. StringMap.map_solver.
  - (** Case rec *)
    destruct (String.eq_dec _ _); simplify_eq.
    { do 2 f_equal. StringMap.map_solver. }
    destruct (String.eq_dec _ _); simplify_eq.
    { do 2 f_equal. StringMap.map_solver. }
    do 2 f_equal.
    do 2 rewrite StringMap.delete_insert, String.eq_dec_neq by congruence.
    rewrite IHe. do 2 f_equal. StringMap.map_solver.
Qed.

Lemma subst_map_singleton x v e :
  subst_map (StringMap.singleton x v) e = subst x v e.
Proof.
  rewrite <-StringMap.insert_empty, subst_map_insert.
  by rewrite StringMap.delete_empty, subst_map_empty.
Qed.

Lemma PlusOp_typed :
  bin_op_typed PlusOp TNat TNat TNat.
Proof.
  iIntros (v1 v2) "[[%n1 ->] [%n2 ->]]"; eauto.
Qed.

Lemma MinusOp_typed :
  bin_op_typed MinusOp TNat TNat TNat.
Proof.
  iIntros (v1 v2) "[[%n1 ->] [%n2 ->]]"; eauto.
Qed.

Lemma LeOp_typed :
  bin_op_typed LeOp TNat TNat TBool.
Proof.
  iIntros (v1 v2) "[[%n1 ->] [%n2 ->]]"; eauto.
Qed.

Lemma LtOp_typed :
  bin_op_typed LtOp TNat TNat TBool.
Proof.
  iIntros (v1 v2) "[[%n1 ->] [%n2 ->]]"; eauto.
Qed.

Lemma EqOp_Nat_typed :
  bin_op_typed EqOp TNat TNat TBool.
Proof.
  iIntros (v1 v2) "[[%n1 ->] [%n2 ->]]"; eauto.
Qed.

Lemma EqOp_Bool_typed :
  bin_op_typed EqOp TBool TBool TBool.
Proof.
  iIntros (v1 v2) "[[%b1 ->] [%b2 ->]]"; eauto.
Qed.

Lemma ctx_typed_app Gamma1 Gamma2 vs :
  ctx_typed (Gamma1 ++ Gamma2) vs |~
  ctx_typed Gamma1 vs ** ctx_typed Gamma2 vs.
Proof.
  iIntros "Hvs". iInduction Gamma1 as [| [x A] Gamma1] "IH"; simpl.
  { by iFrame. }
  iDestruct "Hvs" as "[$ vs]". by iApply "IH".
Qed.

Lemma ctx_typed_insert Gamma vs x v :
  ~In x (ctx_dom Gamma) ->
  ctx_typed Gamma vs |~ ctx_typed Gamma (StringMap.insert x v vs).
Proof.
  iIntros (Hx) "Hvs".
  iInduction Gamma as [|[y A] Gamma] "IH"; simpl in *; [done |].
  iDestruct "Hvs" as "[(%w & % & Hw) Hvs]". iSplitL "Hw".
  - iExists w. iFrame. iPureIntro.
    rewrite StringMap.lookup_insert.
    destruct (String.eq_dec _ _) as [-> | ?]; tauto.
  - iApply ("IH" with "[%] Hvs"). tauto.
Qed.

Lemma all_copy_ctx_copy Gamma :
  Forall (fun xA => copy (snd xA)) Gamma -> ctx_copy Gamma.
Proof.
  unfold ctx_copy; induction Gamma as [| [x A] Gamma]; simpl; intros HGamma.
  { iIntros (vs) "_ !% _ //". }
  iIntros (vs) "[(%v & % & Hv) Hvs]". inv HGamma.
  iDestruct (H2 with "Hv") as "Hv"; iDestruct "Hv" as %Hv.
  iDestruct (IHGamma with "Hvs") as "Hvs"; [done |].
  iDestruct "Hvs" as %Hvs. iIntros "!% _"; iSplitL.
  { iExists v; iSplitL; [done |]. by iApply Hv. }
  by iApply Hvs.
Qed.

(*
   When proving the typing rules, we often have goals of the shape
   P /\\ (All (t : tag) (ve : val), abs2 TEx t ve -** abs2 TEx t ve)
   The right conjunct is the case for the exceptional postcondition.
   The tactic 'ex_done' proves the right conjuct, and transforms the goal to P
*)
Ltac ex_done := iSplit; [| iIntros (??) "[??]"; by iFrame].

(*
  Since typed programs are allowed to leak resources, in the proofs we often
  have to absorb assumptions into the ( ** TRUE) part of the postcondition.
  wp_absorb takes care of this.
*)
Tactic Notation "wp_absorb" constr(spat) :=
  iApply (absorb with spat);
    [apply wp_absorbing; intros; apply abs_absorbing | done |].

(* ########################################################################## *)
(** * Copy rules *)
(* ########################################################################## *)

Lemma copy_emp A v :
  copy A ->
  A v |~ EMP.
Proof.
  iIntros (HA) "Hv".
  by iDestruct (HA with "Hv") as "Hv".
Qed.

Lemma copy_dup A v :
  copy A ->
  A v |~ A v ** A v.
Proof.
  iIntros (HA) "Hv".
  iDestruct (HA with "Hv") as %Hv. iFrame "Hv". by iApply Hv.
Qed.

Lemma Moved_copy :
  copy TMoved.
Proof.
  by iIntros (v) "_ !% _".
Qed.

Lemma Unit_copy :
  copy TUnit.
Proof.
  by iIntros (v) "-> !% _".
Qed.

Lemma Nat_copy :
  copy TNat.
Proof.
  iIntros (v) "[%n ->] !% _"; eauto.
Qed.

Lemma Bool_copy :
  copy TBool.
Proof.
  iIntros (v) "[%b ->] !% _"; eauto.
Qed.

Lemma Prod_copy A1 A2 :
  copy A1 ->
  copy A2 ->
  copy (TProd A1 A2).
Proof.
  iIntros (HA1 HA2 v) "(%w1 & %w2 & % & Hw1 & Hw2)".
  iDestruct (HA1 with "Hw1") as "Hw1"; iDestruct "Hw1" as %Hw1.
  iDestruct (HA2 with "Hw2") as "Hw2"; iDestruct "Hw2" as %Hw2.
  iIntros "!% _"; iExists w1, w2. iSplitR; [done |].
  iSplitR; [by iApply Hw1 | by iApply Hw2].
Qed.

Lemma Sum_copy A1 A2 :
  copy A1 ->
  copy A2 ->
  copy (TSum A1 A2).
Proof.
  iIntros (HA1 HA2 v) "[%w [[% Hw] | [% Hw]]]".
  - iDestruct (HA1 with "Hw") as "Hw"; iDestruct "Hw" as %Hw.
    iIntros "!% _"; iExists w. iLeft; iSplitR; [done |]. by iApply Hw.
  - iDestruct (HA2 with "Hw") as "Hw"; iDestruct "Hw" as %Hw.
    iIntros "!% _"; iExists w. iRight; iSplitR; [done |]. by iApply Hw.
Qed.

Lemma Fun_copy A1 A2 :
  copy (TFun A1 A2).
Proof.
  by iStartProof; iIntros (v) "%Hfun !% _".
Qed.

(* ########################################################################## *)
(** * Semantic typing rules *)
(* ########################################################################## *)

Lemma Unit_typed :
  val_typed VUnit TUnit.
Proof.
  by iIntros "_".
Qed.

Lemma Nat_typed n :
  val_typed (VNat n) TNat.
Proof.
  iIntros "_"; iSplitR; [| done]; by iExists n.
Qed.

Lemma Bool_typed b :
  val_typed (VBool b) TBool.
Proof.
  iIntros "_"; iSplitR; [| done]; by iExists b.
Qed.

Lemma Closure_typed x e A1 A2 :
  typed [(x, A1)] e A2 ->
  val_typed (VClosure x e) (TFun A1 A2).
Proof.
  iIntros (He) "_". iSplitR; [| done]. iIntros "!% %v Hv".
  iApply App_wp. rewrite <-subst_map_singleton.
  iApply He; simpl. iSplitL; [| done].
  iExists v; iFrame; StringMap.map_solver.
Qed.

Lemma Val_typed Gamma v A :
  val_typed v A ->
  typed Gamma (EVal v) A.
Proof.
  iIntros (Hv vs) "Hvs"; simpl.
  iDestruct (Hv with "[//]") as "-#[Hv ?]".
  iApply Val_wp. by iSplitL "Hv".
Qed.

Lemma Var_typed Gamma x A :
  In (x, A) Gamma ->
  typed Gamma (EVar x) A.
Proof.
  iIntros (HIn vs) "Hvs".
  iInduction Gamma as [| [y B] Gamma] "IH" forall (vs); simpl in *; [done |].
  destruct HIn as [? | HIn]; simplify_eq.
  - iDestruct "Hvs" as "[(%v & -> & Hv) Hvs]".
    iApply Val_wp. by iSplitL "Hv".
  - iDestruct "Hvs" as "[? Hvs]".
    wp_absorb "[- Hvs]". by iApply "IH".
Qed.

Lemma Lam_typed Gamma x e A1 A2 :
  ~In x (ctx_dom Gamma) ->
  typed ((x, A1) :: Gamma) e A2 ->
  typed Gamma (ELam x e) (TFunOnce A1 A2).
Proof.
  iIntros (Hdom He vs) "Hvs"; simpl.
  iApply Lam_wp. iSplitL; [| done]. iIntros (v) "Hv".
  iApply App_wp. rewrite <-subst_map_insert.
  iApply He; simpl. iSplitL "Hv".
  { iExists v; iFrame; StringMap.map_solver. }
  by iApply ctx_typed_insert.
Qed.

Lemma Lam_copy_typed Gamma e x A1 A2 :
  ~In x (ctx_dom Gamma) ->
  Forall (fun xA => copy (snd xA)) Gamma ->
  typed ((x, A1) :: Gamma) e A2 ->
  typed Gamma (ELam x e) (TFun A1 A2).
Proof.
  iIntros (Hdom HGamma He vs) "Hvs"; simpl.
  iDestruct (all_copy_ctx_copy with "Hvs") as "Hvs"; [done |].
  iDestruct "Hvs" as %Hvs. iApply Lam_wp.
  iSplitR; [| done]. iIntros "!% %w Hw".
  iApply App_wp. rewrite <-subst_map_insert.
  iApply He; simpl. iSplitL.
  { iExists w; iFrame. iPureIntro; StringMap.map_solver. }
  iApply ctx_typed_insert; [done |]. by iApply Hvs.
Qed.

Lemma App_typed Gamma1 Gamma2 e1 e2 A1 A2 :
  typed Gamma1 e1 (TFunOnce A1 A2) ->
  typed Gamma2 e2 A1 ->
  typed (Gamma1 ++ Gamma2) (EApp e1 e2) A2.
Proof.
  iIntros (He1 He2 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply (He1 with "Hvs1"); ex_done; iIntros (v1) "[Hv1 ?]".
  iApply (He2 with "Hvs2"); ex_done; iIntros (v2) "[Hv2 ?]".
  wp_absorb "[- Hv1 Hv2]". iApply ("Hv1" with "Hv2").
Qed.

Lemma Op_typed Gamma1 Gamma2 op e1 e2 A1 A2 B :
  bin_op_typed op A1 A2 B ->
  typed Gamma1 e1 A1 ->
  typed Gamma2 e2 A2 ->
  typed (Gamma1 ++ Gamma2) (EOp op e1 e2) B.
Proof.
  iIntros (Hop He1 He2 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply (He1 with "Hvs1"); ex_done; iIntros (v1) "[Hv1 ?]".
  iApply (He2 with "Hvs2"); ex_done; iIntros (v2) "[Hv2 ?]".
  iDestruct (Hop with "[$Hv1 $Hv2]") as "(%v & % & Hv)".
  iApply Op_wp. iFrame.
Qed.

Lemma Pair_typed Gamma1 Gamma2 e1 e2 A1 A2 :
  typed Gamma1 e1 A1 ->
  typed Gamma2 e2 A2 ->
  typed (Gamma1 ++ Gamma2) (EPair e1 e2) (TProd A1 A2).
Proof.
  iIntros (He1 He2 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply (He1 with "Hvs1"); ex_done; iIntros (v1) "[Hv1 ?]".
  iApply (He2 with "Hvs2"); ex_done; iIntros (v2) "[Hv2 ?]".
  iApply Pair_wp. iSplitL "Hv1 Hv2"; [| done]. iExists v1, v2. by iFrame.
Qed.

Lemma LetPair_typed Gamma1 Gamma2 x1 x2 e1 e2 A1 A2 B :
  ~In x1 (ctx_dom Gamma2) ->
  ~In x2 (ctx_dom Gamma2) ->
  x1 <> x2 ->
  typed Gamma1 e1 (TProd A1 A2) ->
  typed ((x1, A1) :: (x2, A2) :: Gamma2) e2 B ->
  typed (Gamma1 ++ Gamma2) (ELetPair x1 x2 e1 e2) B.
Proof.
  iIntros (Hin1 Hin2 Hne He1 He2 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply (He1 with "Hvs1"); ex_done;
  iIntros (v1) "[(%w1 & %w2 & -> & Hw1 & Hw2) Htrue]"; wp_absorb "[Htrue]".
  iApply LetPair_wp. rewrite <- subst_map_insert, StringMap.insert_delete.
  destruct String.eq_dec; [done|].
  rewrite <- subst_map_insert.
  iApply He2; simpl.
  iSplitL "Hw1".
  { iExists w1; iFrame. StringMap.map_solver. }
  iSplitL "Hw2".
  { iExists w2; iFrame. StringMap.map_solver. }
  iApply ctx_typed_insert; [done|]. by iApply ctx_typed_insert.
Qed.

Lemma If_typed Gamma1 Gamma2 e1 e2 e3 A :
  typed Gamma1 e1 TBool ->
  typed Gamma2 e2 A ->
  typed Gamma2 e3 A ->
  typed (Gamma1 ++ Gamma2) (EIf e1 e2 e3) A.
Proof.
  iIntros (He1 He2 He3 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply (He1 with "Hvs1"); ex_done; iIntros (v1) "[[%b ->] ?]". destruct b.
  - iApply If_true_wp. wp_absorb "[- Hvs2]". by iApply He2.
  - iApply If_false_wp. wp_absorb "[- Hvs2]". by iApply He3.
Qed.

Lemma Seq_typed Gamma1 Gamma2 e1 e2 A B :
  typed Gamma1 e1 A ->
  typed Gamma2 e2 B ->
  typed (Gamma1 ++ Gamma2) (ESeq e1 e2) B.
Proof.
  iIntros (He1 He2 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply Seq_wp. iApply (He1 with "Hvs1"); ex_done; iIntros (v1) "[??]".
  wp_absorb "[- Hvs2]". iApply (He2 with "Hvs2").
Qed.

Lemma Alloc_typed Gamma e A :
  typed Gamma e A ->
  typed Gamma (EAlloc e) (TRef A).
Proof.
  iIntros (He vs) "Hvs"; simpl.
  iApply (He with "Hvs"); ex_done; iIntros (vret) "[Hvret ?]".
  iApply Alloc_wp. iIntros (l) "Hl";iFrame;iSplitL;[|done].
  iExists l; eauto with iFrame.
Qed.

Lemma LinLoad_typed Gamma e A :
  typed Gamma e (TRef A) ->
  typed Gamma (ELinLoad e) (TProd (TRef TMoved) A).
Proof.
  iIntros (He vs) "Hvs";simpl.
  iApply (He with "Hvs"); ex_done;
  iIntros (vret) "[(%l & %w & -> & Hl & Hw) Htrue]".
  iApply LinLoad_wp; iIntros "{$Hl} Hl {$Htrue}"; iSplitL;[|done].
  iExists (VRef l), w; iFrame; iSplitR; [done|].
  iExists l; eauto with iFrame.
Qed.

Lemma LinLoad_copy_typed Gamma e A :
  copy A ->
  typed Gamma e (TRef A) ->
  typed Gamma (ELinLoad e) (TProd (TRef A) A).
Proof.
  iIntros (Hcopy He vs) "Hvs"; simpl.
  iApply (He with "Hvs"); ex_done;
  iIntros (vret) "[(%l & %w & -> & Hl & Hw) Htrue]".
  iApply LinLoad_wp; iIntros "{$Hl} Hl {$Htrue}"; iSplitL;[|done].
  iDestruct (copy_dup with "Hw") as "[Hw1 Hw2]";[done|].
  iExists (VRef l), w; iFrame; iSplitR; [done|].
  iExists l, w; eauto with iFrame.
Qed.

Lemma Store_typed Gamma1 Gamma2 e1 e2 A :
  typed Gamma1 e1 (TRef A) ->
  typed Gamma2 e2 A ->
  typed (Gamma1 ++ Gamma2) (EStore e1 e2) (TRef A).
Proof.
  iIntros (He1 He2 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply (He1 with "Hvs1"); ex_done;
  iIntros (v1) "[(%l & %w & -> & Hl & Hw) ?]".
  iApply (He2 with "Hvs2"); ex_done; iIntros (v2) "[Hv2 ?]".
  wp_absorb "[- Hl Hw Hv2]"; iApply Store_wp; iFrame.
  iIntros "Hl"; iSplitR "Hw"; [|done].
  iExists l, v2; eauto with iFrame.
Qed.

Lemma Free_typed Gamma e A :
  typed Gamma e (TRef A) ->
  typed Gamma (EFree e) A.
Proof.
  iIntros (He vs) "Hvs"; simpl.
  iApply (He with "Hvs"); ex_done; iIntros (v) "[(%l & %w & -> & Hl & Hw) ?]".
  iApply Free_wp; eauto with iFrame.
Qed.

Lemma Throw_typed Gamma t e A :
  typed Gamma e TNat ->
  typed Gamma (EThrow t e) A.
Proof.
  iIntros (He vs) "Hvs"; simpl.
  iApply Throw_wp; by iApply He.
Qed.

Lemma Catch_typed Gamma1 Gamma2 e1 t e2 A :
  typed Gamma1 e1 A ->
  typed Gamma2 e2 (TFunOnce TNat A) ->
  typed (Gamma1 ++ Gamma2) (ECatch e1 t e2) A.
Proof.
  iIntros (He1 He2 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply Catch_wp.
  iApply (He1 with "Hvs1"); iSplitR.
  { iIntros (?) "$Hvret". }
  iIntros (t' ve) "[Hve ?]". destruct (tag_dec t t'); [|iFrame].
  iApply (He2 with "Hvs2"); ex_done; iIntros (vret) "[Hvret ?]".
  wp_absorb "[- Hve Hvret]". by iApply "Hvret".
Qed.

Lemma Let_typed Gamma1 Gamma2 x e1 e2 A B :
  ~In x (ctx_dom Gamma2) ->
  typed Gamma1 e1 A ->
  typed ((x, A) :: Gamma2) e2 B ->
  typed (Gamma1 ++ Gamma2) (ELet x e1 e2) B.
Proof.
  iIntros (Hin He1 He2 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply Let_wp. iApply (He1 with "Hvs1"); ex_done; iIntros (vret) "[Hvret ?]".
  rewrite <- subst_map_insert. wp_absorb "[- Hvs2 Hvret]".
  iApply (He2 with "[Hvret Hvs2]"); simpl. iSplitL "Hvret".
  - iExists vret;iFrame. iPureIntro.
    rewrite StringMap.lookup_insert. by destruct (String.eq_dec x x).
  - by iApply (ctx_typed_insert with "Hvs2").
Qed.

Lemma InjL_typed Gamma e A1 A2 :
  typed Gamma e A1 ->
  typed Gamma (EInjL e) (TSum A1 A2).
Proof.
  iIntros (He1 vs) "Hvs"; simpl.
  iApply (He1 with "Hvs"); ex_done; iIntros (vret) "[Hvret ?]".
  iApply InjL_wp; iFrame; iSplitL; [|done].
  iExists vret; eauto with iFrame.
Qed.

Lemma InjR_typed Gamma e A1 A2 :
  typed Gamma e A2 ->
  typed Gamma (EInjR e) (TSum A1 A2).
Proof.
  iIntros (He1 vs) "Hvs"; simpl.
  iApply (He1 with "Hvs"); ex_done; iIntros (vret) "[Hvret ?]".
  iApply InjR_wp; iFrame; iSplitL; [|done].
  iExists vret; eauto with iFrame.
Qed.

Lemma Match_typed Gamma1 Gamma2 e x1 e1 x2 e2 A1 A2 B :
  ~In x1 (ctx_dom Gamma2) ->
  ~In x2 (ctx_dom Gamma2) ->
  typed Gamma1 e (TSum A1 A2) ->
  typed ((x1, A1) :: Gamma2) e1 B ->
  typed ((x2, A2) :: Gamma2) e2 B ->
  typed (Gamma1 ++ Gamma2) (EMatch e x1 e1 x2 e2) B.
Proof.
  iIntros (Hin1 Hin2 He He1 He2 vs) "Hvs"; simpl.
  iDestruct (ctx_typed_app with "Hvs") as "[Hvs1 Hvs2]".
  iApply (He with "Hvs1"); ex_done; unfold abs1,TSum.
  iIntros (vret) "[(%w & [[-> Hw] | [-> Hw]]) ?]"; wp_absorb "[- Hvs2 Hw]".
  - iApply Match_InjL_wp. rewrite <- subst_map_insert. iApply He1.
    iSplitL "Hw".
    { iExists w. rewrite StringMap.lookup_insert.
    destruct String.eq_dec;[|done]. eauto with iFrame. }
    by iApply ctx_typed_insert.
  - iApply Match_InjR_wp. rewrite <- subst_map_insert. iApply He2.
    iSplitL "Hw".
    { iExists w. rewrite StringMap.lookup_insert.
    destruct String.eq_dec;[|done]. eauto with iFrame. }
    by iApply ctx_typed_insert.
Qed.

(* ########################################################################## *)
(** * Subtyping rules *)
(* ########################################################################## *)

Lemma subty_refl A :
  subty A A.
Proof.
  iIntros (v) "$ //".
Qed.

Lemma subty_trans A1 A2 A3 :
  subty A1 A2 ->
  subty A2 A3 ->
  subty A1 A3.
Proof.
  iIntros (HA12 HA23 v) "Hv".
  iDestruct (HA12 with "Hv") as "[Hv ?]".
  iDestruct (HA23 with "Hv") as "[Hv ?]". iFrame.
Qed.

(* Every type is a subtype of moved *)
Lemma subty_moved A :
  subty A TMoved.
Proof.
  iIntros (v) "Hv". by iSplitR.
Qed.

Lemma Fun_to_FunOnce_subty A1 A2 :
  subty (TFun A1 A2) (TFunOnce A1 A2).
Proof.
  iStartProof; iIntros (v Hfun). iSplitL; [| done].
  iIntros (w) "Hw". by iApply Hfun.
Qed.

Lemma Ref_subty A1 A2 :
  subty A1 A2 ->
  subty (TRef A1) (TRef A2).
Proof.
  iIntros (HA v) "(%l & %w & % & Hl & Hv)".
  iDestruct (HA with "Hv") as "[Hv ?]".
  iSplitL "Hl Hv"; [| done]. iExists l, w. by iFrame.
Qed.

Lemma Prod_subty A1 A2 B1 B2 :
  subty A1 A2 ->
  subty B1 B2 ->
  subty (TProd A1 B1) (TProd A2 B2).
Proof.
  iIntros (HA HB v) "(%w1 & %w2 & % & Hw1 & Hw2)".
  iDestruct (HA with "Hw1") as "[Hw1 ?]".
  iDestruct (HB with "Hw2") as "[Hw2 ?]".
  iSplitL "Hw1 Hw2"; [| done]. iExists w1, w2. by iFrame.
Qed.

Lemma Sum_subty A1 A2 B1 B2 :
  subty A1 A2 ->
  subty B1 B2 ->
  subty (TSum A1 B1) (TSum A2 B2).
Proof.
  iIntros (HA HB v) "[%w [[% Hw] | [% Hw]]]".
  - iDestruct (HA with "Hw") as "[Hw ?]".
    iSplitL "Hw"; [| done]. iExists w. iLeft. by iFrame.
  - iDestruct (HB with "Hw") as "[Hw ?]".
    iSplitL "Hw"; [| done]. iExists w. iRight. by iFrame.
Qed.

Lemma Fun_subty A1 A2 B1 B2 :
  subty A2 A1 ->
  subty B1 B2 ->
  subty (TFun A1 B1) (TFun A2 B2).
Proof.
  iIntros (HA HB v) "Hfun"; iDestruct "Hfun" as %Hfun.
  iSplitL;[|done]; iIntros "!% %w Hw".
  iDestruct (HA with "Hw") as "[Hw ?]"; wp_absorb "[- Hw]".
  iApply (Hfun with "[Hw]"); [done|ex_done].
  iIntros (vret) "[Hvret ?]".
  iDestruct (HB with "Hvret") as "[Hvret ?]"; iFrame.
Qed.

Lemma FunOnce_subty A1 A2 B1 B2 :
  subty A2 A1 ->
  subty B1 B2 ->
  subty (TFunOnce A1 B1) (TFunOnce A2 B2).
Proof.
  iIntros (HA HB v) "Hfun"; iSplitL;[|done]; iIntros (w) "Hw".
  iDestruct (HA with "Hw") as "[Hw ?]"; wp_absorb "[- Hw Hfun]".
  iApply ("Hfun" with "Hw"); ex_done.
  iIntros (vret) "[Hvret ?]".
  iDestruct (HB with "Hvret") as "[Hvret ?]"; iFrame.
Qed.

Lemma subctx_refl Gamma :
  subctx Gamma Gamma.
Proof.
  iIntros (vs) "$ //".
Qed.

Lemma subctx_trans Gamma1 Gamma2 Gamma3 :
  subctx Gamma1 Gamma2 ->
  subctx Gamma2 Gamma3 ->
  subctx Gamma1 Gamma3.
Proof.
  iIntros (HGamma12 HGamma23 vs) "Hvs".
  iDestruct (HGamma12 with "Hvs") as "[Hvs ?]".
  iDestruct (HGamma23 with "Hvs") as "[Hvs ?]". iFrame.
Qed.

Lemma subctx_cons Gamma1 Gamma2 x A1 A2 :
  subty A1 A2 ->
  subctx Gamma1 Gamma2 ->
  subctx ((x, A1) :: Gamma1) ((x, A2) :: Gamma2).
Proof.
  iIntros (HA HGamma vs) "Hvs"; simpl.
  iDestruct "Hvs" as "[(%v & % & Hv) Hvs]".
  iDestruct (HA with "Hv") as "[Hv ?]".
  iDestruct (HGamma with "Hvs") as "[Hvs ?]".
  iSplitL "Hv Hvs"; [| done]. iFrame. iExists v. by iFrame.
Qed.

Lemma subctx_swap Gamma x1 x2 A1 A2 :
  subctx ((x1, A1) :: (x2, A2) :: Gamma) ((x2, A2) :: (x1, A1) :: Gamma).
Proof.
  iIntros (vs) "Hvs"; simpl. iSplitL; [| done].
  iDestruct "Hvs" as "((%v1 & % & Hv1) & (%v2 & % & Hv2) & Hvs)".
  iFrame; iSplitL "Hv2"; eauto.
Qed.

(* The typing system is affine: weakening holds for arbitrary A *)
Lemma subctx_weakening Gamma x A :
  subctx ((x, A) :: Gamma) Gamma.
Proof.
  iIntros (vs) "Hvs"; simpl.
  iDestruct "Hvs" as "[(%v & _ & Hv) Hvs]". by iFrame.
Qed.

Lemma subctx_copy_contraction Gamma x A :
  copy A ->
  subctx ((x, A) :: Gamma) ((x, A) :: (x, A) :: Gamma).
Proof.
  iIntros (HA vs) "Hvs"; simpl. iSplitL; [| done].
  iDestruct "Hvs" as "[(%v & % & Hv) Hvs]". iFrame.
  iDestruct (copy_dup with "Hv") as "[Hv1 Hv2]"; [done |].
  iSplitL "Hv1"; iExists v; by iFrame.
Qed.

Lemma val_subsumption v A1 A2 :
  subty A1 A2 ->
  val_typed v A1 ->
  val_typed v A2.
Proof.
  iIntros (HA Hv) "_".
  iDestruct (Hv with "[//]") as "-#[Hv ?]".
  iDestruct (HA with "Hv") as "[Hv ?]". iFrame.
Qed.

Lemma subsumption Gamma1 Gamma2 e A1 A2 :
  subctx Gamma2 Gamma1 ->
  subty A1 A2 ->
  typed Gamma1 e A1 ->
  typed Gamma2 e A2.
Proof.
  iIntros (HGamma HA He vs) "Hvs".
  iDestruct (HGamma with "Hvs") as "[Hvs ?]".
  iApply (He with "Hvs"); ex_done; iIntros (v) "[Hv1 ?]".
  iDestruct (HA with "Hv1") as "[Hv1 ?]". iFrame.
Qed.

(* ########################################################################## *)
(** * Type soundness *)
(* ########################################################################## *)

Definition terminates (e : expr) :Prop :=
  exists r h, big_step e NatMap.empty r h.

Section wp_adequacy.
  Transparent sepEntails.

  Lemma wp_adequacy Phi EPhi e :
    (EMP |~ wp e Phi EPhi) ->
    exists r h, big_step e NatMap.empty r h /\ (Phi # EPhi) r h.
  Proof.
    unfold sepEntails, wp; intros H.
    edestruct H as (r & h & _ & Hbig & HPost).
    { done. }
    { apply (NatMap.disjoint_empty NatMap.empty). }
    rewrite !NatMap.union_empty_r in Hbig. eauto.
  Qed.
End wp_adequacy.

Theorem type_soundness e A :
  typed [] e A ->
  terminates e.
Proof.
  unfold typed, terminates; simpl; intros He.
  specialize (He StringMap.empty). rewrite subst_map_empty in He.
  apply wp_adequacy in He as (r & h & Hbig & _). eauto.
Qed.


Require Export BPlusTree.
Require Export ValidBPlusTree.
Require Export SortingProofs.
Require Export AppearsInKVL.
Require Export HeightProofs.
Require Export InsertProofs.
Require Export KvAppearsInTree.

Theorem appears_leaf_impl_search_found_app : forall (X: Type) (k: nat) (v: X) (l1 l2: list (nat * X)),
  kvl_sorted (l1 ++ (k, v) :: l2) ->
  search_leaf k (l1 ++ (k, v) :: l2) = Some v.
Proof.
  intros.
  induction l1.
  Case "l1 = []".
    simpl. rewrite <- beq_nat_refl.
    reflexivity.
  Case "l1 = a::l1".
    simpl.
    destruct a.
    remember (beq_nat n k) as eq.
    destruct eq.
    SCase "not here".
      apply kvl_sorted_key_across_app in H.
      symmetry in Heqeq. apply beq_nat_true_iff in Heqeq.
      apply ex_falso_quodlibet. omega.
    SCase "later".
      apply IHl1.
      rewrite <- app_comm_cons in H.
      apply list_tail_is_sorted in H.
      assumption.
Qed.

Theorem appears_leaf_impl_search_found : forall (X: Type) (k: nat) (v: X) (kvl: list (nat * X)),
  kvl_sorted kvl ->
  kv_appears_in_kvl k v kvl ->
  search_leaf k kvl = Some v.
Proof.
  intros.
  apply kv_appears_in_kvl_app in H0.
  do 2 destruct H0.
  rewrite H0.
  apply appears_leaf_impl_search_found_app.
  rewrite <- H0.
  assumption.
Qed.

Theorem appears_impl_search'_found : forall (X: Type) (counter b sk: nat) (sv: X) (t: bplustree b X),
  valid_bplustree b X t ->
  kv_appears_in_tree sk sv t ->
  counter = (height t) ->
  search' counter sk t = Some(sv).
Proof.
  induction counter.
  Case "counter = 0".
    intros.
    inversion H.
    SCase "bptLeaf".
      subst. inversion H0.
      apply appears_leaf_impl_search_found; assumption.
    SCase "bptNode".
      subst. simpl in H1.
      destruct kpl.
      simpl in H3. exfalso. omega.
      destruct p. inversion H1.
  Case "counter = S counter".
    intros.
    inversion H.
    SCase "bptLeaf".
      subst. simpl in H1. inversion H1.
    SCase "bptNode".
      simpl.
      remember (find_subtree sk kpl).
      destruct o.
      SSCase "find_subtree = Some p".
        symmetry in Heqo. destruct p.
        assert (find_subtree sk kpl = Some (n, b0)) by assumption.
        (* Our goal here is to find all the requirements for using IHcounter
         * on the tree b0. *)
        assert (valid_bplustree b X b0).
          apply find_subtree_impl_kpl_app in H11.
          do 2 destruct H11. inversion H11. clear H11.
          rewrite H12 in H6.
          apply all_values_single in H6.
          apply valid_sub_bplustree_impl_valid_bplustree in H6.
          apply H6.
        assert (kv_appears_in_tree sk sv b0).
          apply kv_appears_in_subtree_when_appears_in_tree_and_found with (v := sv) in Heqo.
          apply Heqo. assumption.
          rewrite H10. assumption.
        assert (counter = height b0).
          apply find_subtree_impl_kpl_app in H11.
          do 2 destruct H11. inversion H11. clear H11.
          apply height_of_parent_one_bigger in H14.
          rewrite H10 in H14.
          omega.
          apply H7.

        apply IHcounter; assumption.
      SSCase "find_subtree = None".
        rewrite <- H10 in H.
        apply find_subtree_finds_a_subtree with (sk := sk) in H.
        do 2 destruct H. rewrite H in Heqo.
        inversion Heqo.
Qed.

Theorem appears_impl_search_found : forall (b: nat) (X: Type) (v: X) (t: bplustree b X) (k: nat),
  valid_bplustree b X t ->
  kv_appears_in_tree k v t ->
  search k t = Some(v).
Proof.
  intros.
  unfold search.
  remember (height t) as counter.
  apply appears_impl_search'_found; assumption.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2010-01-28
- Pierre-Yves Strub, 2009-04-09

Wrapper for Coq's FMaps definition + additional facts
*)

Set Implicit Arguments.

From Coq Require Import FMaps FSetInterface.
From CoLoR Require Import LogicUtil RelUtil BoolUtil ListUtil FSetUtil.

Module Make (Export XMap : FMapInterface.S).

  Module Export XMapProps := Properties XMap.
  Module Export XMapFacts := Facts XMap.
  Module Export XMapOrdProps := OrdProperties XMap.

  Arguments empty {elt}.

(***********************************************************************)
(** In the following, we assume given a type [A] and a relation [eq] on [A]. *)

  Section S.

    Variables (A : Type) (eq : relation A).

(***********************************************************************)
(* Properties of [remove]. *)

    Lemma remove_empty : forall x, Equal (remove x empty) (@empty A).

    Proof.
      intros x k. rewrite remove_o, empty_o. destruct (eq_dec x k); refl.
    Qed.

(***********************************************************************)
(** Properties of [Equiv]. *)

    Arguments inclusion {A} R1 R2.

    Global Instance Equiv_m' : Proper (inclusion ==> inclusion) (@Equiv A).

    Proof. fo. Qed.

    Global Instance Equiv_m : Proper (same ==> same) (@Equiv A).

    Proof. fo. Qed.

    Lemma Equal_Equiv : Reflexive eq -> Equal << Equiv eq.

    Proof.
      intros heq m m'. rewrite Equal_Equiv. apply Equiv_m'.
      intros x y xy. subst. refl.
    Qed.

    Global Instance Equiv_Refl : Reflexive eq -> Reflexive (Equiv eq).

    Proof.
      intros heq m. unfold Equiv. fo. rewrite find_mapsto_iff in H, H0.
      rewrite H in H0. inversion H0. subst e'. refl.
    Qed.

    Global Instance Equiv_Sym : Symmetric eq -> Symmetric (Equiv eq).

    Proof. fo. Qed.

    Global Instance Equiv_Trans : Transitive eq -> Transitive (Equiv eq).

    Proof.
      intros h m n p. unfold Equiv, XMap.Equiv. intuition.
      rewrite <- H, <- H1. hyp. rewrite H1, H. hyp. unfold In in H1, H.
      assert (exists e, MapsTo k e m). ex e. hyp.
      rewrite H1 in H5. destruct H5 as [f].
      trans f. apply H2 with k; hyp. apply H3 with k; hyp.
    Qed.

(***********************************************************************)
(** Properties of [transpose_neqkey]. *)

    Global Instance transpose_neqkey_m' : forall B,
      Proper (inclusion ==> Logic.eq ==> impl) (@transpose_neqkey A B).

    Proof.
      intros B R R' RR' f f' ff' h. subst f'. unfold transpose_neqkey.
      intros k k' e e' b n. apply RR'. apply h. hyp.
    Qed.

    Global Instance transpose_neqkey_m : forall B,
      Proper (same ==> Logic.eq ==> iff) (@transpose_neqkey A B).

    Proof.
      intros B R R' [h1 h2] f f' ff'. split; apply transpose_neqkey_m'; auto.
    Qed.

(***********************************************************************)
(** Properties of [add]. *)

    Lemma add_transp : transpose_neqkey Equal (@add A).

    Proof.
      unfold transpose_neqkey. intros k l x y m n. unfold Equal.
      intro k'. rewrite !add_o.
      destruct (eq_dec k k'); destruct (eq_dec l k'); try refl.
      absurd (E.eq k l). hyp. trans k'; hyp.
    Qed.

    Definition add_add_neq := add_transp.

    Lemma add_add_eq : forall k l, E.eq k l ->
      forall (x y : A) m, Equal (add k x (add l y m)) (add k x m).

    Proof.
      intros k l kl x y m. unfold Equal. intro k'. rewrite !add_o.
      destruct (eq_dec k k'); destruct (eq_dec l k'); try refl.
      absurd (E.eq k k'). hyp. trans l; hyp.
    Qed.

    Lemma add_add : forall k l (x y : A) m,
      Equal (add k x (add l y m))
      (if eq_dec k l then add k x m else add l y (add k x m)).

    Proof.
      intros k l x y m. destruct (eq_dec k l).
      apply add_add_eq; hyp. apply add_add_neq; hyp.
    Qed.

    Lemma add_transp_Equiv :
      Reflexive eq -> transpose_neqkey (Equiv eq) (@add A).

    Proof.
      intro heq. eapply transpose_neqkey_m'. apply Equal_Equiv. intuition.
      refl. apply add_transp.
    Qed.

    Definition add_add_neq_Equiv := add_transp_Equiv.

    Lemma add_add_eq_Equiv : Reflexive eq -> forall k l, E.eq k l ->
      forall x y m, Equiv eq (add k x (add l y m)) (add k x m).

    Proof.
      intros heq k l kl x y m. apply Equal_Equiv.
      intuition. apply add_add_eq. hyp.
    Qed.

    Lemma add_add_Equiv : Reflexive eq -> forall k l x y m,
      Equiv eq (add k x (add l y m))
      (if eq_dec k l then add k x m else add l y (add k x m)).

    Proof.
      intros heq k l x y m. destruct (eq_dec k l).
      apply add_add_eq_Equiv; hyp. apply add_add_neq_Equiv; hyp.
    Qed.

(***********************************************************************)
(** [add] is a morphism wrt Equiv. *)

    Global Instance add_Equiv :
      Proper (E.eq ==> eq ==> Equiv eq ==> Equiv eq) (@add A).

    Proof. (* by Cedric Auger *)
      intros k1 k2 Hk e1 e2 He m1 m2 Hm.
      split.
       intro k.
       gen (proj1 Hm k); clear -Hm Hk.
       intros [Hm1 Hm2]; split; intros [a_ Ha_].
        destruct (eq_dec k2 k).
         split with e2.
         now apply add_1.
        destruct Hm1.
         split with a_.
         apply add_3 with k1 e1; auto.
         intro H; destruct n.
         now apply E.eq_trans with k1; auto.
        split with x.
        now apply add_2; auto.
       destruct (eq_dec k1 k).
        split with e1.
        now apply add_1.
       destruct Hm2.
        split with a_.
        apply add_3 with k2 e2; auto.
        intro H; destruct n.
        now apply E.eq_trans with k2; auto.
       split with x.
       now apply add_2; auto.
      intro k.
      destruct (eq_dec k2 k).
       intros e_ e_' H H'.
       revert He.
       gen (find_1 H').
       rewrite (find_1 (add_1 _ _ e)).
       gen (find_1 H).
       rewrite (find_1 (add_1 _ _ (E.eq_trans Hk e))).
       clear.
       intro H; inversion_clear H.
       intro H; inversion_clear H.
       now auto.
      intros e_ e_' H H'.
      gen (add_3 n H').
      cut (not (E.eq k1 k)).
       intro n'; gen (add_3 n' H).
       exact (proj2 Hm k e_ e_').
      clear -n Hk.
      intro H; destruct n.
      now apply E.eq_trans with k1; auto.
    Qed.

(***********************************************************************)
(** Properties of [find]. *)

    Lemma find_None : forall k m,
      find k m = None <-> (forall x:A, ~MapsTo k x m).

    Proof.
      intros k m. split.
      intros h x. rewrite find_mapsto_iff. rewrite h. intro. discr.
      intro h. case_eq (find k m); intros.
      rewrite <- find_mapsto_iff in H. ded (h a). contr. refl.
    Qed.

    Lemma Equiv_MapsTo : forall m m', Equiv eq m m' -> forall k x,
      MapsTo k x m -> exists x', MapsTo k x' m' /\ eq x x'.

    Proof.
      intros m m' [h1 h2] k x kx. unfold In in h1.
      assert (exists e, MapsTo k e m). exists x. hyp.
      rewrite h1 in H. destruct H as [x']. exists x'. intuition.
      apply h2 with k; hyp.
    Qed.

    Arguments Equiv_MapsTo [m m'] _ [k x] _.

    Lemma Equiv_find_Some : forall m m', Equiv eq m m' -> forall k x,
      find k m = Some x -> exists x', find k m' = Some x' /\ eq x x'.

    Proof.
      intros m m' mm' k x kx. rewrite <- find_mapsto_iff in kx.
      destruct (Equiv_MapsTo mm' kx) as [x']. exists x'.
      rewrite <- find_mapsto_iff. hyp.
    Qed.

    Arguments Equiv_find_Some [m m'] _ [k x] _.

    Lemma Equiv_MapsTo' : forall m m', Equiv eq m m' -> forall k x,
      MapsTo k x m' -> exists x', MapsTo k x' m /\ eq x' x.

    Proof.
      intros m m' [h1 h2] k x kx. unfold In in h1.
      assert (exists e, MapsTo k e m'). exists x. hyp.
      rewrite <- h1 in H. destruct H as [x']. exists x'. intuition.
      apply h2 with k; hyp.
    Qed.

    Arguments Equiv_MapsTo' [m m'] _ [k x] _.

    Lemma Equiv_find_Some' : forall m m', Equiv eq m m' -> forall k x,
      find k m' = Some x -> exists x', find k m = Some x' /\ eq x' x.

    Proof.
      intros m m' mm' k x kx. rewrite <- find_mapsto_iff in kx.
      destruct (Equiv_MapsTo' mm' kx) as [x']. exists x'.
      rewrite <- find_mapsto_iff. hyp.
    Qed.

    Arguments Equiv_find_Some' [m m'] _ [k x] _.

    Lemma Equiv_find_None : forall m m', Equiv eq m m' ->
      forall k, find k m = None <-> find k m' = None.

    Proof.
      intros m m' [h1 h2] k. split; intro hk.
      case_eq (find k m'); intros. 2: refl.
      destruct (Equiv_find_Some' (conj h1 h2) H). destruct H0.
      rewrite hk in H0. discr.
      case_eq (find k m); intros. 2: refl.
      destruct (Equiv_find_Some (conj h1 h2) H). destruct H0.
      rewrite hk in H0. discr.
    Qed.

    Global Instance find_m : Proper (E.eq ==> Equiv eq ==> opt_r eq) (@find A).

    Proof.
      intros k k' kk' m m' [h1 h2]. rewrite <- kk'. clear k' kk'.
      case_eq (find k m); intros.
      destruct (Equiv_find_Some (conj h1 h2) H). destruct H0. rewrite H0.
      apply opt_r_Some. hyp.
      rewrite (Equiv_find_None (conj h1 h2) k) in H. rewrite H.
      apply opt_r_None.
    Qed.

    Lemma find_empty k : find k empty = @None A.

    Proof. apply not_find_in_iff. rewrite empty_in_iff. auto. Qed.

(***********************************************************************)
(** Properties of [Empty] and [is_empty]. *)

    Global Instance Empty_Equiv : Proper (Equiv eq ==> iff) (@Empty A).

    Proof.
      intros m m' mm'. unfold Empty. split; intros h k x kx.
      destruct (Equiv_MapsTo' mm' kx) as [x' [h1 h2]]. fo.
      destruct (Equiv_MapsTo mm' kx) as [x' [h1 h2]]. fo.
    Qed.

    Global Instance is_empty_Equiv :
      Proper (Equiv eq ==> Logic.eq) (@is_empty A).

    Proof.
      intros m m' mm'. apply beq_true. rewrite <- !is_empty_iff.
      apply Empty_Equiv. hyp.
    Qed.

(***********************************************************************)
(** Other properties of [Equiv]. *)

    Lemma Equiv_empty : forall m, Equiv eq empty m <-> Empty m.

    Proof.
      intro m. unfold Equiv, Empty. intuition.
      assert (In a m). exists e. hyp.
      rewrite <- H0 in H2. rewrite empty_in_iff in H2. hyp.
      rewrite empty_in_iff in H0. contr.
      rewrite empty_in_iff. destruct H0. eapply H. apply H0.
      assert (In k (@empty A)). exists e. hyp.
      rewrite empty_in_iff in H2. contr.
    Qed.

    Lemma Equiv_add_remove : forall n k x m', ~In k n ->
      Equiv eq (add k x n) m' -> Equiv eq n (remove k m').

    Proof.
      intros n k x m' hk [h1 h2]. split.
      (* In *)
      intro l. rewrite remove_in_iff. intuition. apply hk. rewrite H0. hyp.
      rewrite <- h1. rewrite add_in_iff. auto.
      rewrite <- h1 in H1. rewrite add_in_iff in H1. intuition.
      (* eq *)
      intros l y z ly lz.
      assert (~E.eq k l). intro e. apply hk. exists y.
      change (MapsTo k y n). rewrite (MapsTo_iff _ _ e). hyp.
      apply h2 with l. rewrite add_mapsto_iff. right. intuition.
      rewrite remove_mapsto_iff in lz. intuition.
    Qed.

    Lemma Equiv_add : forall n k x m', ~In k n -> Equiv eq (add k x n) m' ->
      exists x', eq x x' /\ Add k x' (remove k m') m'.

    Proof.
      intros n k x m' hk [h1 h2].
      assert (In k (add k x n)). rewrite add_in_iff. auto with ordered_type.
      rewrite h1 in H. destruct H as [x']. exists x'. split.
      apply h2 with k. rewrite add_mapsto_iff. auto with ordered_type. hyp.
      intro l. rewrite add_o. rewrite remove_o. destruct (eq_dec k l).
      rewrite <- e. rewrite <- find_mapsto_iff. hyp. refl.
    Qed.

(***********************************************************************)
(** Properties of [fold]. *)

    Lemma fold_empty f (i:A) : fold f (@empty A) i = i.

    Proof. rewrite fold_1, elements_empty. refl. Qed.

(* [fold f] is a morphism wrt [Equiv eq] if [f] is a morphism wrt [eq]
and satisfies some commutation property. *)

    Section fold.

      Variables (heq : PreOrder eq)
        (B : Type) (eqB : relation B) (heqB : Equivalence eqB).

      Global Instance fold_Equiv : forall (f : E.t -> A -> B -> B)
        (f_m : Proper (E.eq ==> eq ==> eqB ==> eqB) f)
        (hf : transpose_neqkey eqB f),
        Proper (Equiv eq ==> eqB ==> eqB) (fold f).

      Proof.
        intros f f_m hf m m' mm' b b' bb'; revert m' mm' b b' bb'.
        pattern m; apply map_induction_bis; clear m.
        (* Equal *)
        intros m n mn hm n' nn' b b' bb'. apply Equal_Equiv in mn.
        2: intuition. trans (fold f m b).
        sym. apply hm. hyp. refl. apply hm. trans n; hyp. hyp.
        (* Empty *)
        intros m hm b b' bb'. rewrite Equiv_empty in hm.
        rewrite fold_Empty; auto. 2: apply empty_1.
        rewrite fold_1. rewrite elements_Empty in hm. rewrite hm. hyp.
        (* Add *)
        intros k x m nxm hm m' xemm' b b' bb'.
        assert (f_m': Proper (E.eq ==> Logic.eq ==> eqB ==> eqB) f).
        intros l l' ll' y y' yy' c c' cc'. subst y'. apply f_m; auto. refl.
        rewrite fold_add; auto. destruct (Equiv_add nxm xemm') as [x' [h1 h2]].
        assert (n: ~In k (remove k m')). apply remove_1. refl.
        rewrite fold_Add with (m2:=m'); auto. 2: apply n. 2: apply h2.
        apply f_m; auto with ordered_type. apply hm; auto.
        eapply Equiv_add_remove. hyp. apply xemm'.
      Qed.

      Lemma fold_Equiv_ext : forall (f : E.t -> A -> B -> B)
        (f_m : Proper (E.eq ==> eq ==> eqB ==> eqB) f)
        (hf : transpose_neqkey eqB f) f',
        (forall k k', E.eq k k' -> forall x x', eq x x' ->
          forall b b', eqB b b' -> eqB (f k x b) (f' k' x' b')) ->
        forall m m', Equiv eq m m' -> forall b b', eqB b b' ->
          eqB (fold f m b) (fold f' m' b').

      Proof.
        intros f f_m hf f' ff' m m' mm' b b' bb'. rewrite !fold_1.
        set (F := fun a (p:key*A) => f (fst p) (snd p) a).
        set (F' := fun a (p:key*A) => f' (fst p) (snd p) a).
        trans (fold_left F (elements m') b').
        unfold F. rewrite <- !fold_1. apply fold_Equiv; auto||refl.
        apply fold_left_m_ext with (eqB:=@eq_key_elt A); try refl.
        intros a a' aa' [k x] [k' x'] e. inversion e. unfold F, F'. simpl in *.
        subst x'. apply ff'; auto||refl.
      Qed.

    End fold.

(***********************************************************************)
(** Properties of [In]. *)

    Global Instance In_Equiv' : Proper (E.eq ==> Equiv eq ==> impl) (@In A).

    Proof.
      intros k k' kk' m m' [h1 h2]. rewrite h1. rewrite kk'. unfold impl. auto.
    Qed.

    Global Instance In_Equiv : Reflexive eq ->
      Proper (E.eq ==> Equiv eq ==> iff) (@In A).

    Proof.
      intros heq k k' kk' m m' [h1 h2]. rewrite h1. apply In_m. hyp. refl.
    Qed.

(***********************************************************************)
(** Properties of [for_all]. *)

    Section for_all.

      Variable f : E.t -> A -> bool.

      Definition for_all_aux k x b := f k x && b.

      Global Instance for_all_aux_m : Proper (E.eq ==> eq ==> Logic.eq) f ->
        Proper (E.eq ==> eq ==> Logic.eq ==> Logic.eq) for_all_aux.

      Proof.
        intros fm k k' kk' x x' xx' b b' bb'. subst b'. unfold for_all_aux.
        f_equal. apply fm; hyp.
      Qed.

      Lemma for_all_aux_transp : transpose_neqkey Logic.eq for_all_aux.

      Proof.
        unfold transpose_neqkey. intros k k' x x' b n.
        unfold for_all_aux. bool. rewrite andb_comm with (b1:=f k x). refl.
      Qed.

      Lemma for_all_eq : forall m, for_all f m = fold for_all_aux m true.

      Proof. refl. Qed.

      Lemma for_all_add : Reflexive eq ->
        Proper (E.eq ==> eq ==> Logic.eq) f -> forall k m, ~In k m ->
          forall x, for_all f (add k x m) = f k x && for_all f m.

      Proof.
        intros heq fm k m n x. rewrite for_all_eq. rewrite fold_add; intuition.
        clear - heq fm. intros k k' kk' x x' xx' b b' bb'.
        apply for_all_aux_m; intuition. subst x'. refl.
        apply for_all_aux_transp.
      Qed.

      Global Instance for_all_Equiv : PreOrder eq ->
        Proper (E.eq ==> eq ==> Logic.eq) f ->
        Proper (Equiv eq ==> Logic.eq) (for_all f).

      Proof.
        intros heq fm m m' mm'. rewrite !for_all_eq.
        apply fold_Equiv; intuition. apply for_all_aux_transp.
      Qed.

      Global Instance for_all_m : Reflexive eq ->
        Proper (E.eq ==> eq ==> Logic.eq) f ->
        Proper (Equal ==> Logic.eq) (for_all f).

      Proof.
        intros heq fm m m' mm'. rewrite !for_all_eq.
        apply fold_Equal; intuition. eapply prop3_incl.
        5: apply for_all_aux_m. refl. intros x y xy. subst y. refl.
        refl. refl. hyp.
      Qed.

    End for_all.

(***********************************************************************)
(** Properties of [filter]. *)

    Section filter.

      Variable f : E.t -> A -> bool.

      Definition filter_aux k x m := if f k x then add k x m else m.

      Global Instance filter_aux_m : PreOrder eq ->
        Proper (E.eq ==> eq ==> Logic.eq) f ->
        Proper (E.eq ==> eq ==> Equiv eq ==> Equiv eq) filter_aux.

      Proof.
        intros heq fm k k' kk' x x' xx' m m' mm'. unfold filter_aux.
        rewrite kk', xx'. destruct (f k' x'). rewrite kk', xx', mm'. refl. hyp.
      Qed.

      Lemma filter_aux_transp : Reflexive eq ->
        transpose_neqkey (Equiv eq) filter_aux.

      Proof.
        unfold transpose_neqkey. intros heq k k' x x' b n. unfold filter_aux.
        destruct (f k x); destruct (f k' x'); try refl.
        apply add_transp_Equiv; hyp.
      Qed.

      Lemma filter_eq : forall m, filter f m = fold filter_aux m empty.

      Proof. refl. Qed.

      (*TODO?

      Lemma filter_add : Reflexive eq ->
        Proper (E.eq ==> eq ==> Logic.eq) f -> forall k m, ~In k m ->
          forall x, filter f (add k x m) = f k x && filter f m.

      Proof.
        intros heq fm k m n x. rewrite filter_eq. rewrite fold_add; intuition.
        clear - heq fm. intros k k' kk' x x' xx' b b' bb'.
        apply filter_aux_m; intuition. subst x'. refl.
        apply filter_aux_transp.
      Qed.

      Global Instance filter_Equiv : PreOrder eq ->
        Proper (E.eq ==> eq ==> Logic.eq) f ->
        Proper (Equiv eq ==> Logic.eq) (filter f).

      Proof.
        intros heq fm m m' mm'. rewrite !filter_eq.
        apply fold_Equiv; intuition. apply filter_aux_transp.
      Qed.

      Global Instance filter_m : Reflexive eq ->
        Proper (E.eq ==> eq ==> Logic.eq) f ->
        Proper (Equal ==> Logic.eq) (filter f).

      Proof.
        intros heq fm m m' mm'. rewrite !filter_eq.
        apply fold_Equal; intuition. eapply Proper_inclusion_3.
        5: apply filter_aux_m. refl. intros x y xy. subst y. refl.
        refl. refl. hyp.
      Qed.*)

    End filter.

(****************************************************************************)
(** Inclusion ordering on maps. *)

    Definition le E F := forall x (T : A), MapsTo x T E -> MapsTo x T F.

    Global Instance le_refl : Reflexive le.

    Proof. fo. Qed.

    Global Instance le_trans : Transitive le.

    Proof. intros E F G EF FG x T h. apply FG. apply EF. hyp. Qed.

    Global Instance le_Equal : Proper (@Equal A ==> @Equal A ==> impl) le.

    Proof.
      intros E E' EE' F F' FF' EF x T hx.
      rewrite <- FF'. apply EF. rewrite EE'. hyp.
    Qed.

    Lemma le_add : forall E x T, find x E = None -> le E (add x T E).

    Proof.
      intros E x T hx y U' hy. rewrite add_mapsto_iff. right. intuition.
      rewrite H in hx. rewrite find_mapsto_iff, hx in hy. discr.
    Qed.

    Global Instance MapsTo_le :
      Proper (Logic.eq ==> Logic.eq ==> le ==> impl) (@MapsTo A).

    Proof. intros x y xy T V TV E F EF h. subst y V. fo. Qed.

    Global Instance In_le : Proper (Logic.eq ==> le ==> impl) (@In A).

    Proof. intros x y xy E F EF [T h]. subst y. exists T. fo. Qed.

    Global Instance add_le : Proper (E.eq ==> Logic.eq ==> le ==> le) (@add A).

    Proof.
      intros x y xy T V TV E F EF. subst V. rewrite xy. intros z V.
      do 2 rewrite find_mapsto_iff, add_o. case (E.eq_dec y z).
      auto. do 2 rewrite <- find_mapsto_iff. rewrite EF. auto.
    Qed.

  End S.

  Arguments Equiv_find_Some [A eq0 m m'] _ [k x] _ : rename.
  Arguments Equiv_find_Some' [A eq0 m m'] _ [k x] _ : rename.
  Arguments le {A} _ _.

(****************************************************************************)
(** * Module providing results on the domain of a map. *)

  Module Domain (XSet : FSetInterface.S with Module E := XMap.E).

    Module Export XSetUtil := FSetUtil.Make XSet.

    Import XMap XMapFacts XMapProps XMapOrdProps.

    Section S.

      Variable A : Type.

(****************************************************************************)
(** ** Restriction of an environment to some set of variables. *)

      Definition restrict_fun xs x (T:A) E :=
        if XSet.mem x xs then add x T E else E.

      Global Instance restrict_fun_e :
        Proper (XSet.Equal ==> E.eq ==> Logic.eq ==> Equal ==> Equal)
               restrict_fun.

      Proof.
        intros xs xs' xsxs' x x' xx' T T' TT' E E' EE'. subst T'.
        unfold restrict_fun. rewrite xx', xsxs'. destruct (XSet.mem x' xs').
        rewrite xx', EE'. refl. hyp.
      Qed.

      Lemma restrict_fun_transp : forall xs,
          transpose_neqkey Equal (restrict_fun xs).

      Proof.
        intros xs x x' T T' E h z. unfold restrict_fun.
        destruct (XSet.mem x xs); destruct (XSet.mem x' xs); try refl.
        rewrite !add_o. case (E.eq_dec x z); case (E.eq_dec x' z); try refl.
        intros x'z. rewrite <- x'z. tauto.
      Qed.

      Definition restrict_dom E xs := fold (restrict_fun xs) E empty.

      Lemma restrict_dom_empty : forall xs, Equal (restrict_dom empty xs) empty.

      Proof.
        intro xs. unfold restrict_dom. rewrite fold_Empty. refl. auto.
        apply empty_1.
      Qed.

      Lemma restrict_dom_add : forall xs x T E, ~In x E ->
        Equal (restrict_dom (add x T E) xs)
              (restrict_fun xs x T (restrict_dom E xs)).

      Proof.
        intros xs x T E hx. unfold restrict_dom. rewrite fold_add. refl. auto.
        apply restrict_fun_e. refl. apply restrict_fun_transp. hyp.
      Qed.

      Global Instance restrict_dom_e :
        Proper (Equal ==> XSet.Equal ==> Equal) restrict_dom.

      Proof.
        intro E; pattern E; apply map_induction_bis; clear E.
        (* Equal *)
        intros E E' EE' h F E'F xs xs' xsxs'. trans (restrict_dom E xs).
        sym. apply h. hyp. refl. apply h. trans E'; hyp. hyp.
        (* empty *)
        intros E h xs xs' xsxs'. rewrite restrict_dom_empty. unfold restrict_dom.
        rewrite fold_Empty. refl. auto. rewrite <- h. apply empty_1.
        (* add *)
        intros x T E hx h F e xs xs' xsxs'. rewrite restrict_dom_add. 2: hyp.
        unfold restrict_dom at -1. rewrite <- (fold_Equal _ _ _ e).
        rewrite fold_add; auto. apply restrict_fun_e; auto with ordered_type. apply h; auto. refl.
        apply restrict_fun_e. refl. apply restrict_fun_transp.
      Qed.

      Lemma mapsto_restrict_dom : forall E xs x T,
          MapsTo x T (restrict_dom E xs) <-> (MapsTo x T E /\ XSet.In x xs).

      Proof.
        intro E; pattern E; apply map_induction_bis; clear E.
        (* Equal *)
        intros E E' EE' h xs x T. rewrite <- EE'. apply h.
        (* empty *)
        intros xs x T. rewrite restrict_dom_empty. rewrite empty_mapsto_iff.
        tauto.
        (* add *)
        intros x T E hx h xs y V. rewrite restrict_dom_add. 2: hyp.
        unfold restrict_fun. case_eq (XSet.mem x xs).
        do 2 rewrite add_mapsto_iff. rewrite h, mem_iff. intuition.
        subst. rewrite <- H0. hyp.
        rewrite add_mapsto_iff, h, <- not_mem_iff. intuition.
        right. intuition. rewrite <- H0 in H2. tauto.
        subst. rewrite <- H1 in H2. tauto.
      Qed.

      Global Instance restrict_dom_s :
        Proper (le ==> Subset ==> le) restrict_dom.

      Proof.
        intros E F EF xs xs' xsxs' x T. do 2 rewrite mapsto_restrict_dom.
        rewrite <- xsxs'. intuition.
      Qed.

      Lemma restrict_dom_le : forall E xs, le (restrict_dom E xs) E.

      Proof. intros E xs y hy. rewrite mapsto_restrict_dom. tauto. Qed.

      Lemma restrict_dom_singleton : forall E x,
          Equal (restrict_dom E (singleton x))
                match find x E with None => empty | Some T => add x T empty end.

      Proof.
        intros E x. case_eq (find x E).
        (* Some *)
        intro T. rewrite <- find_mapsto_iff, Equal_mapsto_iff. intros hx y V.
        rewrite mapsto_restrict_dom. set_iff.
        rewrite add_mapsto_iff, empty_mapsto_iff.
        intuition; subst. 2: rewrite <- H; hyp. left. intuition.
        eapply MapsTo_fun. apply hx. rewrite H1. hyp.
        (* None *)
        rewrite <- not_find_in_iff, Equal_mapsto_iff. intros hx y V.
        rewrite empty_mapsto_iff, mapsto_restrict_dom. set_iff. intuition.
        apply hx. rewrite H1. ex V. hyp.
      Qed.

      Lemma mapsto_restrict_dom_singleton : forall x T E,
          MapsTo x T E -> MapsTo x T (restrict_dom E (singleton x)).

      Proof. intros x T E h. rewrite mapsto_restrict_dom. set_iff. auto with ordered_type. Qed.

(****************************************************************************)
(** ** Domain of a typing environment. *)

      Definition dom_fun x (T:A) xs := XSet.add x xs.

      Global Instance dom_fun_e :
        Proper (E.eq ==> Logic.eq ==> XSet.Equal ==> XSet.Equal) dom_fun.

      Proof.
        intros x y xy T V TV s t st. subst. unfold dom_fun. rewrite xy, st. refl.
      Qed.

      Lemma dom_fun_transp : transpose_neqkey XSet.Equal dom_fun.

      Proof. intros x y xy T V E. unfold dom_fun. apply add_add. Qed.

      Definition dom E := fold dom_fun E XSet.empty.

      Global Instance dom_e : Proper (Equal ==> XSet.Equal) dom.

      Proof.
        intros E F EF. unfold dom. apply fold_Equal. fo. apply dom_fun_e. hyp.
      Qed.

      Lemma dom_empty : dom empty [=] XSet.empty.

      Proof. unfold dom. rewrite fold_Empty. refl. fo. apply empty_1. Qed.

      Lemma dom_add_notin : forall x T E,
          ~In x E -> dom (add x T E) [=] XSet.add x (dom E).

      Proof.
        intros x T E h. unfold dom. rewrite fold_add. refl. fo. apply dom_fun_e.
        apply dom_fun_transp. hyp.
      Qed.

      Lemma In_dom : forall x E, XSet.In x (dom E) <-> In x E.

      Proof.
        intros x E; pattern E; apply map_induction_bis; clear E.
        (* Equal *)
        intros E F EF h. rewrite <- EF. hyp.
        (* empty *)
        rewrite dom_empty, empty_in_iff. set_iff. refl.
        (* add *)
        intros y T E hy h. rewrite dom_add_notin. 2: hyp.
        set_iff. rewrite add_in_iff, h. refl.
      Qed.

      Lemma dom_add : forall x T E, dom (add x T E) [=] XSet.add x (dom E).

      Proof.
        intros x T E y. rewrite In_dom, add_in_iff, <- In_dom. set_iff. refl.
      Qed.

    End S.

  End Domain.

End Make.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal27.

Set Printing Depth 1000.
Definition lfind_eval  x:=
append (rev x) Nil.

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero Nil)))).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) Nil).

Compute lfind_eval  (Nil).


(************************************************************************)
(* Copyright 2007 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses/lgpl.txt>              *)
(************************************************************************)

Require Import Arith Omega.

Require OrderedTypeEx.
Require FSetList.
Require Extraction.
Module NatSet := FSetList.Make(OrderedTypeEx.Nat_as_OT).
Import NatSet.

Notation " A ⇒ B " := (A -> B) (at level 90, right associativity) : type_scope.
Notation " ∀ x , B  " := (forall x:_, B ) (at level 200, x at level 0, no associativity) : type_scope.
Notation " ∀ x y , B  " := (forall (x:_) (y:_), B ) (at level 200, x at level 0, y at level 0, no associativity) : type_scope.
Notation " ∀ x y z , B  " := (forall (x:_) (y:_) (z:_), B ) (at level 200, x at level 0, y at level 0, z at level 0, no associativity) : type_scope.
Notation " ¬ x " := (not  x) (at level 75, right associativity) : type_scope.
Notation " A ∧ B " := (A /\ B) (at level 80, right associativity) : type_scope.
Notation " A ∨ B " := (sumor A B) (at level 85, right associativity) : type_scope.
Notation " A \/ B " := (sumbool A B) (at level 85, right associativity) : type_scope.
Notation " ∃ x , B  " := (sig (fun x:_=>B) ) (at level 0, x at level 99, no associativity) : type_scope.
Notation " A × B " := (A * B) (at level 40, left associativity) : type_scope.
Notation " 'ℕ' " := nat : type_scope.
Infix " ≤ " := le (at level 70, right associativity): nat_scope.
Notation "s ≐ t" := (Equal s t) (at level 70, no associativity).
Infix "∈" := In (at level 30, no associativity).
Infix "⊆" := Subset (at level 70, right associativity).
Infix "\" := diff (at level 40, left associativity).
Notation "| A |" := (cardinal A) (at level 10, no associativity).
Infix "≡" := E.eq (at level 70, no associativity).
Infix "∩" := inter (at level 40, left associativity).
Infix "∪" := union (at level 50, left associativity).
Notation " { x } ∪ X " := (add x X) (at level 50, left associativity).
Notation " X \ { x } " := (remove x X) (at level 40, left associativity).
Notation "∅" := empty.

Require FSetFacts FSetProperties.

Module GeneralProperties := FSetProperties.Properties NatSet.
Import GeneralProperties.

Section problem_knows_not_refl.

Variable town: t.
Variable n:ℕ.
Variable cardinality: | town | = 2×n+1.

Variable knows: elt ⇒ elt ⇒ Prop.
Infix "ℛ" := knows (at level 70, no associativity).

Variable knows_sym: ∀m n, m ℛ n ⇒ n ℛ m.
Variable knows_extensional:∀m n p, n≡p ⇒ m ℛ n⇒ m ℛ p.

Variable property: ∀B, B ⊆ town ⇒ |B| = n ⇒
           ∃d, d∈(town\B) /\ (∀b, b∈B ⇒ d ℛ b).

Lemma extendible_by_one:∀ B', |B'| ≤ |town| -1 ⇒ ∃d, d∈town ∧ ¬(d∈B').
Proof.
 clear knows knows_sym knows_extensional property.
 intros B' H_cardinal_town.
 assert (H_town:1≤ |town|); [omega|].
 rewrite <- (diff_inter_cardinal town B') in H_cardinal_town.
 rewrite <- (diff_inter_cardinal town B') in H_town.
 assert (H_inter:|town∩B'| ≤ |B'|);
  [apply (subset_cardinal);apply (inter_subset_2)|].
 generalize (le_trans _ _ _ H_inter H_cardinal_town); intro H1.
 assert (H2:1≤|town\B'|); [omega|].
 assert (H3:=(S_pred _ _ H2)).
 destruct (cardinal_inv_2 H3) as [d Hd].
 exists d; split.
  apply diff_1 with B'; assumption.
  apply diff_2 with town; assumption.
Qed.

Lemma extendible_to_n:∀ B', B'⊆town ⇒ |B'| ≤ n ⇒ ∃B, |B| = n ∧  B'⊆B ∧ B⊆town.
Proof.
 intros B' H_sub H_B'_cardinal.
 assert (H_cardinal_aux_3:2×n≤ |town| -1);[apply le_trans with (2×n); omega|].
 clear property.
 induction n in H_B'_cardinal, H_cardinal_aux_3 |- *.
 (* n = 0 *)
 generalize (sym_eq (le_n_O_eq _ H_B'_cardinal)); intro H_eq.
 generalize (empty_is_empty_1 (cardinal_inv_1 H_eq)).
 intro H_B'.
 exists ∅; repeat split.
  rewrite H_B'; apply subset_empty.
  apply subset_empty.
 (* n = S n0 *)
 destruct (le_lt_eq_dec _ _ H_B'_cardinal) as [H_lt|H_le].
  generalize (lt_n_Sm_le _ _ H_lt); clear H_lt; intro H_le.
  assert (H_cardinal_town_2:2 * n0 ≤ |town| - 1);[omega|].
  destruct (IHn0 H_le H_cardinal_town_2) as [C [HC1 [HC2 HC3]]].
  assert (HC5:|C| ≤ |town| - 1).
   rewrite HC1; apply le_trans with (2×(S n0));[omega| assumption].
  destruct (extendible_by_one C HC5) as [d [Hd1 Hd2]].
  exists ({d} ∪ C).
  repeat split.
   rewrite (add_cardinal_2 Hd2); rewrite HC1; reflexivity.
   apply subset_add_2; assumption.
   apply subset_add_3; assumption.

  exists B'.
  repeat split; trivial; apply subset_refl.
Qed.

(** The following property, proven by induction, is the heart of the
solution, and is due to Tonny Hurkens. *)
Lemma inductive_invariant:∀ m, m≤ n ⇒
                ∃B', B'⊆town ∧ |B'| = m ∧ ∀ b'₀ b'₁, b'₀∈B' ⇒ b'₁∈B' ⇒ ¬(b'₀≡b'₁) ⇒ b'₀ ℛ b'₁.
Proof.
 intros m.
 induction m; intros H_le.
  (* 0 *)
  exists ∅.
  repeat split.
   apply subset_empty.
   intros b'₀ b'₁ H0 H1; apply False_ind.
   elim (FM.empty_iff b'₀); intros H2 _; apply H2; assumption.
  (* S n *)
  assert (H_le0:=le_Sn_le _ _ H_le).
  destruct (IHm H_le0) as [B' [H3' [H1 H2]]].
  rewrite <- H1 in H_le0.
  destruct (extendible_to_n B' H3' H_le0) as [B [HB1 [HB2 HB3]]].
  destruct (property B HB3 HB1) as [d [Hd1 Hd2]].
  exists ({d}∪ B'); repeat split.
   (* subset of town *)
   apply subset_add_3.
   apply diff_1 with B; assumption.
   apply subset_trans with B; assumption.
   (* cardinality *)
   rewrite <- H1.
   apply add_cardinal_2.
   intro Hd4.
   generalize (in_subset Hd4 HB2).
   apply diff_2 with town; assumption.
(* second big goal *)
   intros b'₀ b'₁ H_b'₀ H_b'₁ H_neq.
   destruct ((proj1 (FM.add_iff B' d b'₀)) H_b'₀) as [H3|H3].
    apply knows_sym; apply knows_extensional with d; trivial.
    destruct ((proj1 (FM.add_iff B' d b'₁)) H_b'₁) as [H4|H4].
     apply False_ind; apply H_neq; rewrite <- H3; assumption.
     apply knows_sym.
     apply Hd2; apply in_subset with B'; trivial.
    destruct ((proj1 (FM.add_iff B' d b'₁)) H_b'₁) as [H4|H4].
     apply knows_extensional with d; trivial.
     apply knows_sym.
     apply Hd2; apply in_subset with B'; trivial.
     apply H2; assumption.
Qed.

Theorem AMM11262: ∃e,e∈town ∧ ∀ u, u∈town ∧ ¬(u≡e)⇒ e ℛ u.
Proof.
 destruct (inductive_invariant n (le_refl n)) as [B [HB1 [HB2 HB3]]].
 destruct (property B HB1 HB2) as [d [Hd1 Hd2]].
 set (C:=(town\({d}∪B))).
 (* C subset town *)
 assert (H_susbset_C:C⊆town);
 [ subst C; apply subset_diff; apply subset_refl
 | ].
 (* inter town *)
 assert (H_inter_town: (town∩ ({d}∪B)) ≐ {d} ∪ B).
  rewrite inter_sym; apply inter_subset_equal;
  apply subset_add_3; trivial; apply diff_1 with B; assumption.
 (* ¬ d∈B *)
 assert (H_d_nin_B:¬d∈B); [apply diff_2 with town; assumption|].
 (* |C| = n *)
 assert (H_cardinal_C:|C| =n).
  assert (H_aux:|town∩({d}∪B)|=S n).
   rewrite (@Equal_cardinal (town∩({d}∪B)) ({d}∪B) H_inter_town);
   rewrite (add_cardinal_2 H_d_nin_B); rewrite HB2; reflexivity.
  generalize (diff_inter_cardinal town ({d}∪B));
  fold C; rewrite H_aux; rewrite cardinality; omega.

 destruct (property C H_susbset_C H_cardinal_C) as [e [He1 He2]].
 exists e.
 (* ({d}∪B)⊆town *)
 assert (H_dB_town:({d}∪B)⊆town).
  intros a Ha0; destruct ((proj1 (FM.add_iff B d a)) Ha0) as [Had|HaB].
   rewrite <- Had; apply diff_1 with B; assumption.
   apply HB1; assumption.
 (* town\C = {d}∪B *)
 assert (H_diff: town\C ≐ {d}∪B ).
  unfold C; split; intro H_mem.
   (* ≥ *)
   assert (H_a0:=diff_1 H_mem);
   assert (H_a1:=diff_2 H_mem);
   destruct (In_dec a ({d}∪B)) as [H_a2|H_a2]; trivial;
   apply False_ind; apply H_a1; exact (diff_3 H_a0 H_a2).
   (* ≤ *)
   destruct (In_dec a (town\({d}∪B))) as [H_a2|H_a2].
    apply False_ind; exact (diff_2 H_a2 H_mem).
    apply diff_3; trivial; apply H_dB_town; assumption.
 (* e∈({d}∪B) *)
 assert (H_e_dB:e∈({d}∪B)); [rewrite <- H_diff; assumption|].

 split.
  apply diff_1 with C; assumption...
  intros u [Hu Hu'].
  assert (H_town_part:town ≐ (C∪({d}∪B))).
   rewrite <- (diff_inter_all town ({d}∪B)); rewrite H_inter_town; apply equal_refl.
   rewrite H_town_part in Hu.
   destruct (union_1 Hu) as [HuC|HudB].
    (* u∈C *)
    apply He2; assumption.
    (* u∈({d}∪B) *)
    destruct ((proj1 (FM.add_iff B d u)) HudB) as [Hud|HuB].
     (* d=u *)
     apply knows_extensional with d; trivial.
     apply knows_sym.
     destruct ((proj1 (FM.add_iff B d e)) H_e_dB) as [Hed|HeB].
      (* d=e *)
      apply False_ind; apply Hu'; rewrite <- Hud; assumption.
      (* e∈B *)
      apply Hd2; assumption.
     (* u∈B *)
     destruct ((proj1 (FM.add_iff B d e)) H_e_dB) as [Hed|HeB].
      (* d=e *)
      apply knows_sym; apply knows_extensional with d; trivial;
      apply knows_sym; apply Hd2; assumption.
      (* e∈B *)
      apply HB3; assumption || contradict Hu'; auto with *.
Qed.

End problem_knows_not_refl.

Extraction "amm11262" AMM11262.


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

(** BFN (Breadth-First Numbering) is a particular instance of
    BFR (Breadth-First Reconstruction)   *)

Require Import List Arith Omega Extraction.
Require Import list_utils wf_utils.
Require Import bt bft_inj fifo bfn_fifo bfr_fifo.

Set Implicit Arguments.

Module BFR_BFN_FIFO (Q: FIFO).

  Export Q.

  Module MBFN := BFN_FIFO Q.
  Module MBFR := BFR_FIFO Q.

  Export MBFN MBFR.

  Theorem bfr_bfn_fifo (X:Type) (t : bt X) : bfn_fifo t = bfr_fifo t (seq_an 1 (m_bt t)) (eq_sym (seq_an_length _ _)).
  Proof.
    apply bft_std_inj.
    * apply bt_eq_trans with (s := t).
      + apply bt_eq_sym, bfn_fifo_spec_1.
      + apply bfr_fifo_spec_1.
    * rewrite bfr_fifo_spec_2, bfn_fifo_spec_3; trivial.
  Qed.

End BFR_BFN_FIFO.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteTask.

  Import SporadicTaskset.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_task :=
    {
      task_id: nat; (* for uniqueness *)
      task_cost: nat;
      task_period: nat;
      task_deadline: nat;
      task_suspension_bound: nat
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete tasks. *)
    Definition task_eqdef (t1 t2: concrete_task) :=
      (task_id t1 == task_id t2) &&
      (task_cost t1 == task_cost t2) &&
      (task_period t1 == task_period t2) &&
      (task_deadline t1 == task_deadline t2) &&
      (task_suspension_bound t1 == task_suspension_bound t2).

    (* Next, we prove that task_eqdef is indeed an equality, ... *)
    Lemma eqn_task : Equality.axiom task_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (task_eqdef x y) eqn:EQ.
      {
        apply ReflectT.
        unfold task_eqdef in *.
        move: EQ => /andP [/andP [/andP [/andP [/eqP ID /eqP COST] /eqP PERIOD] /eqP DL] /eqP SUSP].
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold task_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [/orP [EQ | /eqP DL] | /eqP SUSP]; last by apply SUSP; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP DL]; last by apply DL; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP PERIOD]; last by apply PERIOD; inversion BUG.
        by apply ID; inversion BUG.
        by apply DL; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_task_eqMixin := EqMixin eqn_task.
    Canonical concrete_task_eqType := Eval hnf in EqType concrete_task concrete_task_eqMixin.

  End Defs.

  Section ConcreteTaskset.

    Definition concrete_taskset :=
      taskset_of concrete_task_eqType.

  End ConcreteTaskset.

End ConcreteTask.


Add LoadPath "somePath".

Require Export DNF.

(*----------cons decide----------*)

Lemma conj_full_ncons_max_point : forall f:propForm, [[f]]full_environment -> conj_propForm f ->
  forall x:propVar, ~propForm_cons f (var x) -> [[f]]environment_max_point x.
Proof.
intros.
induction f;simpl in *;auto.
unfold environment_max_point.
assert (beq_nat x p=false).
apply (beq_nat_false_iff).
intro.
apply H1.
rewrite H2;intro;auto.
rewrite H2;auto.
inversion H0.
destruct H.
destruct H0.
assert (~propForm_cons f1 (var x)).
intro.
apply H1.
intro;intro.
destruct H5;auto.
assert (~propForm_cons f2 (var x)).
intro.
apply H1.
intro;intro.
destruct H6;auto.
split.
apply IHf1;auto.
apply IHf2;auto.
Qed.

Lemma conj_cons_propForm_decidable : forall f g:propForm, conj_propForm f ->
  (propForm_cons f g \/ exists theta:environment, ([[f]]theta /\ ~[[g]]theta)).
Proof.
intros.
destruct (eqv_propForm_bot_decidable f).
left;intro;intro.
destruct (H0 theta).
destruct H2;auto.
destruct (eqv_top_decidable g).
left;intro;intro.
apply (H1 theta);simpl;auto.
induction g;simpl in *;auto.
left;intro;intro;simpl;auto.
right.
exists (full_environment).
split;simpl;auto.
apply neqv_bot_full_true;auto.
destruct (var_cons_propForm_decidable f p);auto.
right.
exists (environment_max_point p).
split.
apply conj_full_ncons_max_point;auto.
apply neqv_bot_full_true;auto.
unfold environment_max_point.
rewrite <- (beq_nat_refl p);intro.
inversion H3.
assert (~propForm_eqv g1 top).
intro.
apply H1.
split;intro;simpl;auto.
left;apply H2;auto.
assert (~propForm_eqv g2 top).
intro.
apply H1.
split;intro;simpl;auto.
right;apply H3;auto.
destruct (IHg1 H2).
left;intro;intro.
left;apply H4;auto.
destruct (IHg2 H3).
left;intro;intro.
right;apply H5;auto.
destruct H4 as [theta1 H4].
destruct H5 as [theta2 H5].
right.
exists (environment_intersect theta1 theta2).
destruct H4.
destruct H5.
split.
apply env_intersect_conj;auto.
intro.
destruct (environment_intersect_distributes_neg theta1 theta2 g1 g2);auto.
destruct H8;contradiction.
destruct (eqv_top_decidable g1).
assert (~propForm_eqv g2 top).
intro.
apply H1.
split;intro;simpl;auto.
split.
apply H2;auto.
apply H3;auto.
destruct (IHg2 H3).
left;intro;intro.
split.
apply H2;simpl;auto.
apply H4;auto.
destruct H4 as [theta H4].
destruct H4.
right.
exists theta.
split;auto.
intro.
destruct H6;contradiction.
destruct (eqv_top_decidable g2).
destruct (IHg1 H2).
left;intro;intro.
split.
apply H4;auto.
apply H3;simpl;auto.
destruct H4 as [theta H4].
destruct H4.
right.
exists theta.
split;auto.
intro.
destruct H6;contradiction.
destruct (IHg1 H2).
destruct (IHg2 H3).
left;intro;intro.
split.
apply H4;auto.
apply H5;auto.
destruct H5 as [theta H5].
destruct H5.
right.
exists theta;split;auto.
intro.
destruct H7;contradiction.
destruct H4 as [theta H5].
destruct H5.
right.
exists theta;split;auto.
intro.
destruct H6;contradiction.
Qed.

Lemma DNF_cons_propForm_decidable : forall f g:propForm, DNF_propForm f ->
  (propForm_cons f g \/ exists theta:environment, ([[f]]theta /\ ~[[g]]theta)).
Proof.
intros.
induction H using DNF_ind.
apply (conj_cons_propForm_decidable top g).
unfold conj_propForm;unfold singleton_propForm;auto.
apply (conj_cons_propForm_decidable bot g).
unfold conj_propForm;unfold singleton_propForm;auto.
apply (conj_cons_propForm_decidable (var x) g).
unfold conj_propForm;unfold singleton_propForm;auto.
apply (conj_cons_propForm_decidable (f /\p g0) g).
split;auto.
destruct IHDNF_propForm1.
destruct IHDNF_propForm2.
left;intro;intro.
destruct H3.
apply H1;auto.
apply H2;auto.
destruct H2 as [theta H2].
destruct H2.
right.
exists theta;split;auto.
right;auto.
destruct H1 as [theta H1].
destruct H1.
right.
exists theta;split;auto.
left;auto.
Qed.

Lemma propForm_cons_propForm_decidable : forall f g:propForm,
  (propForm_cons f g \/ exists theta:environment, ([[f]]theta /\ ~[[g]]theta)).
Proof.
intros.
destruct (DNF_cons_propForm_decidable (toDNF f) g).
apply DNF_toDNF;auto.
left.
intro;intro.
apply H;apply cons_toDNF;auto.
right.
destruct H as [theta H].
destruct H.
exists theta.
split;auto.
apply toDNF_cons;auto.
Qed.

Lemma conj_cons_disj_decide : forall c f g:propForm, conj_propForm c ->
  propForm_cons c (f \/p g) -> (propForm_cons c f \/ propForm_cons c g).
Proof.
intros.
destruct (propForm_cons_propForm_decidable c f);auto.
destruct (propForm_cons_propForm_decidable c g);auto.
destruct H1 as [theta1 H1].
destruct H2 as [theta2 H2].
destruct H1.
destruct H2.
destruct (environment_intersect_distributes_neg theta1 theta2 f g).
split;auto.
destruct (H0 (environment_intersect theta1 theta2) (env_intersect_conj c H theta1 theta2 H1 H2));contradiction.
Qed.

Lemma propForm_eqv_decidable : forall f g:propForm, propForm_eqv f g \/ ~propForm_eqv f g.
Proof.
intros.
destruct (propForm_cons_propForm_decidable f g).
destruct (propForm_cons_propForm_decidable g f).
left;split;intro.
apply H;auto.
apply H0;auto.
destruct H0.
destruct H0.
right;intro.
destruct (H2 x).
assert ([[f]]x);auto.
destruct H.
destruct H.
right;intro.
destruct (H1 x).
assert ([[g]]x);auto.
Qed.