(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for PPC generation: auxiliary results. *)

Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Op.
Require Import Locations.
Require Import Mach.
Require Import Asm.
Require Import Asmgen.
Require Import Conventions.
Require Import Asmgenproof0.

(** * Properties of low half/high half decomposition *)

Lemma high_half_zero:
  forall v, Val.add (high_half v) Vzero = high_half v.
Proof.
  intros. generalize (high_half_type v).
  rewrite Val.add_commut.
  case (high_half v); simpl; intros; try contradiction.
  auto.
  rewrite Int.add_commut; rewrite Int.add_zero; auto.
  rewrite Int.add_zero; auto.
Qed.

Lemma low_high_u:
  forall n, Int.or (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n.
Proof.
  intros. unfold high_u, low_u.
  rewrite Int.shl_rolm. rewrite Int.shru_rolm.
  rewrite Int.rolm_rolm.
  change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat Int.wordsize)) (Int.repr 16))
                            (Int.repr 16))
                   (Int.repr (Z_of_nat Int.wordsize)))
    with (Int.zero).
  rewrite Int.rolm_zero. rewrite <- Int.and_or_distrib.
  exact (Int.and_mone n).
  apply int_wordsize_divides_modulus. reflexivity. reflexivity.
Qed.

Lemma low_high_u_xor:
  forall n, Int.xor (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n.
Proof.
  intros. unfold high_u, low_u.
  rewrite Int.shl_rolm. rewrite Int.shru_rolm.
  rewrite Int.rolm_rolm.
  change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat Int.wordsize)) (Int.repr 16))
                            (Int.repr 16))
                   (Int.repr (Z_of_nat Int.wordsize)))
    with (Int.zero).
  rewrite Int.rolm_zero. rewrite <- Int.and_xor_distrib.
  exact (Int.and_mone n).
  apply int_wordsize_divides_modulus. reflexivity. reflexivity.
Qed.

Lemma low_high_s:
  forall n, Int.add (Int.shl (high_s n) (Int.repr 16)) (low_s n) = n.
Proof.
  intros.
  rewrite Int.shl_mul_two_p.
  unfold high_s.
  rewrite <- (Int.divu_pow2 (Int.sub n (low_s n)) (Int.repr 65536) (Int.repr 16)).
  2: reflexivity.
  change (two_p (Int.unsigned (Int.repr 16))) with 65536.
  set (x := Int.sub n (low_s n)).
  assert (x = Int.add (Int.mul (Int.divu x (Int.repr 65536)) (Int.repr 65536))
                      (Int.modu x (Int.repr 65536))).
    apply Int.modu_divu_Euclid. vm_compute; congruence.
  assert (Int.modu x (Int.repr 65536) = Int.zero).
    unfold Int.modu, Int.zero. decEq.
    change 0 with (0 mod 65536).
    change (Int.unsigned (Int.repr 65536)) with 65536.
    apply Int.eqmod_mod_eq. omega.
    unfold x, low_s. eapply Int.eqmod_trans.
    apply Int.eqmod_divides with Int.modulus.
    unfold Int.sub. apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl.
    exists 65536. compute; auto.
    replace 0 with (Int.unsigned n - Int.unsigned n) by omega.
    apply Int.eqmod_sub. apply Int.eqmod_refl. apply Int.eqmod_sign_ext'.
    compute; auto.
  rewrite H0 in H. rewrite Int.add_zero in H.
  rewrite <- H. unfold x. rewrite Int.sub_add_opp. rewrite Int.add_assoc.
  rewrite (Int.add_commut (Int.neg (low_s n))). rewrite <- Int.sub_add_opp.
  rewrite Int.sub_idem. apply Int.add_zero.
Qed.

(** Useful properties of the GPR0 registers. *)

Lemma gpr_or_zero_not_zero:
  forall rs r, r <> GPR0 -> gpr_or_zero rs r = rs#r.
Proof.
  intros. unfold gpr_or_zero. case (ireg_eq r GPR0); tauto.
Qed.
Lemma gpr_or_zero_zero:
  forall rs, gpr_or_zero rs GPR0 = Vzero.
Proof.
  intros. reflexivity.
Qed.
Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: asmgen.

Lemma ireg_of_not_GPR0:
  forall m r, ireg_of m = OK r -> IR r <> IR GPR0.
Proof.
  intros. erewrite <- ireg_of_eq; eauto with asmgen.
Qed.
Hint Resolve ireg_of_not_GPR0: asmgen.

Lemma ireg_of_not_GPR0':
  forall m r, ireg_of m = OK r -> r <> GPR0.
Proof.
  intros. generalize (ireg_of_not_GPR0 _ _ H). congruence.
Qed.
Hint Resolve ireg_of_not_GPR0': asmgen.

(** Useful simplification tactic *)

