(***************************************************************)
(* Basci Coq lib                                               *)
(***************************************************************)
Require Import Omega.
Require Export ZArith.
Require Export Znumtheory.
Require Export List.
Require Export Bool.

(* *********************************************************************** *)
(** * The [skip] tactic from Stephanie Weirich and Brian Andemir of UPenn  *)

(** The [skip] tactic will prove any goal, since we assert below that
    [False] is provable.  This is a useful technique for skipping over
    troublesome parts of proofs.  In a complete development, one would
    comment out the [skip] axiom and tactic.

    In the exercises below, [skip] lets us give partial proofs by
    using it as a placeholder for locations in the proof script where
    the reader should fill in the proof.
*)
(* Axiom false_false : forall P, P. *)
(* Ltac skip := apply false_false. *)
(* *)

(** Section 1: optionT and pairT **)
Axiom extensionality:
  forall (A B: Set) (f g : A -> B),
  (forall x, f x = g x) -> f = g.

Inductive OptionT (T : Type) : Type :=
    NoneT1 : OptionT T
  | SomeT1 : T -> OptionT T.

Inductive optionT (A : Type) : Type :=
  | SomeT : A -> optionT A
  | NoneT : optionT A.

Implicit Arguments SomeT [A].
Implicit Arguments NoneT [A].

Notation opt_predT :=
  (fun opt:optionT _ =>
    fun f =>
      match opt with
	| SomeT t => f t
	| NoneT => False
      end).

Notation optpT :=
  (fun f => fun opt:optionT _ =>
    match opt with
      | SomeT t => f t
      | NoneT => False
    end).

Notation optgT :=
  (fun f => fun opt:optionT _ =>
    fun t' =>
      match opt with
        | SomeT t => f t t'
        | NoneT => False
      end).

Notation opt_predT2 :=
  (fun opt:optionT _ =>
    fun opt':optionT _ =>
      fun f =>
	match opt, opt' with
	  | SomeT t, SomeT t' => f t t'
	  | _, _ => False
	end).

Inductive prodT (A : Set) (B : Type) : Type :=
    pairT : A -> B -> prodT A B.
Implicit Arguments pairT [A B].

Notation "( x , y , .. , z )" :=
  (pairT .. (pairT x y) .. z) : t_type_scope.

(** Section 2: Tactics **)
(***************************************************************)

Ltac hypreplace H y :=
  let H' := fresh in
    (assert (H' := y); try (clear H; rename H' into H)).

Ltac hypreplace2 H y Hn:=
  let H' := fresh in
    (assert (H' := y); try (clear H; rename H' into Hn)).

Tactic Notation "substH" hyp (H) :=
  match goal with
    | |- ?a -> ?b => clear H; intro H
    | |- _ => fail 1 "goal must be 'A -> B'."
  end.

Tactic Notation "substH" hyp (H) "with" constr (t) :=
  hypreplace H t.

Tactic Notation "substH" hyp (H) "with" constr (t) "into" ident (Hn) :=
  hypreplace2 H t Hn.

Tactic Notation "bool_destruct" hyp (H) "as" simple_intropattern (pat) :=
  let H0 := fresh "H" in
    (rename H into H0;
    match type of (H0) with
      | (andb ?a ?b = true) =>
        destruct (andb_prop a b H0) as pat; clear H0
      | (orb ?a ?b = true) =>
        destruct (orb_prop a b H0) as pat; clear H0
      | _ => fail "not destructable"
    end).

Tactic Notation "destructH" hyp (H) "with" constr (t) :=
  destruct t; clear H.

Tactic Notation "destructH" hyp (H) "with" constr (t)
  "as" simple_intropattern (p) :=
  destruct t as p; clear H.

Tactic Notation "discri" :=
  match goal with
    | H : ?a <> ?a |- _ =>
      elimtype False; apply H; reflexivity
    | |- _ -> _ => intros; discriminate
    | H : False |- _ => destruct H
    | _ => discriminate
  end.

Tactic Notation "gen_clear" hyp (H) :=
  generalize H; clear H.

Tactic Notation "gen_clear" hyp (H1) hyp (H2) :=
  generalize H1 H2; clear H1 H2.

Tactic Notation "gen_clear"
  hyp (H1) hyp (H2) hyp (H3) :=
  generalize H1 H2 H3; clear H1 H2 H3.

Tactic Notation "gen_clear"
  hyp (H1) hyp (H2) hyp (H3) hyp (H4) :=
  generalize H1 H2 H3 H4;
    clear H1 H2 H3 H4.

Tactic Notation "gen_clear"
  hyp (H1) hyp (H2) hyp (H3)
  hyp (H4) hyp (H5):=
  generalize H1 H2 H3 H4 H5;
    clear H1 H2 H3 H4 H5.

Tactic Notation "gen_clear"
  hyp (H1) hyp (H2) hyp (H3)
  hyp (H4) hyp (H5) hyp (H6):=
  generalize H1 H2 H3 H4 H5 H6;
    clear H1 H2 H3 H4 H5 H6.

Tactic Notation "split_l" :=
  split; [trivial | idtac].

Tactic Notation "split_r" :=
  split; [idtac | trivial ].

Tactic Notation "split_lr" :=
  split; [trivial | trivial ].

Tactic Notation "split_l" "with" constr (t) :=
  split; [apply t | idtac].

Tactic Notation "split_r" "with" constr (t) :=
  split; [idtac | apply t ].

Tactic Notation "split_l" "by" tactic (tac) :=
  split; [tac | idtac ].

Tactic Notation "split_r" "by" tactic (tac) :=
  split; [idtac | tac ].

Tactic Notation "split_l_clear" "with" hyp (H) :=
  split; [apply H | clear H].

Tactic Notation "split_r_clear" "with" hyp (H) :=
  split; [clear H | apply H ].

Lemma and_sym : forall (A B : Prop), A /\ B -> B /\ A.
Proof. intros  A B [HA HB]; split; trivial. Qed.
Implicit Arguments and_sym [A B].

Ltac rsplit := apply and_sym; split.

Lemma and_sym_rr : forall A B C : Prop, A /\ B /\ C -> B /\ C /\ A.
Proof.
  tauto.
Qed.

Ltac rrsplit := apply and_sym_rr; split.

Tactic Notation "inj_hyp" hyp (H) :=
  injection H; clear H; intro H.

Tactic Notation "rew_clear" hyp (H) :=
  rewrite H; clear H.

Tactic Notation "injection" hyp (H) :=
  injection H.

Tactic Notation "injection" hyp (H) "as"
  simple_intropattern (pat) :=
  injection H; intros pat.

Tactic Notation "injsubst" ident (id) "in" hyp (H) :=
  injection H; intro; subst id; clear H.

Ltac InvertAll :=
  repeat
    match goal with
      | H: _ /\ _ |- _ => inversion_clear H
      | H: ex _   |- _ => inversion_clear H
    end.

Ltac arith_replace t1 t2 :=
  (replace t1 with t2; fail "error") ||
    (replace t1 with t2; [trivial | try omega; fail "error" ]).

Ltac arith_replaceH H t1 t2 :=
  (replace t1 with t2 in H; fail "error") ||
    (replace t1 with t2 in H; [trivial | try omega; fail "error" ]).

Tactic Notation "arith_rep" constr(t1) "with" constr (t2) :=
  arith_replace t1 t2.

Tactic Notation "arith_rep" constr(t1) "with" constr (t2) "in" hyp (H):=
  arith_replaceH H t1 t2.

Ltac clearall :=
  match goal with
    | H : _ |- _ =>
      (clear H || (generalize H; clear H)); clearall
    | _ => intros
  end.

Ltac clearall_arith :=
  match goal with
    | H : ?a > ?b |- _ => (generalize H; clear H); clearall_arith
    | H : ?a >= ?b |- _ => (generalize H; clear H); clearall_arith
    | H : ?a < ?b |- _ => (generalize H; clear H); clearall_arith
    | H : ?a <= ?b |- _ => (generalize H; clear H); clearall_arith
    | H : ?a = ?b |- _ =>
      match type of a with
        | nat => (generalize H; clear H); clearall_arith
        | _ => (clear H || (generalize H; clear H)); clearall_arith
      end
    | H : _ |- _ =>
      (clear H || (generalize H; clear H)); clearall_arith
    | _ => intros
  end.

(** * Useful tactics *)

Ltac inv H := inversion H; clear H; subst.

Ltac predSpec pred predspec x y :=
  generalize (predspec x y); case (pred x y); intro.

Ltac caseEq name :=
  generalize (refl_equal name); pattern name at -1 in |- *; case name.

Ltac destructEq name :=
  destruct name eqn:?.

Ltac decEq :=
  match goal with
  | [ |- _ = _ ] => f_equal
  | [ |- (?X ?A <> ?X ?B) ] =>
      cut (A <> B); [intro; congruence | try discriminate]
  end.

Ltac byContradiction :=
  cut False; [contradiction|idtac].

Ltac omegaContradiction :=
  cut False; [contradiction|omega].

Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q.
Proof. auto. Qed.

Ltac exploit x :=
    refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _) _)
 || refine (modusponens _ _ (x _ _) _)
 || refine (modusponens _ _ (x _) _).

(** * Definitions and theorems over the type [positive] *)

Definition peq: forall (x y: positive), {x = y} + {x <> y} := Pos.eq_dec.
Global Opaque peq.

Lemma peq_true:
  forall (A: Type) (x: positive) (a b: A), (if peq x x then a else b) = a.
Proof.
  intros. case (peq x x); intros.
  auto.
  elim n; auto.
Qed.

Lemma peq_false:
  forall (A: Type) (x y: positive) (a b: A), x <> y -> (if peq x y then a else b) = b.
Proof.
  intros. case (peq x y); intros.
  elim H; auto.
  auto.
Qed.

Definition Plt: positive -> positive -> Prop := Pos.lt.

Lemma Plt_ne:
  forall (x y: positive), Plt x y -> x <> y.
Proof.
  unfold Plt; intros. red; intro. subst y. eelim Pos.lt_irrefl; eauto.
Qed.
Hint Resolve Plt_ne: coqlib.

Lemma Plt_trans:
  forall (x y z: positive), Plt x y -> Plt y z -> Plt x z.
Proof (Pos.lt_trans).

Lemma Plt_succ:
  forall (x: positive), Plt x (Psucc x).
Proof.
  unfold Plt; intros. apply Pos.lt_succ_r. apply Pos.le_refl.
Qed.
Hint Resolve Plt_succ: coqlib.

Lemma Plt_trans_succ:
  forall (x y: positive), Plt x y -> Plt x (Psucc y).
Proof.
  intros. apply Plt_trans with y. assumption. apply Plt_succ.
Qed.
Hint Resolve Plt_succ: coqlib.

Lemma Plt_succ_inv:
  forall (x y: positive), Plt x (Psucc y) -> Plt x y \/ x = y.
Proof.
  unfold Plt; intros. rewrite Pos.lt_succ_r in H.
  apply Pos.le_lteq; auto.
Qed.

Definition plt (x y: positive) : {Plt x y} + {~ Plt x y}.
Proof.
  unfold Plt, Pos.lt; intros. destruct (Pos.compare x y).
  - right; congruence.
  - left; auto.
  - right; congruence.
Defined.
Global Opaque plt.

Definition Ple: positive -> positive -> Prop := Pos.le.

Lemma Ple_refl: forall (p: positive), Ple p p.
Proof (Pos.le_refl).

Lemma Ple_trans: forall (p q r: positive), Ple p q -> Ple q r -> Ple p r.
Proof (Pos.le_trans).

Lemma Plt_Ple: forall (p q: positive), Plt p q -> Ple p q.
Proof (Pos.lt_le_incl).

Lemma Ple_succ: forall (p: positive), Ple p (Psucc p).
Proof.
  intros. apply Plt_Ple. apply Plt_succ.
Qed.

Lemma Plt_Ple_trans:
  forall (p q r: positive), Plt p q -> Ple q r -> Plt p r.
Proof (Pos.lt_le_trans).

Lemma Plt_strict: forall p, ~ Plt p p.
Proof (Pos.lt_irrefl).

Hint Resolve Ple_refl Plt_Ple Ple_succ Plt_strict: coqlib.

Ltac xomega := unfold Plt, Ple in *; zify; omega.
Ltac xomegaContradiction := exfalso; xomega.

(** Peano recursion over positive numbers. *)

Section POSITIVE_ITERATION.

Lemma Plt_wf: well_founded Plt.
Proof.
  apply well_founded_lt_compat with nat_of_P.
  intros. apply nat_of_P_lt_Lt_compare_morphism. exact H.
Qed.

Variable A: Type.
Variable v1: A.
Variable f: positive -> A -> A.

Lemma Ppred_Plt:
  forall x, x <> xH -> Plt (Ppred x) x.
Proof.
  intros. elim (Psucc_pred x); intro. contradiction.
  set (y := Ppred x) in *. rewrite <- H0. apply Plt_succ.
Qed.

Let iter (x: positive) (P: forall y, Plt y x -> A) : A :=
  match peq x xH with
  | left EQ => v1
  | right NOTEQ => f (Ppred x) (P (Ppred x) (Ppred_Plt x NOTEQ))
  end.

Definition positive_rec : positive -> A :=
  Fix Plt_wf (fun _ => A) iter.

Lemma unroll_positive_rec:
  forall x,
  positive_rec x = iter x (fun y _ => positive_rec y).
Proof.
  unfold positive_rec. apply (Fix_eq Plt_wf (fun _ => A) iter).
  intros. unfold iter. case (peq x 1); intro. auto. decEq. apply H.
Qed.

Lemma positive_rec_base:
  positive_rec 1%positive = v1.
Proof.
  rewrite unroll_positive_rec. unfold iter. case (peq 1 1); intro.
  auto. elim n; auto.
Qed.

Lemma positive_rec_succ:
  forall x, positive_rec (Psucc x) = f x (positive_rec x).
Proof.
  intro. rewrite unroll_positive_rec. unfold iter.
  case (peq (Psucc x) 1); intro.
  destruct x; simpl in e; discriminate.
  rewrite Ppred_succ. auto.
Qed.

Lemma positive_Peano_ind:
  forall (P: positive -> Prop),
  P xH ->
  (forall x, P x -> P (Psucc x)) ->
  forall x, P x.
Proof.
  intros.
  apply (well_founded_ind Plt_wf P).
  intros.
  case (peq x0 xH); intro.
  subst x0; auto.
  elim (Psucc_pred x0); intro. contradiction. rewrite <- H2.
  apply H0. apply H1. apply Ppred_Plt. auto.
Qed.

End POSITIVE_ITERATION.

(** * Definitions and theorems over the type [Z] *)

Definition zeq: forall (x y: Z), {x = y} + {x <> y} := Z.eq_dec.

