(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export sequents_useful.
Require Export per_props_equality.
Require Export per_props_pertype.
Require Export sequents_equality.
Require Export list. (* why *)

(* [20] ============ PERTYPE ELIMINATION 2 ============ *)

(**

  Let us now provide another pertype elimination rule.  This version
  is stated in terms of a pertype hypothesis and not an equality in a
  pertype:

<<
   H, x : pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : pertype(R), [z : R x x], J |- C ext e
     H, x : pertype(R) |- R x x in Type(i)
>>
 *)

Definition rule_pertype_elimination2 {o}
           (R C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_pertype R)) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_pertype R)))
              (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x)))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        (snoc H (mk_hyp x (mk_pertype R)))
        (mk_conclax (mk_member
                       (mk_apply2 R (mk_var x) (mk_var x))
                       (mk_uni i)))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination2_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination2
                 R C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_pertype_elimination2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent
                      (snoc (snoc H (mk_hyp x (mk_pertype R)))
                            (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x))) ++ J)
                      (mk_concl C e))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      (snoc H (mk_hyp x (mk_pertype R)))
                      (mk_conclax (mk_member (mk_apply2 R (mk_var x) (mk_var x)) (mk_uni i))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_pertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (vars_hyps H)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nizc vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_pertype in sim2; repnd.
  rw @equality_in_mkc_pertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 ((snoc (snoc s1a0 (x, t1)) (z, t')) ++ s1b)
                   ((snoc (snoc s2a0 (x, t2)) (z, t')) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim12; simpl in sim12; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim8; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t4)) (z, t0))
         s1b
         (snoc (snoc s2a1 (x, t5)) (z, t3))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s2a1 (x, t5)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply @cover_vars_var);
             repeat (apply @cover_vars_snoc_weak); sp;
             repeat (rw @dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t4)) (snoc s2a1 (x, t5)) t0 t3 w0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac.
  apply @tequality_in_uni_implies_tequality with (i := i); sp.
  apply member_if_inhabited in hyp1; auto.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (z, t'))
         s1b
         (snoc (snoc s2a0 (x, t2)) (z, t'))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R (mk_var x) (mk_var x)))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x, t1)))
         as cvap
         by (rw @cover_vars_apply2; sp;
             try (complete (apply cover_vars_snoc_weak; sp));
             apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t2)) t' t' wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t1) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t2) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

Lemma rule_pertype_elimination2_true_ex {o} :
  forall lib i z R C e x H J,
    rule_true_if lib (@rule_pertype_elimination2 o
                 R C e
                 x z
                 i
                 H J).
Proof.
  intros.
  generalize (rule_pertype_elimination2_true lib R C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.


Require Import Crypto.Util.Notations.
Require Import Crypto.Util.ZUtil.Hints.ZArith.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.

Open Scope Z_scope.

(** This file proves an implementation of the variant of Barrett reduction
    described in
    http://www.ridiculousfish.com/blog/posts/labor-of-division-episode-i.html *)

(** To simulate C behavior with fixed-width words, we introduce a word data type
    and associated operations that automatically take a modulus. We'll then
    prove the moduli are all no-ops (save one which is a subtraction).

    TODO(davidben): This does not perfectly match C's behavior. In C, operations
    on types smaller than [int], notably [uint16_t], promote both types to [int]
    first. Assuming a standard 32-bit [int], multiplying two [uint32_t]s is
    always defined, but multiplying two [uint16_t]s may not be! However, we
    never multiply [uint16_t]s, and we would otherwise need an unreasonably
    large expression to overflow [int] by way of promoted [uint16_t]
    additions. *)

(** First, the C data types will ultimately compile down to a bunch of extra
    modulus operations, which we must remove. Define a primitive [wrap]
    operation operations which we'll instruct [cbn] to leave alone and match on
    in the proof script. *)
Definition wrap (bits val : Z) : Z := val mod 2^bits.

(** A [word] is a C data type with a specified bit size. *)
Inductive word (bits : Z) :=
| Word (v : Z).

Definition to_Z {bits : Z} (a : word bits) : Z :=
  match a with Word v => v end.
Definition to_word {bits : Z} (val : Z) :=
  Word bits (wrap bits val).

Definition word_binop
           (aw bw : Z)
           (op : Z -> Z -> Z)
           (a : word aw) (b : word bw) : word (Z.max aw bw) :=
  to_word (op (to_Z a) (to_Z b)).

Definition word_add {aw bw : Z} := word_binop aw bw Z.add.
Definition word_sub {aw bw : Z} := word_binop aw bw Z.sub.
Definition word_mul {aw bw : Z} := word_binop aw bw Z.mul.
Definition word_div {aw bw : Z} := word_binop aw bw Z.div.

(** The type of a shift expression in C is the type of the first argument, not
    the larger of the two type. *)
Definition word_shiftl {aw bw : Z} (a : word aw) (b : word bw) : word aw :=
  to_word (Z.shiftl (to_Z a) (to_Z b)).
Definition word_shiftr {aw bw : Z} (a : word aw) (b : word bw) : word aw :=
  to_word (Z.shiftr (to_Z a) (to_Z b)).

Definition word_cast (from to : Z) (a : word from) : word to :=
  to_word (to_Z a).

Definition u16 := word 16.
Definition u32 := word 32.
Definition u64 := word 64.

Definition to_u16 {bits : Z} := word_cast bits 16.
Definition to_u32 {bits : Z} := word_cast bits 32.
Definition to_u64 {bits : Z} := word_cast bits 64.

Definition Z_to_u16 := @to_word 16.
Definition Z_to_u32 := @to_word 32.
Definition Z_to_u64 := @to_word 64.

(** [to_u32'] is identical to [to_u32], but it is expected to be a subtraction
    of 2^32, rather than a no-op. *)
Definition to_u32' {bits : Z} (a : word bits) : u32 :=
  Z_to_u32 ((to_Z a) - 2^32).

Declare Scope word_scope.
Delimit Scope word_scope with word.
Bind Scope word_scope with word.
Infix "+" := word_add : word_scope.
Infix "-" := word_sub : word_scope.
Infix "*" := word_mul : word_scope.
Infix "/" := word_div : word_scope.
Infix "<<" := word_shiftl : word_scope.
Infix ">>" := word_shiftr : word_scope.
Notation "1" := (Z_to_u32 1) : word_scope.
Notation "32" := (Z_to_u32 32) : word_scope.

Definition num_bits (a : Z) : Z :=
  match a with
  | Z0 => 0
  | Zpos p => Zpos (Pos.size p)
  | Zneg _ => 0 (* A [u32] is always non-negative, so this does not come up. *)
  end.

Definition BN_num_bits_word (a : u32) : u32 :=
  Z_to_u32 (num_bits (to_Z a)).

(** See [mod_u16] in
    https://boringssl-review.googlesource.com/#/c/boringssl/+/25887. *)
Definition mod_u16 (n : u32) (d : u16) : u16 :=
  let p := to_u32 (BN_num_bits_word (to_u32 (d - 1))) in
  let m := to_u32' ((((to_u64 1) << (32 + p)) + d - 1) / d) in
  let q := to_u32 (((to_u64 m) * n) >> 32) in
  let t := to_u32 (((n - q) >> 1) + q) in
  let t := to_u32 (t >> (p - 1)) in
  let n := to_u32 (n - d * t) in
  to_u16 n.

(** Proofs *)

Lemma num_bits_log2_up (a : Z) :
  num_bits (a - 1) = Z.log2_up a.
Proof.
  unfold Z.log2_up, Z.log2, num_bits.
  destruct (1 ?= a) eqn:H.
  { (* [1 = a] *)
    rewrite Z.compare_eq_iff in H.
    rewrite <- H.
    reflexivity. }
  { (* [1 < a] *)
    rewrite Z.compare_lt_iff in H.
    assert (0 < a - 1) by lia.
    rewrite Z.sub_1_r in *.
    destruct (Z.pred a); try lia.
    destruct p; cbn; lia. }
  { (* [1 > a] *)
    rewrite Z.compare_gt_iff in H.
    assert (a - 1 < 0) by lia.
    destruct (a - 1); lia. }
Qed.

Lemma wrap_bound (a b : Z) (H : 0 < a) :
  0 <= wrap a b < 2^a.
Proof.
  unfold wrap.
  Z.div_mod_to_quot_rem_in_goal.
  lia.
Qed.

Lemma remove_outer_wrap (a a' b : Z) (H : 0 < a' <= a) :
  wrap a (wrap a' b) = wrap a' b.
Proof.
  unfold wrap.
  apply Z.mod_small.
  Z.div_mod_to_quot_rem_in_goal.
  assert (2^a' <= 2^a) by (apply Z.pow_le_mono_r; lia).
  lia.
Qed.

Lemma divide_pow (a b c : Z) (Ha : 0 < a) (Hb : 0 <= b <= c) :
  (a^b | a^c).
Proof.
  exists (a^(c - b)).
  rewrite <- Z.pow_add_r; try f_equal; lia.
Qed.

Lemma remove_inner_wrap (a a' b : Z) (H : 0 < a <= a') :
  wrap a (wrap a' b) = wrap a b.
Proof.
  unfold wrap.
  rewrite (Znumtheory.Zmod_div_mod (2^a) (2^a') b);
    try apply Z.pow_pos_nonneg;
    try apply divide_pow;
    lia.
Qed.

Lemma double_wrap (a a' b : Z) (Ha : 0 < a) (Ha' : 0 < a') :
  wrap a (wrap a' b) = wrap (Z.min a a') b.
Proof.
  destruct (a <? a') eqn:H.
  { apply Z.ltb_lt in H.
    rewrite Z.min_l by lia.
    apply remove_inner_wrap.
    lia. }
  { apply Z.ltb_ge in H.
    rewrite Z.min_r by lia.
    apply remove_outer_wrap.
    lia. }
Qed.

Lemma a_minus_b_div_2_plus_b (a b : Z) (H : a >= b) :
  (a - b) / 2 + b = (a + b) / 2.
Proof. Z.div_mod_to_quot_rem_in_goal; lia. Qed.

Lemma p_bound (d bits : Z) (Hbits : 0 < bits) (H : 1 < d < 2^bits) :
  0 < Z.log2_up d <= bits.
Proof.
  split.
  - apply Z.log2_up_pos; lia.
  - apply Z.log2_up_le_pow2; lia.
Qed.

Lemma pow2_log2_up_bounds (d : Z) (H : 1 < d) :
  d <= 2^(Z.log2_up d) < d + d.
Proof.
  pose proof (Z.log2_up_spec d H).
  assert (2 ^ Z.log2_up d = 2 * (2 ^ Z.pred (Z.log2_up d))).
  { rewrite <- Z.pow_succ_r by (apply Z.lt_le_pred; apply Z.log2_up_pos; lia).
    f_equal.
    lia. }
  lia.
Qed.

Lemma m_bound (d bits : Z) (Hbits : 0 < bits) (H : 1 < d < 2^bits) :
  2^bits <= (2^(bits + Z.log2_up d) + d - 1) / d < 2 * 2^bits.
Proof.
  rewrite !Z.pow_add_r by (auto with zarith).
  pose proof (pow2_log2_up_bounds d (proj1 H)).
  split.
  - apply Z.div_le_lower_bound; nia.
  - apply Z.div_lt_upper_bound; nia.
Qed.

Lemma division_shrinks (a b c : Z) (Hb : 0 < b) (H : 0 <= a < c) :
  a / b < c.
Proof. Z.div_mod_to_quot_rem_in_goal; nia. Qed.

Lemma mul_div_ceil_ge (a b : Z) (Hb : 0 < b) :
  a <= b * ((a + b - 1) / b).
Proof. Z.div_mod_to_quot_rem_in_goal; nia. Qed.

(** This is the main theorem this algorithm relies on. *)
Lemma division_algorithm (bits n d k : Z)
      (Hbits : 0 < bits)
      (Hn : 0 <= n < 2^bits)
      (Hd : 1 < d)
      (Hk : bits + Z.log2_up d <= k) :
  n * ((2^k + d - 1) / d) / 2^k = n / d.
Proof.
  (* Help [lia] and [nia] out. *)
  pose proof (Z.log2_up_nonneg d).
  pose proof (pow2_log2_up_bounds d Hd).
  assert (0 < 2^k) by (apply Z.pow_pos_nonneg; lia).

  assert (n/d <= n * ((2^k + d - 1) / d) / 2^k).
  { (* This direction is true independent of [Hk]. *)
    assert (2^k <= d * ((2 ^ k + d - 1) / d)) by (apply mul_div_ceil_ge; lia).
    apply Z.div_le_lower_bound; try lia.
    rewrite Z.div_mul_le by (try auto with zarith; lia).
    apply Z.div_le_upper_bound; try lia.
    nia. }
  assert (n * ((2^k + d - 1) / d) / 2^k <= n / d).
  { assert (div_mul_le_inner : n * ((2^k + d - 1) / d) / 2^k <=
                               (n * (2^k + d - 1) / d) / 2^k).
    { apply Z.div_le_mono; try apply Z.div_mul_le; lia. }
    rewrite div_mul_le_inner.
    replace (n * (2^k + d - 1)) with (n * 2^k + n * (d - 1)) by nia.
    (* Swap [d] and [2^k] in the denominator. *)
    rewrite Z.div_div by lia.
    rewrite (Z.mul_comm d (2^k)).
    rewrite <- Z.div_div by lia.
    (* We now can extract the [n * 2^k] term from the inner division. *)
    rewrite Z.div_add_l by lia.
    (* We show the error term is zero, which allows the inequality to hold. *)
    assert (zero_error : n * (d - 1) / 2 ^ k = 0).
    { apply Z.div_small.
      assert (2^bits * 2^(Z.log2_up d) <= 2^k) by
          (rewrite <- Z.pow_add_r; try apply Z.pow_le_mono_r; lia).
      nia. }
    rewrite zero_error.
    auto with zarith. }
  lia.
Qed.

(** Peel off one innermost [wrap], and replace it with the expected
    bounds. Before doing so, introduce a lemma into the context that the value
    is bounded. This is allows later goals to make use of earlier bounds.

    TODO(davidben): Most of the slowness comes from these intermediate
    hypotheses. The proofs need them, but only those one or two layers down. Can
    we be smarter about retaining them? *)
Local Ltac replace_innermost_wrap expr :=
  match expr with
  | context[wrap ?x ?y] =>
    first [ replace_innermost_wrap y |
            assert (0 <= (wrap x y) < 2^x) by (apply wrap_bound; lia);
            replace (wrap x y) with y in * ]
  end.

(** Finally, the correctness proof. *)
Theorem mod_u16_spec (n d : Z) (Hn : 0 <= n < 2^32) (Hd : 1 < d < 2^16) :
  to_Z (mod_u16 (Z_to_u32 n) (Z_to_u16 d)) = n mod d.
Proof.
  unfold mod_u16.
  (* Evaluate away everything except for exponentations, which are
     still useful, and our [wrap] metadata. *)
  cbn -[Z.pow num_bits wrap].

  (* The solver needs some help getting these in the context. *)
  assert (Hlog : 0 < Z.log2_up d <= 16) by (apply p_bound; lia).
  assert (d <= 2^(Z.log2_up d) < d + d) by (apply pow2_log2_up_bounds; lia).
  assert (2^(Z.log2_up d) < 2 ^ 17) by lia.
  assert (2^32 <= (2^32 * 2^(Z.log2_up d) + d - 1) / d < 2 * 2^32) by
      (rewrite <- Z.pow_add_r by lia; apply m_bound; lia).

  (* Convert shifts to multiplication and divison. *)
  rewrite !Z.shiftl_mul_pow2 by (apply wrap_bound; lia).
  rewrite !Z.shiftr_div_pow2 by (apply wrap_bound; lia).
  rewrite !Z.mul_1_l.
  rewrite !Z.pow_1_r.

  (* Replace all the [to_word] calls with their expected bounds. *)
  repeat match goal with
         | [ |- ?x = n mod d ] =>
           match goal with
           (* Evaluate away the [Z.min]s. *)
           | _ => progress cbn -[Z.pow Z.add Z.mul wrap]
           (* Remove obviously pointless casts. The solver could handle them,
              but this cuts down on the number of generated hypotheses. *)
           | [ |- context[wrap ?x (wrap ?x' ?y)] ] =>
             replace (wrap x (wrap x' y)) with (wrap (Z.min x x') y) by
                 (symmetry; apply double_wrap; lia)
           | [ |- context[wrap ?x n] ] =>
             replace (wrap x n) with n by (unfold wrap; rewrite Z.mod_small; lia)
           | [ |- context[wrap ?x d] ] =>
             replace (wrap x d) with d by (unfold wrap; rewrite Z.mod_small; lia)
           | [ |- context[wrap ?x (Zpos ?p)] ] =>
             replace (wrap x (Zpos p)) with (Zpos p) by reflexivity
           (* Perform rewrites as soon as possible, so the generated hypotheses
              match too. *)
           | _ => rewrite a_minus_b_div_2_plus_b
           | _ => rewrite num_bits_log2_up
           | _ => rewrite Z.pow_add_r by lia
           | _ => replace_innermost_wrap x
           end
         end;

    repeat unfold wrap in *;

    repeat match goal with
           (* Normalize a few things. *)
           | _ => apply Z.le_ge
           | _ => apply Z.lt_gt
           | [ |- _ = _ mod _ ] => symmetry
           (* Apply these transforms everywhere. *)
           | _ => apply Z.mod_small
           | _ => split
           (* Everything is positive, so these tend to be easy. *)
           | [ |- 0 <= _ * _ ] => nia
           (* Don't touch the goals that involve the final division
              expression. We'll dispatch them separately. *)
           | [ |- context[d * (_ / 2^_)] ] => fail 1
           (* The solver needs some help for this one, otherwise the [Z.div_*]
              theorems below break apart the numerator term. *)
           | [ _ : 0 <= ?x < ?y |- ?x / _ < ?y ] => apply division_shrinks
           (* Simplify the various inequalities. *)
           | _ => apply Z.div_le_upper_bound
           | _ => apply Z.div_lt_upper_bound
           | _ => apply Z.div_le_lower_bound
           | _ => apply Z.pow_nonneg
           | _ => apply Z.pow_pos_nonneg
           (* Only apply in one direction. *)
           | [ |- 0 <= _ - _ ] => apply Z.le_0_sub
           | _ => apply Z.mul_le_mono_nonneg_r
           (* [nia] is rather slow, and only one case needs it. *)
           | [ _ : 0 <= ?x < _, _ : 0 <= ?y < _ |- ?x * ?y < ?z ] => nia
           | _ => lia
           end;

    (* Clear the now unnecessary intermediate hypotheses. *)
    clear - Hn Hd Hlog;

    (* Invert the various transforms to get to the main theorem. *)
    repeat match goal with
           | _ => rewrite Z.div_div by (try apply Z.pow_pos_nonneg; lia)
           | _ => rewrite <- Z.pow_succ_r by lia
           | _ => rewrite <- Z.add_1_r
           | _ => rewrite Z.sub_add
           | _ => rewrite Zplus_minus
           | _ => rewrite <- Z.pow_add_r by lia
           | _ => rewrite <- Z.mul_add_distr_l
           | _ => rewrite <- Z.div_add_l by lia
           | [ |- context[?x * ?y + ?z * ?x] ] => rewrite (Z.mul_comm z x)
           end;

    (* And finish with the main theorem. *)
    rewrite (division_algorithm 32) by lia;
    Z.div_mod_to_quot_rem_in_goal;
    nia.
Qed.


Reserved Notation "A 'wimp' B" (at level 99).

Inductive WImp (A B : Prop) : Prop :=
  | wl : ~A -> A wimp B
  | wr : ~~B -> A wimp B
where "A 'wimp' B" := (WImp A B) : type_scope.

Print WImp_ind.

Theorem problem_1 : forall A B : Prop, A wimp B -> A -> ~~B.
Proof.
  intro.
  intro.
  intro.
  induction H. contradiction.
  auto.
Qed.

Theorem problem_2 : forall A B C: Prop,
A -> A wimp (B wimp C) -> (~~(B wimp C)) wimp C -> ~~C.
Proof.
  intro.
  intro.
  intro.
  intros.
  destruct H0.
  contradiction.
  destruct H1.
  contradiction.
  auto.
Qed.

Axiom wmp : forall A B : Prop, A wimp B -> A -> ~~B.

Theorem wimp_ind : forall A B P : Prop, (A \/ ~A) -> (~ A -> P) -> (~ ~ B -> P) -> (A wimp B) -> P.
Proof.
  intro.
  intro.
  intro.
  intro.
  intro.
  intro.
  intro.
  Print wmp.
  destruct H2.
  auto.
  auto.
Qed.


(*
vim: set fenc=utf-8 ff=unix sts=2 sw=2 et ft=coq :
*)
(*
Copyright (C) 2016-2019 Philip H. Smith

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 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.
*)

Require Import Way.StaleAtoms.
Require Import Way.Tactics.

Require Import Way.Beta.
Require Import Way.Context.
Require Import Way.Conversion.
Require Import Way.Open.
Require Import Way.Preterm.
Require Import Way.Relation.
Require Import Way.Subtyping.

(* Typings are proofs that under a given context, a given term has the given type.

Since types are terms, this emerges as a ternary relation between a context and two terms.

An interesting twist appears in the definition of contexts.  A context is a list that that
identifies the types of free variables in a term.  Since types are terms, the types
appearing in the context must themselves be well-typed, and can have free variables.  This
circular dependency is accounted for with a pair of mutually recursive definitions (or
"judgements").

The first kind of judgement is the typing of terms.
*)
Inductive typing : context -> preterm -> preterm -> Set :=

(* The type of a sort is the next sort in the hierarchy. *)
| type :
  forall (c : context), well_formed c -> forall (n : nat),
  typing c (Preterm.type n) (Preterm.type (S n))

(* The type of a free variable is that which it is bound to in a well-formed context. *)
| free_variable :
  forall (c : context), well_formed c -> forall (a : atom) (T : preterm), has (a, T) c ->
  typing c (Preterm.free_variable a) T

(* The type of a product is a sort, shared with its domain and codomain after opening.

Since the codomain can depend on the domain, we only require it to type after opening it
with the domain (using a sufficiently fresh free variable.)
*)
| product :
  forall (l : list atom) (c : context) (n : nat) (T U : preterm),
  typing c T (Preterm.type n) ->
  (fresh (a : l), typing ((a, T) :: c) (open_free a U) (Preterm.type n)) ->
  typing c (Preterm.product T U) (Preterm.type n)

(* The type of an abstraction is a well-typed product.

The abstraction body must have the product codomain as its type, after each has been
opened with the product's domain type (using a sufficiently fresh free variable.)
*)
| abstraction :
  forall (l : list atom) (n : nat) (c : context) (T U : preterm),
  typing c (Preterm.product T U) (Preterm.type n) ->
  forall (t : preterm),
  (fresh (a : l), typing ((a, T) :: c) (open_free a t) (open_free a U)) ->
  typing c (Preterm.abstraction T t) (Preterm.product T U)

(* The type of an application is its abstraction's codomain type opened with the argument.

The abstraction must have a product as its type, and the argument must be well-typed.
The equation involving open is required to allow proof search to match the head.
*)
| application :
  forall (T U : preterm) (c : context) (u : preterm),
  typing c u (Preterm.product T U) ->
  forall (t : preterm), typing c t T ->
  forall (v : preterm), v = open 0 t U ->
  typing c (Preterm.application u t) v

| subtyping :
  forall (T : preterm) (n : nat) (U : preterm), Subtyping.subtyping T U ->
  forall (c : context) (t : preterm), typing c t T ->
  typing c U (Preterm.type n) ->
  typing c t U

(* The second kind of judgement is the well-formation of contexts. *)
with well_formed : context -> Set :=

(* Empty contexts are well-formed. *)
| empty : well_formed []

(* A context that types a term as a type can be extended by it with a fresh variable. *)
| extend :
  forall (n : nat) (c : context) (T : preterm), typing c T (Preterm.type n) ->
  fresh (a : (domain c)), well_formed ((a, T) :: c).

Hint Resolve type free_variable empty : way.

Hint Extern 7 (typing _ (Preterm.product _ _) (Preterm.type _)) =>
  let stale := stale_atoms in apply (Typing.product stale) : way.

(* TODO(phs): hint extern for abstraction application subtyping extend *)

Module Examples.

Import Aliases.

(* TODO(phs): Use the type checker once it exists *)
Example polymorphic_identity :
  typing []
    Preterm.Examples.polymorphic_identity
    (prod (type 0) (prod (bvar 0) (bvar 1))).
Proof.
  unfold Preterm.Examples.polymorphic_identity;
  apply (Typing.abstraction [] 1);
  [ apply (Typing.product []);
    [ infer
    | intros a Ha; unfold open_free;
      apply (Typing.subtyping (type 1) 2);
      [ infer
      | apply (Typing.product [a]);
        [ apply (Typing.subtyping (type 0) 2);
          infer from (Typing.extend 1)
        | intros b Hb; unfold open_free;
          apply (Typing.subtyping (type 0) 2);
          [ infer
          | apply Typing.free_variable;
            [ apply (Typing.extend 0);
              [ apply Typing.free_variable;
                infer from (Typing.extend 1)
              | infer
              ]
            | infer
            ]
          | apply Typing.type;
            apply (Typing.extend 0);
            [ apply Typing.free_variable;
              infer from (Typing.extend 1)
            | infer
            ]
          ]
        ]
      | infer from (Typing.extend 1)
      ]
    ]
  | intros a Ha; unfold open_free;
    apply (Typing.abstraction [a] 0);
    [ apply (Typing.product [a]);
      [ infer from (Typing.extend 1)
      | intros b Hb; unfold open_free;
        apply Typing.free_variable;
        [ apply (Typing.extend 0);
          [ apply Typing.free_variable;
            infer from (Typing.extend 1)
          | infer
          ]
        | infer
        ]
      ]
    | intros b Hb; unfold open_free;
      apply Typing.free_variable;
      [ apply (Typing.extend 0);
        [ apply Typing.free_variable;
          infer from (Typing.extend 1)
        | infer
        ]
      | infer
      ]
    ]
  ].
Defined.

(* TODO(phs): Demonstrate polymorphic identity application *)
(* You chose type 0 in the definition of the identity.  This is tricky without base types
or the polymorphism allowing us to elide universe indices.
Example apply_polymorphic_identity :
  typing []
    (app Preterm.Examples.polymorphic_identity (abs (type 0) (bvar 0)))
    (prod (type 0) (type 0))
*)

Example type_of_sort_is_next_sort : typing [] (type 3) (type 4).
Proof.
  infer.
Defined.

Example type_of_free_variable_is_in_context :
  forall (a : atom), typing [(a, (type 7))] (fvar a) (type 7).
Proof.
  infer from (Typing.extend 8).
Defined.

Example type_of_product_is_sort : typing [] (prod (type 1) (type 1)) (type 2).
Proof.
  infer from (Typing.extend 2).
Defined.

Example type_of_abstraction_is_product :
  typing [] (abs (type 3) (bvar 0)) (prod (type 3) (type 3)).
Proof.
  infer from
    (Typing.abstraction [] 4)
    (Typing.extend 4).
Defined.

Example type_of_application_is_product_codomain :
  typing [] (app (abs (type 1) (bvar 0)) (type 0)) (type 1).
Proof.
  infer from
    (Typing.application (type 1) (type 1))
    (Typing.abstraction [] 2)
    (Typing.extend 2).
Defined.

Example terms_of_subtype_are_terms_of_supertype :
  typing []
    (type 0)
    (app (abs (type 2) (bvar 0)) (type 1)).
Proof.
  apply (Typing.subtyping (type 1) 2);
  [ apply Subtyping.conversion;
    apply Equivalence.symmetry
  | | ];
  infer from
    (Typing.application (type 2) (type 2))
    (Typing.abstraction [] 3)
    (Typing.extend 3).
Defined.

Example empty_context_is_well_formed : well_formed [].
Proof.
  infer.
Defined.

Example context_extended_with_fresh_name_is_well_formed :
  forall (a b : atom), a <> b -> well_formed [(a, (type 0)); (b, (type 0))].
Proof.
  infer from (Typing.extend 1).
Defined.

End Examples.


(* (c) Copyright Christian Doczkal and Joachim Bard                       *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations Classical_Pred_Type.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From CompDecModal.libs Require Import edone bcase fset base.
From CompDecModal.PDL Require Import PDL_def.

Set Default Proof Using "Type".

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Arguments subsep {T X P}.

Implicit Types (S cls X Y : {fset clause}) (C D : clause).

(** * Demos *)

Definition rtrans a C D := R a C `<=` D.

Fixpoint reach_demo cls p : rel clause :=
  match p with
  | pV a => rtrans a
  | pSeq p0 p1 => (fun C D => [some C' in cls, reach_demo cls p0 C C' && reach_demo cls p1 C' D])
  | pCh p0 p1 => (fun C D => reach_demo cls p0 C D || reach_demo cls p1 C D)
  | pStar p => (fun C D => connect_in cls (reach_demo cls p) C D)
  | pTest s => (fun C D => (C == D) && (s^+ \in C))
  end.

Definition D0 cls := forall C, C \in cls -> hintikka C.
Definition D1 cls := forall C, C \in cls -> forall p s, [p]s^- \in C -> [some D in cls, reach_demo cls p C D &&  (s^- \in D)].

(** A demo consists of a finite set of Hintikka clauses that satisfy the demo condition. *)

Record demo := Demo {
  cls :> {fset clause} ;
  demoD0 : D0 cls ;
  demoD1 : D1 cls }.

Arguments demoD1 [d C] _ [p s] _.

Canonical demo_predType := PredType (fun (S : demo) (C : clause) => nosimpl C \in cls S).

Lemma LCF (S : demo) C : C \in S -> ((fF^+ \in C) = false) * (forall p, (fV p^+ \in C) && (fV p^- \in C) = false).
Proof.
  move/demoD0. case/andP => /andP [/negbTE -> /allP H] _. split => // x.
  case inC: (fV x^+ \in C) => //=. apply: negbTE. apply: H _ inC.
Qed.

(** ** Demo Theorem *)

Section ModelExistience.
  Variables (S : demo).

  Definition Mtype := seq_sub S.
  Definition Mtrans a : rel Mtype := @restrict _ S (rtrans a).
  Definition Mlabel (x: var) (C : Mtype) := fV x^+ \in val C.

  Definition model_of := FModel Mtrans Mlabel.

  Implicit Types (c d e : model_of).

  Unset Printing Records.

  Lemma model_of_dc c s : s \in val c -> hintikka' s (val c).
  Proof. case/demoD0/andP : (valP c) => _ /allP. apply. Qed.

  (* Lemma 4.3 *)
  Lemma model_reach_pos p s c d :
    (forall t e, sizef t < sizep p -> t^- \in val e -> ~ eval t e) ->
    [p]s^+ \in val c -> reach p c d -> s^+ \in val d.
  Proof.
    elim: p s c d => [a|p0 IH0 p1 IH1|p0 IH0 p1 IH1|p IHp|t] s c d /= Ht.
    - rewrite /= /Mtrans /restrict /= /rtrans => A /subP B. apply: B. by rewrite RE.
    - move/model_of_dc => /= /andP[A B] [].
      + apply: IH0 => // t e H. apply: Ht. by ssrlia.
      + apply: IH1 => // t e H. apply: Ht. by ssrlia.
    - move/model_of_dc => /= A [e E1 E2].
      (apply: IH1 E2; last apply: IH0 E1 => //) => t e' ?; apply Ht; by ssrlia.
    - move => /= A B. elim: B A => {c d} [c|c e d A _ IH B]; first by case/model_of_dc/andP.
      apply: IH. case/model_of_dc/andP : B => _ ?. apply: IHp A => //.
      move => t {e} - e A. apply: Ht. by ssrlia.
    - case/model_of_dc/orP; last by move => ? [->].
      move => A [->] B. exfalso. apply: Ht A B. by ssrlia.
  Qed.

  (* Lemma 4.4 *)
  Lemma demo2reach p c d :
    (forall t e, sizef t < sizep p -> t^+ \in val e -> eval t e) ->
    reach_demo S p (val c) (val d) -> reach p c d.
  Proof.
    elim : p c d => [a|p0 IH0 p1 IH1|p0 IH0 p1 IH1|p IHp|s] c d //= Ht.
    - move/orP => [H|H];[left; apply: IH0|right;apply: IH1] => // t e ?; apply Ht; by ssrlia.
    - move/hasP => [C' inS /andP [L R]]. exists (SeqSub C' inS).
      + apply IH0 => // t e ?. by apply: Ht; ssrlia.
      + apply IH1 => // t e ?. by apply: Ht; ssrlia.
    - case/connect_inP => cs. elim: cs c d => /= [|e cd IH] c d.
      + case => _ _ /eqP. rewrite -[_ d == _ c]/(d == c) => /eqP->. by constructor.
      + case => /and3P[A B C] /andP[D E] F. apply: (StarL (z := SeqSub e B)).
        * apply: IHp => // t e' E'. apply: Ht; ssrlia.
        * apply IH. by rewrite /= B C E F.
    - rewrite -[_ c == _ d]/(c == d) => /andP[/eqP-> A]. split => //. by apply: Ht A; ssrlia.
  Qed.

  Ltac discharge_with tac := case/(_ _)/Wrap; first by tac.

  (* Theorem 4.6 (Demo Theorem) *)
  Theorem demo_eval s b c :  (s, b) \in val c -> eval (interp (s, b)) c.
  Proof with discharge_with ssrlia.
    move: s b c. apply: (nat_size_ind (f := sizef)) => s IH b.
    case: s b IH => [|x|s t|p s] [|] IH c;
      try by rewrite /= ?(LCF (ssvalP c)); auto.
    - move => /= nx. rewrite /Mlabel. case: (LCF (ssvalP c)) => /= _ H px. move: (H x).
        by rewrite px nx.
    - case/hint_imp_pos ; first by case: c => C; exact: demoD0.
      move/IH => //=... tauto. move/IH => /=... by auto.
    - case/hint_imp_neg; first by case: c => C; exact: demoD0.
      move/IH => /=... move => Hs /IH => /=... by auto.
    - move => H d cRd. apply: (IH s _ true) => /=; first by ssrlia.
      apply: model_reach_pos cRd => // t e A. apply: IH => //=. by ssrlia.
    - move => inC /=. apply: ex_not_not_all.
      have /hasP CD: [some D in S , reach_demo S p (val c) D && (s^- \in D)]
        by apply: (demoD1 (ssvalP c)).
      case: CD => D DinS /andP [cRD inD]. exists (SeqSub D DinS).
      case/(_ _)/Wrap.
      + apply: demo2reach => // t e A. apply IH => //; by ssrlia.
      + rewrite -/(not _). apply: (IH s _ false) => //=. by ssrlia.
  Qed.

End ModelExistience.

(** ** Pruning *)

Section Pruning.

  Variable (F: {fset form}).
  Hypothesis sfc_F : sf_closed F.
  Definition PU := powerset (flipcl F).
  Definition S0 := [fset C in PU | hintikka C && maximal F C].

  Definition pcond C S := ~~ [all u in C, if u is [p]s^- then
    [some D in S, reach_demo S p C D && (s^- \in D)] else true].

  (* Lemma 5.2 *)
  Lemma prune_D0 : D0 (prune pcond S0).
  Proof.
    move => C. move/(subP (prune_sub _ _)). rewrite inE. by case/and3P.
  Qed.

  Lemma prune_D1 : D1 (prune pcond S0).
  Proof.
    move => C /pruneE. rewrite negbK. move/allP => H p s Hs. exact: (H ([p]s^-) Hs).
  Qed.

  Definition DD := Demo prune_D0 prune_D1.

  (** ** Pruning Refutations *)

  Definition supp S (C: clause) := [some D in S, C `<=` D].

  Local Notation "S |> C" := (supp S C) (at level 30, format "S  |>  C").

  Definition coref (ref : clause -> Prop) S :=
    forall C, C \in S0 `\` S -> ref C.

  Inductive pref : clause -> Prop :=
  | P1 S C : coref pref S -> C \in PU -> ~~ S |> C -> pref C
  | P2 S C p s : S `<=` S0 -> coref pref S -> C \in S
                 -> [p]s^- \in C -> ~~[some D in S, reach_demo S p C D && (s^- \in D)] -> pref C.

  Lemma corefD1 S C : pref C -> coref pref S -> coref pref (S `\` [fset C]).
  Proof.
    move => rC coS D. rewrite !in_fsetD negb_and andb_orr -in_fsetD negbK in_fset1.
    case/orP; first exact: coS. by case/andP => [_ /eqP ->].
  Qed.

  (* Lemma 5.3 - corefutability of the pruning demo *)
  Lemma coref_DD : coref pref DD.
  Proof.
    apply: prune_myind => [C|C S]; first by rewrite inE andbN.
    case/allPn. case. case => // p s. case => // inC H inS corS sub.
    apply: corefD1 => //. exact: (P2 sub).
  Qed.

  Lemma DD_refute C : C \in PU -> ~~ DD |> C -> pref C.
  Proof. move => inU. apply: P1 _ inU => //. exact: coref_DD. Qed.

End Pruning.

(** ** Pruning Completeness *)

Definition satT (M: cmodel) C := { w: M | forall s, s \in C -> eval (interp s) w}.

Notation "S |> C" := (supp S C) (at level 30, format "S  |>  C").

(* Theorem 5.4 (Pruning Completeness) *)
Theorem pruning_completeness F (sfc_F : sf_closed F) (C: clause) :
  C \in PU F -> pref F C + { M: fmodel & satT M C & #|{: M}| <= 2 ^ (2 * size F)}.
Proof.
  move => inPU. case: (boolP ((DD F) |> C)) => H; [right|left; exact: DD_refute].
  exists (model_of (DD F)).
  - case/hasS : H => D D1 /subP D2. exists (SeqSub _ D1) => s inC.
    move: inPU. move/powersetP => sub. case: s inC => s b inC.
    apply: demo_eval => //=; last exact: D2.
  - rewrite card_seq_sub ?funiq //.
    apply: leq_trans; last by apply: (leq_pexp2l _ (size_flipcl F)).
    rewrite -powerset_size subset_size /DD /S0 //=.
    apply: sub_trans; [exact: prune_sub | exact: subsep].
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)         *)
(************************************************************************)

(** Tactics related to (dependent) equality and proof irrelevance. *)

Require Export JMeq.

Require Import Coq.Program.Tactics.

Ltac is_ground_goal :=
  match goal with
    |- ?T => is_ground T
  end.

(** Try to find a contradiction. *)

Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso.

(** We will use the [block] definition to separate the goal from the
   equalities generated by the tactic. *)

Definition block {A : Type} (a : A) := a.

Ltac block_goal := match goal with [ |- ?T ] => change (block T) end.
Ltac unblock_goal := unfold block in *.

(** Notation for heterogenous equality. *)

Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity).

(** Do something on an heterogeneous equality appearing in the context. *)

Ltac on_JMeq tac :=
  match goal with
    | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H
  end.

(** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *)

Ltac simpl_one_JMeq :=
  on_JMeq ltac:(fun H => apply JMeq_eq in H).

(** Repeat it for every possible hypothesis. *)

Ltac simpl_JMeq := repeat simpl_one_JMeq.

(** Just simplify an h.eq. without clearing it. *)

Ltac simpl_one_dep_JMeq :=
  on_JMeq
  ltac:(fun H => let H' := fresh "H" in
    assert (H' := JMeq_eq H)).

Require Import Eqdep.

(** Simplify dependent equality using sigmas to equality of the second projections if possible.
   Uses UIP. *)

Ltac simpl_existT :=
  match goal with
    [ H : existT _ ?x _ = existT _ ?x _ |- _ ] =>
    let Hi := fresh H in assert(Hi:=inj_pairT2 _ _ _ _ _ H) ; clear H
  end.

Ltac simpl_existTs := repeat simpl_existT.

(** Tries to eliminate a call to [eq_rect] (the substitution principle) by any means available. *)

Ltac elim_eq_rect :=
  match goal with
    | [ |- ?t ] =>
      match t with
        | context [ @eq_rect _ _ _ _ _ ?p ] =>
          let P := fresh "P" in
            set (P := p); simpl in P ;
	      ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
        | context [ @eq_rect _ _ _ _ _ ?p _ ] =>
          let P := fresh "P" in
            set (P := p); simpl in P ;
	      ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
      end
  end.

(** Rewrite using uniqueness of indentity proofs [H = eq_refl]. *)

Ltac simpl_uip :=
  match goal with
    [ H : ?X = ?X |- _ ] => rewrite (UIP_refl _ _ H) in *; clear H
  end.

(** Simplify equalities appearing in the context and goal. *)

Ltac simpl_eq := simpl ; unfold eq_rec_r, eq_rec ; repeat (elim_eq_rect ; simpl) ; repeat (simpl_uip ; simpl).

(** Try to abstract a proof of equality, if no proof of the same equality is present in the context. *)

Ltac abstract_eq_hyp H' p :=
  let ty := type of p in
  let tyred := eval simpl in ty in
    match tyred with
      ?X = ?Y =>
      match goal with
        | [ H : X = Y |- _ ] => fail 1
        | _ => set (H':=p) ; try (change p with H') ; clearbody H' ; simpl in H'
      end
    end.

(** Apply the tactic tac to proofs of equality appearing as coercion arguments.
   Just redefine this tactic (using [Ltac on_coerce_proof tac ::=]) to handle custom coercion operators.
   *)

Ltac on_coerce_proof tac T :=
  match T with
    | context [ eq_rect _ _ _ _ ?p ] => tac p
  end.

Ltac on_coerce_proof_gl tac :=
  match goal with
    [ |- ?T ] => on_coerce_proof tac T
  end.

(** Abstract proofs of equalities of coercions. *)

Ltac abstract_eq_proof := on_coerce_proof_gl ltac:(fun p => let H := fresh "eqH" in abstract_eq_hyp H p).

Ltac abstract_eq_proofs := repeat abstract_eq_proof.

(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality
   in the goal become convertible. *)

Ltac pi_eq_proof_hyp p :=
  let ty := type of p in
  let tyred := eval simpl in ty in
  match tyred with
    ?X = ?Y =>
    match goal with
      | [ H : X = Y |- _ ] =>
        match p with
          | H => fail 2
          | _ => rewrite (UIP _ X Y p H)
        end
      | _ => fail " No hypothesis with same type "
    end
  end.

(** Factorize proofs of equality appearing as coercion arguments. *)

Ltac pi_eq_proof := on_coerce_proof_gl pi_eq_proof_hyp.

Ltac pi_eq_proofs := repeat pi_eq_proof.

(** The two preceding tactics in sequence. *)

Ltac clear_eq_proofs :=
  abstract_eq_proofs ; pi_eq_proofs.

Hint Rewrite <- eq_rect_eq : refl_id.

(** The [refl_id] database should be populated with lemmas of the form
   [coerce_* t eq_refl = t]. *)

Lemma JMeq_eq_refl {A} (x : A) : JMeq_eq (@JMeq_refl _ x) = eq_refl.
Proof. apply UIP. Qed.

Lemma UIP_refl_refl A (x : A) :
  Eqdep.EqdepTheory.UIP_refl A x eq_refl = eq_refl.
Proof. apply UIP_refl. Qed.

Lemma inj_pairT2_refl A (x : A) (P : A -> Type) (p : P x) :
  Eqdep.EqdepTheory.inj_pairT2 A P x p p eq_refl = eq_refl.
Proof. apply UIP_refl. Qed.

Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id.

Ltac rewrite_refl_id := autorewrite with refl_id.

(** Clear the context and goal of equality proofs. *)

Ltac clear_eq_ctx :=
  rewrite_refl_id ; clear_eq_proofs.

(** Reapeated elimination of [eq_rect] applications.
   Abstracting equalities makes it run much faster than an naive implementation. *)

Ltac simpl_eqs :=
  repeat (elim_eq_rect ; simpl ; clear_eq_ctx).

(** Clear unused reflexivity proofs. *)

Ltac clear_refl_eq :=
  match goal with [ H : ?X = ?X |- _ ] => clear H end.
Ltac clear_refl_eqs := repeat clear_refl_eq.

(** Clear unused equality proofs. *)

Ltac clear_eq :=
  match goal with [ H : _ = _ |- _ ] => clear H end.
Ltac clear_eqs := repeat clear_eq.

(** Combine all the tactics to simplify goals containing coercions. *)

Ltac simplify_eqs :=
  simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ;
    try subst ; simpl ; repeat simpl_uip ; rewrite_refl_id.

(** A tactic that tries to remove trivial equality guards in induction hypotheses coming
   from [dependent induction]/[generalize_eqs] invocations. *)

Ltac simplify_IH_hyps := repeat
  match goal with
    | [ hyp : context [ block _ ] |- _ ] =>
      specialize_eqs hyp
  end.

(** We split substitution tactics in the two directions depending on which
   names we want to keep corresponding to the generalization performed by the
   [generalize_eqs] tactic. *)

Ltac subst_left_no_fail :=
  repeat (match goal with
            [ H : ?X = ?Y |- _ ] => subst X
          end).

Ltac subst_right_no_fail :=
  repeat (match goal with
            [ H : ?X = ?Y |- _ ] => subst Y
          end).

Ltac inject_left H :=
  progress (inversion H ; subst_left_no_fail ; clear_dups) ; clear H.

Ltac inject_right H :=
  progress (inversion H ; subst_right_no_fail ; clear_dups) ; clear H.

Ltac autoinjections_left := repeat autoinjection ltac:(inject_left).
Ltac autoinjections_right := repeat autoinjection ltac:(inject_right).

Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ;
  simpl_JMeq ; simpl_existTs ; simplify_IH_hyps.

Ltac simpl_depind_l := subst_left_no_fail ; autoinjections_left ; try discriminates ;
  simpl_JMeq ; simpl_existTs ; simplify_IH_hyps.

Ltac simpl_depind_r := subst_right_no_fail ; autoinjections_right ; try discriminates ;
  simpl_JMeq ; simpl_existTs ; simplify_IH_hyps.

Ltac blocked t := block_goal ; t ; unblock_goal.

(** The [DependentEliminationPackage] provides the default dependent elimination principle to
   be used by the [equations] resolver. It is especially useful to register the dependent elimination
   principles for things in [Prop] which are not automatically generated. *)

Class DependentEliminationPackage (A : Type) :=
  { elim_type : Type ; elim : elim_type }.

(** A higher-order tactic to apply a registered eliminator. *)

Ltac elim_tac tac p :=
  let ty := type of p in
  let eliminator := eval simpl in (@elim (_ : DependentEliminationPackage ty)) in
    tac p eliminator.

(** Specialization to do case analysis or induction.
   Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register
   generated induction principles. *)

Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p.
Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p.

(** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *)

Lemma solution_left A (B : A -> Type) (t : A) :
  B t -> (forall x, x = t -> B x).
Proof. intros; subst; assumption. Defined.

Lemma solution_right A (B : A -> Type) (t : A) :
  B t -> (forall x, t = x -> B x).
Proof. intros; subst; assumption. Defined.

Lemma deletion A B (t : A) : B -> (t = t -> B).
Proof. intros; assumption. Defined.

Lemma simplification_heq A B (x y : A) :
  (x = y -> B) -> (JMeq x y -> B).
Proof. intros H J; apply H; apply (JMeq_eq J). Defined.

Definition conditional_eq {A} (x y : A) := eq x y.

Lemma simplification_existT2 A (P : A -> Type) B (p : A) (x y : P p) :
  (x = y -> B) -> (conditional_eq (existT P p x) (existT P p y) -> B).
Proof. intros H E. apply H. apply inj_pair2. assumption. Defined.

Lemma simplification_existT1 A (P : A -> Type) B (p q : A) (x : P p) (y : P q) :
  (p = q -> conditional_eq (existT P p x) (existT P q y) -> B) -> (existT P p x = existT P q y -> B).
Proof. injection 2. auto. Defined.

Lemma simplification_K A (x : A) (B : x = x -> Type) :
  B eq_refl -> (forall p : x = x, B p).
Proof. intros. rewrite (UIP_refl A). assumption. Defined.

(** This hint database and the following tactic can be used with [autounfold] to
   unfold everything to [eq_rect]s. *)

Hint Unfold solution_left solution_right deletion simplification_heq
  simplification_existT1 simplification_existT2 simplification_K
  eq_rect_r eq_rec eq_ind : dep_elim.

(** Using these we can make a simplifier that will perform the unification
   steps needed to put the goal in normalised form (provided there are only
   constructor forms). Compare with the lemma 16 of the paper.
   We don't have a [noCycle] procedure yet. *)

Ltac simplify_one_dep_elim_term c :=
  match c with
    | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _)
    | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _)
    | eq (existT _ _ _) (existT _ _ _) -> _ =>
        refine (simplification_existT1 _ _ _ _ _ _ _ _)
    | conditional_eq (existT _ _ _) (existT _ _ _) -> _ =>
        refine (simplification_existT2 _ _ _ _ _ _ _) ||
               (unfold conditional_eq; intro)
    | ?x = ?y -> _ => (* variables case *)
      (unfold x) || (unfold y) ||
      (let hyp := fresh in intros hyp ;
        move hyp before x ; revert_until hyp ; generalize dependent x ;
          refine (solution_left _ _ _ _)(*  ; intros until 0 *)) ||
      (let hyp := fresh in intros hyp ;
        move hyp before y ; revert_until hyp ; generalize dependent y ;
          refine (solution_right _ _ _ _)(*  ; intros until 0 *))
    | ?f ?x = ?g ?y -> _ => let H := fresh in progress (intros H ; simple injection H; clear H)
    | ?t = ?u -> _ => let hyp := fresh in
      intros hyp ; exfalso ; discriminate
    | ?x = ?y -> _ => let hyp := fresh in
      intros hyp ; (try (clear hyp ; (* If non dependent, don't clear it! *) fail 1)) ;
        case hyp ; clear hyp
    | block ?T => fail 1 (* Do not put any part of the rhs in the hyps *)
    | forall x, _ => intro x || (let H := fresh x in rename x into H ; intro x) (* Try to keep original names *)
    | _ => intro
  end.

Ltac simplify_one_dep_elim :=
  match goal with
    | [ |- ?gl ] => simplify_one_dep_elim_term gl
  end.

(** Repeat until no progress is possible. By construction, it should leave the goal with
   no remaining equalities generated by the [generalize_eqs] tactic. *)

Ltac simplify_dep_elim := repeat simplify_one_dep_elim.

(** Do dependent elimination of the last hypothesis, but not simplifying yet
   (used internally). *)

Ltac destruct_last :=
  on_last_hyp ltac:(fun id => simpl in id ; generalize_eqs id ; destruct id).

Ltac introduce p := first [
  match p with _ => (* Already there, generalize dependent hyps *)
    generalize dependent p ; intros p
  end
  | intros until p | intros until 1 | intros ].

Ltac do_case p := introduce p ; (destruct p || elim_case p || (case p ; clear p)).
Ltac do_ind p := introduce p ; (induction p || elim_ind p).

(** The following tactics allow to do induction on an already instantiated inductive predicate
   by first generalizing it and adding the proper equalities to the context, in a maner similar to
   the BasicElim tactic of "Elimination with a motive" by Conor McBride. *)

(** The [do_depelim] higher-order tactic takes an elimination tactic as argument and an hypothesis
   and starts a dependent elimination using this tactic. *)

Ltac is_introduced H :=
  match goal with
    | [ H' : _ |- _ ] => match H' with H => idtac end
  end.

Tactic Notation "intro_block" hyp(H) :=
  (is_introduced H ; block_goal ; revert_until H ; block_goal) ||
    (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal).

Tactic Notation "intro_block_id" ident(H) :=
  (is_introduced H ; block_goal ; revert_until H; block_goal) ||
    (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal).

Ltac unblock_dep_elim :=
  match goal with
    | |- block ?T =>
      match T with context [ block _ ] =>
        change T ; intros ; unblock_goal
      end
    | _ => unblock_goal
  end.

Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_dep_elim.

Ltac do_intros H :=
  (try intros until H) ; (intro_block_id H || intro_block H).

Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_eqs H ; tac H.

Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim.

Ltac do_depind tac H :=
  (try intros until H) ; intro_block H ;
  generalize_eqs_vars H ; tac H ; simpl_dep_elim.

(** To dependent elimination on some hyp. *)

Ltac depelim id := do_depelim ltac:(fun hyp => do_case hyp) id.

(** Used internally. *)

Ltac depelim_nosimpl id := do_depelim_nosimpl ltac:(fun hyp => do_case hyp) id.

(** To dependent induction on some hyp. *)

Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id.

(** A variant where generalized variables should be given by the user. *)

Ltac do_depelim' rev tac H :=
  (try intros until H) ; block_goal ;
  (try revert_until H ; block_goal) ;
  generalize_eqs H ; rev H ; tac H ; simpl_dep_elim.

(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion.
   By default, we don't try to generalize the hyp by its variable indices.  *)

Tactic Notation "dependent" "destruction" ident(H) :=
  do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => do_case hyp) H.

Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => destruct hyp using c) H.

(** This tactic also generalizes the goal by the given variables before the elimination. *)

Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) :=
  do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_case hyp) H.

Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => destruct hyp using c) H.

(** Then we have wrappers for usual calls to induction. One can customize the induction tactic by
   writting another wrapper calling do_depelim. We suppose the hyp has to be generalized before
   calling [induction]. *)

Tactic Notation "dependent" "induction" ident(H) :=
  do_depind ltac:(fun hyp => do_ind hyp) H.

Tactic Notation "dependent" "induction" ident(H) "using" constr(c) :=
  do_depind ltac:(fun hyp => induction hyp using c) H.

(** This tactic also generalizes the goal by the given variables before the induction. *)

Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) :=
  do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_ind hyp) H.

Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => induction hyp using c) H.

Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) :=
  do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l) H.

Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) "using" constr(c) :=
  do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l using c) H.


(** Proof Reflection in Coq ; indices.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export Arith.
Require Export Compare_dec.
Require Export list.

(* parts of this file were taken from or inspired by
   Venanzio Capretta's development of universal algebra in Coq *)

Inductive sigTS (T : Type) (P : T -> Set) : Type :=
    existTS : forall B : T, P B -> sigTS T P.

Inductive empty : Set :=.

Definition from_empty (A : Set) := empty_rec (fun _ => A).

Definition empty_ind' (e : empty) (p : Prop) : p := empty_ind (fun _ => p) e.

Set Implicit Arguments.

Section Sigma_Type_Set.

Variable T : Type.
Variable P : T -> Set.

Definition projTS1 (p : sigTS T P) : T :=
  match p with existTS a _ => a end.

Definition projTS2 (p : sigTS T P) : P (projTS1 p) :=
  match p as p' return (P (projTS1 p')) with
  | existTS _ x => x
  end.

End Sigma_Type_Set.

Section indices.

Variable A : Set.

Fixpoint index (l : list A) : Set :=
  match l with
  | nil => empty
  | _ :: t => (unit + index t)%type
  end.

Fixpoint index_eqb (l : list A) : index l -> index l -> bool :=
  match l return (index l -> index l -> bool) with
  | nil => fun _ => from_empty bool
  | a :: t =>
      fun i j =>
      match i, j with
      | inl _, inl _ => true
      | inr i', inr j' => index_eqb t i' j'
      | _, _ => false
      end
  end.

Lemma index_eqb_refl :
 forall (L : list A) (i : index L), index_eqb L i i = true.
Proof.
simple induction L.
intro H. elim H.
intros a l IH i.
case i.
intro u. case u; reflexivity.
exact IH.
Qed.

Lemma index_eqb_dec :
 forall (L : list A) (i j : index L), index_eqb L i j = true -> i = j.
Proof.
simple induction L.
simple destruct i.
intros a l IH i.
case i.
intros u j.
case u.
case j.
intro u2.
case u2.
reflexivity.
intros. discriminate.
intros i' j.
case j.
intros. discriminate.
intros j' H.
rewrite (IH i' j' H).
reflexivity.
Qed.

Definition ltll (n : nat) (l : list A) := n < length l.

Fixpoint index_inj (n : nat) (l : list A) {struct l} :
 ltll n l -> index l :=
  match l as l' return (ltll n l' -> index l') with
  | nil => fun p => False_rec empty (lt_n_O n p)
  | a :: t =>
      match n as m return (ltll m (a :: t) -> unit + index t) with
      | O => fun _ => inl (index t) tt
      | S n' => fun p => inr unit (index_inj (lt_S_n n' (length t) p))
      end
  end.

Section index_L.

Variable L : list A.
Let len := length L.

Lemma ltll_dec_opaque : forall n : nat, {ltll n L} + {~ ltll n L}.
Proof.
intro n.
case (le_gt_dec (S n) len); intro H.
left.
exact H.
right.
unfold not in |- *.
intro H0.
exact (le_not_gt (S n) len H0 H).
Qed.

(*
Transparent le_gt_dec.
Transparent le_not_gt.
Transparent le_lt_dec.
Transparent ltll_dec_opaque.
Eval Cbv Beta Delta -[length] Iota in ltll_dec_opaque.
*)

Definition ltll_dec (n : nat) : {ltll n L} + {~ ltll n L} :=
  match
    (fix F (n0 : nat) : {S n <= n0} + {S n0 <= S n} :=
       match n0 as n1 return ({S n <= n1} + {S n1 <= S n}) with
       | O => right (S n <= 0) (lt_le_S 0 (S n) (lt_O_Sn n))
       | S n1 =>
           match
             (fix F0 (n2 : nat) : forall m : nat, {n2 <= m} + {S m <= n2} :=
                match
                  n2 as n3 return (forall m : nat, {n3 <= m} + {S m <= n3})
                with
                | O => fun m : nat => left (S m <= 0) (le_O_n m)
                | S n3 =>
                    fun m : nat =>
                    (fix F1 (n4 : nat) : {S n3 <= n4} + {S n4 <= S n3} :=
                       match
                         n4 as n5 return ({S n3 <= n5} + {S n5 <= S n3})
                       with
                       | O =>
                           right (S n3 <= 0) (lt_le_S 0 (S n3) (lt_O_Sn n3))
                       | S n5 =>
                           match
                             F0 n3 n5
                             return ({S n3 <= S n5} + {S (S n5) <= S n3})
                           with
                           | left y =>
                               left (S (S n5) <= S n3) (le_n_S n3 n5 y)
                           | right y =>
                               right (S n3 <= S n5) (le_n_S (S n5) n3 y)
                           end
                       end) m
                end) n n1 return ({S n <= S n1} + {S (S n1) <= S n})
           with
           | left y => left (S (S n1) <= S n) (le_n_S n n1 y)
           | right y => right (S n <= S n1) (le_n_S (S n1) n y)
           end
       end) (length L)
    return ({S n <= length L} + {S n <= length L -> False})
  with
  | left h => left (S n <= length L -> False) h
  | right h =>
      right (S n <= length L) (fun h0 => le_not_lt (S n) (length L) h0 h)
  end.

Definition nat2index_sig (n : nat) : sigTS Set (fun B : Set => B) :=
  match ltll_dec n with
  | left p => existTS Set (fun B : Set => B) (index L) (index_inj p)
  | _ => existTS Set (fun B : Set => B) unit tt
  end.

Definition nat2index (n : nat) : Set := projTS1 (nat2index_sig n).

Definition nat_inj (n : nat) : nat2index n := projTS2 (nat2index_sig n).

Fixpoint index2nat (L : list A) : index L -> nat :=
  match L return (index L -> nat) with
  | nil => fun e => from_empty nat e
  | a :: t =>
      fun i => match i with
               | inl tt => 0
               | inr i' => S (index2nat t i')
               end
  end.

End index_L.

Fixpoint select_expl (l : list A) : index l -> A :=
  match l as l' return (index l' -> A) with
  | nil => empty_rec (fun _ => A)
  | h :: t =>
      fun i : unit + index t =>
      match i with
      | inl tt => h
      | inr i' => select_expl t i'
      end
  end.

End indices.

Infix "}-" := nat_inj (left associativity, at level 50).

Notation select := (select_expl _) (only parsing).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable ltA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable isosceles_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deftriangle_1 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_2 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable defcollinear_3 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_4 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_5 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_6 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_7 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_8 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_9 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_inequalitysymmetric_10 : (forall A B : Universe, (A <> B -> B <> A)).
Variable defanglelessthan_11 : (forall A B C D E F : Universe, (exists U X V : Universe, (ltA_ A B C D E F -> (betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X)))))).
Variable defanglelessthan2_12 : (forall A B C D E F U X V : Universe, ((betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X))) -> ltA_ A B C D E F)).
Variable lemma_equalanglesNC_13 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable lemma_layoff_14 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Variable lemma_congruencetransitive_15 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable lemma_rayimpliescollinear_16 : (forall A B C : Universe, (out_ A B C -> col_ A B C)).
Variable lemma_collinearorder_17 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_raystrict_18 : (forall A B C : Universe, (out_ A B C -> A <> C)).
Variable lemma_collinear4_19 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_ray4_1_20 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_21 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_22 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_equalangleshelper_23 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable lemma_equalanglessymmetric_24 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_equalanglesflip_25 : (forall A B C D E F : Universe, (congA_ A B C D E F -> congA_ C B A F E D)).
Variable proposition_04_26 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).
Variable lemma_ray5_27 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_ray2_28 : (forall A B C : Universe, (out_ A B C -> A <> B)).
Variable axiom_betweennesssymmetry_29 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_crossbar_30 : (forall A B C E U V : Universe, (exists X : Universe, ((triangle_ A B C /\ (betS_ A E C /\ (out_ B A U /\ out_ B C V))) -> (out_ B E X /\ betS_ U X V)))).
Variable lemma_ray3_31 : (forall B C D V : Universe, ((out_ B C D /\ out_ B C V) -> out_ B D V)).
Variable lemma_congruencesymmetric_32 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_betweennotequal_33 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable defisosceles_34 : (forall A B C : Universe, (isosceles_ A B C -> (triangle_ A B C /\ cong_ A B A C))).
Variable defisosceles2_35 : (forall A B C : Universe, ((triangle_ A B C /\ cong_ A B A C) -> isosceles_ A B C)).
Variable proposition_05_36 : (forall A B C : Universe, (isosceles_ A B C -> congA_ A B C A C B)).
Variable lemma_ray1_37 : (forall A B P : Universe, (out_ A B P -> (betS_ A P B \/ (B = P \/ betS_ A B P)))).
Variable proposition_16_38 : (forall A B C D : Universe, ((triangle_ A B C /\ betS_ B C D) -> (ltA_ B A C A C D /\ ltA_ C B A A C D))).
Variable lemma_ABCequalsCBA_39 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_angleorderrespectscongruence2_40 : (forall A B C D E F Xa Xb Xc : Universe, ((ltA_ A B C D E F /\ congA_ Xa Xb Xc A B C) -> ltA_ Xa Xb Xc D E F)).
Variable lemma_angleorderrespectscongruence_41 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ congA_ P Q R D E F) -> ltA_ A B C P Q R)).
Variable lemma_equalanglesreflexive_42 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_angledistinct_43 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> (A <> B /\ (B <> C /\ (A <> C /\ (Xa <> Xb /\ (Xb <> Xc /\ Xa <> Xc))))))).
Variable lemma_angleordertransitive_44 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ ltA_ D E F P Q R) -> ltA_ A B C P Q R)).
Variable proposition_19_45 : (forall A B C : Universe, ((triangle_ A B C /\ ltA_ B C A A B C) -> lt_ A B A C)).
Variable cn_equalityreverse_46 : (forall A B : Universe, cong_ A B B A).
Variable lemma_lessthancongruence2_47 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ A B E F) -> lt_ E F C D)).
Variable lemma_lessthancongruence_48 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ C D E F) -> lt_ A B E F)).
Variable deflessthan_49 : (forall A B C D : Universe, (exists X : Universe, (lt_ A B C D -> (betS_ C X D /\ cong_ C X A B)))).
Variable deflessthan2_50 : (forall A B C D X : Universe, ((betS_ C X D /\ cong_ C X A B) -> lt_ A B C D)).

Theorem proposition_24_51 : (forall A B C D E F : Universe, ((triangle_ A B C /\ (triangle_ D E F /\ (cong_ A B D E /\ (cong_ A C D F /\ ltA_ E D F B A C)))) -> lt_ E F B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O X Z Zprime : Universe, ((wd_ O X /\ (wd_ O Z /\ (wd_ Z O /\ (wd_ O Zprime /\ (wd_ Z Zprime /\ (col_ O X Zprime /\ col_ Z O Zprime)))))) -> col_ O X Z)).
Proof.
  time tac.
Qed.

End FOFProblem.


(**
 * Efficient (but uncertified) extraction of usual [Z] functions
 * into equivalent versions in Haskell's Prelude that are defined
 * for any [Num] typeclass instances.  Useful in combination with
 * [Extract Inductive Z] that maps [Z] onto a Haskell type that
 * implements [Num].
 *)

Require Coq.extraction.Extraction.

Require Import ZArith.
Require Import EqNat.

Extract Inlined Constant Z.add => "(Prelude.+)".
Extract Inlined Constant Z.sub => "(Prelude.-)".
Extract Inlined Constant Z.mul => "(Prelude.*)".
Extract Inlined Constant Z.max => "Prelude.max".
Extract Inlined Constant Z.min => "Prelude.min".
Extract Inlined Constant Z_ge_lt_dec => "(Prelude.>=)".
Extract Inlined Constant Z_gt_le_dec => "(Prelude.>)".

Extract Constant Z.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)".
Extract Constant Z.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)".


Require Export SfLib.
Require Export Smimpl.

Module SmimplProp.
Import Smimpl.Smimpl.

Theorem unique_typing : forall Gamma t T1 T2,
    Gamma |- t \in T1 ->
    Gamma |- t \in T2 ->
    T1 = T2 .

Proof with auto.
  intros Gamma t Ta Tb HTa HTb.
  generalize dependent Tb.
  has_type_cases (induction HTa) Case ; intros Tb HTb; inversion HTb.
  Case "T_Var". rewrite H in H2. injection H2. auto.
  Case "T_Abs".
    assert (T12 = T1).
    apply IHHTa. assumption.
    rewrite H5. reflexivity.
  Case "T_App".
    assert (TArrow T11 T12 = TArrow T0 Tb). apply IHHTa1. assumption.
    injection H5. auto.
  Case "T_Unit". reflexivity.
  Case "T_Pair".
    f_equal.
    apply IHHTa1...
    apply IHHTa2...
  Case "T_Fst".
    assert (TProd T1 T2 = TProd Tb T3).
    apply IHHTa...
    injection H3...
  Case "T_Snd".
    assert (TProd T1 T2 = TProd T0 Tb).
    apply IHHTa...
    injection H3...
  Case "T_Inl".
    f_equal.
    apply IHHTa...
  Case "T_Inr".
    f_equal. apply IHHTa...
  Case "T_Sum".
    f_equal.
    apply IHHTa1. assumption.
    apply IHHTa2. assumption.
  Case "T_Case".
    assert (TArrow T1 T3 = TArrow T0 Tb)...
    injection H7...
  Case "T_Fix".
    assert (TArrow T T = TArrow Tb Tb)...
    injection H3...
  Case "T_Ite".
    apply IHHTa1. assumption.
  Case "T_ReturnIO".
    f_equal. apply IHHTa...
  Case "T_BindIO".
    f_equal.
    assert (TArrow T1 (TIO T2) = TArrow T0 (TIO T3))...
    injection H5...
  Case "T_SearchIO".
    f_equal.
    assert (TS T = TS T0)...
    injection H3. intro.
    rewrite H4. reflexivity.
  Case "T_IteIO". apply IHHTa1. assumption.
  Case "T_ReturnS".
    f_equal. apply IHHTa...
  Case "T_BindS".
    f_equal.
    assert (TArrow T1 (TS T2) = TArrow T0 (TS T3))...
    injection H5...
  Case "T_ZeroS". reflexivity.
  Case "T_PlusS".
    f_equal.
    assert (TS T = TS T0)...
    injection H5...
  Case "T_SetS".
    f_equal.
    apply IHHTa. assumption.
  Case "T_IteS".
    apply IHHTa1. assumption.
Qed.

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Ht) Case; subst Gamma...
  Case "T_Var".  (* contradictory: variables cannot be typed in an empty context *)
    unfold empty in H. discriminate H.

  Case "T_App".
    right. (* We will show we always can make progress *)
    destruct IHHt1... (* by case on whether the function t1 is a value or steps *)
    SCase "t1 is a value".
      (* The only value with function type is v_abs, in which case ST_AppAbs applies *)
      remember (TArrow T11 T12) as TF eqn:HdefTF.
      remember t1 as tf eqn:Hdeftf.
      Ltac nonfunction_value Hdeftf Ht1 :=
             rewrite Hdeftf in Ht1 ; destruct Ht1 ; discriminate .
      v_cases (destruct H) SSCase .
      SSCase "v_abs"; exists ([x0:=t2]t); apply ST_AppAbs.
      SSCase "v_unit". nonfunction_value Hdeftf Ht1.
      SSCase "v_pair". nonfunction_value Hdeftf Ht1.
      SSCase "v_sum". nonfunction_value Hdeftf Ht1.
      SSCase "v_IO". destruct H ; nonfunction_value Hdeftf Ht1.
      SSCase "v_S". destruct H ; nonfunction_value Hdeftf Ht1.

    SCase "t1 steps".
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  Case "T_Fst".
    right. destruct IHHt...

    SCase "t is a value".
      (* Since [t] is a value of product type, it must
         be a pair *)
      v_cases (inversion H) SSCase; subst; try solve by inversion.
      SSCase "v_pair". eauto.
      SSCase "v_IO". inversion H0; subst; try solve by inversion.
      SSCase "v_S". inversion H0; subst; try solve by inversion.

    SCase "t also steps".
      inversion H as [t' Hstp]. exists (tfst t')...

  Case "T_Snd".
    right. destruct IHHt...

    SCase "t is a value".
      (* Since [t] is a value of product type, it must
         be a pair *)
      v_cases (inversion H) SSCase; subst; try solve by inversion.
      SSCase "v_pair". eauto.
      SSCase "v_IO". inversion H0; subst; try solve by inversion.
      SSCase "v_S". inversion H0; subst; try solve by inversion.

    SCase "t also steps".
      inversion H as [t' Hstp]. exists (tsnd t')...

  Case "T_Case".
    right. destruct IHHt1...

    SCase "t1 is a value".
      v_cases (inversion H) SSCase; subst; try solve by inversion.
      SSCase "v_sum". eauto.
      SSCase "v_IO". inversion H0; subst; try solve by inversion.
      SSCase "v_S". inversion H0; subst; try solve by inversion.

    SCase "t1 also steps".
      inversion H as [t1' Hstp]. exists (tcase t1' t2 t3)...

  Case "T_Ite".
    right. destruct IHHt1...

    SCase "t1 is a value".
      destruct IHHt2...
      SSCase "t2 is a value".
        v_cases (inversion H) SSSCase.
        SSSCase "v_abs".
           v_cases (inversion H0) SSSSCase;
              subst ; inversion Ht2 ; subst ; inversion Ht1 ; try (inversion H2).
           SSSSCase "v_abs".
             subst.
             exists (tabs x T1 (tite p (tapp (tabs x0 T1 t) (tvar x)) (tapp (tabs x1 T1 t0) (tvar x)))).
             apply ST_IteAbs.
        SSSCase "v_unit".
           v_cases (inversion H0) SSSSCase;
             subst ; inversion Ht2 ; subst ; inversion Ht1 ; try (inversion H2).
           SSSSCase "v_unit".
             exists tunit. apply ST_IteUnit.
        SSSCase "v_pair".
           v_cases (inversion H0) SSSSCase;
             subst ; inversion Ht2 ; subst ; inversion Ht1 ; try (inversion H2).
           SSSSCase "v_pair". subst.
             exists (tpair (tite p t0 t4) (tite p t3 t5)).
             apply ST_ItePair.
        SSSCase "v_sum".
           v_cases (inversion H0) SSSSCase;
             subst ; inversion Ht2 ; subst ; inversion Ht1 ; try (inversion H2).
           SSSSCase "v_sum". subst.
             exists (tsum (Sat.fite p p0 p1) (tite p t0 t4) (tite p t3 t5)).
             apply ST_IteSum.
        SSSCase "v_IO".
           v_cases (inversion H0) SSSSCase.
           SSSSCase "v_abs". inversion H1 ; subst ; inversion Ht2 ; subst ; inversion Ht1.
           SSSSCase "v_unit". inversion H1 ; subst ; inversion Ht2 ; subst ; inversion Ht1.
           SSSSCase "v_pair". inversion H1 ; subst ; inversion Ht2 ; subst ; inversion Ht1.
           SSSSCase "v_sum". inversion H1 ; subst ; inversion Ht2 ; subst ; inversion Ht1.
           SSSSCase "v_IO".
             exists (titeIO p t1 t2). apply ST_IteIO; assumption.
           SSSSCase "v_S".
             inversion H1; subst;
             inversion H3; subst;
             inversion Ht1; subst ; inversion Ht2.
        SSSCase "v_S".
           v_cases (inversion H0) SSSSCase.
           SSSSCase "v_abs". inversion H1 ; subst ; inversion Ht2 ; subst ; inversion Ht1.
           SSSSCase "v_unit".
             subst.
             remember tunit as t eqn:Heq.
             has_type_cases (destruct Ht2) SSSSSCase ; try discriminate Heq.
             SSSSSCase "T_Unit".
               (* no svalue t1 has type TUnit *)
               remember t1 as tx eqn:Heqtx ;
               destruct H1 ;
                rewrite Heqtx in Ht1 ;
                remember TUnit as Tval eqn:HeqT ;
                destruct Ht1 ;
                 try discriminate HeqT ; try discriminate Heqtx.

           SSSSCase "v_pair". inversion H1 ; subst ; inversion Ht2 ; subst ; inversion Ht1.
           SSSSCase "v_sum". inversion H1 ; subst ; inversion Ht2 ; subst ; inversion Ht1.
           SSSSCase "v_IO".
             inversion H1; subst;
             inversion H3; subst;
             inversion Ht1; subst ; inversion Ht2.
           SSSSCase "v_S".
             exists (titeS p t1 t2). apply ST_IteS; assumption.
      SSCase "t2 steps".
        inversion H0 as [t2'].
        exists (tite p t1 t2').
        apply ST_Ite2; assumption.
    SCase "t1 steps".
      inversion H as [t1'].
      exists (tite p t1' t2).
      apply ST_Ite1; assumption.

Qed.

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_pair1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tpair t1 t2)
  | afi_pair2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tpair t1 t2)
  | afi_fst : forall x t,
      appears_free_in x t ->
      appears_free_in x (tfst t)
  | afi_snd : forall x t,
      appears_free_in x t ->
      appears_free_in x (tsnd t)
  | afi_inl : forall x T t,
      appears_free_in x t ->
      appears_free_in x (tinl T t)
  | afi_inr : forall x T t,
      appears_free_in x t ->
      appears_free_in x (tinr T t)
  | afi_sum1 : forall x p t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tsum p t1 t2)
  | afi_sum2 : forall x p t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tsum p t1 t2)
  | afi_case1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tcase t1 t2 t3)
  | afi_case2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tcase t1 t2 t3)
  | afi_case3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tcase t1 t2 t3)
  | afi_fix : forall x t,
      appears_free_in x t ->
      appears_free_in x (tfix t)
  | afi_ite1 : forall x p t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tite p t1 t2)
  | afi_ite2 : forall x p t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tite p t1 t2)
  | afi_returnIO : forall x t,
      appears_free_in x t ->
      appears_free_in x (treturnIO t)
  | afi_bindIO1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tbindIO t1 t2)
  | afi_bindIO2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tbindIO t1 t2)
  | afi_searchIO : forall x t,
      appears_free_in x t ->
      appears_free_in x (tsearchIO t)
  | afi_iteIO1 : forall x p t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (titeIO p t1 t2)
  | afi_iteIO2 : forall x p t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (titeIO p t1 t2)
  | afi_returnS : forall x t,
      appears_free_in x t ->
      appears_free_in x (treturnS t)
  | afi_bindS1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tbindS t1 t2)
  | afi_bindS2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tbindS t1 t2)
  | afi_plusS1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tplusS t1 t2)
  | afi_plusS2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tplusS t1 t2)
  | afi_setS : forall x p t,
      appears_free_in x t ->
      appears_free_in x (tsetS p t)
  | afi_iteS1 : forall x p t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (titeS p t1 t2)
  | afi_iteS2 : forall x p t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (titeS p t1 t2)
  .

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_app1" | Case_aux c "afi_app2"
  | Case_aux c "afi_abs"
  | Case_aux c "afi_pair1" | Case_aux c "afi_pair2"
  | Case_aux c "afi_fst" | Case_aux c "afi_snd"
  | Case_aux c "afi_inl" | Case_aux c "afi_inr"
  | Case_aux c "afi_sum1" | Case_aux c "afi_sum2"
  | Case_aux c "afi_case1" | Case_aux c "afi_case2"
  | Case_aux c "afi_case3" | Case_aux c "afi_fix"
  | Case_aux c "afi_ite1" | Case_aux c "afi_ite2"
  | Case_aux c "afi_returnIO"
  | Case_aux c "afi_bindIO1" | Case_aux c "afi_bindIO2"
  | Case_aux c "afi_searchIO"
  | Case_aux c "afi_iteIO1" | Case_aux c "afi_iteIO2"
  | Case_aux c "afi_returnS"
  | Case_aux c "afi_bindS1" | Case_aux c "afi_bindS2"
  | Case_aux c "afi_plusS1" | Case_aux c "afi_plusS2"
  | Case_aux c "afi_setS"
  | Case_aux c "afi_iteS1" | Case_aux c "afi_iteS2"
  ].

Hint Constructors appears_free_in.

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  afi_cases (induction H) Case;
         intros; try solve [inversion H0; eauto].
  Case "afi_abs".
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite extend_neq in H7; assumption.
Qed.

Lemma closed_typing : forall t T,
  empty |- t \in T ->
  closed t.
Proof.
  intros t T HT.
  unfold closed.
  intro x.
  unfold not.
  intro Hafi.
  absurd (exists (T':ty), empty x = Some T').
  unfold not. intro Hsilly. inversion Hsilly. inversion H.
  apply free_in_context with t T; assumption.
Qed.

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  has_type_cases (induction H) Case; intros; auto.
  Case "T_Var".
    apply T_Var. rewrite <- H0...
  Case "T_Abs".
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [extend Gamma x T11] *)
    unfold extend. destruct (eq_id_dec x0 x1)...
  Case "T_App". apply T_App with T11...
  Case "T_Fst". apply T_Fst with T2...
  Case "T_Snd". apply T_Snd with T1...
  Case "T_Case". apply T_Case with T1 T2...
  Case "T_BindIO". apply T_BindIO with T1...
  Case "T_BindS". apply T_BindS with T1...
Qed.

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     extend Gamma x U |- t \in T ->
     empty |- v \in U   ->
     Gamma |- [x:=v]t \in T.

Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  t_cases (induction t) Case; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  Case "tvar".
    rename i into y. destruct (eq_id_dec x y).
    SCase "x=y".
      subst.
      rewrite extend_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      apply T_Var. rewrite extend_neq in H2...
  Case "tabs".
    rename i into y. apply T_Abs.
    destruct (eq_id_dec x y).
    SCase "x=y".
      eapply context_invariance...
      subst.
      intros x Hafi. unfold extend.
      destruct (eq_id_dec y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      destruct (eq_id_dec y z)...
      subst. rewrite neq_id...
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t ==> t'  ->
     empty |- t' \in T.

Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  has_type_cases (induction HT) Case;
       intros t' HE; subst Gamma; subst;
       try solve [inversion HE; subst; auto].
  Case "T_App".
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    SCase "ST_AppAbs".
      apply substitution_preserves_typing with T11...
      inversion HT1...
  Case "T_Fst".
    inversion HE; subst...
    inversion HT; subst...
  Case "T_Snd".
    inversion HE; subst...
    inversion HT; subst...
  Case "T_Case".
    inversion HE; subst...
    SCase "inl". inversion HT1; subst...
  Case "T_Fix".
    inversion HE; subst...
  Case "T_Ite".
    inversion HE; subst...
    SCase "tabs".
      inversion HT1; subst...
      apply T_Abs.
      apply T_Ite.
      apply T_App with T0.
      apply context_invariance with empty.
      assumption.
      intros x0 Hfree.
      absurd (appears_free_in x0 (tabs x1 T0 t0)).
      assert (closed (tabs x1 T0 t0)).
      apply closed_typing with (TArrow T0 T12) ; assumption.
      unfold closed in H.
      specialize H with x0. apply H.
      apply Hfree.
      apply T_Var. auto.

      apply T_App with T0.
      apply context_invariance with empty.
      assumption.
      intros x0 Hfree.
      absurd (appears_free_in x0 (tabs x2 T0 t3)).
      assert (closed (tabs x2 T0 t3)).
      apply closed_typing with (TArrow T0 T12) ; assumption.
      unfold closed in H.
      specialize H with x0. apply H.
      apply Hfree.
      apply T_Var. auto.
    SCase "tpair".
      inversion HT2; subst; inversion HT1; subst.
      apply T_Pair.
      apply T_Ite ; assumption.
      apply T_Ite ; assumption.
    SCase "tsum".
      inversion HT2; subst; inversion HT1; subst.
      apply T_Sum; apply T_Ite ; assumption.
    SCase "io".
      destruct H3; inversion HT1; subst ; apply T_IteIO ; assumption.
    SCase "s".
      destruct H3; inversion HT1; subst ; apply T_IteS ; assumption.
Qed.

Definition stuck (t:tm) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti. apply Hnot_val.
   destruct (progress x0 T).
   apply Hhas_type. apply H.
   contradiction.

   apply IHHmulti.
   apply (preservation x0 y0). apply Hhas_type. apply H.
   apply Hnf. apply Hnot_val.
Qed.

Theorem step_deterministic : forall t t1 t2 T,
   empty |- t \in T ->
   t ==> t1 ->
   t ==> t2 ->
   t1 = t2
   .
Proof.
  intro t.
  t_cases (induction t) Case;
    intros ty1 ty2 T HT Hstep1 Hstep2 ; inversion Hstep1.
  Case "tapp".
    SCase "tf = tabs x0 T0 t0".
      rewrite <- H0 in Hstep2.
      inversion Hstep2.
      SSCase "tf = tabs x0 T0 t0". reflexivity.
      SSCase "tf steps". inversion H5.
    SCase "tf steps".
      inversion Hstep2.
      SSCase "tf = tabs".
         rewrite <- H4 in H2.
         inversion H2.
      SSCase "tf steps".
         f_equal.
         inversion HT.
         apply IHt1 with (TArrow T11 T).
         assumption. assumption. assumption.
    Case "tfst".
      SCase "fst pair".
        rewrite <- H0 in Hstep2.
        rewrite H1 in Hstep2.
        inversion Hstep2.
        SSCase "fst pair". reflexivity.
        SSCase "fst". inversion H2.
      SCase "fst".
        inversion Hstep2.
        SSCase "fst pair".
          rewrite <- H3 in H0.
          inversion H0.
        SSCase "fst".
          f_equal.
          inversion HT.
          apply IHt with (TProd T T2).
          assumption. assumption. assumption.
    Case "tsnd".
      SCase "snd pair".
        rewrite <- H0 in Hstep2.
        rewrite H1 in Hstep2.
        inversion Hstep2.
        SSCase "snd pair". reflexivity.
        SSCase "snd". inversion H2.
      SCase "snd".
        inversion Hstep2.
        SSCase "snd pair".
          rewrite <- H3 in H0.
          inversion H0.
        SSCase "snd".
          f_equal.
          inversion HT.
          apply IHt with (TProd T1 T).
          assumption. assumption. assumption.
   Case "tinl".
      subst.
      inversion Hstep2.
      reflexivity.
   Case "tinr". inversion Hstep2. reflexivity.
   Case "tcase".
      SCase "case sum".
        rewrite <- H0 in Hstep2.
        inversion Hstep2.
        SSCase "case inl". reflexivity.
        SSCase "case". inversion H7.
      SCase "case".
        inversion Hstep2.
        SSCase "case sum".
          rewrite <- H5 in H3. inversion H3.
        SSCase "case".
          f_equal.
          inversion HT.
          apply IHt1 with (TSum T1 T2).
          assumption. assumption. assumption.
   Case "tfix".
     inversion Hstep2.
     reflexivity.
   Case "tite".
     SCase "tite1".
       inversion HT. subst.
       inversion Hstep2 ; subst.
       SSCase "tite1".
         f_equal. subst.
         apply IHt1 with T ; assumption.
       SSCase "tite2".
         inversion H4 ; subst.
         SSSCase "abs". inversion H3.
         SSSCase "unit". inversion H3.
         SSSCase "pair". inversion H3.
         SSSCase "sum". inversion H3.
         SSSCase "io". inversion H ; subst ; inversion H3.
         SSSCase "s". inversion H ; subst ; inversion H3.
       SSCase "ite abs". inversion H3.
       SSCase "ite unit". inversion H3.
       SSCase "ite pair". inversion H3.
       SSCase "ite sum". inversion H3.
       SSCase "ite IO". inversion H4 ; subst ; inversion H3.
       SSCase "ite S". inversion H4 ; subst ; inversion H3.
     SCase "tite2".
       inversion HT. subst.
       inversion Hstep2 ; subst.
       SSCase "tite1".
         inversion H3 ; subst.
         SSSCase "abs". inversion H5.
         SSSCase "unit". inversion H5.
         SSSCase "pair". inversion H5.
         SSSCase "sum". inversion H5.
         SSSCase "io". inversion H ; subst ; inversion H5.
         SSSCase "s". inversion H ; subst ; inversion H5.
       SSCase "tite2".
         f_equal.
         apply IHt2 with T ; assumption.
       SSCase "ite abs". inversion H4.
       SSCase "ite unit". inversion H4.
       SSCase "ite pair". inversion H4.
       SSCase "ite sum". inversion H4.
       SSCase "ite IO". inversion H6 ; subst ; inversion H4.
       SSCase "ite S". inversion H6 ; subst ; inversion H4.
     SCase "ite abs".
       subst.
       inversion Hstep2 ; subst.
       SSCase "ite1". inversion H3.
       SSCase "ite2". inversion H4.
       SSCase "ite abs". reflexivity.
       SSCase "ite io". inversion H3.
       SSCase "ite s". inversion H3.
     SCase "ite unit".
       subst.
       inversion Hstep2 ; subst.
       SSCase "ite1". inversion H3.
       SSCase "ite2". inversion H4.
       SSCase "ite unit". reflexivity.
       SSCase "ite io". inversion H3.
       SSCase "ite s". inversion H3.
     SCase "ite pair".
       subst.
       inversion Hstep2 ; subst.
       SSCase "ite1". inversion H3.
       SSCase "ite2". inversion H4.
       SSCase "ite pair". reflexivity.
       SSCase "ite io". inversion H3.
       SSCase "ite s". inversion H3.
     SCase "ite sum".
       subst.
       inversion Hstep2 ; subst.
       SSCase "ite1". inversion H3.
       SSCase "ite2". inversion H4.
       SSCase "ite sum". reflexivity.
       SSCase "ite io". inversion H3.
       SSCase "ite s". inversion H3.
     SCase "ite io".
       subst.
       inversion Hstep2 ; subst.
       SSCase "ite1". inversion H3 ; subst ; inversion H5.
       SSCase "ite2". inversion H4 ; subst ; inversion H6.
       SSCase "ite abs". inversion H3.
       SSCase "ite unit". inversion H3.
       SSCase "ite pair". inversion H4.
       SSCase "ite sum". inversion H4.
       SSCase "ite io". reflexivity.
       SSCase "ite s". inversion H3 ; subst ; inversion H5.
     SCase "ite s".
       subst.
       inversion Hstep2 ; subst.
       SSCase "ite1". inversion H3 ; subst ; inversion H5.
       SSCase "ite2". inversion H4 ; subst ; inversion H6.
       SSCase "ite abs". inversion H3.
       SSCase "ite unit". inversion H3.
       SSCase "ite pair". inversion H4.
       SSCase "ite sum". inversion H4.
       SSCase "ite io". inversion H3 ; subst ; inversion H5.
       SSCase "ite s". reflexivity.

Qed.

End SmimplProp.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj32synthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv1) (Succ lv0)) (plus Zero (mult (Succ lv1) (Succ lv0)))).
Admitted.
QuickChick conj32synthconj2.