Ltac Simplif :=
  ((rewrite nextinstr_inv by eauto with asmgen)
  || (rewrite nextinstr_inv1 by eauto with asmgen)
  || (rewrite Pregmap.gss)
  || (rewrite nextinstr_pc)
  || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen.

Ltac Simpl := repeat Simplif.

(** * Correctness of PowerPC constructor functions *)

Section CONSTRUCTORS.

Variable ge: genv.
Variable fn: code.

(** Properties of comparisons. *)

Lemma compare_float_spec:
  forall rs v1 v2,
  let rs1 := nextinstr (compare_float rs v1 v2) in
     rs1#CR0_0 = Val.cmpf Clt v1 v2
  /\ rs1#CR0_1 = Val.cmpf Cgt v1 v2
  /\ rs1#CR0_2 = Val.cmpf Ceq v1 v2
  /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1.
  split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  intros. unfold compare_float. Simpl.
Qed.

Lemma compare_sint_spec:
  forall rs v1 v2,
  let rs1 := nextinstr (compare_sint rs v1 v2) in
     rs1#CR0_0 = Val.cmp Clt v1 v2
  /\ rs1#CR0_1 = Val.cmp Cgt v1 v2
  /\ rs1#CR0_2 = Val.cmp Ceq v1 v2
  /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1.
  split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  intros. unfold compare_sint. Simpl.
Qed.

Lemma compare_uint_spec:
  forall rs m v1 v2,
  let rs1 := nextinstr (compare_uint rs m v1 v2) in
     rs1#CR0_0 = Val.cmpu (Mem.valid_pointer m) Clt v1 v2
  /\ rs1#CR0_1 = Val.cmpu (Mem.valid_pointer m) Cgt v1 v2
  /\ rs1#CR0_2 = Val.cmpu (Mem.valid_pointer m) Ceq v1 v2
  /\ forall r', r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> r' <> PC -> rs1#r' = rs#r'.
Proof.
  intros. unfold rs1.
  split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  intros. unfold compare_uint. Simpl.
Qed.

(** Loading a constant. *)

Lemma loadimm_correct:
  forall r n k rs m,
  exists rs',
     exec_straight ge fn (loadimm r n k) rs m  k rs' m
  /\ rs'#r = Vint n
  /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold loadimm.
  case (Int.eq (high_s n) Int.zero).
  (* addi *)
  econstructor; split. apply exec_straight_one. simpl; eauto. auto.
  rewrite Int.add_zero_l. intuition Simpl.
  (* addis *)
  generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
  econstructor; split. apply exec_straight_one. simpl; eauto. auto.
  rewrite <- H. rewrite Int.add_commut. rewrite low_high_s.
  intuition Simpl.
  (* addis + ori *)
  econstructor; split. eapply exec_straight_two.
  simpl; eauto. simpl; eauto. auto. auto.
  split. Simpl. rewrite Int.add_zero_l. unfold Val.or. rewrite low_high_u. auto.
  intros; Simpl.
Qed.

(** Add integer immediate. *)

Lemma addimm_correct:
  forall r1 r2 n k rs m,
  r1 <> GPR0 ->
  r2 <> GPR0 ->
  exists rs',
     exec_straight ge fn (addimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = Val.add rs#r2 (Vint n)
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold addimm.
  (* addi *)
  case (Int.eq (high_s n) Int.zero).
  econstructor; split. apply exec_straight_one.
  simpl. rewrite gpr_or_zero_not_zero; eauto.
  reflexivity.
  intuition Simpl.
  (* addis *)
  generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro.
  econstructor; split. apply exec_straight_one.
  simpl. rewrite gpr_or_zero_not_zero; auto. auto.
  split. Simpl.
  generalize (low_high_s n). rewrite H1. rewrite Int.add_zero. congruence.
  intros; Simpl.
  (* addis + addi *)
  econstructor; split. eapply exec_straight_two.
  simpl. rewrite gpr_or_zero_not_zero; eauto.
  simpl. rewrite gpr_or_zero_not_zero; eauto.
  auto. auto.
  split. Simpl. rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
  intros; Simpl.
Qed.

(** And integer immediate. *)

Lemma andimm_base_correct:
  forall r1 r2 n k (rs : regset) m,
  r2 <> GPR0 ->
  let v := Val.and rs#r2 (Vint n) in
  exists rs',
     exec_straight ge fn (andimm_base r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = v
  /\ rs'#CR0_2 = Val.cmp Ceq v Vzero
  /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
  intros. unfold andimm_base.
  case (Int.eq (high_u n) Int.zero).
  (* andi *)
  exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)).
  generalize (compare_sint_spec (rs#r1 <- v) v Vzero).
  intros [A [B [C D]]].
  split. apply exec_straight_one. reflexivity. reflexivity.
  split. rewrite D; auto with asmgen. Simpl.
  split. auto.
  intros. rewrite D; auto with asmgen. Simpl.
  (* andis *)
  generalize (Int.eq_spec (low_u n) Int.zero);
  case (Int.eq (low_u n) Int.zero); intro.
  exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)).
  generalize (compare_sint_spec (rs#r1 <- v) v Vzero).
  intros [A [B [C D]]].
  split. apply exec_straight_one. simpl.
  generalize (low_high_u n). rewrite H0. rewrite Int.or_zero.
  intro. rewrite H1. reflexivity. reflexivity.
  split. rewrite D; auto with asmgen. Simpl.
  split. auto.
  intros. rewrite D; auto with asmgen. Simpl.
  (* loadimm + and *)
  generalize (loadimm_correct GPR0 n (Pand_ r1 r2 GPR0 :: k) rs m).
  intros [rs1 [EX1 [RES1 OTHER1]]].
  exists (nextinstr (compare_sint (rs1#r1 <- v) v Vzero)).
  generalize (compare_sint_spec (rs1#r1 <- v) v Vzero).
  intros [A [B [C D]]].
  split. eapply exec_straight_trans. eexact EX1.
  apply exec_straight_one. simpl. rewrite RES1.
  rewrite (OTHER1 r2). reflexivity. congruence. congruence.
  reflexivity.
  split. rewrite D; auto with asmgen. Simpl.
  split. auto.
  intros. rewrite D; auto with asmgen. Simpl.
Qed.

Lemma andimm_correct:
  forall r1 r2 n k (rs : regset) m,
  r2 <> GPR0 ->
  exists rs',
     exec_straight ge fn (andimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = Val.and rs#r2 (Vint n)
  /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
  intros. unfold andimm. destruct (is_rlw_mask n).
  (* turned into rlw *)
  econstructor; split. eapply exec_straight_one.
  simpl. rewrite Val.rolm_zero. eauto. auto.
  intuition Simpl.
  (* andimm_base *)
  destruct (andimm_base_correct r1 r2 n k rs m) as [rs' [A [B [C D]]]]; auto.
  exists rs'; auto.
Qed.

(** Or integer immediate. *)

Lemma orimm_correct:
  forall r1 (r2: ireg) n k (rs : regset) m,
  let v := Val.or rs#r2 (Vint n) in
  exists rs',
     exec_straight ge fn (orimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = v
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold orimm.
  case (Int.eq (high_u n) Int.zero).
  (* ori *)
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. reflexivity. reflexivity.
  intuition Simpl.
  (* oris *)
  generalize (Int.eq_spec (low_u n) Int.zero);
  case (Int.eq (low_u n) Int.zero); intro.
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. simpl.
  generalize (low_high_u n). rewrite H. rewrite Int.or_zero.
  intro. rewrite H0. reflexivity. reflexivity.
  intuition Simpl.
  (* oris + ori *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  intuition Simpl.
  rewrite Val.or_assoc. simpl. rewrite low_high_u. reflexivity.
Qed.

(** Xor integer immediate. *)

Lemma xorimm_correct:
  forall r1 (r2: ireg) n k (rs : regset) m,
  let v := Val.xor rs#r2 (Vint n) in
  exists rs',
     exec_straight ge fn (xorimm r1 r2 n k) rs m  k rs' m
  /\ rs'#r1 = v
  /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
  intros. unfold xorimm.
  case (Int.eq (high_u n) Int.zero).
  (* xori *)
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. reflexivity. reflexivity.
  intuition Simpl.
  (* xoris *)
  generalize (Int.eq_spec (low_u n) Int.zero);
  case (Int.eq (low_u n) Int.zero); intro.
  exists (nextinstr (rs#r1 <- v)).
  split. apply exec_straight_one. simpl.
  generalize (low_high_u n). rewrite H. rewrite Int.or_zero.
  intro. rewrite H0. reflexivity. reflexivity.
  intuition Simpl.
  (* xoris + xori *)
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  intuition Simpl.
  rewrite Val.xor_assoc. simpl. rewrite low_high_u_xor. reflexivity.
Qed.

(** Rotate and mask. *)

Lemma rolm_correct:
  forall r1 r2 amount mask k (rs : regset) m,
  r1 <> GPR0 ->
  exists rs',
     exec_straight ge fn (rolm r1 r2 amount mask k) rs m  k rs' m
  /\ rs'#r1 = Val.rolm rs#r2 amount mask
  /\ forall r', data_preg r' = true -> r' <> r1 -> rs'#r' = rs#r'.
Proof.
  intros. unfold rolm. destruct (is_rlw_mask mask).
  (* rlwinm *)
  econstructor; split. eapply exec_straight_one; simpl; eauto.
  intuition Simpl.
  (* rlwinm ; andimm *)
  set (rs1 := nextinstr (rs#r1 <- (Val.rolm rs#r2 amount Int.mone))).
  destruct (andimm_base_correct r1 r1 mask k rs1 m) as [rs' [A [B [C D]]]]; auto.
  exists rs'.
  split. eapply exec_straight_step; eauto. auto. auto.
  split. rewrite B. unfold rs1. rewrite nextinstr_inv; auto with asmgen.
  rewrite Pregmap.gss. destruct (rs r2); simpl; auto.
  unfold Int.rolm. rewrite Int.and_assoc.
  decEq; decEq; decEq. rewrite Int.and_commut. apply Int.and_mone.
  intros. rewrite D; auto. unfold rs1; Simpl.
Qed.

(** Indexed memory loads. *)

Lemma loadind_correct:
  forall (base: ireg) ofs ty dst k (rs: regset) m v c,
  loadind base ofs ty dst k = OK c ->
  Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v ->
  base <> GPR0 ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of dst) = v
  /\ forall r, r <> PC -> r <> preg_of dst -> r <> GPR0 -> rs'#r = rs#r.
Proof.
Opaque Int.eq.
  unfold loadind; intros. destruct ty; monadInv H; simpl in H0.
(* integer *)
  rewrite (ireg_of_eq _ _ EQ).
  destruct (Int.eq (high_s ofs) Int.zero).
  (* one load *)
  econstructor; split. apply exec_straight_one. simpl.
  unfold load1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
  intuition Simpl.
  (* loadimm + load *)
  exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
  exists (nextinstr (rs'#x <- v)); split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
  simpl. unfold load2. rewrite C; auto with asmgen. rewrite B. rewrite H0. auto.
  intuition Simpl.
(* float *)
  rewrite (freg_of_eq _ _ EQ).
  destruct (Int.eq (high_s ofs) Int.zero).
  (* one load *)
  econstructor; split. apply exec_straight_one. simpl.
  unfold load1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
  intuition Simpl.
  (* loadimm + load *)
  exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
  exists (nextinstr (rs'#x <- v)); split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
  simpl. unfold load2. rewrite C; auto with asmgen. rewrite B. rewrite H0. auto.
  intuition Simpl.
Qed.

(** Indexed memory stores. *)

Lemma storeind_correct:
  forall (base: ireg) ofs ty src k (rs: regset) m m' c,
  storeind src base ofs ty k = OK c ->
  Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' ->
  base <> GPR0 ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, r <> PC -> r <> GPR0 -> rs'#r = rs#r.
Proof.
  unfold storeind; intros.
  assert (preg_of src <> GPR0) by auto with asmgen.
  destruct ty; monadInv H; simpl in H0.
(* integer *)
  rewrite (ireg_of_eq _ _ EQ) in *.
  destruct (Int.eq (high_s ofs) Int.zero).
  (* one store *)
  econstructor; split. apply exec_straight_one. simpl.
  unfold store1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
  intros; Simpl.
  (* loadimm + store *)
  exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
  exists (nextinstr rs'); split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
  simpl. unfold store2. rewrite B. rewrite ! C; auto with asmgen. rewrite H0. auto.
  intuition Simpl.
(* float *)
  rewrite (freg_of_eq _ _ EQ) in *.
  destruct (Int.eq (high_s ofs) Int.zero).
  (* one store *)
  econstructor; split. apply exec_straight_one. simpl.
  unfold store1. rewrite gpr_or_zero_not_zero; auto. simpl. rewrite H0. eauto. auto.
  intuition Simpl.
  (* loadimm + store *)
  exploit (loadimm_correct GPR0 ofs); eauto. intros [rs' [A [B C]]].
  exists (nextinstr rs'); split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one; auto.
  simpl. unfold store2. rewrite B. rewrite ! C; auto with asmgen. rewrite H0. auto.
  intuition Simpl.
Qed.

(** Float comparisons. *)

Lemma floatcomp_correct:
  forall cmp (r1 r2: freg) k rs m,
  exists rs',
     exec_straight ge fn (floatcomp cmp r1 r2 k) rs m k rs' m
  /\ rs'#(reg_of_crbit (fst (crbit_for_fcmp cmp))) =
       (if snd (crbit_for_fcmp cmp)
        then Val.cmpf cmp rs#r1 rs#r2
        else Val.notbool (Val.cmpf cmp rs#r1 rs#r2))
  /\ forall r',
       r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 ->
       r' <> CR0_2 -> r' <> CR0_3 -> rs'#r' = rs#r'.
Proof.
  intros.
  generalize (compare_float_spec rs rs#r1 rs#r2).
  intros [A [B [C D]]].
  set (rs1 := nextinstr (compare_float rs rs#r1 rs#r2)) in *.
  assert ((cmp = Ceq \/ cmp = Cne \/ cmp = Clt \/ cmp = Cgt)
          \/ (cmp = Cle \/ cmp = Cge)).
    case cmp; tauto.
  unfold floatcomp.  elim H; intro; clear H.
  exists rs1.
  split. destruct H0 as [EQ|[EQ|[EQ|EQ]]]; subst cmp;
  apply exec_straight_one; reflexivity.
  split.
  destruct H0 as [EQ|[EQ|[EQ|EQ]]]; subst cmp; simpl; auto.
  rewrite Val.negate_cmpf_eq. auto.
  auto.
  (* two instrs *)
  exists (nextinstr (rs1#CR0_3 <- (Val.cmpf cmp rs#r1 rs#r2))).
  split. elim H0; intro; subst cmp.
  apply exec_straight_two with rs1 m.
  reflexivity. simpl.
  rewrite C; rewrite A. rewrite Val.or_commut. rewrite <- Val.cmpf_le.
  reflexivity. reflexivity. reflexivity.
  apply exec_straight_two with rs1 m.
  reflexivity. simpl.
  rewrite C; rewrite B. rewrite Val.or_commut. rewrite <- Val.cmpf_ge.
  reflexivity. reflexivity. reflexivity.
  split. elim H0; intro; subst cmp; simpl.
  reflexivity.
  reflexivity.
  intros. Simpl.
Qed.

(** Translation of conditions. *)

Ltac ArgsInv :=
  repeat (match goal with
  | [ H: Error _ = OK _ |- _ ] => discriminate
  | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args
  | [ H: bind _ _ = OK _ |- _ ] => monadInv H
  | [ H: assertion _ = OK _ |- _ ] => monadInv H
  end);
  subst;
  repeat (match goal with
  | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *
  | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *
  end).

Lemma transl_cond_correct_1:
  forall cond args k rs m c,
  transl_cond cond args k = OK c ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
       (if snd (crbit_for_cond cond)
        then Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
        else Val.notbool (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)))
  /\ forall r, data_preg r = true -> rs'#r = rs#r.
Proof.
  intros.
Opaque Int.eq.
  unfold transl_cond in H; destruct cond; ArgsInv; simpl.
  (* Ccomp *)
  fold (Val.cmp c0 (rs x) (rs x0)).
  destruct (compare_sint_spec rs (rs x) (rs x0)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
  auto with asmgen.
  (* Ccompu *)
  fold (Val.cmpu (Mem.valid_pointer m) c0 (rs x) (rs x0)).
  destruct (compare_uint_spec rs m (rs x) (rs x0)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
  auto with asmgen.
  (* Ccompimm *)
  fold (Val.cmp c0 (rs x) (Vint i)).
  destruct (Int.eq (high_s i) Int.zero); inv EQ0.
  destruct (compare_sint_spec rs (rs x) (Vint i)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
  auto with asmgen.
  destruct (loadimm_correct GPR0 i (Pcmpw x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
  destruct (compare_sint_spec rs1 (rs x) (Vint i)) as [A [B [C D]]].
  assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
  exists (nextinstr (compare_sint rs1 (rs1 x) (Vint i))).
  split. eapply exec_straight_trans. eexact EX1.
  apply exec_straight_one. simpl. rewrite RES1; rewrite SAME; auto.
  reflexivity.
  split. rewrite SAME.
  case c0; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto.
  intros. rewrite SAME; rewrite D; auto with asmgen.
  (* Ccompuimm *)
  fold (Val.cmpu (Mem.valid_pointer m) c0 (rs x) (Vint i)).
  destruct (Int.eq (high_u i) Int.zero); inv EQ0.
  destruct (compare_uint_spec rs m (rs x) (Vint i)) as [A [B [C D]]].
  econstructor; split.
  apply exec_straight_one. simpl; reflexivity. reflexivity.
  split.
  case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
  auto with asmgen.
  destruct (loadimm_correct GPR0 i (Pcmplw x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
  destruct (compare_uint_spec rs1 m (rs x) (Vint i)) as [A [B [C D]]].
  assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
  exists (nextinstr (compare_uint rs1 m (rs1 x) (Vint i))).
  split. eapply exec_straight_trans. eexact EX1.
  apply exec_straight_one. simpl. rewrite RES1; rewrite SAME; auto.
  reflexivity.
  split. rewrite SAME.
  case c0; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto.
  intros. rewrite SAME; rewrite D; auto with asmgen.
  (* Ccompf *)
  fold (Val.cmpf c0 (rs x) (rs x0)).
  destruct (floatcomp_correct c0 x x0 k rs m) as [rs' [EX [RES OTH]]].
  exists rs'. split. auto.
  split. apply RES.
  auto with asmgen.
  (* Cnotcompf *)
  rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4.
  fold (Val.cmpf c0 (rs x) (rs x0)).
  destruct (floatcomp_correct c0 x x0 k rs m) as [rs' [EX [RES OTH]]].
  exists rs'. split. auto.
  split. rewrite RES. destruct (snd (crbit_for_fcmp c0)); auto.
  auto with asmgen.
  (* Cmaskzero *)
  destruct (andimm_base_correct GPR0 x i k rs m) as [rs' [A [B [C D]]]].
  eauto with asmgen.
  exists rs'. split. assumption.
  split. rewrite C. destruct (rs x); auto.
  auto with asmgen.
  (* Cmasknotzero *)
  destruct (andimm_base_correct GPR0 x i k rs m) as [rs' [A [B [C D]]]].
  eauto with asmgen.
  exists rs'. split. assumption.
  split. rewrite C. destruct (rs x); auto.
  fold (option_map negb (Some (Int.eq (Int.and i0 i) Int.zero))).
  rewrite Val.notbool_negb_3. rewrite Val.notbool_idem4. auto.
  auto with asmgen.
Qed.

Lemma transl_cond_correct_2:
  forall cond args k rs m b c,
  transl_cond cond args k = OK c ->
  eval_condition cond (map rs (map preg_of args)) m = Some b ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
       (if snd (crbit_for_cond cond)
        then Val.of_bool b
        else Val.notbool (Val.of_bool b))
  /\ forall r, data_preg r = true -> rs'#r = rs#r.
Proof.
  intros.
  replace (Val.of_bool b)
  with (Val.of_optbool (eval_condition cond rs ## (preg_of ## args) m)).
  eapply transl_cond_correct_1; eauto.
  rewrite H0; auto.
Qed.

Lemma transl_cond_correct_3:
  forall cond args k ms sp rs m b m' c,
  transl_cond cond args k = OK c ->
  agree ms sp rs ->
  eval_condition cond (map ms args) m = Some b ->
  Mem.extends m m' ->
  exists rs',
     exec_straight ge fn c rs m' k rs' m'
  /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) =
       (if snd (crbit_for_cond cond)
        then Val.of_bool b
        else Val.notbool (Val.of_bool b))
  /\ agree ms sp rs'.
Proof.
  intros.
  exploit transl_cond_correct_2. eauto.
    eapply eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto.
  intros [rs' [A [B C]]].
  exists rs'; split. eauto. split. auto. apply agree_exten with rs; auto.
Qed.

(** Translation of condition operators *)

Remark add_carry_eq0:
  forall i,
  Vint (Int.add (Int.add (Int.sub Int.zero i) i)
                (Int.add_carry Int.zero (Int.xor i Int.mone) Int.one)) =
  Val.of_bool (Int.eq i Int.zero).
Proof.
  intros. rewrite <- Int.sub_add_l. rewrite Int.add_zero_l.
  rewrite Int.sub_idem. rewrite Int.add_zero_l. fold (Int.not i).
  predSpec Int.eq Int.eq_spec i Int.zero.
  subst i. reflexivity.
  unfold Val.of_bool, Vfalse. decEq.
  unfold Int.add_carry. rewrite Int.unsigned_zero. rewrite Int.unsigned_one.
  apply zlt_true.
  generalize (Int.unsigned_range (Int.not i)); intro.
  assert (Int.unsigned (Int.not i) <> Int.modulus - 1).
    red; intros.
    assert (Int.repr (Int.unsigned (Int.not i)) = Int.mone).
Local Transparent Int.repr.
      rewrite H1. apply Int.mkint_eq. reflexivity.
   rewrite Int.repr_unsigned in H2.
   assert (Int.not (Int.not i) = Int.zero).
   rewrite H2. apply Int.mkint_eq; reflexivity.
  rewrite Int.not_involutive in H3.
  congruence.
  omega.
Qed.

Remark add_carry_ne0:
  forall i,
  Vint (Int.add (Int.add i (Int.xor (Int.add i Int.mone) Int.mone))
                (Int.add_carry i Int.mone Int.zero)) =
  Val.of_bool (negb (Int.eq i Int.zero)).
Proof.
  intros. fold (Int.not (Int.add i Int.mone)). rewrite Int.not_neg.
  rewrite (Int.add_commut  (Int.neg (Int.add i Int.mone))).
  rewrite <- Int.sub_add_opp. rewrite Int.sub_add_r. rewrite Int.sub_idem.
  rewrite Int.add_zero_l. rewrite Int.add_neg_zero. rewrite Int.add_zero_l.
Transparent Int.eq.
  unfold Int.add_carry, Int.eq.
  rewrite Int.unsigned_zero.  rewrite Int.unsigned_mone.
  unfold negb, Val.of_bool, Vtrue, Vfalse.
  destruct (zeq (Int.unsigned i) 0); decEq.
  apply zlt_true. omega.
  apply zlt_false. generalize (Int.unsigned_range i). omega.
Qed.

Lemma transl_cond_op_correct:
  forall cond args r k rs m c,
  transl_cond_op cond args r k = OK c ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of r) = Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
  /\ forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r'.
Proof.
  intros until args. unfold transl_cond_op.
  destruct (classify_condition cond args); intros; monadInv H; simpl;
  erewrite ! ireg_of_eq; eauto.
(* eq 0 *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. destruct (rs x0); simpl; auto.
  apply add_carry_eq0.
  intros; Simpl.
(* ne 0 *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  rewrite gpr_or_zero_not_zero; eauto with asmgen.
  split. Simpl. destruct (rs x0); simpl; auto.
  apply add_carry_ne0.
  intros; Simpl.
(* ge 0 *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. rewrite Val.rolm_ge_zero. auto.
  intros; Simpl.
(* lt 0 *)
  econstructor; split.
  apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite Val.rolm_lt_zero. auto.
  intros; Simpl.
(* default *)
  set (bit := fst (crbit_for_cond c)) in *.
  set (isset := snd (crbit_for_cond c)) in *.
  set (k1 :=
        Pmfcrbit x bit ::
        (if isset
         then k
         else Pxori x x (Cint Int.one) :: k)).
  generalize (transl_cond_correct_1 c rl k1 rs m c0 EQ0).
  fold bit; fold isset.
  intros [rs1 [EX1 [RES1 AG1]]].
  destruct isset.
  (* bit set *)
  econstructor; split.  eapply exec_straight_trans. eexact EX1.
  unfold k1. apply exec_straight_one; simpl; reflexivity.
  intuition Simpl.
  (* bit clear *)
  econstructor; split.  eapply exec_straight_trans. eexact EX1.
  unfold k1. eapply exec_straight_two; simpl; reflexivity.
  intuition Simpl.
  rewrite RES1. destruct (eval_condition c rs ## (preg_of ## rl) m). destruct b; auto. auto.
Qed.

(** Translation of arithmetic operations. *)

Ltac TranslOpSimpl :=
  econstructor; split;
  [ apply exec_straight_one; [simpl; eauto | reflexivity]
  | split; intros; Simpl; fail ].

Lemma transl_op_correct_aux:
  forall op args res k (rs: regset) m v c,
  transl_op op args res k = OK c ->
  eval_operation ge (rs#GPR1) op (map rs (map preg_of args)) m = Some v ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of res) = v
  /\ forall r,
     match op with Omove => data_preg r = true | _ => nontemp_preg r = true end ->
     r <> preg_of res -> rs'#r = rs#r.
Proof.
Opaque Int.eq.
  intros. unfold transl_op in H; destruct op; ArgsInv; simpl in H0; try (inv H0); try TranslOpSimpl.
  (* Omove *)
  destruct (preg_of res) eqn:RES; destruct (preg_of m0) eqn:ARG; inv H.
  TranslOpSimpl.
  TranslOpSimpl.
  (* Ointconst *)
  destruct (loadimm_correct x i k rs m) as [rs' [A [B C]]].
  exists rs'. auto with asmgen.
  (* Oaddrsymbol *)
  change (symbol_address ge i i0) with (symbol_offset ge i i0).
  set (v' := symbol_offset ge i i0).
  destruct (symbol_is_small_data i i0) eqn:SD.
  (* small data *)
  econstructor; split. apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite (small_data_area_addressing _ _ _ SD). unfold v', symbol_offset.
  destruct (Genv.find_symbol ge i); auto. rewrite Int.add_zero; auto.
  intros; Simpl.
  (* not small data *)
Opaque Val.add.
  econstructor; split. eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. rewrite gpr_or_zero_zero.
  rewrite gpr_or_zero_not_zero; eauto with asmgen. Simpl.
  rewrite (Val.add_commut Vzero). rewrite high_half_zero.
  rewrite Val.add_commut. rewrite low_high_half. auto.
  intros; Simpl.
  (* Oaddrstack *)
  destruct (addimm_correct x GPR1 i k rs m) as [rs' [EX [RES OTH]]]; eauto with asmgen.
  exists rs'; auto with asmgen.
  (* Oaddimm *)
  destruct (addimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen.
  exists rs'; auto with asmgen.
  (* Osubimm *)
  case (Int.eq (high_s i) Int.zero).
  TranslOpSimpl.
  destruct (loadimm_correct GPR0 i (Psubfc x0 x GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
  econstructor; split.
  eapply exec_straight_trans. eexact EX. apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite RES. rewrite OTH; eauto with asmgen.
  intros; Simpl.
  (* Omulimm *)
  case (Int.eq (high_s i) Int.zero).
  TranslOpSimpl.
  destruct (loadimm_correct GPR0 i (Pmullw x0 x GPR0 :: k) rs m) as [rs1 [EX [RES OTH]]].
  econstructor; split.
  eapply exec_straight_trans. eexact EX. apply exec_straight_one; simpl; reflexivity.
  split. Simpl. rewrite RES. rewrite OTH; eauto with asmgen.
  intros; Simpl.
  (* Odivs *)
  replace v with (Val.maketotal (Val.divs (rs x) (rs x0))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Odivu *)
  replace v with (Val.maketotal (Val.divu (rs x) (rs x0))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Oand *)
  set (v' := Val.and (rs x) (rs x0)) in *.
  pose (rs1 := rs#x1 <- v').
  destruct (compare_sint_spec rs1 v' Vzero) as [A [B [C D]]].
  econstructor; split. apply exec_straight_one; simpl; reflexivity.
  split. rewrite D; auto with asmgen. unfold rs1; Simpl.
  intros. rewrite D; auto with asmgen. unfold rs1; Simpl.
  (* Oandimm *)
  destruct (andimm_correct x0 x i k rs m) as [rs' [A [B C]]]; eauto with asmgen.
  exists rs'; auto with asmgen.
  (* Oorimm *)
  destruct (orimm_correct x0 x i k rs m) as [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Oxorimm *)
  destruct (xorimm_correct x0 x i k rs m) as [rs' [A [B C]]].
  exists rs'; auto with asmgen.
  (* Onor *)
  replace (Val.notint (rs x))
     with (Val.notint (Val.or (rs x) (rs x))).
  TranslOpSimpl.
  destruct (rs x); simpl; auto. rewrite Int.or_idem. auto.
  (* Oshrximm *)
  econstructor; split.
  eapply exec_straight_two; simpl; reflexivity.
  split. Simpl. apply Val.shrx_carry. auto.
  intros; Simpl.
  (* Orolm *)
  destruct (rolm_correct x0 x i i0 k rs m) as [rs' [A [B C]]]; eauto with asmgen.
  exists rs'; auto with asmgen.
  (* Ointoffloat *)
  replace v with (Val.maketotal (Val.intoffloat (rs x))).
  TranslOpSimpl.
  rewrite H1; auto.
  (* Ocmp *)
  destruct (transl_cond_op_correct c0 args res k rs m c) as [rs' [A [B C]]]; auto.
  exists rs'; auto with asmgen.
Qed.

Lemma transl_op_correct:
  forall op args res k ms sp rs m v m' c,
  transl_op op args res k = OK c ->
  agree ms sp rs ->
  eval_operation ge sp op (map ms args) m = Some v ->
  Mem.extends m m' ->
  exists rs',
     exec_straight ge fn c rs m' k rs' m'
  /\ agree (Regmap.set res v (undef_op op ms)) sp rs'
  /\ forall r, op = Omove -> data_preg r = true -> r <> preg_of res -> rs'#r = rs#r.
Proof.
  intros.
  exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eauto.
  intros [v' [A B]].  rewrite (sp_val _ _ _ H0) in A.
  exploit transl_op_correct_aux; eauto. intros [rs' [P [Q R]]].
  rewrite <- Q in B.
  exists rs'; split. eexact P.
  split. unfold undef_op. destruct op;
  (apply agree_set_undef_mreg with rs || apply agree_set_mreg with rs);
  auto.
  intros. subst op. auto.
Qed.

(** Translation of memory accesses *)

Lemma transl_memory_access_correct:
  forall (P: regset -> Prop) mk1 mk2 addr args temp k c (rs: regset) a m m',
  transl_memory_access mk1 mk2 addr args temp k = OK c ->
  eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
  temp <> GPR0 ->
  (forall cst (r1: ireg) (rs1: regset) k,
    Val.add (gpr_or_zero rs1 r1) (const_low ge cst) = a ->
    (forall r, r <> PC -> r <> temp -> rs1 r = rs r) ->
    exists rs',
        exec_straight ge fn (mk1 cst r1 :: k) rs1 m k rs' m' /\ P rs') ->
  (forall (r1 r2: ireg) (rs1: regset) k,
    Val.add rs1#r1 rs1#r2 = a ->
    (forall r, r <> PC -> r <> temp -> rs1 r = rs r) ->
    exists rs',
        exec_straight ge fn (mk2 r1 r2 :: k) rs1 m k rs' m' /\ P rs') ->
  exists rs',
      exec_straight ge fn c rs m k rs' m' /\ P rs'.
Proof.
  intros until m'; intros TR ADDR TEMP MK1 MK2.
  unfold transl_memory_access in TR; destruct addr; ArgsInv; simpl in ADDR; inv ADDR.
  (* Aindexed *)
  case (Int.eq (high_s i) Int.zero).
  (* Aindexed short *)
  apply MK1. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  (* Aindexed long *)
  set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (Vint (Int.shl (high_s i) (Int.repr 16)))))).
  exploit (MK1 (Cint (low_s i)) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
    unfold rs1; Simpl. rewrite Val.add_assoc.
Transparent Val.add.
    simpl. rewrite low_high_s. auto.
    intros; unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  auto. auto.
  (* Aindexed2 *)
  apply MK2; auto.
  (* Aglobal *)
  destruct (symbol_is_small_data i i0) eqn:SISD; inv TR.
  (* Aglobal from small data *)
  apply MK1. simpl. rewrite small_data_area_addressing; auto.
  unfold symbol_address, symbol_offset.
  destruct (Genv.find_symbol ge i); auto. rewrite Int.add_zero. auto.
  auto.
  (* Aglobal general case *)
  set (rs1 := nextinstr (rs#temp <- (const_high ge (Csymbol_high i i0)))).
  exploit (MK1 (Csymbol_low i i0) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
    unfold rs1. Simpl.
    unfold const_high, const_low.
    rewrite Val.add_commut. rewrite low_high_half. auto.
    intros; unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  unfold exec_instr. rewrite gpr_or_zero_zero.
  rewrite Val.add_commut. unfold const_high.
  rewrite high_half_zero.
  reflexivity. reflexivity.
  assumption. assumption.
  (* Abased *)
  set (rs1 := nextinstr (rs#temp <- (Val.add (rs x) (const_high ge (Csymbol_high i i0))))).
  exploit (MK1 (Csymbol_low i i0) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen.
    unfold rs1. Simpl.
    rewrite Val.add_assoc.
    unfold const_high, const_low.
    symmetry. rewrite Val.add_commut. f_equal. f_equal.
    rewrite Val.add_commut. rewrite low_high_half. auto.
    intros; unfold rs1; Simpl.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  assumption. assumption.
  (* Ainstack *)
  destruct (Int.eq (high_s i) Int.zero); inv TR.
  apply MK1. simpl. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  set (rs1 := nextinstr (rs#temp <- (Val.add rs#GPR1 (Vint (Int.shl (high_s i) (Int.repr 16)))))).
  exploit (MK1 (Cint (low_s i)) temp rs1 k).
    simpl. rewrite gpr_or_zero_not_zero; auto.
    unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss.
    rewrite Val.add_assoc. simpl. rewrite low_high_s. auto.
    congruence.
    intros. unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto.
  intros [rs' [EX' AG']].
  exists rs'. split. apply exec_straight_step with rs1 m.
  unfold exec_instr. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto.
  assumption. assumption.
Qed.

(** Translation of loads *)

Lemma transl_load_correct:
  forall chunk addr args dst k c (rs: regset) m a v,
  transl_load chunk addr args dst k = OK c ->
  eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
  Mem.loadv chunk m a = Some v ->
  exists rs',
     exec_straight ge fn c rs m k rs' m
  /\ rs'#(preg_of dst) = v
  /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs' r = rs r.
Proof.
  intros.
  assert (BASE: forall mk1 mk2 k' chunk' v',
  transl_memory_access mk1 mk2 addr args GPR12 k' = OK c ->
  Mem.loadv chunk' m a = Some v' ->
  (forall cst (r1: ireg) (rs1: regset),
    exec_instr ge fn (mk1 cst r1) rs1 m =
    load1 ge chunk' (preg_of dst) cst r1 rs1 m) ->
  (forall (r1 r2: ireg) (rs1: regset),
    exec_instr ge fn (mk2 r1 r2) rs1 m =
    load2 chunk' (preg_of dst) r1 r2 rs1 m) ->
  exists rs',
     exec_straight ge fn c rs m k' rs' m
  /\ rs'#(preg_of dst) = v'
  /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs' r = rs r).
  {
  intros. eapply transl_memory_access_correct; eauto. congruence.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H4. unfold load1. rewrite H6. rewrite H3. eauto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen.
  intuition Simpl.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H5. unfold load2. rewrite H6. rewrite H3. eauto.
  unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso; auto with asmgen.
  intuition Simpl.
  }
  destruct chunk; monadInv H.
- (* Mint8signed *)
  assert (exists v1, Mem.loadv Mint8unsigned m a = Some v1 /\ v = Val.sign_ext 8 v1).
  {
    destruct a; simpl in *; try discriminate.
    rewrite Mem.load_int8_signed_unsigned in H1.
    destruct (Mem.load Mint8unsigned m b (Int.unsigned i)); simpl in H1; inv H1.
    exists v0; auto.
  }
  destruct H as [v1 [LD SG]]. clear H1.
  exploit BASE; eauto; erewrite ireg_of_eq by eauto; auto.
  intros [rs1 [A [B C]]].
  econstructor; split.
  eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto.
  split. Simpl. congruence. intros. Simpl.
- (* Mint8unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint816signed *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint16unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint32 *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mfloat32 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
- (* Mfloat64 *)
  apply Mem.loadv_float64al32 in H1. eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
- (* Mfloat64al32 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
Qed.

(** Translation of stores *)

Lemma transl_store_correct:
  forall chunk addr args src k c (rs: regset) m a m',
  transl_store chunk addr args src k = OK c ->
  eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
  Mem.storev chunk m a (rs (preg_of src)) = Some m' ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, r <> PC -> r <> GPR11 -> r <> GPR12 -> r <> FPR13 -> rs' r = rs r.
Proof.
  intros.
  assert (TEMP0: int_temp_for src = GPR11 \/ int_temp_for src = GPR12).
    unfold int_temp_for. destruct (mreg_eq src IT2); auto.
  assert (TEMP1: int_temp_for src <> GPR0).
    destruct TEMP0; congruence.
  assert (TEMP2: IR (int_temp_for src) <> preg_of src).
    unfold int_temp_for. destruct (mreg_eq src IT2).
    subst src; simpl; congruence.
    change (IR GPR12) with (preg_of IT2). red; intros; elim n.
    eapply preg_of_injective; eauto.
  assert (BASE: forall mk1 mk2 chunk',
  transl_memory_access mk1 mk2 addr args (int_temp_for src) k = OK c ->
  Mem.storev chunk' m a (rs (preg_of src)) = Some m' ->
  (forall cst (r1: ireg) (rs1: regset),
    exec_instr ge fn (mk1 cst r1) rs1 m =
    store1 ge chunk' (preg_of src) cst r1 rs1 m) ->
  (forall (r1 r2: ireg) (rs1: regset),
    exec_instr ge fn (mk2 r1 r2) rs1 m =
    store2 chunk' (preg_of src) r1 r2 rs1 m) ->
  exists rs',
     exec_straight ge fn c rs m k rs' m'
  /\ forall r, r <> PC -> r <> GPR11 -> r <> GPR12 -> r <> FPR13 -> rs' r = rs r).
  {
  intros. eapply transl_memory_access_correct; eauto.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H4. unfold store1. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto.
  intros; Simpl. apply H7; auto. destruct TEMP0; congruence.
  intros. econstructor; split. apply exec_straight_one.
  rewrite H5. unfold store2. rewrite H6. rewrite H7; auto with asmgen. rewrite H3. eauto. auto.
  intros; Simpl. apply H7; auto. destruct TEMP0; congruence.
  }
  destruct chunk; monadInv H.
- (* Mint8signed *)
  assert (Mem.storev Mint8unsigned m a (rs (preg_of src)) = Some m').
    rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_8.
  clear H1. eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint8unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint16signed *)
  assert (Mem.storev Mint16unsigned m a (rs (preg_of src)) = Some m').
    rewrite <- H1. destruct a; simpl; auto. symmetry. apply Mem.store_signed_unsigned_16.
  clear H1. eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint16unsigned *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mint32 *)
  eapply BASE; eauto; erewrite ireg_of_eq by eauto; auto.
- (* Mfloat32 *)
  rewrite (freg_of_eq _ _ EQ) in H1.
  eapply transl_memory_access_correct. eauto. eauto. eauto.
  intros. econstructor; split. apply exec_straight_one.
  simpl. unfold store1. rewrite H. rewrite H2; auto with asmgen. rewrite H1. eauto. auto.
  intros. Simpl. apply H2; auto with asmgen. destruct TEMP0; congruence.
  intros. econstructor; split. apply exec_straight_one.
  simpl. unfold store2. rewrite H. rewrite H2; auto with asmgen. rewrite H1. eauto. auto.
  intros. Simpl. apply H2; auto with asmgen. destruct TEMP0; congruence.
- (* Mfloat64 *)
  apply Mem.storev_float64al32 in H1. eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
- (* Mfloat64al32 *)
  eapply BASE; eauto; erewrite freg_of_eq by eauto; auto.
Qed.

End CONSTRUCTORS.


Require Import TestSuite.admit.
Set Universe Polymorphism.
Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Goal forall (A : Type) (P : forall _ : A, Type) (x0 : A)
     (p : P x0) (q : @paths (@sigT A P) (@existT A P x0 p) (@existT A P x0 p)),
   @paths (@paths (@sigT A P) (@existT A P x0 p) (@existT A P x0 p))
     (@idpath (@sigT A P) (@existT A P x0 p))
     (@idpath (@sigT A P) (@existT A P x0 p)).
  intros.
  induction q.
  admit.
Qed.
(** Error: Illegal application:
The term "paths_rect" of type
 "forall (A : Type) (a : A) (P : forall a0 : A, paths a a0 -> Type),
  P a (idpath a) -> forall (y : A) (p : paths a y), P y p"
cannot be applied to the terms
 "{x : _ & P x}" : "Type"
 "s" : "{x : _ & P x}"
 "fun (a : {x : _ & P x}) (_ : paths s a) => paths (idpath a) (idpath a)"
   : "forall a : {x : _ & P x}, paths s a -> Type"
 "match proof_admitted return (paths (idpath s) (idpath s)) with
  end" : "paths (idpath s) (idpath s)"
 "s" : "{x : _ & P x}"
 "q" : "paths (existT P x0 p) (existT P x0 p)"
The 3rd term has type "forall a : {x : _ & P x}, paths s a -> Type"
which should be coercible to "forall a : {x : _ & P x}, paths s a -> Type". *)


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^165 - 25
Base: 41.25
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 41 + 1/4;
    bitwidth := 64;
    s := 2^165;
    c := [(1, 25)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^191 - 19
Base: 47.75
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 47 + 3/4;
    bitwidth := 64;
    s := 2^191;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(** Administrative lemmas for Bang.

    Authors: Steve Zdancewic and Karl Mazurak and Jianzhou Zhao.

    Table of contents:
      - #Properties of wf_typ#
      - #Properties of wf_env and wf_typ#
      - #Properties of wf_env#
      - #Properties of substitution#
      - #Regularity lemmas#
      - #Automation# *)

Require Export Bang_Infrastructure.
Require Export Extra.
Require Import Omega.

(* ********************************************************************** *)
(** * ## Properties of [wf_typ] *)

Lemma type_from_wf_typ : forall E T,
  wf_typ E T -> type T.
Proof.
  intros E T H; induction H; eauto.
Qed.

Lemma wf_typ_weakening : forall T E F G,
  wf_typ (G ++ E) T ->
  uniq (G ++ F ++ E) ->
  wf_typ (G ++ F ++ E) T.
Proof with simpl_env; eauto.
  intros T E F G Hwf_typ Huniq.
  remember (G ++ E) as FF.
  generalize dependent G.
  (wf_typ_cases (induction Hwf_typ) Case); intros G Huniq Heq; subst...
  Case "wf_typ_all".
    pick fresh Y and apply wf_typ_all...
    rewrite <- app_assoc.
    apply H0...
Qed.

Lemma wf_typ_weaken_head : forall T E F,
  wf_typ E T ->
  uniq (F ++ E) ->
  wf_typ (F ++ E) T.
Proof.
  intros.
  rewrite_env (empty ++ F++ E).
  auto using wf_typ_weakening.
Qed.

Lemma wf_typ_subst_tb : forall F E Z P T,
  wf_typ (F ++ [(Z, bind_kn)] ++ E) T ->
  wf_typ E P->
  wf_typ (map (subst_tb Z P) F ++ E) (subst_tt Z P T).
Proof with simpl_env; eauto using wf_typ_weaken_head, type_from_wf_typ.
  intros F E Z P T WT WP.
  remember (F ++ [(Z, bind_kn)] ++ E) as G.
  generalize dependent F.
  (wf_typ_cases (induction WT) Case); intros F EQ; subst; simpl subst_tt...
  Case "wf_typ_var".
    destruct (X == Z).  subst...
      analyze_binds_uniq H0...
        apply wf_typ_var.
          assert ((subst_tb Z P bind_kn) = bind_kn) as J; auto.
            solve_uniq.
          apply binds_weaken_at_tail.

          assert (bind_kn = (subst_tb Z P bind_kn)) as J; auto.
          rewrite J.
          apply binds_map; auto.
  Case "wf_typ_all".
    pick fresh Y and apply wf_typ_all...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) ([(Y, bind_kn)] ++ F) ++ E).
    apply H0...
Qed.

Lemma wf_typ_strengthening : forall E F x U T,
 wf_typ (F ++ [(x, bind_typ U)] ++ E) T ->
 wf_typ (F ++ E) T.
Proof with simpl_env; eauto.
  intros E F x U T H.
  remember (F ++ [(x, bind_typ U)] ++ E) as G.
  generalize dependent F.
  (wf_typ_cases (induction H) Case); intros F Heq; subst...
  Case "wf_typ_var".
    analyze_binds_uniq H0...
  Case "wf_typ_all".
    pick fresh Y and apply wf_typ_all...
    rewrite <- app_assoc.
    apply H0...
Qed.

Lemma wf_typ_strengthening_typ : forall E F X T,
 wf_typ (F ++ [(X, bind_kn)] ++ E) T ->
 X `notin` (fv_tt T) ->
 wf_typ (F ++ E) T.
Proof with simpl_env; eauto.
  intros E F X T H.
  remember (F ++ [(X, bind_kn)] ++ E) as G.
  generalize dependent F.
  (wf_typ_cases (induction H) Case);
     intros F Heq Nin; simpl in Nin; subst...
  Case "wf_typ_var".
    analyze_binds_uniq H0; subst...
  Case "wf_typ_all".
    pick fresh Y and apply wf_typ_all.
    rewrite <- app_assoc.
    eapply H0...
      apply notin_open_tt_fv; auto.
Qed.

(* ********************************************************************** *)
(** * ## Properties of [wf_env] and [wf_typ] *)

Lemma uniq_from_wf_env : forall E,
  wf_env E ->
  uniq E.
Proof.
  intros E H; induction H; auto.
Qed.

Lemma uniq_from_wf_lenv: forall E D,
  wf_lenv E D ->
  uniq D.
Proof.
  induction D; intros; auto.
  destruct a.
  inversion H; auto.
Qed.

(** We add [uniq_from_wf_env] as a hint here since it helps blur the
    distinction between [wf_env] and [uniq] in proofs.  The lemmas in
    the [Environment] library use [uniq], whereas here we naturally have
    (or can easily show) the stronger [wf_env].  Thus,
    [uniq_from_wf_env] serves as a bridge that allows us to use the
    environments library. *)

Hint Resolve uniq_from_wf_env.
Hint Resolve uniq_from_wf_lenv.

Lemma wf_typ_from_binds_typ : forall x U E,
  wf_env E ->
  binds x (bind_typ U) E ->
  wf_typ E U.
Proof with auto using wf_typ_weaken_head.
  induction 1; intros J; analyze_binds_uniq J...
  inversion BindsTacVal. subst...
Qed.

Lemma wf_typ_from_wf_env_typ : forall x T E,
  wf_env ([(x, bind_typ T)] ++ E) ->
  wf_typ E T.
Proof.
  intros x T E H. inversion H; auto.
Qed.

(* ********************************************************************** *)
(** * ## Properties of [wf_env] and [wf_lenv] *)

(** These properties are analogous to the properties that we need to
    show for the subtyping and typing relations. *)

Lemma wf_env_strengthening : forall x T E F,
  wf_env (F ++ [(x, bind_typ T)] ++ E) ->
  wf_env (F ++ E).
Proof with eauto using wf_typ_strengthening.
  induction F; intros Wf_env; inversion Wf_env; subst; simpl_env in *...
Qed.

Lemma wf_env_strengthening_tail: forall E F,
  wf_env (F ++ E) ->
  wf_env E.
Proof.
  intros E F H.
  induction F; auto.
    rewrite_env ([a] ++ (F ++ E)) in H.
    apply IHF.
      inversion H; auto.
Qed.

Lemma wf_env_from_wf_lenv: forall E D,
  wf_lenv E D ->
  wf_env E.
Proof.
  intros E D WFL.
  induction WFL; auto.
Qed.

Lemma wf_lenv_strengthening: forall x T E F D,
  wf_lenv (F ++ [(x, bind_typ T)] ++ E) D ->
  wf_lenv (F ++ E) D.
Proof.
  intros x T E F D WFL.
  remember (F ++ [(x, bind_typ T)] ++ E) as E0.
  generalize dependent F.
  (wf_lenv_cases (induction WFL) Case); intros F EQ; subst.
  Case "wf_lenv_empty".
    apply wf_lenv_empty; auto.
      eapply wf_env_strengthening; eauto.
  Case "wf_lenv_typ".
    apply wf_lenv_typ; auto.
      eapply wf_typ_strengthening; eauto.
Qed.

Lemma wf_lenv_strengthening_typ: forall G D X,
  wf_lenv ([(X, bind_kn)] ++ G) D ->
  X `notin` fv_lenv D ->
  wf_lenv G D.
Proof.
  induction D; intros X WFL NIN.
  Case "nil".
    apply wf_lenv_empty.
      inversion WFL; subst.
      inversion H; subst.
      auto.
  Case "con".
    destruct a. destruct l. simpl in NIN.
    inversion WFL; subst.
    simpl_env in *.
    apply wf_lenv_typ; auto.
      eapply IHD; eauto.

      rewrite_env (empty ++ G).
      eapply wf_typ_strengthening_typ.
        simpl_env. apply H6.
        fsetdec.
Qed.

Lemma wf_env_subst_tb : forall Z P E F,
  wf_env (F ++ [(Z, bind_kn)] ++ E) ->
  wf_typ E P ->
  wf_env (map (subst_tb Z P) F ++ E).
Proof with eauto 6 using wf_typ_subst_tb.
  induction F; intros Wf_env WP; simpl_env;
    inversion Wf_env; simpl_env in *; simpl subst_tb...
Qed.

Lemma wf_lenv_subst_tb: forall Z P E F D,
  wf_lenv (F ++ [(Z, bind_kn)] ++ E) D ->
  wf_typ E P ->
  wf_lenv (map (subst_tb Z P) F ++ E) (map (subst_tlb Z P) D).
Proof.
  intros Z P E F D WFL.
  remember (F ++[(Z, bind_kn)] ++ E) as E0.
  generalize dependent F.
  (wf_lenv_cases (induction WFL) Case); intros F EQ WFT; subst; simpl_env in *.
  Case "wf_lenv_empty".
    apply wf_lenv_empty.
      eapply wf_env_subst_tb; eauto.
  Case "wf_lenv_typ".
    apply wf_lenv_typ; auto.
      eapply wf_typ_subst_tb; eauto.
Qed.

(* ********************************************************************** *)
(** * ## Environment is unchanged by substitution for a fresh name *)

Lemma notin_fv_wf : forall E (X : atom) T,
  wf_typ E T ->
  X `notin` dom E ->
  X `notin` fv_tt T.
Proof with auto.
  intros E X T Wf_typ.
  (wf_typ_cases (induction Wf_typ) Case); intros Fr; simpl...
  Case "wf_typ_var".
    assert (X0 `in` (dom E))...
    eapply binds_In; eauto. fsetdec.
  Case "wf_typ_all".
    pick fresh Y.
    apply (notin_fv_tt_open Y)...
Qed.

Lemma map_subst_tb_id : forall G Z P,
  wf_env G ->
  Z `notin` dom G ->
  G = map (subst_tb Z P) G.
Proof with auto.
  intros G Z P H.
  (wf_env_cases (induction H) Case); simpl; intros Fr; simpl_env...
  Case "wf_env_kn".
    rewrite <- IHwf_env...
  Case "wf_env_typ".
    rewrite <- IHwf_env...
    rewrite <- subst_tt_fresh...
    eapply notin_fv_wf; eauto.
Qed.

(* Basic properties of the env_split relation *)

Lemma dom_lenv_split: forall G E1 E2 E3,
  lenv_split G E1 E2 E3  ->
  dom E3 [=] dom E1 `union` dom E2.
Proof.
  intros E1 E2 E3 G S.
  induction S; simpl; try fsetdec.
Qed.

Lemma lenv_split_commute: forall G E1 E2 E3,
  lenv_split G E1 E2 E3 ->
  lenv_split G E2 E1 E3.
Proof.
  intros G E1 E2 E3 S.
  induction S; auto.
Qed.

Lemma lenv_split_empty_left: forall G E F,
  lenv_split G lempty E F ->
  E = F.
Proof.
  induction E; intros F H; inversion H; auto.
  Case "con".
    rewrite (IHE D3); auto.
Qed.

Lemma lenv_split_empty_right: forall G E F,
  lenv_split G E lempty F ->
  E = F.
Proof.
  intros.
  eapply lenv_split_empty_left.
  eapply lenv_split_commute; eauto.
Qed.

Lemma wf_lenv_split: forall D1 D2 D3 G,
  lenv_split G D1 D2 D3  ->
  wf_lenv G D3.
Proof.
  intros G D1 D2 D3 S.
  (lenv_split_cases (induction S) Case); simpl_env in *;
    try solve [ eauto | eapply wf_lenv_typ; eauto ].
Qed.

Lemma wf_lenv_split_left: forall G D1 D2 D3,
  lenv_split G D1 D2 D3 ->
  wf_lenv G D1.
Proof.
  intros G D1 D2 D3 S.
  (lenv_split_cases (induction S) Case); auto.
  Case "lenv_split_left".
    apply wf_lenv_typ; auto.
      rewrite (dom_lenv_split E D1 D2 D3) in H0; auto.
Qed.

Lemma wf_lenv_split_right: forall G D1 D2 D3,
  lenv_split G D1 D2 D3 ->
  wf_lenv G D2.
Proof.
  intros.
  eapply wf_lenv_split_left.
  eapply lenv_split_commute; eauto.
Qed.

Hint Extern 1 (wf_env ?E) =>
  match goal with
  | H: wf_lenv _ _ |- _ => apply (wf_env_from_wf_lenv _ _ H)
  end.

Hint Extern 1 (wf_lenv ?G ?D) =>
  match goal with
  | H: lenv_split _ _ _ _ |- _ => apply (wf_lenv_split _ _ _ _ H)
  | H: lenv_split _ _ _ _ |- _ => apply (wf_lenv_split_left _ _ _ _ H)
  | H: lenv_split _ _ _ _ |- _ => apply (wf_lenv_split_right _ _ _ _ H)
  end.

(* requires the kind to be kn_lin!! *)
Lemma typing_regular : forall E D e T,
  typing E D e T ->
  wf_env E /\ wf_lenv E D /\ expr e /\ wf_typ E T.
Proof with simpl_env; try solve [intuition].
  intros E D e T H; (typing_cases (induction H) Case)...
  Case "typing_var".
    repeat split...
    eauto using wf_typ_from_binds_typ.
  Case "typing_lvar".
    repeat split...
    inversion H; auto.
  Case "typing_abs".
    pick fresh y.
    destruct (H1 y) as [WF [WFL [EXP WFT]]]...
    repeat split...
    SCase "wf_lenv".
      inversion WFL; auto.
    SCase "expr".
      pick fresh x and apply expr_abs.
      eapply type_from_wf_typ; eauto.
      lapply (H1 x); auto...
  Case "typing_app".
    destruct IHtyping1 as [WF1 [WFL1 [EX1 J1]]]...
    destruct IHtyping2 as [WF2 [WFL2 [EX2 J2]]]...
    repeat split...
    SCase "wf_typ".
      inversion J1; subst; auto.
  Case "typing_tabs".
    pick fresh Y.
    destruct (H0 Y) as [HWF [WFL [EX WT]]]...
    inversion HWF; subst.
    repeat split...
    SCase "wf_lenv".
      inversion WFL; subst; auto.
      eapply wf_lenv_strengthening_typ; eauto.
    SCase "expr".
      pick fresh X and apply expr_tabs.
      destruct (H0 X) as [A [B [C CC]]]...
    SCase "wf_typ".
      pick fresh X and apply wf_typ_all.
      destruct (H0 X) as [A [B [C CC]]]...
  Case "typing_tapp".
    repeat split...
    SCase "expr".
      apply (expr_tapp).
        tauto.
        eapply type_from_wf_typ; eauto.
    SCase "wf_typ".
      destruct IHtyping as [_ [_ [_ WF]]].
      inversion WF; subst...
      SSCase "wf_typ_all".
        pick fresh Y.
        rewrite (subst_tt_intro Y); auto.
        rewrite_env ((map (subst_tb Y T) empty) ++ E); auto.
        eapply (wf_typ_subst_tb empty); auto.
        rewrite_env ([(Y, bind_kn)] ++ E); auto.
  Case "typing_let".
    pick fresh y.
    destruct (H1 y) as [WF2 [WFL2 [EXP2 WFT2]]]...
    destruct IHtyping as [WF1 [WFL1 [EXP1 WFT1]]].
    repeat split...
    SCase "expr".
      pick fresh x and apply expr_let...
        lapply (H1 x); auto...
    SCase "wf_typ".
      rewrite_env (empty ++ E).
      eapply wf_typ_strengthening; eauto.
  Case "typing_fst".
    destruct IHtyping as [WF [WFL1 [EX J]]]...
    repeat split...
    SCase "wf_typ".
      inversion J; subst; auto.
  Case "typing_snd".
    destruct IHtyping as [WF [WFL1 [EX J]]]...
    repeat split...
    SCase "wf_typ".
      inversion J; subst; auto.
Qed.

Lemma value_regular : forall e,
  value e ->
  expr e.
Proof.
  intros e H. induction H; auto.
Qed.

Lemma red_regular : forall e e',
  red e e' ->
  expr e /\ expr e'.
Proof with try solve [solve_notin | intuition].
  intros e e' H.
  induction H; assert(J := value_regular); split...
  Case "red_abs".
    inversion H. pick fresh y. rewrite (subst_ee_intro y)...
  Case "red_tabs".
    inversion H. pick fresh Y. rewrite (subst_te_intro Y)...
  Case "red_let_cong".
    destruct IHred as [EXP1 EXP1'].
    apply expr_let with (L:={}) ; auto.
      intros x xnL.
      inversion H. pick fresh y. rewrite (subst_ee_intro y)...
  Case "red_let_beta".
    inversion H; subst. inversion H2; subst.
    pick fresh y. rewrite (subst_ee_intro y)...
Qed.

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

(** The lemma [uniq_from_wf_env] was already added above as a hint since it
    helps blur the distinction between [wf_env] and [uniq] in proofs.

    As currently stated, the regularity lemmas are ill-suited to be
    used with [auto] and [eauto] since they end in conjunctions.  Even
    if we were, for example, to split [sub_regularity] into three
    separate lemmas, the resulting lemmas would be usable only by
    [eauto] and there is no guarantee that [eauto] would be able to
    find proofs effectively.  Thus, the hints below apply the
    regularity lemmas and [type_from_wf_typ] to discharge goals about
    local closure and well-formedness, but in such a way as to
    minimize proof search.

    The first hint introduces an [wf_env] fact into the context.  It
    works well when combined with the lemmas relating [wf_env] and
    [wf_typ].  We choose to use those lemmas explicitly via [(auto
    using ...)] tactics rather than add them as hints.  When used this
    way, the explicitness makes the proof more informative rather than
    more cluttered (with useless details).

    The other three hints try outright to solve their respective
    goals. *)

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

Hint Extern 1 (wf_lenv ?G ?D) =>
  match goal with
  | H: typing _ _ _ _ |- _ => apply (proj1 (proj2 (typing_regular _ _ _ _ H)))
  end.

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

Hint Extern 1 (type ?T) =>
  let go E := apply (type_from_wf_typ E); auto in
  match goal with
  | H: typing ?E _ _ T |- _ => go E
  end.

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

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../../../metatheory") ***
*** End: ***
 *)


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

(** %\subsection*{ support :  conshdtl.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export finite.
From Algebra Require Export Parts.

(** - This file introduces the "cons" operator on sequences (called "conseq" here to
 avoid confusion with the normal notion for Lists). It is denoted as "a;;v" instead
 of "a::v" since the latter is already taken in coq.
 - Also it defines "Seqtl" (the "tail" operator) and "head". *)

Section MAIN.

(* conseq adjoins an element x of X to finite functions f:(fin N)->X *)
(* This is done by {0->x; m+1->f(m)} : (fin N+1)->X, ie. the new element *)
(* is inserted at the front. That's why it's called conseq: it's the seq *)
(* variant of the cons operator as seen in lists *)

(** %\label{conseq}% *)

Definition conseq :
  forall (A : Setoid) (n : Nat) (a : A) (v : seq n A), seq (S n) A.
intros.
apply
 (Build_Map
    (Ap:=fun m : fin (S n) =>
         match m return (A:Type) with
         | Build_finiteT x0 x1 =>
             match x0 as x2 return (x2 < S n -> (A:Type)) with
             | O => fun _ : 0 < S n => a
             | S m' =>
                 fun HSm' : S m' < S n =>
                 Ap v (Build_finiteT (lt_S_n m' n HSm'))
             end x1
         end)).
red in |- *.
simpl in |- *.
intros x0 y.
case x0.
case y.
simpl in |- *.
intros x2 y1.
induction x2.
intros x2 y2.
induction x2.
intro; apply Refl.
intro H.
inversion H.
clear IHx2.
simple induction index.
intros h H.
inversion H.
intros.
clear H.
apply Ap_comp; auto with algebra.
Defined.

Notation "a ;; b" := (conseq a b) (at level 60, right associativity).

Variables (A : Setoid) (n : Nat) (a : A).

Lemma cons_comp :
 forall (a' : A) (v v' : seq n A),
 a =' a' in _ -> v =' v' in _ -> a;; v =' a';; v' in _.
intros.
simpl in |- *.
red in |- *.
intro i'.
elim i'.
intro i.
simpl in |- *.
case i.
auto.
intros.
apply Ap_comp; auto with algebra.
Qed.

Hint Resolve cons_comp: algebra.

Lemma cons_first_element :
 forall (v : seq n A) (H : 0 < S n), (a;; v) (Build_finiteT H) =' a in _.
auto with algebra.
Qed.

(** %\label{head}% *)
Definition head (A : Setoid) (n : Nat) (v : seq (S n) A) :=
  v (Build_finiteT (lt_O_Sn n)).

Lemma head_comp :
 forall (A : Setoid) (n : Nat) (v v' : seq (S n) A),
 v =' v' in _ -> head v =' head v' in _.
unfold head in |- *.
auto with algebra.
Qed.

Hint Resolve head_comp cons_first_element: algebra.

(** - these two lemmas are mainly useful for the algebra Hints database
 (hence the names) *)
Lemma head_unfolding1 :
 forall v : seq (S n) A,
 v (Build_finiteT (lt_O_Sn n)) =' a in _ -> head v =' a in _.
auto with algebra.
Qed.

Lemma head_unfolding2 :
 forall v : seq (S n) A,
 a =' v (Build_finiteT (lt_O_Sn n)) in _ -> a =' head v in _.
auto with algebra.
Qed.

Hint Resolve head_unfolding1 head_unfolding2: algebra.
Hint Extern 0 (head _ =' _ in _) => unfold head in |- *: algebra.
Hint Extern 0 (_ =' head _ in _) => unfold head in |- *: algebra.

Lemma head_cons_inv : forall v : seq n A, head (a;; v) =' a in _.
auto with algebra.
Qed.

Hint Resolve head_cons_inv: algebra.

Lemma seq_S_O_contains_single_elt :
 forall (A : Setoid) (v : seq 1 A) (i : fin 1), v i =' head v in _.
intros.
unfold head in |- *.
apply Ap_comp; auto with algebra.
Qed.

Hint Resolve seq_S_O_contains_single_elt: algebra.

Lemma seq_S_O_head_fixes_everything :
 forall (A : Setoid) (v v' : seq 1 A), head v =' head v' in _ -> v =' v' in _.
intros.
simpl in |- *.
red in |- *.
intro.
apply Trans with (head v).
apply seq_S_O_contains_single_elt; auto with algebra.
apply Trans with (head v'); auto with algebra.
Qed.

Hint Resolve seq_S_O_head_fixes_everything: algebra.

Lemma cons_later_elements :
 forall (v : seq n A) (i : Nat) (Hi : S i < S n) (Hi' : i < n),
 (a;; v) (Build_finiteT Hi) =' v (Build_finiteT Hi') in _.
intros.
simpl in |- *.
apply Ap_comp; auto with algebra.
Qed.

Hint Resolve cons_later_elements: algebra.

(* Taking the "tl" of a sequence *)
(** %\label{Seqtl}% *)
Definition Seqtl : forall n : Nat, seq n A -> seq (pred n) A.
clear n.
intro n.
case n.
intro f.
exact f.
intros m f.
apply
 (Build_Map
    (Ap:=fun i' : fin m =>
         match i' with
         | Build_finiteT i Hi => f (Build_finiteT (lt_n_S _ _ (Hi:i < m)))
         end)).
red in |- *.
intros x y.
case x.
case y.
simpl in |- *.
intros.
apply Ap_comp; auto with algebra.
Defined.

Lemma Seqtl_comp :
 forall v v' : seq n A, v =' v' in _ -> Seqtl v =' Seqtl v' in _.
induction n.
intros.
simpl in |- *.
auto.
intros.
simpl in |- *.
red in |- *.
simpl in |- *.
intro.
elim x.
intros.
apply Ap_comp; auto with algebra.
Qed.

Hint Resolve Seqtl_comp: algebra.

(** - "hdtl" is a 'tool' for writing a sequence as the cons of its head and its tail
 %\label{hdtl}% *)

Definition hdtl (v : seq (S n) A) := head v;; Seqtl v:seq (S n) A.

Lemma conseq_hdtl :
 forall (v : seq (S n) A) (H : 0 < S n),
 v =' v (Build_finiteT H);; Seqtl v in _.
(* note we don't say v='(head v);;(Seqtl v): we want freedom in the choice of the proof H *)
intros.
simpl in |- *.
red in |- *.
simpl in |- *.
intro x.
case x.
intro.
case index.
intros; apply Ap_comp; simpl in |- *; auto with algebra arith.
red in |- *; auto with algebra.
intros; apply Ap_comp; simpl in |- *; auto with algebra arith.
red in |- *; auto with algebra.
Qed.

Hint Resolve conseq_hdtl: algebra.

Lemma hdtl_x_is_x : forall v : seq (S n) A, v =' hdtl v in _.
unfold hdtl in |- *.
intros.
unfold head in |- *.
apply conseq_hdtl.
Qed.

Hint Resolve hdtl_x_is_x: algebra.
Hint Extern 0 (head _;; Seqtl _ =' _ in _) =>
  fold hdtl in |- *; apply Sym; apply hdtl_x_is_x: algebra.
Hint Extern 0 (_ =' head _;; Seqtl _ in _) =>
  fold hdtl in |- *; apply hdtl_x_is_x: algebra.

Lemma cons_lemma_nice :
 forall P : Predicate (seq (S n) A),
 (forall (a : A) (v : seq n A), Pred_fun P (a;; v)) ->
 forall w : seq (S n) A, Pred_fun P w.
intro.
elim P.
intros.
unfold pred_compatible in Pred_compatible_prf.
apply Pred_compatible_prf with (hdtl w); auto with algebra.
unfold hdtl in |- *.
apply H.
Qed.

Lemma cons_lemma_verynice :
 forall (P : Predicate (seq (S n) A)) (H : 0 < S n) (w : seq (S n) A),
 Pred_fun P (w (Build_finiteT H);; Seqtl w) -> Pred_fun P w.
intros P H w.
elim P.
intros.
unfold pred_compatible in Pred_compatible_prf.
apply Pred_compatible_prf with (w (Build_finiteT H);; Seqtl w);
 auto with algebra.
Qed.

Lemma Seqtl_cons_inv : forall v : seq n A, Seqtl (a;; v) =' v in _.
intros.
simpl in |- *.
red in |- *.
simpl in |- *.
intro i.
elim i.
intros.
apply Ap_comp; auto with algebra.
Qed.

Hint Resolve Seqtl_cons_inv: algebra.

Lemma Seqtl_to_seq :
 forall (v : seq (S n) A) (i : Nat) (Hi : i < n) (HSi : S i < S n),
 Seqtl v (Build_finiteT Hi) =' v (Build_finiteT HSi) in _.
intros.
simpl in |- *.
apply Ap_comp; auto with algebra.
Qed.

Hint Resolve Seqtl_to_seq: algebra.

Lemma split_hd_tl_equality :
 forall v w : seq (S n) A,
 head v =' head w in _ -> Seqtl v =' Seqtl w in _ -> v =' w in _.
intros.
intro.
destruct x.
destruct index as [| n0].
apply Trans with (head v); auto with algebra.
apply Trans with (head w); auto with algebra.
apply Trans with (Seqtl v (Build_finiteT (lt_S_n _ _ in_range_prf)));
 auto with algebra.
apply Trans with (Seqtl w (Build_finiteT (lt_S_n _ _ in_range_prf)));
 auto with algebra.
Qed.

Hint Resolve split_hd_tl_equality: algebra.
End MAIN.

(* Hints and notation inside sections is forgotten... *)
Notation "a ;; b" := (conseq a b) (at level 60, right associativity).

Hint Resolve cons_comp: algebra.
Hint Resolve head_comp cons_first_element: algebra.
Hint Resolve head_unfolding1 head_unfolding2: algebra.
Hint Extern 0 (head _ =' _ in _) => unfold head in |- *: algebra.
Hint Extern 0 (_ =' head _ in _) => unfold head in |- *: algebra.
Hint Resolve head_cons_inv: algebra.
Hint Resolve cons_later_elements: algebra.
Hint Resolve Seqtl_comp: algebra.
Hint Resolve conseq_hdtl: algebra.
Hint Resolve hdtl_x_is_x: algebra.
Hint Extern 0 (head _;; Seqtl _ =' _ in _) =>
  fold hdtl in |- *; apply Sym; apply hdtl_x_is_x: algebra.
Hint Extern 0 (_ =' head _;; Seqtl _ in _) =>
  fold hdtl in |- *; apply hdtl_x_is_x: algebra.
Hint Resolve Seqtl_cons_inv: algebra.
Hint Resolve Seqtl_to_seq: algebra.
Hint Resolve split_hd_tl_equality: algebra.
Hint Resolve seq_S_O_contains_single_elt: algebra.
Hint Resolve seq_S_O_head_fixes_everything: algebra.


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

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.
Require Import ssrbool.

Lemma test b : b || ~~b.
wlog _ : b / b = true.
  case: b; [ by apply | by rewrite orbC ].
wlog suff: b /  b || ~~b.
  by case: b.
by case: b.
Qed.

Lemma test2 b c (H : c = b) : b || ~~b.
wlog _ : b {c H} / b = true.
  by case: b H.
by case: b.
Qed.


Require Import Datatypes.
Require Import ZArith.

(** Instructions used by the machines. *)

(** An [Atom] is an integer plus some metadata, and forms the basic
data unit in our machines. In the abstract and symbolic rule machine,
this metadata field contains an element from some arbitrary
information-flow lattice. In the concrete machine, it contains just a
plain integer. *)

Definition Atom {Label: Type} := (Z * Label)%type.

(** [Instr] is the type of instructions used in all three of our
machines. Our machines are stack machines, thus most instructions
operate on the machine stack, with no need for arguments. *)

Inductive Instr :=
  | Noop : Instr
  | Add : Instr
  | Sub : Instr
  | Push : Z  -> Instr
  | Pop : Instr

  (* Memory operations *)
  | Load : Instr
  | Store : Instr

  | Jump : Instr
  | BranchNZ : Z -> Instr

  (* [Call n b] : call a function with n arguments; the boolean
  indicates a value or void returning function.  We need that flag to
  ensure two calls to high contexts have the same stack layout upon a
  return *)
  | Call : nat -> bool -> Instr

  (* [Ret] and [VRet] return from function calls. The latter returns a
  value, while the former doesn't. *)
  | Ret: Instr
  | VRet : Instr

  | Halt : Instr
  | Output : Instr.

(** [OpCode]s are used to index TMU rules.
There is no [OpCode] for Halt, as there is no stepping rule for Halt.*)
(* (If we ever move to having common rules for multiple instructions
("operation groups"), we should expect one OpCode per group.) *)

Inductive OpCode : Type :=
| OpNoop
| OpAdd
| OpSub
| OpPush
| OpPop
| OpLoad
| OpStore
| OpJump
| OpBranchNZ
| OpCall
| OpRet
| OpVRet
| OpOutput.

Lemma dec_eq_OpCode: forall (o o': OpCode),
  o = o' \/ o <> o'.
Proof.
  destruct o; destruct o'; solve [ left; reflexivity | right; congruence ].
Qed.

(** Opcodes corresponding to instructions *)
Definition opcode_of_instr (i : Instr) : option OpCode :=
  match i with
    | Noop => Some OpNoop
    | Add => Some OpAdd
    | Sub => Some OpSub
    | Push _ => Some OpPush
    | Pop => Some OpPop
    | Load => Some OpLoad
    | Store => Some OpStore
    | Jump => Some OpJump
    | BranchNZ _ => Some OpBranchNZ
    | Call _ _ => Some OpCall
    | Ret => Some OpRet
    | VRet => Some OpVRet
    | Halt => None
    | Output => Some OpOutput
  end.


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

Benedikt Ahrens, Chris Kapulkin, Mike Shulman

january 2013

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

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

Contents : Rezk completion

 - Construction of the Rezk completion via Yoneda

 - Universal property of the Rezk completion

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

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.

Require Import RezkCompletion.auxiliary_lemmas_HoTT.

Require Import RezkCompletion.precategories.
Require Import RezkCompletion.functors_transformations.
Require Import RezkCompletion.category_hset.
Require Import RezkCompletion.yoneda.
Require Import RezkCompletion.sub_precategories.
Require Import RezkCompletion.equivalences.
Require Import RezkCompletion.whiskering.
Require Import RezkCompletion.precomp_fully_faithful.
Require Import RezkCompletion.precomp_ess_surj.

Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

(** * Construction of the Rezk completion via Yoneda *)

Section rezk.

Variable A : precategory.

Definition Rezk_completion : category.
Proof.
  exists (full_img_sub_precategory (yoneda A)).
  apply is_category_full_subcat.
  apply is_category_functor_category.
  apply is_category_HSET.
Defined.

Definition Rezk_eta : functor A Rezk_completion.
Proof.
  apply (functor_full_img (yoneda A)).
Defined.

Lemma Rezk_eta_is_fully_faithful : fully_faithful Rezk_eta.
Proof.
  apply (functor_full_img_fully_faithful_if_fun_is _ _ (yoneda A)).
  apply yoneda_fully_faithful.
Qed.

Lemma Rezk_eta_essentially_surjective : essentially_surjective Rezk_eta.
Proof.
  apply (functor_full_img_essentially_surjective _ _ (yoneda A)).
Qed.

End rezk.

(** * Universal property of the Rezk completion *)

Section rezk_universal_property.

Variables A C : precategory.
Hypothesis Ccat : is_category C.

Lemma pre_comp_rezk_eta_is_fully_faithful :
    fully_faithful (pre_composition_functor A (Rezk_completion A) C (Rezk_eta A)).
Proof.
  apply pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful.
  apply Rezk_eta_essentially_surjective.
  apply Rezk_eta_is_fully_faithful.
Qed.

Lemma pre_comp_rezk_eta_is_ess_surj :
   essentially_surjective (pre_composition_functor A (Rezk_completion A) C (Rezk_eta A)).
Proof.
  apply pre_composition_essentially_surjective.
  assumption.
  apply Rezk_eta_essentially_surjective.
  apply Rezk_eta_is_fully_faithful.
Qed.

Theorem Rezk_eta_Universal_Property :
  isweq (pre_composition_functor A (Rezk_completion A) C (Rezk_eta A)).
Proof.
  apply equiv_of_cats_is_weq_of_objects.
  apply is_category_functor_category;
  assumption.
  apply is_category_functor_category;
  assumption.

  apply rad_equivalence_of_precats.
  apply is_category_functor_category;
  assumption.
  apply pre_comp_rezk_eta_is_fully_faithful.
  apply pre_comp_rezk_eta_is_ess_surj.
Qed.

End rezk_universal_property.


Require Import Coq.Strings.String Coq.Lists.List.
Require Import Coq.omega.Omega.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Enumerable.
Require Import Fiat.Common.LogicFacts.
Require Import Fiat.Common.Equality.

Set Implicit Arguments.

Local Open Scope string_like_scope.
Local Open Scope type_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {HEC : Enumerable Char}.

  Class paren_balanced_hiding_dataT :=
    { is_open : Char -> bool;
      is_close : Char -> bool;
      is_bin_op : Char -> bool }.

  Context {pdata : paren_balanced_hiding_dataT}.

  Context (G : grammar Char).

  (**
<<
pb' ch n "" = (n == 0)
pb' ch n (ch :: s) = n > 0 && pb' ch n s
pb' ch n ('(' :: s) = pb' ch (n + 1) s
pb' ch n (')' :: s) = n > 0 && pb' ch (n - 1) s
pb' ch n (_ :: s) = pb' ch n s

pb = pb' '+' 0
>>
*)

  Definition pb_check_level (hiding : bool) (ch : Char) (start_level : nat) : bool
    := if is_bin_op ch
       then if hiding
            then Compare_dec.gt_dec start_level 0 : bool
            else true
       else if is_open ch
            then true
            else if is_close ch
                 then (Compare_dec.gt_dec start_level 0 : bool)
                 else true.

  Definition pb_new_level (ch : Char) (start_level : nat) : nat
    := if is_bin_op ch
       then start_level
       else if is_open ch
            then (S start_level)
            else if is_close ch
                 then (pred start_level)
                 else start_level.

  (** We can check the level for a function [Char -> bool] by enumerating through all the booleans *)
  Definition pb_check_level_fun (hiding : bool) (P : Char -> bool) (start_level : nat) : bool
    := List.fold_right
         andb
         true
         (List.map
            (fun ch => pb_check_level hiding ch start_level)
            (List.filter
               P
               (enumerate Char))).

  Lemma pb_check_level_fun_correct hiding P start_level
  : pb_check_level_fun hiding P start_level
    <-> (forall ch, P ch -> pb_check_level hiding ch start_level).
  Proof.
    unfold pb_check_level_fun.
    setoid_rewrite fold_right_andb_map_in_iff.
    setoid_rewrite filter_In.
    setoid_rewrite (fun x => @and_TrueP_L (In x (enumerate Char)) (P x = true) (enumerate_correct x)).
    reflexivity.
  Qed.

  Definition pb_new_level_fun (P : Char -> bool) (start_level : nat) : list nat
    := List.uniquize
         EqNat.beq_nat
         (List.map
            (fun ch => pb_new_level ch start_level)
            (List.filter
               P
               (enumerate Char))).

  Lemma pb_new_level_fun_correct P start_level new_level
  : pb_new_level_fun P start_level = [new_level]
    <-> ((exists ch, P ch) /\ forall ch, P ch -> new_level = pb_new_level ch start_level).
  Proof.
    unfold pb_new_level_fun.
    rewrite (uniquize_singleton (beq := EqNat.beq_nat) bl lb).
    setoid_rewrite in_map_iff.
    setoid_rewrite filter_In.
    setoid_rewrite (fun x => @and_TrueP_L (In x (enumerate Char)) (P x = true) (enumerate_correct _)).
    split; intro H;
    repeat match goal with
             | _ => split
             | _ => intro
             | _ => progress subst
             | _ => progress destruct_head ex
             | _ => progress split_and
             | _ => progress split_iff
             | [ H : forall x, _ = x -> _ |- _ ] => specialize (H _ eq_refl)
             | [ H : forall x, x = _ -> _ |- _ ] => specialize (H _ eq_refl)
             | [ H : forall x, _ -> _ = _ |- _ ] => unique pose proof (fun x H' => eq_sym (H x H'))
             | _ => solve [ eauto ]
           end.
  Qed.

  Section generic.
    Context (transform_valid : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT).

    Inductive generic_pb'_productions : nonterminals_listT -> productions Char -> Type :=
    | PBNil : forall valid,
                 generic_pb'_productions valid nil
    | PBCons : forall valid pat pats,
                  generic_pb'_production valid 0 pat
                  -> generic_pb'_productions valid pats
                  -> generic_pb'_productions valid (pat::pats)
    with generic_pb'_production : nonterminals_listT -> nat -> production Char -> Type :=
    | PBProductionNil : forall valid,
                           generic_pb'_production valid 0 nil
    | PBProductionConsNonTerminal : forall valid start_level nt its,
                                       is_valid_nonterminal valid (of_nonterminal nt)
                                       -> generic_pb'_productions (transform_valid valid (of_nonterminal nt)) (Lookup G nt)
                                       -> generic_pb'_production valid start_level its
                                       -> generic_pb'_production valid start_level (NonTerminal nt :: its)
    | PBProductionConsTerminal : forall valid start_level new_level P its,
                                   (forall ch, is_true (P ch) -> pb_check_level false ch start_level)
                                   -> (forall ch, is_true (P ch) -> pb_new_level ch start_level = new_level)
                                    -> generic_pb'_production valid new_level its
                                    -> generic_pb'_production valid start_level (Terminal P :: its).
  End generic.

  Definition minimal_pb'_productions := generic_pb'_productions remove_nonterminal.
  Definition minimal_pb'_production := generic_pb'_production remove_nonterminal.

  Definition pb'_productions := generic_pb'_productions (fun valid _ => valid).
  Definition pb'_production := generic_pb'_production (fun valid _ => valid).

  Lemma pb_check_level_le {ch b} {n n'} (Hle : n <= n')
  : pb_check_level b ch n -> pb_check_level b ch n'.
  Proof.
    unfold pb_check_level.
    do 2 edestruct Compare_dec.gt_dec; trivial; try omega; simpl.
    destruct b;
    edestruct is_bin_op; trivial;
    edestruct is_close;
    edestruct is_open;
    unfold is_true;
    trivial.
  Qed.

  Global Instance pb_new_level_Proper {ch}
  : Proper (le ==> le) (pb_new_level ch).
  Proof.
    intros ???.
    unfold pb_new_level.
    edestruct is_bin_op; trivial;
    edestruct is_close;
    edestruct is_open;
    unfold is_true;
    trivial;
    omega.
  Qed.

  Global Instance pb_new_level_flip_Proper {ch}
  : Proper (Basics.flip le ==> Basics.flip le) (pb_new_level ch).
  Proof.
    unfold Basics.flip, pb_new_level.
    intros ???.
    edestruct is_bin_op; trivial;
    edestruct is_close;
    edestruct is_open;
    unfold is_true;
    trivial;
    omega.
  Qed.
End cfg.

Global Arguments paren_balanced_hiding_dataT : clear implicits.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_upp_nil_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_upp x1 L1 T1') ->
                  subtype T1 t_nil = false.
Proof.
  intros; subst.

  unfold subtype, subtype_func;
    simpl;
    rewrite fix_sub_eq_ext;
    simpl;
    fold subtype_func.

  auto.

Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-20011                            *)
(*                                                                      *)
(************************************************************************)

Require Import List.
Require Import Refl.
Require Import Bool.

Set Implicit Arguments.

  Inductive BFormula (A:Type) : Type :=
  | TT   : BFormula A
  | FF   : BFormula A
  | X : Prop -> BFormula A
  | A : A -> BFormula A
  | Cj  : BFormula A -> BFormula A -> BFormula A
  | D   : BFormula A-> BFormula A -> BFormula A
  | N  : BFormula A -> BFormula A
  | I : BFormula A-> BFormula A-> BFormula A.

  Fixpoint eval_f (A:Type)  (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop :=
    match f with
      | TT _ => True
      | FF _ => False
      | A a =>  ev a
      | X _ p => p
      | Cj e1 e2 => (eval_f  ev e1) /\ (eval_f ev e2)
      | D e1 e2  => (eval_f  ev e1) \/ (eval_f  ev e2)
      | N e     => ~ (eval_f  ev e)
      | I f1 f2 => (eval_f  ev f1) -> (eval_f  ev f2)
    end.

  Lemma eval_f_morph : forall  A (ev ev' : A -> Prop) (f : BFormula A),
    (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f).
  Proof.
    induction f ; simpl ; try tauto.
    intros.
    assert (H' := H a).
    auto.
  Qed.

  Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U :=
    match f with
      | TT _ => TT _
      | FF _ => FF _
      | X _ p => X _ p
      | A a => A (fct a)
      | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2)
      | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2)
      | N f     => N (map_bformula fct f)
      | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2)
    end.

  Lemma eval_f_map : forall T U (fct: T-> U) env f ,
    eval_f env  (map_bformula fct f)  = eval_f (fun x => env (fct x)) f.
  Proof.
    induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto.
    rewrite <- IHf.  auto.
  Qed.

  Lemma map_simpl : forall A B f l, @map A B f l = match l with
                                                 | nil => nil
                                                 | a :: l=> (f a) :: (@map A B f l)
                                               end.
  Proof.
    destruct l ; reflexivity.
  Qed.

  Section S.

    Variable Env   : Type.
    Variable Term  : Type.
    Variable eval  : Env -> Term -> Prop.
    Variable Term' : Type.
    Variable eval'  : Env -> Term' -> Prop.

    Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).

    Variable unsat : Term'  -> bool.

    Variable unsat_prop : forall t, unsat t  = true ->
      forall env, eval' env t -> False.

    Variable deduce : Term' -> Term' -> option Term'.

    Variable deduce_prop : forall env t t' u,
      eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u.

    Definition clause := list  Term'.
    Definition cnf := list clause.

    Variable normalise : Term -> cnf.
    Variable negate : Term -> cnf.

    Definition tt : cnf := @nil clause.
    Definition ff : cnf :=  cons (@nil Term') nil.

    Fixpoint add_term (t: Term') (cl : clause) : option clause :=
      match cl with
        | nil =>
          match deduce t t with
            | None =>  Some (t ::nil)
            | Some u => if unsat u then None else Some (t::nil)
          end
        | t'::cl =>
          match deduce t t' with
            | None =>
              match add_term t cl with
                | None => None
                | Some cl' => Some (t' :: cl')
              end
            | Some u =>
              if unsat u then None else
                match add_term t cl with
                  | None => None
                  | Some cl' => Some (t' :: cl')
                end
          end
      end.

    Fixpoint or_clause (cl1 cl2 : clause) : option clause :=
      match cl1 with
        | nil => Some cl2
        | t::cl => match add_term t cl2 with
                     | None => None
                     | Some cl' => or_clause cl cl'
                   end
      end.

(*    Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
      List.map (fun x => (t++x)) f. *)

    Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
      List.fold_right (fun e acc =>
        match or_clause t e with
          | None => acc
          | Some cl => cl :: acc
        end) nil f.

    Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
      match f with
        | nil => tt
        | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f')
      end.

    Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf :=
      f1 ++ f2.

    Fixpoint xcnf (pol : bool) (f : BFormula Term)  {struct f}: cnf :=
      match f with
        | TT _ => if pol then tt else ff
        | FF _ => if pol then ff else tt
        | X _ p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
        | A x => if pol then normalise x else negate x
        | N e  => xcnf (negb pol) e
        | Cj e1 e2 =>
          (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
        | D e1 e2  => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
        | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2)
      end.

    Definition eval_clause (env : Env) (cl : clause) := ~ make_conj  (eval' env) cl.

    Definition eval_cnf (env : Env) (f:cnf) := make_conj  (eval_clause  env) f.

    Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y.
    Proof.
      unfold eval_cnf.
      intros.
      rewrite make_conj_app in H ; auto.
    Qed.

    Definition eval_opt_clause (env : Env) (cl: option clause) :=
      match cl with
        | None => True
        | Some cl => eval_clause env cl
      end.

    Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl).
    Proof.
      induction cl.
      (* BC *)
      simpl.
      case_eq (deduce t t) ; auto.
      intros until 0.
      case_eq (unsat t0) ; auto.
      unfold eval_clause.
      rewrite make_conj_cons.
      intros. intro.
      apply unsat_prop with (1:= H) (env := env).
      apply deduce_prop with (3:= H0) ; tauto.
      (* IC *)
      simpl.
      case_eq (deduce t a).
      intro u.
      case_eq (unsat u).
      simpl. intros.
      unfold eval_clause.
      intro.
      apply unsat_prop  with (1:= H) (env:= env).
      repeat rewrite make_conj_cons in H2.
      apply deduce_prop with (3:= H0); tauto.
      intro.
      case_eq (add_term t cl) ; intros.
      simpl in H2.
      rewrite H0 in IHcl.
      simpl in IHcl.
      unfold eval_clause in *.
      intros.
      repeat rewrite make_conj_cons in *.
      tauto.
      rewrite H0 in IHcl ; simpl in *.
      unfold eval_clause in *.
      intros.
      repeat rewrite make_conj_cons in *.
      tauto.
      case_eq (add_term t cl) ; intros.
      simpl in H1.
      unfold eval_clause in *.
      repeat rewrite make_conj_cons in *.
      rewrite H in IHcl.
      simpl in IHcl.
      tauto.
      simpl in *.
      rewrite H in IHcl.
      simpl in IHcl.
      unfold eval_clause in *.
      repeat rewrite make_conj_cons in *.
      tauto.
    Qed.

  Lemma or_clause_correct : forall cl cl' env,  eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'.
  Proof.
    induction cl.
    simpl. tauto.
    intros until 0.
    simpl.
    assert (HH := add_term_correct env a cl').
    case_eq (add_term a cl').
    simpl in *.
    intros.
    apply IHcl in H0.
    rewrite H in HH.
    simpl in HH.
    unfold eval_clause in *.
    destruct H0.
    repeat rewrite make_conj_cons in *.
    tauto.
    apply HH in H0.
    apply not_make_conj_cons in H0 ; auto.
    repeat rewrite make_conj_cons in *.
    tauto.
    simpl.
    intros.
    rewrite H in HH.
    simpl in HH.
    unfold eval_clause in *.
    assert (HH' := HH Coq.Init.Logic.I).
    apply not_make_conj_cons in HH'; auto.
    repeat rewrite make_conj_cons in *.
    tauto.
  Qed.

  Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f).
  Proof.
    unfold eval_cnf.
    unfold or_clause_cnf.
    intros until t.
    set (F := (fun (e : clause) (acc : list clause) =>
         match or_clause t e with
         | Some cl => cl :: acc
         | None => acc
         end)).
    induction f.
    auto.
    (**)
    simpl.
    intros.
    destruct f.
    simpl in H.
    simpl in IHf.
    unfold F in H.
    revert H.
    intros.
    apply or_clause_correct.
    destruct (or_clause t a) ; simpl in * ; auto.
    unfold F in H at 1.
    revert H.
    assert (HH := or_clause_correct t a env).
    destruct (or_clause t a); simpl in HH ;
    rewrite make_conj_cons in * ; intuition.
    rewrite make_conj_cons in *.
    tauto.
  Qed.

 Lemma eval_cnf_cons : forall env a f,  (~ make_conj  (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f).
 Proof.
   intros.
   unfold eval_cnf in *.
   rewrite make_conj_cons ; eauto.
 Qed.

  Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env  f) \/ (eval_cnf  env f').
  Proof.
    induction f.
    unfold eval_cnf.
    simpl.
    tauto.
    (**)
    intros.
    simpl in H.
    destruct (eval_cnf_app _ _ _ H).
    clear H.
    destruct (IHf _ H0).
    destruct (or_clause_cnf_correct _ _ _ H1).
    left.
    apply eval_cnf_cons ; auto.
    right ; auto.
    right ; auto.
  Qed.

  Variable normalise_correct : forall env t, eval_cnf  env (normalise t) -> eval env t.

  Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t.

  Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f).
  Proof.
    induction f.
    (* TT *)
    unfold eval_cnf.
    simpl.
    destruct pol ; simpl ; auto.
    (* FF *)
    unfold eval_cnf.
    destruct pol; simpl ; auto.
    unfold eval_clause ; simpl.
    tauto.
    (* P *)
    simpl.
    destruct pol ; intros ;simpl.
    unfold eval_cnf in H.
    (* Here I have to drop the proposition *)
    simpl in H.
    unfold eval_clause in H ; simpl in H.
    tauto.
    (* Here, I could store P in the clause *)
    unfold eval_cnf in H;simpl in H.
    unfold eval_clause in H ; simpl in H.
    tauto.
    (* A *)
    simpl.
    destruct pol ; simpl.
    intros.
    apply normalise_correct  ; auto.
    (* A 2 *)
    intros.
    apply  negate_correct ; auto.
    auto.
    (* Cj *)
    destruct pol ; simpl.
    (* pol = true *)
    intros.
    unfold and_cnf in H.
    destruct (eval_cnf_app  _ _ _ H).
    clear H.
    split.
    apply (IHf1 _ _ H0).
    apply (IHf2 _ _ H1).
    (* pol = false *)
    intros.
    destruct (or_cnf_correct _ _ _ H).
    generalize (IHf1 false  env H0).
    simpl.
    tauto.
    generalize (IHf2 false  env H0).
    simpl.
    tauto.
    (* D *)
    simpl.
    destruct pol.
    (* pol = true *)
    intros.
    destruct (or_cnf_correct _ _ _ H).
    generalize (IHf1 _  env H0).
    simpl.
    tauto.
    generalize (IHf2 _  env H0).
    simpl.
    tauto.
    (* pol = true *)
    unfold and_cnf.
    intros.
    destruct (eval_cnf_app  _ _ _ H).
    clear H.
    simpl.
    generalize (IHf1 _ _ H0).
    generalize (IHf2 _ _ H1).
    simpl.
    tauto.
    (**)
    simpl.
    destruct pol ; simpl.
    intros.
    apply (IHf false) ; auto.
    intros.
    generalize (IHf _ _ H).
    tauto.
    (* I *)
    simpl; intros.
    destruct pol.
    simpl.
    intro.
    destruct (or_cnf_correct _ _ _ H).
    generalize (IHf1 _ _ H1).
    simpl in *.
    tauto.
    generalize (IHf2 _ _ H1).
    auto.
    (* pol = false *)
    unfold and_cnf in H.
    simpl in H.
    destruct (eval_cnf_app _ _ _ H).
    generalize (IHf1 _ _ H0).
    generalize (IHf2 _ _ H1).
    simpl.
    tauto.
  Qed.

  Variable Witness : Type.
  Variable checker : list Term' -> Witness -> bool.

  Variable checker_sound : forall t  w, checker t w = true -> forall env, make_impl (eval' env)  t False.

  Fixpoint cnf_checker (f : cnf) (l : list Witness)  {struct f}: bool :=
    match f with
      | nil => true
      | e::f => match l with
                  | nil => false
                  | c::l => match checker e c with
                              | true => cnf_checker f l
                              |   _  => false
                            end
                end
      end.

  Lemma cnf_checker_sound : forall t  w, cnf_checker t w = true -> forall env, eval_cnf  env  t.
  Proof.
    unfold eval_cnf.
    induction t.
    (* bc *)
    simpl.
    auto.
    (* ic *)
    simpl.
    destruct w.
    intros ; discriminate.
    case_eq (checker a w) ; intros ; try discriminate.
    generalize (@checker_sound _ _ H env).
    generalize (IHt _ H0 env) ; intros.
    destruct t.
    red ; intro.
    rewrite <- make_conj_impl in H2.
    tauto.
    rewrite <- make_conj_impl in H2.
    tauto.
  Qed.

  Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool :=
    cnf_checker (xcnf true f) w.

  Lemma tauto_checker_sound : forall t  w, tauto_checker t w = true -> forall env, eval_f  (eval env)  t.
  Proof.
    unfold tauto_checker.
    intros.
    change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)).
    apply (xcnf_correct t true).
    eapply cnf_checker_sound ; eauto.
  Qed.

End S.

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)