Lemma zeq_true:
  forall (A: Type) (x: Z) (a b: A), (if zeq x x then a else b) = a.
Proof.
  intros. case (zeq x x); intros.
  auto.
  elim n; auto.
Qed.

Lemma zeq_false:
  forall (A: Type) (x y: Z) (a b: A), x <> y -> (if zeq x y then a else b) = b.
Proof.
  intros. case (zeq x y); intros.
  elim H; auto.
  auto.
Qed.

Open Scope Z_scope.

Definition zlt: forall (x y: Z), {x < y} + {x >= y} := Z_lt_dec.

Lemma zlt_true:
  forall (A: Type) (x y: Z) (a b: A),
  x < y -> (if zlt x y then a else b) = a.
Proof.
  intros. case (zlt x y); intros.
  auto.
  omegaContradiction.
Qed.

Lemma zlt_false:
  forall (A: Type) (x y: Z) (a b: A),
  x >= y -> (if zlt x y then a else b) = b.
Proof.
  intros. case (zlt x y); intros.
  omegaContradiction.
  auto.
Qed.

Definition zle: forall (x y: Z), {x <= y} + {x > y} := Z_le_gt_dec.

Lemma zle_true:
  forall (A: Type) (x y: Z) (a b: A),
  x <= y -> (if zle x y then a else b) = a.
Proof.
  intros. case (zle x y); intros.
  auto.
  omegaContradiction.
Qed.

Lemma zle_false:
  forall (A: Type) (x y: Z) (a b: A),
  x > y -> (if zle x y then a else b) = b.
Proof.
  intros. case (zle x y); intros.
  omegaContradiction.
  auto.
Qed.

(** Properties of powers of two. *)

Lemma two_power_nat_O : two_power_nat O = 1.
Proof. reflexivity. Qed.

Lemma two_power_nat_pos : forall n : nat, two_power_nat n > 0.
Proof.
  induction n. rewrite two_power_nat_O. omega.
  rewrite two_power_nat_S. omega.
Qed.

Lemma two_power_nat_two_p:
  forall x, two_power_nat x = two_p (Z_of_nat x).
Proof.
  induction x. auto.
  rewrite two_power_nat_S. rewrite inj_S. rewrite two_p_S. omega. omega.
Qed.

Lemma two_p_monotone:
  forall x y, 0 <= x <= y -> two_p x <= two_p y.
Proof.
  intros.
  replace (two_p x) with (two_p x * 1) by omega.
  replace y with (x + (y - x)) by omega.
  rewrite two_p_is_exp; try omega.
  apply Zmult_le_compat_l.
  assert (two_p (y - x) > 0). apply two_p_gt_ZERO. omega. omega.
  assert (two_p x > 0). apply two_p_gt_ZERO. omega. omega.
Qed.

Lemma two_p_monotone_strict:
  forall x y, 0 <= x < y -> two_p x < two_p y.
Proof.
  intros. assert (two_p x <= two_p (y - 1)). apply two_p_monotone; omega.
  assert (two_p (y - 1) > 0). apply two_p_gt_ZERO. omega.
  replace y with (Zsucc (y - 1)) by omega. rewrite two_p_S. omega. omega.
Qed.

Lemma two_p_strict:
  forall x, x >= 0 -> x < two_p x.
Proof.
  intros x0 GT. pattern x0. apply natlike_ind.
  simpl. omega.
  intros. rewrite two_p_S; auto. generalize (two_p_gt_ZERO x H). omega.
  omega.
Qed.

Lemma two_p_strict_2:
  forall x, x >= 0 -> 2 * x - 1 < two_p x.
Proof.
  intros. assert (x = 0 \/ x - 1 >= 0) by omega. destruct H0.
  subst. vm_compute. auto.
  replace (two_p x) with (2 * two_p (x - 1)).
  generalize (two_p_strict _ H0). omega.
  rewrite <- two_p_S. decEq. omega. omega.
Qed.

(** Properties of [Zmin] and [Zmax] *)

Lemma Zmin_spec:
  forall x y, Zmin x y = if zlt x y then x else y.
Proof.
  intros. case (zlt x y); unfold Zlt, Zge; intro z.
  unfold Zmin. rewrite z. auto.
  unfold Zmin. caseEq (x ?= y); intro.
  apply Zcompare_Eq_eq. auto.
  contradiction.
  reflexivity.
Qed.

Lemma Zmax_spec:
  forall x y, Zmax x y = if zlt y x then x else y.
Proof.
  intros. case (zlt y x); unfold Zlt, Zge; intro z.
  unfold Zmax. rewrite <- (Zcompare_antisym y x).
  rewrite z. simpl. auto.
  unfold Zmax. rewrite <- (Zcompare_antisym y x).
  caseEq (y ?= x); intro; simpl.
  symmetry. apply Zcompare_Eq_eq. auto.
  contradiction. reflexivity.
Qed.

Lemma Zmax_bound_l:
  forall x y z, x <= y -> x <= Zmax y z.
Proof.
  intros. generalize (Zmax1 y z). omega.
Qed.
Lemma Zmax_bound_r:
  forall x y z, x <= z -> x <= Zmax y z.
Proof.
  intros. generalize (Zmax2 y z). omega.
Qed.

(** Properties of Euclidean division and modulus. *)

Lemma Zdiv_small:
  forall x y, 0 <= x < y -> x / y = 0.
Proof.
  intros. assert (y > 0). omega.
  assert (forall a b,
    0 <= a < y ->
    0 <= y * b + a < y ->
    b = 0).
  intros.
  assert (b = 0 \/ b > 0 \/ (-b) > 0). omega.
  elim H3; intro.
  auto.
  elim H4; intro.
  assert (y * b >= y * 1). apply Zmult_ge_compat_l. omega. omega.
  omegaContradiction.
  assert (y * (-b) >= y * 1). apply Zmult_ge_compat_l. omega. omega.
  rewrite <- Zopp_mult_distr_r in H6. omegaContradiction.
  apply H1 with (x mod y).
  apply Z_mod_lt. auto.
  rewrite <- Z_div_mod_eq. auto. auto.
Qed.

Lemma Zmod_small:
  forall x y, 0 <= x < y -> x mod y = x.
Proof.
  intros. assert (y > 0). omega.
  generalize (Z_div_mod_eq x y H0).
  rewrite (Zdiv_small x y H). omega.
Qed.

Lemma Zmod_unique:
  forall x y a b,
  x = a * y + b -> 0 <= b < y -> x mod y = b.
Proof.
  intros. subst x. rewrite Zplus_comm.
  rewrite Z_mod_plus. apply Zmod_small. auto. omega.
Qed.

Lemma Zdiv_unique:
  forall x y a b,
  x = a * y + b -> 0 <= b < y -> x / y = a.
Proof.
  intros. subst x. rewrite Zplus_comm.
  rewrite Z_div_plus. rewrite (Zdiv_small b y H0). omega. omega.
Qed.

Lemma Zdiv_Zdiv:
  forall a b c,
  b > 0 -> c > 0 -> (a / b) / c = a / (b * c).
Proof.
  intros.
  generalize (Z_div_mod_eq a b H). generalize (Z_mod_lt a b H). intros.
  generalize (Z_div_mod_eq (a/b) c H0). generalize (Z_mod_lt (a/b) c H0). intros.
  set (q1 := a / b) in *. set (r1 := a mod b) in *.
  set (q2 := q1 / c) in *. set (r2 := q1 mod c) in *.
  symmetry. apply Zdiv_unique with (r2 * b + r1).
  rewrite H2. rewrite H4. ring.
  split.
  assert (0 <= r2 * b). apply Zmult_le_0_compat. omega. omega. omega.
  assert ((r2 + 1) * b <= c * b).
  apply Zmult_le_compat_r. omega. omega.
  replace ((r2 + 1) * b) with (r2 * b + b) in H5 by ring.
  replace (c * b) with (b * c) in H5 by ring.
  omega.
Qed.

Lemma Zmult_le_compat_l_neg :
  forall n m p:Z, n >= m -> p <= 0 -> p * n <= p * m.
Proof.
  intros.
  assert ((-p) * n >= (-p) * m). apply Zmult_ge_compat_l. auto. omega.
  replace (p * n) with (- ((-p) * n)) by ring.
  replace (p * m) with (- ((-p) * m)) by ring.
  omega.
Qed.

Lemma Zdiv_interval_1:
  forall lo hi a b,
  lo <= 0 -> hi > 0 -> b > 0 ->
  lo * b <= a < hi * b ->
  lo <= a/b < hi.
Proof.
  intros.
  generalize (Z_div_mod_eq a b H1). generalize (Z_mod_lt a b H1). intros.
  set (q := a/b) in *. set (r := a mod b) in *.
  split.
  assert (lo < (q + 1)).
  apply Zmult_lt_reg_r with b. omega.
  apply Zle_lt_trans with a. omega.
  replace ((q + 1) * b) with (b * q + b) by ring.
  omega.
  omega.
  apply Zmult_lt_reg_r with b. omega.
  replace (q * b) with (b * q) by ring.
  omega.
Qed.

Lemma Zdiv_interval_2:
  forall lo hi a b,
  lo <= a <= hi -> lo <= 0 -> hi >= 0 -> b > 0 ->
  lo <= a/b <= hi.
Proof.
  intros.
  assert (lo <= a / b < hi+1).
  apply Zdiv_interval_1. omega. omega. auto.
  assert (lo * b <= lo * 1). apply Zmult_le_compat_l_neg. omega. omega.
  replace (lo * 1) with lo in H3 by ring.
  assert ((hi + 1) * 1 <= (hi + 1) * b). apply Zmult_le_compat_l. omega. omega.
  replace ((hi + 1) * 1) with (hi + 1) in H4 by ring.
  omega.
  omega.
Qed.

Lemma Zmod_recombine:
  forall x a b,
  a > 0 -> b > 0 ->
  x mod (a * b) = ((x/b) mod a) * b + (x mod b).
Proof.
  intros.
  set (xb := x/b).
  apply Zmod_unique with (xb/a).
  generalize (Z_div_mod_eq x b H0); fold xb; intro EQ1.
  generalize (Z_div_mod_eq xb a H); intro EQ2.
  rewrite EQ2 in EQ1.
  eapply trans_eq. eexact EQ1. ring.
  generalize (Z_mod_lt x b H0). intro.
  generalize (Z_mod_lt xb a H). intro.
  assert (0 <= xb mod a * b <= a * b - b).
    split. apply Zmult_le_0_compat; omega.
    replace (a * b - b) with ((a - 1) * b) by ring.
    apply Zmult_le_compat; omega.
  omega.
Qed.

(** Properties of divisibility. *)

Lemma Zdivides_trans:
  forall x y z, (x | y) -> (y | z) -> (x | z).
Proof.
  intros x y z [a A] [b B]; subst. exists (a*b); ring.
Qed.

Definition Zdivide_dec:
  forall (p q: Z), p > 0 -> { (p|q) } + { ~(p|q) }.
Proof.
  intros. destruct (zeq (Zmod q p) 0).
  left. exists (q / p).
  transitivity (p * (q / p) + (q mod p)). apply Z_div_mod_eq; auto.
  transitivity (p * (q / p)). omega. ring.
  right; red; intros. elim n. apply Z_div_exact_1; auto.
  inv H0. rewrite Z_div_mult; auto. ring.
Defined.
Global Opaque Zdivide_dec.

Lemma Zdivide_interval:
  forall a b c,
  0 < c -> 0 <= a < b -> (c | a) -> (c | b) -> 0 <= a <= b - c.
Proof.
  intros. destruct H1 as [x EQ1]. destruct H2 as [y EQ2]. subst. destruct H0.
  split. omega. exploit Zmult_lt_reg_r; eauto. intros.
  replace (y * c - c) with ((y - 1) * c) by ring.
  apply Zmult_le_compat_r; omega.
Qed.

(** Conversion from [Z] to [nat]. *)

Definition nat_of_Z: Z -> nat := Z.to_nat.

Lemma nat_of_Z_of_nat:
  forall n, nat_of_Z (Z_of_nat n) = n.
Proof.
  exact Nat2Z.id.
Qed.

Lemma nat_of_Z_max:
  forall z, Z_of_nat (nat_of_Z z) = Zmax z 0.
Proof.
  intros. unfold Zmax. destruct z; simpl; auto.
  change (Z.of_nat (Z.to_nat (Zpos p)) = Zpos p).
  apply Z2Nat.id. compute; intuition congruence.
Qed.

Lemma nat_of_Z_eq:
  forall z, z >= 0 -> Z_of_nat (nat_of_Z z) = z.
Proof.
  unfold nat_of_Z; intros. apply Z2Nat.id. omega.
Qed.

Lemma nat_of_Z_neg:
  forall n, n <= 0 -> nat_of_Z n = O.
Proof.
  destruct n; unfold Zle; simpl; auto. congruence.
Qed.

Lemma nat_of_Z_plus:
  forall p q,
  p >= 0 -> q >= 0 ->
  nat_of_Z (p + q) = (nat_of_Z p + nat_of_Z q)%nat.
Proof.
  unfold nat_of_Z; intros. apply Z2Nat.inj_add; omega.
Qed.

(** Alignment: [align n amount] returns the smallest multiple of [amount]
  greater than or equal to [n]. *)

Definition align (n: Z) (amount: Z) :=
  ((n + amount - 1) / amount) * amount.

Lemma align_le: forall x y, y > 0 -> x <= align x y.
Proof.
  intros. unfold align.
  generalize (Z_div_mod_eq (x + y - 1) y H). intro.
  replace ((x + y - 1) / y * y)
     with ((x + y - 1) - (x + y - 1) mod y).
  generalize (Z_mod_lt (x + y - 1) y H). omega.
  rewrite Zmult_comm. omega.
Qed.

Lemma align_divides: forall x y, y > 0 -> (y | align x y).
Proof.
  intros. unfold align. apply Zdivide_factor_l.
Qed.

(** * Definitions and theorems on the data types [option], [sum] and [list] *)

Set Implicit Arguments.

(** Comparing option types. *)

Definition option_eq (A: Type) (eqA: forall (x y: A), {x=y} + {x<>y}):
  forall (x y: option A), {x=y} + {x<>y}.
Proof. decide equality. Defined.
Global Opaque option_eq.

(** Mapping a function over an option type. *)

Definition option_map (A B: Type) (f: A -> B) (x: option A) : option B :=
  match x with
  | None => None
  | Some y => Some (f y)
  end.

(** Mapping a function over a sum type. *)

Definition sum_left_map (A B C: Type) (f: A -> B) (x: A + C) : B + C :=
  match x with
  | inl y => inl C (f y)
  | inr z => inr B z
  end.

(** Properties of [List.nth] (n-th element of a list). *)

Hint Resolve in_eq in_cons: coqlib.

Lemma nth_error_in:
  forall (A: Type) (n: nat) (l: list A) (x: A),
  List.nth_error l n = Some x -> In x l.
Proof.
  induction n; simpl.
   destruct l; intros.
    discriminate.
    injection H; intro; subst a. apply in_eq.
   destruct l; intros.
    discriminate.
    apply in_cons. auto.
Qed.
Hint Resolve nth_error_in: coqlib.

Lemma nth_error_nil:
  forall (A: Type) (idx: nat), nth_error (@nil A) idx = None.
Proof.
  induction idx; simpl; intros; reflexivity.
Qed.
Hint Resolve nth_error_nil: coqlib.

(** Compute the length of a list, with result in [Z]. *)

Fixpoint list_length_z_aux (A: Type) (l: list A) (acc: Z) {struct l}: Z :=
  match l with
  | nil => acc
  | hd :: tl => list_length_z_aux tl (Zsucc acc)
  end.

Remark list_length_z_aux_shift:
  forall (A: Type) (l: list A) n m,
  list_length_z_aux l n = list_length_z_aux l m + (n - m).
Proof.
  induction l; intros; simpl.
  omega.
  replace (n - m) with (Zsucc n - Zsucc m) by omega. auto.
Qed.

Definition list_length_z (A: Type) (l: list A) : Z :=
  list_length_z_aux l 0.

Lemma list_length_z_cons:
  forall (A: Type) (hd: A) (tl: list A),
  list_length_z (hd :: tl) = list_length_z tl + 1.
Proof.
  intros. unfold list_length_z. simpl.
  rewrite (list_length_z_aux_shift tl 1 0). omega.
Qed.

Lemma list_length_z_pos:
  forall (A: Type) (l: list A),
  list_length_z l >= 0.
Proof.
  induction l; simpl. unfold list_length_z; simpl. omega.
  rewrite list_length_z_cons. omega.
Qed.

Lemma list_length_z_map:
  forall (A B: Type) (f: A -> B) (l: list A),
  list_length_z (map f l) = list_length_z l.
Proof.
  induction l. reflexivity. simpl. repeat rewrite list_length_z_cons. congruence.
Qed.

(** Extract the n-th element of a list, as [List.nth_error] does,
    but the index [n] is of type [Z]. *)

Fixpoint list_nth_z (A: Type) (l: list A) (n: Z) {struct l}: option A :=
  match l with
  | nil => None
  | hd :: tl => if zeq n 0 then Some hd else list_nth_z tl (Zpred n)
  end.

Lemma list_nth_z_in:
  forall (A: Type) (l: list A) n x,
  list_nth_z l n = Some x -> In x l.
Proof.
  induction l; simpl; intros.
  congruence.
  destruct (zeq n 0). left; congruence. right; eauto.
Qed.

Lemma list_nth_z_map:
  forall (A B: Type) (f: A -> B) (l: list A) n,
  list_nth_z (List.map f l) n = option_map f (list_nth_z l n).
Proof.
  induction l; simpl; intros.
  auto.
  destruct (zeq n 0). auto. eauto.
Qed.

Lemma list_nth_z_range:
  forall (A: Type) (l: list A) n x,
  list_nth_z l n = Some x -> 0 <= n < list_length_z l.
Proof.
  induction l; simpl; intros.
  discriminate.
  rewrite list_length_z_cons. destruct (zeq n 0).
  generalize (list_length_z_pos l); omega.
  exploit IHl; eauto. unfold Zpred. omega.
Qed.

(** Properties of [List.incl] (list inclusion). *)

Lemma incl_cons_inv:
  forall (A: Type) (a: A) (b c: list A),
  incl (a :: b) c -> incl b c.
Proof.
  unfold incl; intros. apply H. apply in_cons. auto.
Qed.
Hint Resolve incl_cons_inv: coqlib.

Lemma incl_app_inv_l:
  forall (A: Type) (l1 l2 m: list A),
  incl (l1 ++ l2) m -> incl l1 m.
Proof.
  unfold incl; intros. apply H. apply in_or_app. left; assumption.
Qed.

Lemma incl_app_inv_r:
  forall (A: Type) (l1 l2 m: list A),
  incl (l1 ++ l2) m -> incl l2 m.
Proof.
  unfold incl; intros. apply H. apply in_or_app. right; assumption.
Qed.

Hint Resolve  incl_tl incl_refl incl_app_inv_l incl_app_inv_r: coqlib.

Lemma incl_same_head:
  forall (A: Type) (x: A) (l1 l2: list A),
  incl l1 l2 -> incl (x::l1) (x::l2).
Proof.
  intros; red; simpl; intros. intuition.
Qed.

(** Properties of [List.map] (mapping a function over a list). *)

Lemma list_map_exten:
  forall (A B: Type) (f f': A -> B) (l: list A),
  (forall x, In x l -> f x = f' x) ->
  List.map f' l = List.map f l.
Proof.
  induction l; simpl; intros.
  reflexivity.
  rewrite <- H. rewrite IHl. reflexivity.
  intros. apply H. tauto.
  tauto.
Qed.

Lemma list_map_compose:
  forall (A B C: Type) (f: A -> B) (g: B -> C) (l: list A),
  List.map g (List.map f l) = List.map (fun x => g(f x)) l.
Proof.
  induction l; simpl. reflexivity. rewrite IHl; reflexivity.
Qed.

Lemma list_map_identity:
  forall (A: Type) (l: list A),
  List.map (fun (x:A) => x) l = l.
Proof.
  induction l; simpl; congruence.
Qed.

Lemma list_map_nth:
  forall (A B: Type) (f: A -> B) (l: list A) (n: nat),
  nth_error (List.map f l) n = option_map f (nth_error l n).
Proof.
  induction l; simpl; intros.
  repeat rewrite nth_error_nil. reflexivity.
  destruct n; simpl. reflexivity. auto.
Qed.

Lemma list_length_map:
  forall (A B: Type) (f: A -> B) (l: list A),
  List.length (List.map f l) = List.length l.
Proof.
  induction l; simpl; congruence.
Qed.

Lemma list_in_map_inv:
  forall (A B: Type) (f: A -> B) (l: list A) (y: B),
  In y (List.map f l) -> exists x:A, y = f x /\ In x l.
Proof.
  induction l; simpl; intros.
  contradiction.
  elim H; intro.
  exists a; intuition auto.
  generalize (IHl y H0). intros [x [EQ IN]].
  exists x; tauto.
Qed.

Lemma list_append_map:
  forall (A B: Type) (f: A -> B) (l1 l2: list A),
  List.map f (l1 ++ l2) = List.map f l1 ++ List.map f l2.
Proof.
  induction l1; simpl; intros.
  auto. rewrite IHl1. auto.
Qed.

Lemma list_append_map_inv:
  forall (A B: Type) (f: A -> B) (m1 m2: list B) (l: list A),
  List.map f l = m1 ++ m2 ->
  exists l1, exists l2, List.map f l1 = m1 /\ List.map f l2 = m2 /\ l = l1 ++ l2.
Proof.
  induction m1; simpl; intros.
  exists (@nil A); exists l; auto.
  destruct l; simpl in H; inv H.
  exploit IHm1; eauto. intros [l1 [l2 [P [Q R]]]]. subst l.
  exists (a0 :: l1); exists l2; intuition. simpl; congruence.
Qed.

(** Folding a function over a list *)

Section LIST_FOLD.

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

(** This is exactly [List.fold_left] from Coq's standard library,
  with [f] taking arguments in a different order. *)

Fixpoint list_fold_left (accu: B) (l: list A) : B :=
  match l with nil => accu | x :: l' => list_fold_left (f x accu) l' end.

(** This is exactly [List.fold_right] from Coq's standard library,
  except that it runs in constant stack space. *)

Definition list_fold_right (l: list A) (base: B) : B :=
  list_fold_left base (List.rev' l).

Remark list_fold_left_app:
  forall l1 l2 accu,
  list_fold_left accu (l1 ++ l2) = list_fold_left (list_fold_left accu l1) l2.
Proof.
  induction l1; simpl; intros.
  auto.
  rewrite IHl1. auto.
Qed.

Lemma list_fold_right_eq:
  forall l base,
  list_fold_right l base =
  match l with nil => base | x :: l' => f x (list_fold_right l' base) end.
Proof.
  unfold list_fold_right; intros.
  destruct l.
  auto.
  unfold rev'. rewrite <- ! rev_alt. simpl.
  rewrite list_fold_left_app. simpl. auto.
Qed.

Lemma list_fold_right_spec:
  forall l base, list_fold_right l base = List.fold_right f base l.
Proof.
  induction l; simpl; intros; rewrite list_fold_right_eq; congruence.
Qed.

End LIST_FOLD.

(** Properties of list membership. *)

Lemma in_cns:
  forall (A: Type) (x y: A) (l: list A), In x (y :: l) <-> y = x \/ In x l.
Proof.
  intros. simpl. tauto.
Qed.

Lemma in_app:
  forall (A: Type) (x: A) (l1 l2: list A), In x (l1 ++ l2) <-> In x l1 \/ In x l2.
Proof.
  intros. split; intro. apply in_app_or. auto. apply in_or_app. auto.
Qed.

Lemma list_in_insert:
  forall (A: Type) (x: A) (l1 l2: list A) (y: A),
  In x (l1 ++ l2) -> In x (l1 ++ y :: l2).
Proof.
  intros. apply in_or_app; simpl. elim (in_app_or _ _ _ H); intro; auto.
Qed.

(** [list_disjoint l1 l2] holds iff [l1] and [l2] have no elements
  in common. *)

Definition list_disjoint (A: Type) (l1 l2: list A) : Prop :=
  forall (x y: A), In x l1 -> In y l2 -> x <> y.

Lemma list_disjoint_cons_l:
  forall (A: Type) (a: A) (l1 l2: list A),
  list_disjoint l1 l2 -> ~In a l2 -> list_disjoint (a :: l1) l2.
Proof.
  unfold list_disjoint; simpl; intros. destruct H1. congruence. apply H; auto.
Qed.

Lemma list_disjoint_cons_r:
  forall (A: Type) (a: A) (l1 l2: list A),
  list_disjoint l1 l2 -> ~In a l1 -> list_disjoint l1 (a :: l2).
Proof.
  unfold list_disjoint; simpl; intros. destruct H2. congruence. apply H; auto.
Qed.

Lemma list_disjoint_cons_left:
  forall (A: Type) (a: A) (l1 l2: list A),
  list_disjoint (a :: l1) l2 -> list_disjoint l1 l2.
Proof.
  unfold list_disjoint; simpl; intros. apply H; tauto.
Qed.

Lemma list_disjoint_cons_right:
  forall (A: Type) (a: A) (l1 l2: list A),
  list_disjoint l1 (a :: l2) -> list_disjoint l1 l2.
Proof.
  unfold list_disjoint; simpl; intros. apply H; tauto.
Qed.

Lemma list_disjoint_notin:
  forall (A: Type) (l1 l2: list A) (a: A),
  list_disjoint l1 l2 -> In a l1 -> ~(In a l2).
Proof.
  unfold list_disjoint; intros; red; intros.
  apply H with a a; auto.
Qed.

Lemma list_disjoint_sym:
  forall (A: Type) (l1 l2: list A),
  list_disjoint l1 l2 -> list_disjoint l2 l1.
Proof.
  unfold list_disjoint; intros.
  apply sym_not_equal. apply H; auto.
Qed.

Lemma list_disjoint_dec:
  forall (A: Type) (eqA_dec: forall (x y: A), {x=y} + {x<>y}) (l1 l2: list A),
  {list_disjoint l1 l2} + {~list_disjoint l1 l2}.
Proof.
  induction l1; intros.
  left; red; intros. elim H.
  case (In_dec eqA_dec a l2); intro.
  right; red; intro. apply (H a a); auto with coqlib.
  case (IHl1 l2); intro.
  left; red; intros. elim H; intro.
    red; intro; subst a y. contradiction.
    apply l; auto.
  right; red; intros. elim n0. eapply list_disjoint_cons_left; eauto.
Defined.

(** [list_equiv l1 l2] holds iff the lists [l1] and [l2] contain the same elements. *)

Definition list_equiv (A : Type) (l1 l2: list A) : Prop :=
  forall x, In x l1 <-> In x l2.

(** [list_norepet l] holds iff the list [l] contains no repetitions,
  i.e. no element occurs twice. *)

Inductive list_norepet (A: Type) : list A -> Prop :=
  | list_norepet_nil:
      list_norepet nil
  | list_norepet_cons:
      forall hd tl,
      ~(In hd tl) -> list_norepet tl -> list_norepet (hd :: tl).

Lemma list_norepet_dec:
  forall (A: Type) (eqA_dec: forall (x y: A), {x=y} + {x<>y}) (l: list A),
  {list_norepet l} + {~list_norepet l}.
Proof.
  induction l.
  left; constructor.
  destruct IHl.
  case (In_dec eqA_dec a l); intro.
  right. red; intro. inversion H. contradiction.
  left. constructor; auto.
  right. red; intro. inversion H. contradiction.
Defined.

Lemma list_map_norepet:
  forall (A B: Type) (f: A -> B) (l: list A),
  list_norepet l ->
  (forall x y, In x l -> In y l -> x <> y -> f x <> f y) ->
  list_norepet (List.map f l).
Proof.
  induction 1; simpl; intros.
  constructor.
  constructor.
  red; intro. generalize (list_in_map_inv f _ _ H2).
  intros [x [EQ IN]]. generalize EQ. change (f hd <> f x).
  apply H1. tauto. tauto.
  red; intro; subst x. contradiction.
  apply IHlist_norepet. intros. apply H1. tauto. tauto. auto.
Qed.

Remark list_norepet_append_commut:
  forall (A: Type) (a b: list A),
  list_norepet (a ++ b) -> list_norepet (b ++ a).
Proof.
  intro A.
  assert (forall (x: A) (b: list A) (a: list A),
           list_norepet (a ++ b) -> ~(In x a) -> ~(In x b) ->
           list_norepet (a ++ x :: b)).
    induction a; simpl; intros.
    constructor; auto.
    inversion H. constructor. red; intro.
    elim (in_app_or _ _ _ H6); intro.
    elim H4. apply in_or_app. tauto.
    elim H7; intro. subst a. elim H0. left. auto.
    elim H4. apply in_or_app. tauto.
    auto.
  induction a; simpl; intros.
  rewrite <- app_nil_end. auto.
  inversion H0. apply H. auto.
  red; intro; elim H3. apply in_or_app. tauto.
  red; intro; elim H3. apply in_or_app. tauto.
Qed.

Lemma list_norepet_app:
  forall (A: Type) (l1 l2: list A),
  list_norepet (l1 ++ l2) <->
  list_norepet l1 /\ list_norepet l2 /\ list_disjoint l1 l2.
Proof.
  induction l1; simpl; intros; split; intros.
  intuition. constructor. red;simpl;auto.
  tauto.
  inversion H; subst. rewrite IHl1 in H3. rewrite in_app in H2.
  intuition.
  constructor; auto. red; intros. elim H2; intro. congruence. auto.
  destruct H as [B [C D]]. inversion B; subst.
  constructor. rewrite in_app. intuition. elim (D a a); auto. apply in_eq.
  rewrite IHl1. intuition. red; intros. apply D; auto. apply in_cons; auto.
Qed.

Lemma list_norepet_append:
  forall (A: Type) (l1 l2: list A),
  list_norepet l1 -> list_norepet l2 -> list_disjoint l1 l2 ->
  list_norepet (l1 ++ l2).
Proof.
  generalize list_norepet_app; firstorder.
Qed.

Lemma list_norepet_append_right:
  forall (A: Type) (l1 l2: list A),
  list_norepet (l1 ++ l2) -> list_norepet l2.
Proof.
  generalize list_norepet_app; firstorder.
Qed.

Lemma list_norepet_append_left:
  forall (A: Type) (l1 l2: list A),
  list_norepet (l1 ++ l2) -> list_norepet l1.
Proof.
  generalize list_norepet_app; firstorder.
Qed.

(** [is_tail l1 l2] holds iff [l2] is of the form [l ++ l1] for some [l]. *)

Inductive is_tail (A: Type): list A -> list A -> Prop :=
  | is_tail_refl:
      forall c, is_tail c c
  | is_tail_cons:
      forall i c1 c2, is_tail c1 c2 -> is_tail c1 (i :: c2).

Lemma is_tail_in:
  forall (A: Type) (i: A) c1 c2, is_tail (i :: c1) c2 -> In i c2.
Proof.
  induction c2; simpl; intros.
  inversion H.
  inversion H. tauto. right; auto.
Qed.

Lemma is_tail_cons_left:
  forall (A: Type) (i: A) c1 c2, is_tail (i :: c1) c2 -> is_tail c1 c2.
Proof.
  induction c2; intros; inversion H.
  constructor. constructor. constructor. auto.
Qed.

Hint Resolve is_tail_refl is_tail_cons is_tail_in is_tail_cons_left: coqlib.

Lemma is_tail_incl:
  forall (A: Type) (l1 l2: list A), is_tail l1 l2 -> incl l1 l2.
Proof.
  induction 1; eauto with coqlib.
Qed.

Lemma is_tail_trans:
  forall (A: Type) (l1 l2: list A),
  is_tail l1 l2 -> forall (l3: list A), is_tail l2 l3 -> is_tail l1 l3.
Proof.
  induction 1; intros. auto. apply IHis_tail. eapply is_tail_cons_left; eauto.
Qed.

(** [list_forall2 P [x1 ... xN] [y1 ... yM]] holds iff [N = M] and
  [P xi yi] holds for all [i]. *)

Section FORALL2.

Variable A: Type.
Variable B: Type.
Variable P: A -> B -> Prop.

Inductive list_forall2: list A -> list B -> Prop :=
  | list_forall2_nil:
      list_forall2 nil nil
  | list_forall2_cons:
      forall a1 al b1 bl,
      P a1 b1 ->
      list_forall2 al bl ->
      list_forall2 (a1 :: al) (b1 :: bl).

Lemma list_forall2_app:
  forall a2 b2 a1 b1,
  list_forall2 a1 b1 -> list_forall2 a2 b2 ->
  list_forall2 (a1 ++ a2) (b1 ++ b2).
Proof.
  induction 1; intros; simpl. auto. constructor; auto.
Qed.

Lemma list_forall2_length:
  forall l1 l2,
  list_forall2 l1 l2 -> length l1 = length l2.
Proof.
  induction 1; simpl; congruence.
Qed.

End FORALL2.

Lemma list_forall2_imply:
  forall (A B: Type) (P1: A -> B -> Prop) (l1: list A) (l2: list B),
  list_forall2 P1 l1 l2 ->
  forall (P2: A -> B -> Prop),
  (forall v1 v2, In v1 l1 -> In v2 l2 -> P1 v1 v2 -> P2 v1 v2) ->
  list_forall2 P2 l1 l2.
Proof.
  induction 1; intros.
  constructor.
  constructor. auto with coqlib. apply IHlist_forall2; auto.
  intros. auto with coqlib.
Qed.

(** Dropping the first N elements of a list. *)

Fixpoint list_drop (A: Type) (n: nat) (x: list A) {struct n} : list A :=
  match n with
  | O => x
  | S n' => match x with nil => nil | hd :: tl => list_drop n' tl end
  end.

Lemma list_drop_incl:
  forall (A: Type) (x: A) n (l: list A), In x (list_drop n l) -> In x l.
Proof.
  induction n; simpl; intros. auto.
  destruct l; auto with coqlib.
Qed.

Lemma list_drop_norepet:
  forall (A: Type) n (l: list A), list_norepet l -> list_norepet (list_drop n l).
Proof.
  induction n; simpl; intros. auto.
  inv H. constructor. auto.
Qed.

Lemma list_map_drop:
  forall (A B: Type) (f: A -> B) n (l: list A),
  list_drop n (map f l) = map f (list_drop n l).
Proof.
  induction n; simpl; intros. auto.
  destruct l; simpl; auto.
Qed.

(** A list of [n] elements, all equal to [x]. *)

Fixpoint list_repeat {A: Type} (n: nat) (x: A) {struct n} :=
  match n with
  | O => nil
  | S m => x :: list_repeat m x
  end.

Lemma length_list_repeat:
  forall (A: Type) n (x: A), length (list_repeat n x) = n.
Proof.
  induction n; simpl; intros. auto. decEq; auto.
Qed.

Lemma in_list_repeat:
  forall (A: Type) n (x: A) y, In y (list_repeat n x) -> y = x.
Proof.
  induction n; simpl; intros. elim H. destruct H; auto.
Qed.

(** * Definitions and theorems over boolean types *)

Definition proj_sumbool (P Q: Prop) (a: {P} + {Q}) : bool :=
  if a then true else false.

Implicit Arguments proj_sumbool [P Q].

Coercion proj_sumbool: sumbool >-> bool.

Lemma proj_sumbool_true:
  forall (P Q: Prop) (a: {P}+{Q}), proj_sumbool a = true -> P.
Proof.
  intros P Q a. destruct a; simpl. auto. congruence.
Qed.

Lemma proj_sumbool_is_true:
  forall (P: Prop) (a: {P}+{~P}), P -> proj_sumbool a = true.
Proof.
  intros. unfold proj_sumbool. destruct a. auto. contradiction.
Qed.

Ltac InvBooleans :=
  match goal with
  | [ H: _ && _ = true |- _ ] =>
      destruct (andb_prop _ _ H); clear H; InvBooleans
  | [ H: _ || _ = false |- _ ] =>
      destruct (orb_false_elim _ _ H); clear H; InvBooleans
  | [ H: proj_sumbool ?x = true |- _ ] =>
      generalize (proj_sumbool_true _ H); clear H; intro; InvBooleans
  | _ => idtac
  end.

Section DECIDABLE_EQUALITY.

Variable A: Type.
Variable dec_eq: forall (x y: A), {x=y} + {x<>y}.
Variable B: Type.

Lemma dec_eq_true:
  forall (x: A) (ifso ifnot: B),
  (if dec_eq x x then ifso else ifnot) = ifso.
Proof.
  intros. destruct (dec_eq x x). auto. congruence.
Qed.

Lemma dec_eq_false:
  forall (x y: A) (ifso ifnot: B),
  x <> y -> (if dec_eq x y then ifso else ifnot) = ifnot.
Proof.
  intros. destruct (dec_eq x y). congruence. auto.
Qed.

Lemma dec_eq_sym:
  forall (x y: A) (ifso ifnot: B),
  (if dec_eq x y then ifso else ifnot) =
  (if dec_eq y x then ifso else ifnot).
Proof.
  intros. destruct (dec_eq x y).
  subst y. rewrite dec_eq_true. auto.
  rewrite dec_eq_false; auto.
Qed.

End DECIDABLE_EQUALITY.

Section DECIDABLE_PREDICATE.

Variable P: Prop.
Variable dec: {P} + {~P}.
Variable A: Type.

Lemma pred_dec_true:
  forall (a b: A), P -> (if dec then a else b) = a.
Proof.
  intros. destruct dec. auto. contradiction.
Qed.

Lemma pred_dec_false:
  forall (a b: A), ~P -> (if dec then a else b) = b.
Proof.
  intros. destruct dec. contradiction. auto.
Qed.

End DECIDABLE_PREDICATE.

(** * Well-founded orderings *)

Require Import Relations.

(** A non-dependent version of lexicographic ordering. *)

Section LEX_ORDER.

Variable A: Type.
Variable B: Type.
Variable ordA: A -> A -> Prop.
Variable ordB: B -> B -> Prop.

Inductive lex_ord: A*B -> A*B -> Prop :=
  | lex_ord_left: forall a1 b1 a2 b2,
      ordA a1 a2 -> lex_ord (a1,b1) (a2,b2)
  | lex_ord_right: forall a b1 b2,
      ordB b1 b2 -> lex_ord (a,b1) (a,b2).

Lemma wf_lex_ord:
  well_founded ordA -> well_founded ordB -> well_founded lex_ord.
Proof.
  intros Awf Bwf.
  assert (forall a, Acc ordA a -> forall b, Acc ordB b -> Acc lex_ord (a, b)).
    induction 1. induction 1. constructor; intros. inv H3.
    apply H0. auto. apply Bwf.
    apply H2; auto.
  red; intros. destruct a as [a b]. apply H; auto.
Qed.

Lemma transitive_lex_ord:
  transitive _ ordA -> transitive _ ordB -> transitive _ lex_ord.
Proof.
  intros trA trB; red; intros.
  inv H; inv H0.
  left; eapply trA; eauto.
  left; auto.
  left; auto.
  right; eapply trB; eauto.
Qed.

End LEX_ORDER.


Require Import Bool String List.
Require Import Lib.CommonTactics Lib.ilist Lib.Word Lib.Indexer Lib.StringAsList.
Require Import Kami.Syntax Kami.Notations Kami.Semantics.
Require Import Kami.Wf Kami.Tactics.
Require Import FunctionalExtensionality Eqdep Eqdep_dec.

Set Implicit Arguments.

Section Fifo.
  Variable fifoName: string.
  Variable sz: nat.
  Variable dType: Kind.

  Local Notation "^ s" := (fifoName -- s) (at level 0).

  Definition enq {ty} : forall (d: ty dType), ActionT ty Void := fun d =>
    (Read isFull <- ^"full";
     Assert !#isFull;
     Read eltT <- ^"elt";
     Read enqPT <- ^"enqP";
     Read deqPT <- ^"deqP";
     Write ^"elt" <- #eltT@[#enqPT <- #d];
     Write ^"empty" <- $$false;
     LET next_enqP <- (#enqPT + $1) :: Bit sz;
     Write ^"full" <- (#deqPT == #next_enqP);
     Write ^"enqP" <- #next_enqP;
     Retv)%kami_action.

  Definition deq {ty} : ActionT ty dType :=
    (Read isEmpty <- ^"empty";
     Assert !#isEmpty;
     Read eltT <- ^"elt";
     Read enqPT <- ^"enqP";
     Read deqPT <- ^"deqP";
     Write ^"full" <- $$false;
     LET next_deqP <- (#deqPT + $1) :: Bit sz;
     Write ^"empty" <- (#enqPT == #next_deqP);
     Write ^"deqP" <- #next_deqP;
     Ret #eltT@[#deqPT])%kami_action.

  Definition firstElt {ty} : ActionT ty dType :=
    (Read isEmpty <- ^"empty";
     Assert !#isEmpty;
     Read eltT : Vector dType sz <- ^"elt";
     Read deqPT <- ^"deqP";
     Ret #eltT@[#deqPT])%kami_action.

  Definition fifo := MODULE {
    Register ^"elt" : Vector dType sz <- Default
    with Register ^"enqP" : Bit sz <- Default
    with Register ^"deqP" : Bit sz <- Default
    with Register ^"empty" : Bool <- true
    with Register ^"full" : Bool <- Default

    with Method ^"enq"(d : dType) : Void := (enq d)
    with Method ^"deq"() : dType := deq
    with Method ^"firstElt"() : dType := firstElt
  }.

  Definition simpleFifo := MODULE {
    Register ^"elt" : Vector dType sz <- Default
    with Register ^"enqP" : Bit sz <- Default
    with Register ^"deqP" : Bit sz <- Default
    with Register ^"empty" : Bool <- true
    with Register ^"full" : Bool <- Default

    with Method ^"enq"(d : dType) : Void := (enq d)
    with Method ^"deq"() : dType := deq
  }.

End Fifo.

#[global] Hint Unfold fifo simpleFifo : ModuleDefs.
#[global] Hint Unfold enq deq firstElt : MethDefs.

Section Facts.
  Variable fifoName: string.
  Variable sz: nat.
  Variable dType: Kind.

  Hypothesis HfifoName: index 0 indexSymbol fifoName = None.

  Lemma fifo_ModEquiv:
    ModPhoasWf (fifo fifoName sz dType).
  Proof. kequiv. Qed.
  #[local] Hint Resolve fifo_ModEquiv.

  Lemma simpleFifo_ModEquiv:
    ModPhoasWf (simpleFifo fifoName sz dType).
  Proof. kequiv. Qed.
  #[local] Hint Resolve simpleFifo_ModEquiv.

  Lemma fifo_ValidRegs:
    ModRegsWf (fifo fifoName sz dType).
  Proof. kvr. Qed.
  #[local] Hint Resolve fifo_ValidRegs.

  Lemma simpleFifo_ValidRegs:
    ModRegsWf (simpleFifo fifoName sz dType).
  Proof. kvr. Qed.
  #[local] Hint Resolve simpleFifo_ValidRegs.

End Facts.

#[global] Hint Resolve fifo_ModEquiv simpleFifo_ModEquiv.
#[global] Hint Resolve fifo_ValidRegs simpleFifo_ValidRegs.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Morphisms.
Require Export Category.Theory.Isomorphism.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Bifunctor.
Require Export Category.Structure.Cartesian.
Require Export Category.Structure.Monoidal.Semicartesian.
Require Export Category.Structure.Monoidal.Relevance.
Require Export Category.Structure.Monoidal.Cartesian.
Require Export Category.Structure.Monoidal.Cartesian.Proofs.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section CartesianMonoidalCartesian.

Context `{@Monoidal C}.
Context `{@CartesianMonoidal C _}.

Global Program Definition CartesianMonoidal_Cartesian : @Cartesian C := {|
  product_obj := fun x y => (x ⨂ y)%object;
  fork := fun x _ _ f g => f ⨂ g ∘ ∆x;
  exl  := fun _ _ => proj_left;
  exr  := fun _ _ => proj_right
|}.
Next Obligation. apply is_relevance. Defined.
Next Obligation. proper; rewrites; reflexivity. Qed.
Next Obligation.
  split; intros.
    split.
      rewrites.
      rewrite comp_assoc.
      rewrite proj_left_natural.
      rewrite <- comp_assoc.
      rewrite proj_left_diagonal; cat.
    rewrites.
    rewrite comp_assoc.
    rewrite proj_right_natural.
    rewrite <- comp_assoc.
    rewrite proj_right_diagonal; cat.
  rewrite <- (fst X), <- (snd X).
  rewrite bimap_comp.
  rewrite <- !comp_assoc.
  srewrite diagonal_natural.
  rewrite comp_assoc.
  rewrite proj_left_right_diagonal; cat.
Qed.

End CartesianMonoidalCartesian.


Require Import ExtLib.Data.HList.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.SubstI.

Set Implicit Arguments.
Set Strict Implicit.

Section with_Expr.
  Variable typ : Set.
  Variable expr : Set.
  Variable subst : Type.
  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Expr_expr : @Expr typ _ expr}.
  Context {Subst_subst : Subst subst expr}.
  Context {SubstOk_subst : SubstOk subst typ expr}.
  Context {SubstUpdate_subst : SubstUpdate subst expr}.
  Context {SubstUpdateOk_subst : SubstUpdateOk subst typ expr}.

  Local Existing Instance RType_typ.
  Local Existing Instance Expr_expr.

  Definition unifier : Type :=
    forall (tus tvs : tenv typ) (under : nat) (l r : expr)
           (t : typ) (s : subst), option subst.

  Variable unify : unifier.

  Definition unify_sound : Prop :=
    forall (tu tv : tenv typ) (e1 e2 : expr) (s s' : subst)
           (t : typ) (tv' : tenv typ),
      unify tu (tv' ++ tv) (length tv') e1 e2 t s = Some s' ->
      WellFormed_subst s ->
      WellFormed_subst s' /\
      forall v1 v2 sD,
        exprD tu (tv' ++ tv) t e1 = Some v1 ->
        exprD tu (tv' ++ tv) t e2 = Some v2 ->
        substD tu tv s = Some sD ->
        exists sD',
             substR tu tv s s'
          /\ substD tu tv s' = Some sD'
          /\ forall us vs,
               sD' us vs ->
               sD us vs /\
               forall vs',
                 v1 us (hlist_app vs' vs) = v2 us (hlist_app vs' vs).

End with_Expr.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(****************************************************************************)
(*                          Signes Project                                  *)
(*                            2002-2003                                     *)
(*                           Houda ANOUN                                    *)
(*                          Pierre Casteran                                 *)
(*                           LaBRI/INRIA                                    *)
(****************************************************************************)

Require Import Polarity.
Require Import ZArith.

Inductive atomsEx : Set :=
  | s : atomsEx
  | sn : atomsEx
  | n : atomsEx.

Lemma atomsEx_dec : forall x y : atomsEx, {x = y} + {x <> y}.
 intros x y.
 elim x; elim y; first [ left; reflexivity | right; discriminate ].
Defined.

Lemma notDerivableSequence :
 ~
 weak
   (gentzenSequent NL_Sequent
      (Comma (OneForm (At s)) (OneForm (Slash (At sn) (At n)))) (
      At s)).

 Proof.
  red in |- *.
  intro H.
  elim H.
  intro H0.
  clear H.
  Polartest sn (atomsEx_dec sn) H0.
  apply NLEqualPolarity.
  simpl in |- *.
  auto with zarith.
 Qed.


Require Export Iron.Language.SystemF2Effect.Type.
Require Export Iron.Language.SystemF2Effect.Value.
Require Export Iron.Language.SystemF2Effect.Step.Pure.
Require Export Iron.Language.SystemF2Effect.Store.Prop.

(********************************************************************)
(* Frames *)
Inductive frame : Set :=
 (* Holds the continuation of a let-expression while the right
    of the binding is being evaluated. *)
 | FLet   : ty  -> exp      -> frame

 (* Private region.
    If the first argument is some region identifier then this new
    private region will be merged with that one when leaving its scope,
    otherwise the region is deallocated. *)
 | FPriv  : option nat -> nat -> frame.
Hint Constructors frame.

Definition isFPriv (p2 : nat) (f : frame)
 := exists p1, f = FPriv p1 p2.
Hint Unfold isFPriv.

(* Frame stacks *)
Definition stack := list frame.
Hint Unfold stack.

(********************************************************************)
(* Context sensitive reductions. *)
Inductive
 StepF :  store -> stprops -> stack -> exp
       -> store -> stprops -> stack -> exp
       -> Prop :=

 (* Pure evaluation *****************************)
 (* Pure evaluation in a context. *)
 | SfStep
   :  forall ss sp fs x x'
   ,  StepP           x           x'
   -> StepF  ss sp fs x  ss sp fs x'

 (* Let contexts ********************************)
 (* Push the continuation for a let-expression onto the stack. *)
 | SfLetPush
   :  forall ss sp fs t x1 x2
   ,  StepF  ss sp  fs               (XLet t x1 x2)
             ss sp (fs :> FLet t x2)  x1

 (* Substitute value of the bound variable into the let body. *)
 | SfLetPop
   :  forall ss sp  fs t v1 x2
   ,  StepF  ss sp (fs :> FLet t x2) (XVal v1)
             ss sp  fs               (substVX 0 v1 x2)

 (* Region operators ****************************)
 (* Create a private region. *)
 | SfPrivatePush
   :  forall ss sp fs x p
   ,  p = allocRegion sp
   -> StepF  ss sp                       fs                  (XPrivate x)
             ss (SRegion p <: sp)       (fs :> FPriv None p) (substTX 0 (TRgn p) x)

 (* Pop the frame for a private region and delete it from the heap. *)
 | SfPrivatePop
   :  forall ss sp  fs v1 p
   ,  StepF  ss                         sp (fs :> FPriv None p) (XVal v1)
             (map (deallocRegion p) ss) sp  fs                  (XVal v1)

 (* Begin extending an existing region. *)
 | SfExtendPush
   :  forall ss sp fs x p1 p2
   ,  p2 = allocRegion sp
   -> StepF ss sp                  fs                        (XExtend (TRgn p1) x)
            ss (SRegion p2 <: sp) (fs :> FPriv (Some p1) p2) (substTX 0 (TRgn p2) x)

 (* Pop the frame for a region extension and merge it with the existing one. *)
 | SfExtendPop
   :  forall ss sp fs p1 p2 v1
   ,  StepF  ss                      sp (fs :> FPriv (Some p1) p2) (XVal v1)
             (map (mergeB p1 p2) ss) sp fs                   (XVal (mergeV p1 p2 v1))

 (* Store operators *****************************)
 (* Allocate a reference. *)
 | SfStoreAlloc
   :  forall ss sp fs p1 v1
   ,  StepF  ss                    sp  fs (XAlloc (TRgn p1) v1)
             (StValue p1 v1 <: ss) sp  fs (XVal (VLoc (length ss)))

 (* Read from a reference. *)
 | SfStoreRead
   :  forall ss sp fs l v p
   ,  get l ss = Some (StValue p v)
   -> StepF ss                     sp  fs (XRead (TRgn p)  (VLoc l))
            ss                     sp  fs (XVal v)

 (* Write to a reference. *)
 | SfStoreWrite
   :  forall ss sp fs l p v1 v2
   ,  get l ss = Some (StValue p v1)
   -> StepF  ss sp fs                 (XWrite (TRgn p) (VLoc l) v2)
             (update l (StValue p v2) ss) sp fs (XVal (VConst CUnit)).

Hint Constructors StepF.

(********************************************************************)
Lemma stepF_extends_stprops
 :  forall  ss1 sp1 fs1 x1  ss2 sp2 fs2 x2
 ,  StepF   ss1 sp1 fs1 x1  ss2 sp2 fs2 x2
 -> extends sp2 sp1.
Proof.
 intros.
 induction H; eauto.
Qed.


From iris.proofmode Require Import tactics.
From Perennial.program_logic Require Export crash_weakestpre staged_invariant_alt.
Set Default Proof Using "Type".
Import uPred.

Section modality.
Context `{IRISG: !irisGS Λ Σ, !generationGS Λ Σ}.

Definition wpc_nval E (P : iProp Σ) : iProp Σ :=
  (∀ E' e s Φ Φc,
    ⌜ to_val e = None ⌝ →
    ⌜ E ⊆ E' ⌝ →
    (WPC e @ s; E' {{ λ v, P -∗ Φ v }} {{ Φc }}) -∗
    WPC e @ s; E' {{ λ v, Φ v }} {{ Φc }}).

Lemma wpc_nval_strong_mono E P P' :
  wpc_nval E P -∗
  ▷ (P -∗ |NC={E}=> P') -∗
  wpc_nval E P'.
Proof.
  iIntros "Hwpc_nval Hwand".
  rewrite /wpc_nval. iIntros (????? Hnval Hsub) "H".
  iApply wpc_ncfupd.
  iApply "Hwpc_nval"; auto.
  iApply (wpc_step_strong_mono with "[$]"); eauto.
  iSplit; last eauto.
  iNext. iIntros (?) "HP'". iModIntro. iIntros "HP".
  iApply (ncfupd_mask_mono E); auto.
  iMod ("Hwand" with "[$]"). iDestruct ("HP'" with "[$]") as "$".
  eauto.
Qed.

Lemma wpc_nval_True E : ⊢ wpc_nval E True%I.
Proof.
  rewrite /wpc_nval. iIntros (?????) "Hnval Hsub H".
  iApply (wpc_strong_mono with "H"); eauto.
  iSplit; last eauto.
  iIntros (?) "H". iApply "H". eauto.
Qed.

Lemma wpc_nval_intro E P :
  ▷ P -∗ wpc_nval E P.
Proof.
  iIntros "HP".
  iPoseProof (wpc_nval_True) as "Htrue".
  iApply (wpc_nval_strong_mono with "Htrue"); eauto.
Qed.

Lemma wpc_nval_ncfupd E P :
  wpc_nval E (|NC={E}=> P) -∗ wpc_nval E P.
Proof.
  iIntros "HP".
  iApply (wpc_nval_strong_mono with "HP"); eauto.
Qed.

Lemma ncfupd_wpc_nval E P :
  (|NC={E}=> wpc_nval E P) -∗ wpc_nval E P.
Proof.
  iIntros "HP".
  rewrite /wpc_nval. iIntros (????? Hnval Hsub) "H".
  rewrite ?wpc_unfold. iIntros (mj).
  rewrite /wpc_pre.
  rewrite Hnval.
  iSplit; last first.
  { iDestruct ("H" $! _) as "(_&H)". eauto. }
  iIntros. rewrite ncfupd_eq.
  iSpecialize ("HP" with "[$]").
  iMod (fupd_mask_mono with "HP") as "(HP&HNC)"; auto.
  iSpecialize ("HP" $! E' e s Φ Φc with "[//] [//]").
  rewrite ?wpc_unfold.
  rewrite /wpc_pre.
  rewrite Hnval.
  iSpecialize ("HP" with "H").
  iDestruct ("HP" $! mj) as "(H&_)".
  iApply ("H" with "[$] [$] [$] [$]").
Qed.

Lemma wpc_nval_elim E1 E2 P e s Φ Φc :
  to_val e = None →
  E1 ⊆ E2 →
  wpc_nval E1 P -∗
  (WPC e @ s; E2 {{ λ v, P -∗ Φ v }} {{ Φc }}) -∗
  WPC e @ s; E2 {{ λ v, Φ v }} {{ Φc }}.
Proof.
  iIntros (Hnval Hsub) "Hwpc_nval Hwpc".
  iApply "Hwpc_nval"; eauto.
Qed.

Lemma wpc_nval_elim_wp E1 E2 P e s Φ :
  to_val e = None →
  E1 ⊆ E2 →
  wpc_nval E1 P -∗
  (WP e @ s; E2 {{ λ v, P -∗ Φ v }}) -∗
  WP e @ s; E2 {{ λ v, Φ v }}.
Proof.
  iIntros (Hnval Hsub) "Hwpc_nval Hwpc".
  rewrite wp_eq /wp_def.
  iApply (wpc_nval_elim with "[$]"); eauto.
Qed.

End modality.


Require Export Db.Inst.
Require Export Db.Lemmas.
Require Export Db.WellScoping.
Require Export StlcFix.SpecSyntax.

#[export]
#[refine] Instance vrTm : Vr Tm := {| vr := var |}.
Proof. inversion 1; auto. Defined.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasMatchH;
     rewrite ?comp_up, ?up_liftSub, ?up_comp_lift
    );
  auto.

Module TmKit <: Kit.

  Definition TM := Tm.
  Definition inst_vr := vrTm.

  Section Application.

    Context {Y: Type}.
    Context {vrY : Vr Y}.
    Context {wkY: Wk Y}.
    Context {liftY: Lift Y Tm}.

    #[export]
    #[refine] Instance inst_ap : Ap Tm Y := {| ap := apTm |}.
    Proof. induction x; crush. Defined.

    #[export]
    #[refine] Instance inst_ap_vr : LemApVr Tm Y := {}.
    Proof. reflexivity. Qed.

  End Application.

  #[export]
  #[refine] Instance inst_ap_inj: LemApInj Tm Ix := {}.
  Proof.
    intros m Inj_m x. revert m Inj_m.
    induction x; destruct y; simpl; try discriminate;
    inversion 1; subst; f_equal; eauto using InjSubIxUp.
  Qed.

  #[export]
  #[refine] Instance inst_ap_comp (Y Z: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Tm}
    {vrZ: Vr Z} {wkZ: Wk Z} {liftZ: Lift Z Tm}
    {apYZ: Ap Y Z} {compUpYZ: LemCompUp Y Z}
    {apLiftYTmZ: LemApLift Y Z Tm} :
    LemApComp Tm Y Z := {}.
  Proof. induction x; crush. Qed.

  #[export]
  #[refine] Instance inst_ap_liftSub (Y: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Tm} :
    LemApLiftSub Tm Y := {}.
  Proof. induction t; crush. Qed.

  Lemma inst_ap_ixComp (t: Tm) :
    ∀ (ξ: Sub Ix) (ζ: Sub Tm), t[ξ][ζ] = t[⌈ξ⌉ >=> ζ].
  Proof. pose proof up_comp_lift. induction t; crush. Qed.

End TmKit.

Module InstTm := Inst TmKit.
Export InstTm. (* Export for shorter names. *)

#[export]
Instance wsVrTm: WsVr Tm.
Proof.
  constructor.
  - now constructor.
  - now inversion 1.
Qed.

Section Application.

  Context {Y: Type}.
  Context {vrY : Vr Y}.
  Context {wkY: Wk Y}.
  Context {liftY: Lift Y Tm}.
  Context {wsY: Ws Y}.
  Context {wsVrY: WsVr Y}.
  Context {wsWkY: WsWk Y}.
  Context {wsLiftY: WsLift Y Tm}.

  Hint Resolve wsLift : ws.
  Hint Resolve wsSub_up : ws.

  Global Instance wsApTm : WsAp Tm Y.
  Proof.
    constructor.
    - intros ξ γ δ t wξ wt; revert ξ δ wξ.
      induction wt; intros ξ δ wξ; crush;
      try econstructor;
      try match goal with
            | |- wsTm ?δ ?t =>
              change (wsTm δ t) with ⟨ δ ⊢ t ⟩
          end; eauto with ws.
    - intros γ t wt.
      induction wt; crush.
      + apply IHwt; inversion 1; crush.
      + apply IHwt2; inversion 1; crush.
      + apply IHwt3; inversion 1; crush.
  Qed.
End Application.

#[export]
Instance wsWkTm: WsWk Tm.
Proof.
  constructor; crush.
  - refine (wsAp _ H); eauto.
    constructor; eauto.
Qed.
(*   - admit. *)
(*     (* induction x; cbn in H; inversion H. *) *)
(*     (* + change (wk i) with (S i) in *. *) *)
(*     (*   inversion H1; subst. eapply WsVar; eassumption. *) *)
(*     (* +  *) *)
(* Admitted. *)


From bisimulations Require Import prelude.
From bisimulations Require Import system.
From bisimulations Require Import relations.
From bisimulations Require Import paths.
From bisimulations Require Import nonreflexive.semibranching.
From bisimulations Require Import reflexive.branching.

Section NonreflVsRefl.
Context `{System : system X}.

Notation nr_sb_apart := (@nonreflexive.semibranching.sb_apart X System).
Notation r_b_apart := (@reflexive.branching.b_apart X WithRefl).

Theorem nonrefl_to_refl : ∀ p q, nr_sb_apart p q → r_b_apart p q.
Proof. eapply nonreflexive.semibranching.sb_apart_strong_ind'; [eauto with hints|..].
  - intros p1 p2 q1 Hp12 Ha_p2_q1 HQ.
    eapply reflexive.branching.b_apart_step; [by eapply WithRefl_can_step|].
    intros q2 Hq12 q3 Hq23.
    rewrite <- WithRefl_rtc_can_step in Hq12.
    destruct Hq23 as [Hq23|[_ <-]].
    { by destruct (HQ q2 Hq12 q3 Hq23) as [[]|]; [left|right]. }
    eapply rtc_inv_r in Hq12 as [<-|(qm & Hq1m & Hqm2)].
    { by right. }
    by destruct (HQ qm Hq1m q2 Hqm2) as [[]|]; [left|right].
  - intros p1 p2 q1 Hp12 HQ.
    eapply reflexive.branching.b_apart_step; [by eapply WithRefl_can_step|].
    intros q2 Hq12 q3 Hq23.
    rewrite <- WithRefl_rtc_can_step in Hq12.
    rewrite <- WithRefl_can_step_loud in Hq23.
    by destruct (HQ q2 Hq12 q3 Hq23); [left|right].
Qed.

Theorem refl_to_nonrefl : ∀ p q, r_b_apart p q → nr_sb_apart p q.
Proof. eapply reflexive.branching.b_apart_strong_ind'; [eauto with hints|intros [] p1 p2 q1 Hp12 HQ].
  - assert (rtc (@can_step X WithRefl silent) q1 q1) as Hq11 by eauto with steps.
    assert (@can_step X WithRefl silent q1 q1) as Hq11' by by right.
    destruct (HQ q1 Hq11 q1 Hq11'); try done.
    destruct Hp12 as [Hp12|[_ <-]]; [|done].
    eapply sb_apart_silent; try done.
    intros q2 Hq12 q3 Hq23.
    rewrite WithRefl_rtc_can_step in Hq12.
    eapply WithRefl_can_step in Hq23.
    assert (rtc (@can_step X WithRefl silent) q1 q3) as Hq13 by eauto with steps.
    assert (@can_step X WithRefl silent q3 q3) as Hq33' by by right.
    destruct (HQ q3 Hq13 q3 Hq33') as [|]; [|by right].
    destruct (HQ q2 Hq12 q3 Hq23) as [|]; [left|right]; eauto with hints.
  - eapply WithRefl_can_step_loud in Hp12.
    eapply sb_apart_loud; try done.
    intros q2 Hq12 q3 Hq23.
    rewrite WithRefl_rtc_can_step in Hq12.
    eapply WithRefl_can_step_loud in Hq23.
    by destruct (HQ q2 Hq12 q3 Hq23) as [|]; [left|right].
Qed.

End NonreflVsRefl.


From iris.proofmode Require Import base proofmode classes.
From iris.base_logic.lib Require Export fancy_updates.
From iris.algebra Require Import excl.
From iris.bi Require Export weakestpre fixpoint big_op.
From iris.prelude Require Import options.
From iris.base_logic.lib Require Export ghost_map invariants.

From self.prelude Require Import stdpp_ext iris_ext.
From self.program_logic Require Export exec weakestpre.
From self.prob_lang Require Import
  primitive_laws class_instances spec_ra tactics notation erasure
  metatheory lang.
From self.prob Require Export couplings distribution.
Import uPred.

Section adequacy.
  Context `{!prelocGS Σ}.

  Lemma refRcoupl_dbind' `{Countable A, Countable A', Countable B, Countable B'}
    (f : A → distr A') (g : B → distr B') (μ1 : distr A) (μ2 : distr B) (R : A → B → Prop) (T : A' → B' → Prop) n :
    ⌜refRcoupl μ1 μ2 R⌝ -∗
    (∀ a b, ⌜R a b⌝ ={∅}▷=∗^(S n) ⌜refRcoupl (f a) (g b) T⌝) -∗
    |={∅}▷=>^(S n) ⌜refRcoupl (dbind f μ1) (dbind g μ2) T⌝ : iProp Σ.
  Proof.
    iIntros (HR) "H".
    iApply (step_fupdN_mono _ _ _ (⌜(∀ a b, R a b → refRcoupl (f a) (g b) T)⌝)).
    { iIntros (?). iPureIntro. by eapply refRcoupl_dbind. }
    iIntros (???) "/=".
    iMod ("H" with "[//]"); auto.
  Qed.

  Lemma exec_coupl_erasure (e1 : expr) (σ1 : state) (e1' : expr) (σ1' : state) (n : nat) φ :
    to_val e1 = None →
    exec_coupl e1 σ1 e1' σ1' (λ '(e2, σ2) '(e2', σ2'),
        |={∅}▷=>^(S n) ⌜refRcoupl (exec_val n (e2, σ2)) (lim_exec_val (e2', σ2')) φ⌝)
    ⊢ |={∅}▷=>^(S n) ⌜refRcoupl (exec_val (S n) (e1, σ1)) (lim_exec_val (e1', σ1')) φ⌝.
  Proof.
    iIntros (Hv) "Hexec".
    iAssert (⌜to_val e1 = None⌝)%I as "-#H"; [done|]. iRevert "Hexec H".
    rewrite /exec_coupl /exec_coupl'.
    set (Φ := (λ '((e1, σ1), (e1', σ1')),
                (⌜to_val e1 = None⌝ ={∅}▷=∗^(S n)
                 ⌜refRcoupl (exec_val (S n) (e1, σ1))
                            (lim_exec_val (e1', σ1')) φ⌝)%I) :
           prodO cfgO cfgO → iPropI Σ).
    assert (NonExpansive Φ).
    { intros m ((?&?)&(?&?)) ((?&?)&(?&?)) [[[=] [=]] [[=] [=]]]. by simplify_eq. }
    set (F := (exec_coupl_pre (λ '(e2, σ2) '(e2', σ2'),
                   |={∅}▷=>^(S n) ⌜refRcoupl (exec_val n (e2, σ2))
                     (lim_exec_val (e2', σ2')) φ⌝)%I)).
    iPoseProof (least_fixpoint_iter F Φ with "[]") as "H"; last first.
    { iIntros "Hfix %". by iMod ("H" $! ((_, _), (_, _)) with "Hfix [//]"). }
    clear.
    iIntros "!#" ([[e1 σ1] [e1' σ1']]). rewrite /exec_coupl_pre.
    iIntros "[(%R & % & %Hcpl & H) | [(%R & % & %Hcpl & H) | [(%R & %m & %Hcpl & H) | [H | [H | H]]]]] %Hv".
    - rewrite exec_val_Sn_not_val; [|done].
      rewrite lim_exec_val_prim_step.
      destruct (to_val e1') eqn:Hv'.
      + destruct (decide (prim_step e1 σ1 = dzero)) as [Hs|].
        * rewrite /= Hs dbind_dzero.
          do 3 iModIntro. iApply step_fupdN_intro; [done|].
          iModIntro. iPureIntro.
          apply refRcoupl_dzero.
        * assert (prim_step e1' σ1' = dzero) as Hz by by apply val_stuck_dzero.
          rewrite /= (val_stuck_dzero e1') in Hcpl; [|eauto].
          by apply Rcoupl_dzero_r_inv in Hcpl.
      + rewrite prim_step_or_val_no_val; [|done].
        iApply (refRcoupl_dbind' _ _ _ _ R).
        { iPureIntro. by apply Rcoupl_refRcoupl. }
        iIntros ([] [] HR). by iMod ("H" with "[//]").
    - rewrite exec_val_Sn_not_val; [|done].
      rewrite -(dret_id_left (lim_exec_val)).
      iApply refRcoupl_dbind'.
      { iPureIntro. apply Rcoupl_pos_R in Hcpl. by apply Rcoupl_refRcoupl. }
      iIntros ([] [] (?&?& [= -> ->]%dret_pos)).
      by iMod ("H"  with "[//]").
    - rewrite -(dret_id_left (exec_val _)).
      rewrite (lim_exec_val_exec m).
      iApply refRcoupl_dbind'.
      { iPureIntro. apply Rcoupl_pos_R in Hcpl. by apply Rcoupl_refRcoupl. }
      iIntros ([] [] (?& [= -> ->]%dret_pos &?)).
      by iMod ("H"  with "[//] [//]").
    - iDestruct (big_orL_mono _ (λ _ _,
                     |={∅}▷=>^(S n)
                       ⌜refRcoupl (exec_val (S n) (e1, σ1))
                                  (lim_exec_val (e1', σ1')) φ⌝)%I
                  with "H") as "H".
      { iIntros (i α Hα%elem_of_list_lookup_2) "(% & % & %Hcpl & H)".
        iApply (step_fupdN_mono _ _ _
                  (⌜∀ e2 σ2 σ2', R2 (e2, σ2) σ2' → refRcoupl (exec_val n (e2, σ2))
                                                             (lim_exec_val (e1', σ2')) φ⌝)%I).
        - iIntros (?). iPureIntro.
          rewrite /= /get_active in Hα.
          apply elem_of_elements, elem_of_dom in Hα as [].
          eapply refRcoupl_erasure_r; eauto.
        - iIntros (????). by iMod ("H" with "[//]"). }
      iInduction (language.get_active σ1') as [| α'] "IH"; [done|].
      rewrite big_orL_cons.
      iDestruct "H" as "[H | Ht]"; [done|].
      by iApply "IH".
    - iDestruct (big_orL_mono _ (λ _ _,
                     |={∅}▷=>^(S n)
                       ⌜refRcoupl (exec_val (S n) (e1, σ1))
                                  (lim_exec_val (e1', σ1')) φ⌝)%I
                  with "H") as "H".
      { iIntros (i α' Hα'%elem_of_list_lookup_2) "(% & %Hcpl & H)".
        iApply (step_fupdN_mono _ _ _
                  (⌜∀ σ2 e2' σ2', R2 σ2 (e2', σ2') → refRcoupl (exec_val (S n) (e1, σ2))
                                                               (lim_exec_val (e2', σ2')) φ⌝)%I).
        - iIntros (?). iPureIntro.
          rewrite /= /get_active in Hα'.
          apply elem_of_elements, elem_of_dom in Hα' as [].
          eapply refRcoupl_erasure_l; eauto.
        - iIntros (????). by iMod ("H" with "[//] [//]"). }
      iInduction (language.get_active σ1) as [| α'] "IH"; [done|].
      rewrite big_orL_cons.
      iDestruct "H" as "[H | Ht]"; [done|].
      by iApply "IH".
    - rewrite exec_val_Sn_not_val; [|done].
      iDestruct (big_orL_mono _ (λ _ _,
                     |={∅}▷=>^(S n)
                       ⌜refRcoupl (prim_step e1 σ1 ≫= exec_val n)
                                  (lim_exec_val (e1', σ1')) φ⌝)%I
                  with "H") as "H".
      { iIntros (i [α1 α2] [Hα1 Hα2]%elem_of_list_lookup_2%elem_of_list_prod_1) "(% & %Hcpl & H)".
        rewrite -exec_val_Sn_not_val; [|done].
        iApply (step_fupdN_mono _ _ _
                  (⌜∀ σ2 σ2', R2 σ2 σ2' → refRcoupl (exec_val (S n) (e1, σ2))
                                                    (lim_exec_val (e1', σ2')) φ⌝)%I).
        - iIntros (?). iPureIntro.
          rewrite /= /get_active in Hα1, Hα2.
          apply elem_of_elements, elem_of_dom in Hα1 as [], Hα2 as [].
          eapply refRcoupl_erasure; eauto.
        - iIntros (???). by iMod ("H" with "[//] [//]"). }
      iInduction (list_prod (language.get_active σ1) (language.get_active σ1'))
        as [| [α α']] "IH"; [done|].
      rewrite big_orL_cons.
      iDestruct "H" as "[H | Ht]"; [done|].
      by iApply "IH".
  Qed.

  Theorem wp_refRcoupl_step_fupdN (e e' : expr) (σ σ' : state) n φ :
    state_interp σ ∗ spec_interp (e', σ') ∗ spec_ctx ∗ WP e {{ v, ∃ v', ⤇ Val v' ∗ ⌜φ v v'⌝ }} ⊢
    |={⊤,∅}=> |={∅}▷=>^n ⌜refRcoupl (exec_val n (e, σ)) (lim_exec_val (e', σ')) φ⌝.
  Proof.
    iInduction n as [|n] "IH" forall (e σ e' σ'); iIntros "([Hh Ht] & HspecI_auth & #Hctx & Hwp)".
    - rewrite /exec_val /=.
      destruct (to_val e) eqn:Heq.
      + apply of_to_val in Heq as <-.
        rewrite wp_value_fupd.
        iMod "Hwp" as (v') "[Hspec_frag %]".
        iInv specN as (ρ e0 σ0 n) ">(HspecI_frag & %Hexec & Hspec_auth & Hstate)" "_".
        iDestruct (spec_interp_auth_frag_agree with "HspecI_auth HspecI_frag") as %<-.
        iDestruct (spec_prog_auth_frag_agree with "Hspec_auth Hspec_frag") as %->.
        iApply fupd_mask_intro; [set_solver|]; iIntros "_".
        erewrite lim_exec_val_exec_det; [|done].
        iPureIntro.
        rewrite /dmap.
        by apply refRcoupl_dret.
      + iApply fupd_mask_intro; [set_solver|]; iIntros "_".
        iPureIntro.
        apply refRcoupl_dzero.
    - rewrite exec_val_Sn /prim_step_or_val /=.
      destruct (to_val e) eqn:Heq.
      + apply of_to_val in Heq as <-.
        rewrite wp_value_fupd.
        iMod "Hwp" as (v') "[Hspec_frag %]".
        iInv specN as (ξ ρ e0 σ0) ">(HspecI_frag & %Hexec & Hspec_auth & Hstate)" "_".
        iDestruct (spec_interp_auth_frag_agree with "HspecI_auth HspecI_frag") as %<-.
        iDestruct (spec_prog_auth_frag_agree with "Hspec_auth Hspec_frag") as %->.
        iApply fupd_mask_intro; [set_solver|]; iIntros "_".
        iApply step_fupdN_intro; [done|]. do 4 iModIntro.
        iPureIntro.
        rewrite exec_val_unfold dret_id_left /=.
        erewrite lim_exec_val_exec_det; [|done].
        by apply refRcoupl_dret.
      + rewrite wp_unfold /wp_pre /= Heq.
        iMod ("Hwp" with "[$]") as "Hcpl".
        iModIntro.
        iPoseProof
          (exec_coupl_mono _ (λ '(e2, σ2) '(e2', σ2'), |={∅}▷=>^(S n)
             ⌜refRcoupl (exec_val n (e2, σ2)) (lim_exec_val (e2', σ2')) φ⌝)%I
            with "[] Hcpl") as "H".
        { iIntros ([] []) "H !> !>".
          iMod "H" as "(Hstate & HspecI_auth & Hwp)".
          iMod ("IH" with "[$]") as "H".
          iModIntro. done. }
        rewrite -exec_val_Sn_not_val; [|done].
        by iApply (exec_coupl_erasure with "H").
  Qed.

End adequacy.

Class prelocGpreS Σ := PrelocGpreS {
  prelocGpreS_iris  :> invGpreS Σ;
  prelocGpreS_heap  :> ghost_mapG Σ loc val;
  prelocGpreS_tapes :> ghost_mapG Σ loc (list bool);
  prelocGpreS_cfg   :> inG Σ (authUR cfgUR);
  prelocGpreS_prog  :> inG Σ (authR progUR);
}.

Definition prelocΣ : gFunctors :=
  #[invΣ; ghost_mapΣ loc val; ghost_mapΣ loc (list bool);
    GFunctor (authUR cfgUR); GFunctor (authUR progUR)].
Global Instance subG_prelocGPreS {Σ} : subG prelocΣ Σ → prelocGpreS Σ.
Proof. solve_inG. Qed.

Theorem wp_refRcoupl Σ `{prelocGpreS Σ} (e e' : expr) (σ σ' : state) n φ :
  (∀ `{prelocGS Σ}, ⊢ spec_ctx -∗ ⤇ e' -∗ WP e {{ v, ∃ v', ⤇ Val v' ∗ ⌜φ v v'⌝ }}) →
  refRcoupl (exec_val n (e, σ)) (lim_exec_val (e', σ')) φ.
Proof.
  intros Hwp.
  eapply (step_fupdN_soundness_no_lc _ n 0).
  iIntros (Hinv) "_".
  iMod (ghost_map_alloc σ.(heap)) as "[%γH [Hh _]]".
  iMod (ghost_map_alloc σ.(tapes)) as "[%γT [Ht _]]".
  iMod (ghost_map_alloc σ'.(heap)) as "[%γHs [Hh_spec _]]".
  iMod (ghost_map_alloc σ'.(tapes)) as "[%γTs [Ht_spec _]]".
  iMod (own_alloc ((● (Excl' (e', σ'))) ⋅ (◯ (Excl' (e', σ'))))) as "(%γsi & Hsi_auth & Hsi_frag)".
  { by apply auth_both_valid_discrete. }
  iMod (own_alloc ((● (Excl' e')) ⋅ (◯ (Excl' e')))) as "(%γp & Hprog_auth & Hprog_frag)".
  { by apply auth_both_valid_discrete. }
  set (HspecGS := CfgSG Σ _ γsi _ γp _ _ γHs γTs).
  set (HprelocGS := HeapG Σ _ _ _ γH γT HspecGS).
  iMod (inv_alloc specN ⊤ spec_inv with "[Hsi_frag Hprog_auth Hh_spec Ht_spec]") as "#Hctx".
  { iModIntro. iExists _, _, _, O. iFrame. rewrite exec_O dret_1_1 //. }
  iApply wp_refRcoupl_step_fupdN.
  iFrame. iFrame "Hctx".
  by iApply (Hwp with "[Hctx] [Hprog_frag]").
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import PendingCheckAux.Spec.
Require Import RVIC4.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition check_pending_ptimers_spec0 (rec: Pointer) (adt: RData) : option RData :=
    match rec with
    | (_rec_base, _rec_ofst) =>
      when'' _g_rec_base, _g_rec_ofst == get_rec_g_rec_spec (_rec_base, _rec_ofst) adt;
      rely is_int _g_rec_ofst;
      when' _cntp_ctl == sysreg_read_spec 32 adt;
      rely is_int64 _cntp_ctl;
      when'' _t'6_base, _t'6_ofst == get_rec_ptimer_spec (_rec_base, _rec_ofst) adt;
      rely is_int _t'6_ofst;
      when _t'7, adt == check_timer_became_asserted_spec (_t'6_base, _t'6_ofst) (VZ64 _cntp_ctl) adt;
      rely is_int _t'7;
      if (_t'7 =? 1) then
        when adt == granule_lock_spec (_g_rec_base, _g_rec_ofst) adt;
        rely is_int64 (Z.lor _cntp_ctl 2);
        let _cntp_ctl := (Z.lor _cntp_ctl 2) in
        when adt == sysreg_write_spec 32 (VZ64 _cntp_ctl) adt;
        when' _t'3 == get_rec_sysregs_spec (_rec_base, _rec_ofst) 69 adt;
        rely is_int64 _t'3;
        rely is_int64 (Z.land _t'3 18446744073709549567);
        when adt == set_rec_sysregs_spec (_rec_base, _rec_ofst) 69 (VZ64 (Z.land _t'3 18446744073709549567)) adt;
        when' _t'4 == get_rec_sysregs_spec (_rec_base, _rec_ofst) 69 adt;
        rely is_int64 _t'4;
        when adt == sysreg_write_spec 69 (VZ64 _t'4) adt;
        when adt == set_rec_ptimer_asserted_spec (_rec_base, _rec_ofst) 1 adt;
        when'' _t'5_base, _t'5_ofst == get_rec_rvic_spec (_rec_base, _rec_ofst) adt;
        rely is_int _t'5_ofst;
        when adt == rvic_set_pending_spec (_t'5_base, _t'5_ofst) (VZ64 30) adt;
        when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
        Some adt
      else
        Some adt
     end
    .

End SpecLow.


Require Import Ctl.Paths.
Require Import Ctl.Definition.
Require Import Ctl.Basic.
Open Scope tprop_scope.

Require Import Glib.Glib.

Ltac tentails :=
  match goal with
  | |- ?R @?s ⊨ ⟦?P⟧   => change (P s)
  | |- ?R @?s ⊭ ⟦?P⟧   => change (~ P s)
  | |- ?R @?s ⊨ !⟦?P⟧ => change (~ P s)
  end.

Tactic Notation "tentails!" :=
  cbn;
  repeat match goal with
  | |- ?R @?s ⊨ ?P => unfold P
  | |- ?R @?s ⊭ ?P => unfold P
  | |- ?R @?s ⊨ ! ?P => unfold P
  end;
  tentails;
  cbn.

Tactic Notation "tentails" "in" hyp(H) :=
  change (?R @?s ⊨ ⟦?P⟧)   with (P s) in H +
  change (?R @?s ⊭ ⟦?P⟧)   with (~ P s) in H +
  change (?R @?s ⊨ !⟦?P⟧) with (~ P s) in H.

Tactic Notation "tentails!" "in" hyp(H) :=
  cbn in H;
  repeat match type of H with
  | ?R @?s ⊨ ?P => unfold P in H
  | ?R @?s ⊭ ?P => unfold P in H
  | ?R @?s ⊨ ! ?P => unfold P in H
  end;
  progress tentails in H;
  cbn in H.

Tactic Notation "tentails" "in" "*" :=
  try tentails;
  repeat find (fun H => tentails in H).

Tactic Notation "tentails!" "in" "*" :=
  try tentails!;
  repeat find (fun H => tentails! in H).

Tactic Notation "unfold_timpl" :=
  progress change_no_check (?R @?s ⊨ ?p ⇾ ?q) with (R @s ⊨ p -> R @s ⊨ q) +
  rewrite rew_timpl +
  setoid_rewrite rew_timpl.
Tactic Notation "unfold_timpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?p ⇾ ?q) with (R @s ⊨ p -> R @s ⊨ q) in H +
  rewrite rew_timpl in H +
  setoid_rewrite rew_timpl in H.

Tactic Notation "unfold_tnot" :=
  progress change_no_check (?R @?s ⊨ !?P) with (R @s ⊭ P) +
  rewrite rew_tnot +
  setoid_rewrite rew_tnot.
Tactic Notation "unfold_tnot" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ !?P) with (R @s ⊭ P) in H +
  rewrite rew_tnot in H +
  setoid_rewrite rew_tnot in H.

Tactic Notation "unfold_tconj" :=
  progress change_no_check (?R @?s ⊨ ?P && ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) +
  rewrite rew_tconj +
  setoid_rewrite rew_tconj.
Tactic Notation "unfold_tconj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P && ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) in H +
  rewrite rew_tconj in H +
  setoid_rewrite rew_tconj in H.

Tactic Notation "unfold_tdisj" :=
  progress change_no_check (?R @?s ⊨ ?P || ?Q) with (R @s ⊨ P \/ R @s ⊨ Q) +
  rewrite rew_tdisj +
  setoid_rewrite rew_tdisj.
Tactic Notation "unfold_tdisj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P || ?Q) with (R @s ⊨ P \/ R @s ⊨ Q) in H +
  rewrite rew_tdisj in H +
  setoid_rewrite rew_tdisj in H.

Tactic Notation "unfold_tbiimpl" :=
  progress change_no_check (?R @?s ⊨ ?P ⇿ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) +
  rewrite rew_tbiimpl +
  setoid_rewrite rew_tbiimpl.
Tactic Notation "unfold_tbiimpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ⇿ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) in H +
  rewrite rew_tbiimpl in H +
  setoid_rewrite rew_tbiimpl in H.

Tactic Notation "unfold_tlift" :=
  progress change_no_check (?R @?s ⊨ ⟦?P⟧) with (P s) +
  rewrite rew_tlift +
  setoid_rewrite rew_tlift.
Tactic Notation "unfold_tlift" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ⟦?P⟧) with (P s) in H +
  rewrite rew_tlift in H +
  setoid_rewrite rew_tlift in H.

Tactic Notation "unfold_AX" :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) +
  rewrite rew_AX +
  setoid_rewrite rew_AX.
Tactic Notation "unfold_AX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) in H +
  rewrite rew_AX in H +
  setoid_rewrite rew_AX in H.

Tactic Notation "unfold_EX" :=
  progress change_no_check (?R @?s ⊨ EX ?P) with (exists s', R s s' /\ R @s' ⊨ P) +
  rewrite rew_EX +
  setoid_rewrite rew_EX.
Tactic Notation "unfold_EX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EX ?P) with (exists s', R s s' /\ R @s' ⊨ P) in H +
  rewrite rew_EX in H +
  setoid_rewrite rew_EX in H.

Tactic Notation "unfold_AG" :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall (p: path R s) s', in_path s' p -> R @s' ⊨ P) +
  rewrite rew_AG +
  setoid_rewrite rew_AG.
Tactic Notation "unfold_AG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall (p: path R s) s', in_path s' p -> R @s' ⊨ P) in H +
  rewrite rew_AG in H +
  setoid_rewrite rew_AG in H.

Tactic Notation "unfold_EG" :=
  progress change_no_check (?R @?s ⊨ EG ?P) with
    (exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P) +
  rewrite rew_EG +
  setoid_rewrite rew_EG.
Tactic Notation "unfold_EG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EG ?P) with
    (exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P) in H +
  rewrite rew_EG in H +
  setoid_rewrite rew_EG in H.

Tactic Notation "unfold_AF" :=
  progress change_no_check (?R @?s ⊨ AF ?P) with
    (forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P) +
  rewrite rew_AF +
  setoid_rewrite rew_AF.
Tactic Notation "unfold_AF" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AF ?P) with
    (forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P) in H +
  rewrite rew_AF in H +
  setoid_rewrite rew_AF in H.

Tactic Notation "unfold_EF" :=
  progress change_no_check (?R @?s ⊨ EF ?P) with
    (exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P) +
  rewrite rew_EF +
  setoid_rewrite rew_EF.
Tactic Notation "unfold_EF" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EF ?P) with
    (exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P) in H +
  rewrite rew_EF in H +
  setoid_rewrite rew_EF in H.

Tactic Notation "unfold_AU" :=
  progress change_no_check (?R @?s ⊨ A[?P U ?Q]) with
    (forall p: path R s, exists i,
      (forall x, in_path_before x i p -> R @x ⊨ P) /\
      R @(p i) ⊨ Q) +
  rewrite rew_AU +
  setoid_rewrite rew_AU.
Tactic Notation "unfold_AU" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ A[?P U ?Q]) with
    (forall p: path R s, exists i,
      (forall x, in_path_before x i p -> R @x ⊨ P) /\
      R @(p i) ⊨ Q) +
  rewrite rew_AU in H +
  setoid_rewrite rew_AU in H.

Tactic Notation "unfold_EU" :=
  progress change_no_check (?R @?s ⊨ E[?P U ?Q]) with
    (exists (p: path R s) i,
      (forall x, in_path_before x i p -> R @x ⊨ P) /\
      R @(p i) ⊨ Q) +
  rewrite rew_EU +
  setoid_rewrite rew_EU.
Tactic Notation "unfold_EU" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ E[?P U ?Q]) with
    (exists (p: path R s) i,
      (forall x, in_path_before x i p -> R @x ⊨ P) /\
      R @(p i) ⊨ Q) +
  rewrite rew_EU in H +
  setoid_rewrite rew_EU in H.

Tactic Notation "unfold_AW" :=
  progress change_no_check (?R @?s ⊨ A[?P W ?Q]) with
    (forall p: path R s,
      (forall x, in_path x p -> R @x ⊨ P && !Q) \/
      (exists i,
        (forall x, in_path_before x i p -> R @x ⊨ P) /\
        R @(p i) ⊨ Q)) +
  rewrite rew_AW +
  setoid_rewrite rew_AW.
Tactic Notation "unfold_AW" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ A[?P W ?Q]) with
    (forall p: path R s,
      (forall x, in_path x p -> R @x ⊨ P && !Q) \/
      (exists i,
        (forall x, in_path_before x i p -> R @x ⊨ P) /\
        R @(p i) ⊨ Q)) in H +
  rewrite rew_AW in H +
  setoid_rewrite rew_AW in H.

(* tintro - intro a timpl *)

Tactic Notation "tintro" :=
  match goal with
  | |- _ @_ ⊨ !_ => unfold_tnot; intro
  | |- _ @_ ⊨ _ ⇾ _ => unfold_timpl; intro
  end.

Tactic Notation "tintro" ident(x) :=
  match goal with
  | |- _ @_ ⊨ !_ => unfold_tnot; intro x
  | |- _ @_ ⊨ _ ⇾ _ => unfold_timpl; intro x
  end.

Tactic Notation "tintros" :=
  repeat tintro.
Tactic Notation "tintros" ident(x1) :=
  tintro x1.
Tactic Notation "tintros" ident(x1) ident(x2) :=
  tintro x1; tintros x2.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) :=
  tintro x1; tintros x2 x3.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) :=
  tintro x1; tintros x2 x3 x4.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) ident(x5) :=
  tintro x1; tintros x2 x3 x4 x5.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) ident(x6) :=
  tintro x1; tintros x2 x3 x4 x5 x6.

(* tsimpl - simple a tprop *)

(* Remove AX? May go on forever *)
Tactic Notation "tsimpl_step" :=
  unfold_timpl +
  unfold_tbiimpl +
  unfold_tnot +
  unfold_AX +
  unfold_EX +
  unfold_AG +
  unfold_EG +
  unfold_AF +
  unfold_EF +
  unfold_AU +
  unfold_EU +
  unfold_AW.

Tactic Notation "tsimpl_step" "in" hyp(H) :=
  unfold_timpl in H +
  unfold_tbiimpl in H +
  unfold_tnot in H +
  unfold_AX in H +
  unfold_EX in H +
  unfold_AG in H +
  unfold_EG in H +
  unfold_AF in H +
  unfold_EF in H +
  unfold_AU in H +
  unfold_EU in H +
  unfold_AW in H.

Tactic Notation "tsimpl" := repeat tsimpl_step.
Tactic Notation "tsimpl" "in" hyp(H) := repeat tsimpl_step in H.
Tactic Notation "tsimpl" "in" "*" :=
  try tsimpl;
  repeat match goal with
  | H: _ @_ ⊨ _ |- _ => tsimpl in H
  end.

(* tapply: carefully unfolds TProp hypothesis just enough to use apply *)

Ltac _tapply_unfold_step H :=
  match type of H with
  | _ @_ ⊨ _ ⇾ _ =>
      unfold_timpl in H
  | _ @_ ⊨ !_ =>
      unfold_tnot in H
  | _ @_ ⊨ _ ⇿ _ =>
      unfold_tbiimpl in H
  | _ @_ ⊨ AX _ =>
      unfold_AX in H
  | _ @_ ⊨ AG _ =>
      unfold_AG in H
  end +
  unfold_timpl in H +
  unfold_tnot in H +
  unfold_tbiimpl in H +
  unfold_AX in H +
  unfold_AG in H.

Ltac _tapply_aux H :=
  apply H + (_tapply_unfold_step H; _tapply_aux H).

Ltac _tapply_aux_in H H2 :=
  apply H in H2 + (_tapply_unfold_step H; _tapply_aux_in H H2).

Ltac _etapply_aux H :=
  eapply H + (_tapply_unfold_step H; _etapply_aux H).

Ltac _etapply_aux_in H H2 :=
  eapply H in H2 + (_tapply_unfold_step H; _etapply_aux_in H H2).

Tactic Notation "tapply" uconstr(c) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _tapply_aux Htemp;
  clear Htemp.

Tactic Notation "tapply" uconstr(c) "in" hyp(H) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _tapply_aux_in Htemp H;
  clear Htemp.

Tactic Notation "etapply" uconstr(c) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _etapply_aux Htemp;
  clear Htemp.

Tactic Notation "etapply" uconstr(c) "in" hyp(H) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _etapply_aux_in Htemp H;
  clear Htemp.

Tactic Notation "tapplyc" hyp(H) :=
  tapply H; clear H.
Tactic Notation "tapplyc" hyp(H) "in" hyp(H2) :=
  tapply H in H2; clear H.
Tactic Notation "etapplyc" hyp(H) :=
  etapply H; clear H.
Tactic Notation "etapplyc" hyp(H) "in" hyp(H2) :=
  etapply H in H2; clear H.

Tactic Notation "tcut" uconstr(P) :=
  match goal with
  | |- ?R @?s ⊨ ?Q =>
      cut (R @s ⊨ P); [change (R @s ⊨ P ⇾ Q)| ]
  end.

Tactic Notation "tforward" hyp(H):=
  match type of H with
  | ?R @?s ⊨ ?P ⇾ ?Q =>
      let _temp := fresh in
      define (R @s ⊨ P) as _temp;
      [ |
        specialize (H _temp);
        unfold _temp in H;
        clear _temp
      ]
 end.

Tactic Notation "tforward" hyp(H) "by" tactic3(tac) :=
  tforward H; [solve [tac]| ].

Close Scope tprop_scope.


Require Import FiatFormal.Language.Step.
Require Import FiatFormal.Language.SubstExpExp.
Require Import FiatFormal.Language.SubstTypeExp.
Require Import FiatFormal.Language.SubstTypeType.
Require Import FiatFormal.Language.TyJudge.

Lemma In_Context :
  forall C Val x,
    exps_ctx Val C
    -> @In exp x (C x).
Proof.
  intros.
  induction H; auto.
Qed.

Lemma canonicalFormTFun :
  forall ds ke te t1 t2 x,
    TYPE ds ke te x (TFun t1 t2)
    -> value x
    -> exists x', x = (XFix t1 t2 x').
Proof.
  intros. gen ds ke te t1 t2 H0.
  induction x using exp_mutind
    with (PA := fun a => a = a); rip; try inverts H0; try nope; try inverts H.
  exists x; reflexivity.
Qed.

Lemma canonicalFormTNFun :
  forall ds ke te tsArgs tRes x,
    TYPE ds ke te x (TNFun tsArgs tRes)
    -> value x
    -> exists x', x = (XNFun tsArgs x').
Proof.
  intros. gen ds ke te tsArgs tRes H0.
  induction x using exp_mutind
    with (PA := fun a => a = a); rip; try inverts H0; try nope; try inverts H.
  exists x; reflexivity.
Qed.

Lemma canonicalFormTNProd :
  forall ds ke te ts x,
    TYPE ds ke te x (TNProd ts)
    -> value x
    -> exists xs, x = (XTup xs).
Proof.
  intros. gen ds ke te ts H0.
  induction x using exp_mutind
    with (PA := fun a => a = a); rip; try inverts H0; try nope; try inverts H.
  exists (@nil exp); reflexivity.
  exists (l0 :> x); reflexivity.
Qed.

Lemma wellTypedProjHasX :
  forall ds ke te ts t xs n,
    TYPE ds ke te (XTup xs) (TNProd ts)
    -> get n ts = Some t
    -> exists x, get n xs = Some x.
Proof.
  intros.
  inverts H.
  pose proof @get_length_less_exists exp.
  pose proof(Forall2_length _ _ _ H5).
  apply get_length_less in H0. rewrite <- H1 in H0.
  spec H H0. dest x. eauto.
Qed.

(* A well typed expression is either a value, can take a step,
   or contains a choice. *)
Theorem progress
  : forall pb ds pbOK x,
    (exists t, TYPE ds nil nil x t)
    -> value x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x.
Proof.
 intros. gen pb ds pbOK.
 induction x using exp_mutind with
     (PA := fun a => a = a);
   rip; first [destruct H as [tx] | destruct H0 as [tx]];
     try invert_exp_type; nope.

 Case "XApp".
 right.
 edestruct IHx1; eauto.
 SCase "value x1".
 edestruct IHx2; eauto.
 SSCase "value x2".
 pose proof (canonicalFormTFun).
 spec H1 H4. spec H1 H. destruct H1 as [x' LAM]; subst.
 SSSCase "fix".
 left; exists (substXX 0 (XFix t11 tx x') (substXX 0 x2 x')). apply EsFixApp. inverts H0; auto.
 destruct H0 as [STx2 | HCx2].
 SSCase "x2 steps".
 destruct STx2 as [x2'].
 left; exists (XApp x1 x2'). eauto.
 SSCase "x2 hasChoice".
 right; auto.
 destruct H as [STx1 | HCx1].
 SCase "x1 steps".
 destruct STx1 as [x1'].
 left; exists (XApp x1' x2).
 eapply (EsContext pb ds pbOK (fun xx => XApp xx x2)); eauto.
 SCase "x1 hasChoice".
 right; auto.

 Case "XTup".
 assert (Forall (fun x => wnfX x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x) xs) as HWS.
 repeat nforall. rip.
 have (exists t, TYPE ds nil nil x t). dest t.
 have (value x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x).
 inverts H2; rip.
 inverts H3; rip.
 (* All ctor args are wnf, or there is a context where one can step *)
 lets D: (@exps_ctx_run exp exp) HWS.
 inverts D.
 (* All ctor args are wnf *)
 left. eauto 6.
 (* There is a context where one ctor arg can step *)
 right.
 dest C. dest x'.
 rip. destruct H3 as [STx' | HCx'].
 left.
 lets D: step_context_XTup_exists H1 STx'.
 destruct D as [x'']. eauto.
 SCase "hasChoice x".
 (* nope. *)
 right; apply HcTup.
 apply Exists_exists. exists x'. rip.
 eapply In_Context; eauto.

 Case "XProj".
 right. assert (exists t, TYPE ds nil nil x t) by eauto.
 destruct (IHx pb ds H pbOK); eauto.
 SCase "value x".
 pose proof (canonicalFormTNProd).
 spec H1 H4. spec H1 H0. dest xs; subst.
 left.
 pose proof (wellTypedProjHasX _ _ _ _ _ _ _ H4 H6).
 dest x. exists x. apply EsTupProj; auto.
 inverts H0. inverts H2; auto.
 destruct H0 as [STx | HCx].
 SCase "x steps".
 left. dest x'. exists (XProj n x').
 eapply (EsContext pb ds pbOK (fun xx => XProj n xx)); eauto.
 SCase "x hasChoice".
 (* nope. *)
 right; auto.

 Case "XNFun".
 left; eauto.

 Case "XNApp".
 right. assert (exists t, TYPE ds nil nil x t) by eauto.
 destruct (IHx pb ds H0 pbOK); eauto.
 pose proof (canonicalFormTNFun).
 spec H2 H5. spec H2 H1. dest x'; subst.
 assert (Forall (fun x => wnfX x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x) xs) as HWS.

 repeat nforall. rip.
 have (exists t, TYPE ds nil nil x t). dest t.
 have (value x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x).
 inverts H4; rip. inverts H6. auto.
 (* All args are wnf, or there is a context where one can step *)
 lets D: (@exps_ctx_run exp exp) HWS.
 inverts D.
 (* All ctor args are wnf *)
 left. eauto 6.
 (* There is a context where one ctor arg can step *)
 dest C. rename x' into x''. dest x'.
 rip. destruct H6 as [STx' | HCx'].
 left.
 destruct STx'.
 exists (XNApp (XNFun ts x'') (C x)).
 eapply (EsContext pb ds pbOK (fun xx => XNApp (XNFun ts x'') (C xx))).
 apply XcNApp2; eauto. auto.
 SCase "x' hasChoice".
 right; apply HcNApp2.
 apply Exists_exists. exists x'. rip.
 eapply In_Context; eauto.
 destruct H1 as [STx | HCx].
 left.
 dest x'.
 exists (XNApp x' xs); eauto.
 eapply (EsContext pb ds pbOK (fun xx => XNApp xx xs)); eauto.
 SCase "x hasChoice".
 right; eauto.

 Case "XFix".
 left; eauto.

 Case "XCon".
 (* All ctor args are either wnf or can step *)
 assert (Forall (fun x => wnfX x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x) xs) as HWS.
 repeat nforall. rip.
 have (exists t, TYPE ds nil nil x t). dest t.
 have (value x \/ (exists x', STEP pb ds pbOK x x') \/ hasChoiceX x).
 inverts H2; rip.
 inverts H6; rip.
 (* All ctor args are wnf, or there is a context where one can step *)
 lets D: (@exps_ctx_run exp exp) HWS.
 inverts D.
 (* All ctor args are wnf *)
 left. eauto 6.
 (* There is a context where one ctor arg can step *)
 right.
 dest C. dest x'.
 rip. destruct H6 as [STx' | HCx'].
 left.
 lets D: step_context_XCon_exists H1 STx'.
 destruct D as [x'']. eauto.
 SCase "hasChoice x".
 right; apply HcCon.
 apply Exists_exists. exists x'. rip.
 eapply In_Context; eauto.

 Case "XMatch".
 right. assert (exists t, TYPE ds nil nil x t) by eauto.
 destruct (IHx pb ds H0 pbOK); eauto.
 SCase "x value".
 destruct x; nope.
 SSCase "XCon".
 inverts_type.
 rewrite H8 in H11. inversion H11; subst.
 assert (exists ts x, getAlt d aa = Some (AAlt d ts x)).
 apply getAlt_exists.
 repeat nforall. spec H10 H15. auto.
 dest ts. dest x.
 left. exists (substXXs 0 l x). eapply EsMatchAlt.
 inverts H1. inverts H3; auto. eauto.
 destruct H1 as [STx | HCx].
 SCase "x steps".
 left; destruct STx as [x'].
 exists (XMatch x' aa).
 lets D: EsContext XcMatch; eauto.
 SCase "x hasChoice".
 right; auto.
Qed.