Require Import Reals.
Require Export veric.base.
Require Import veric.compcert_rmaps.
Require Import veric.slice.
Require Import veric.res_predicates.

(* This file contains lemmas regarding "superprecise",
and in principle, almost proving that "mapsto" is superprecise.

However, mapsto is not superprecise, because it's not quite true
that decode_val is injective.  The only reason is the treatment
of single-precision floating-point NaNs, where the conversion
from single-prec to double-prec loses one bit of information:
both quiet 32-bit NaNs and signalling 32-bit NaNs are quietly turned into
quite 64-bit NaNs.

If CompCert ever changes so that this does not happen, then
the lemmas in this file might become useful.

*)

Lemma int_of_bytes_uniq:
  forall i j, length i = length j -> int_of_bytes i = int_of_bytes j -> i = j.
Proof.
  induction i; intros.
 destruct j; inv H. auto.
 destruct j; inv H.
 specialize (IHi _ H2).
 simpl in H0.
do 2 rewrite (Z.add_comm (Byte.unsigned _)) in H0.
 remember (int_of_bytes j * 256 + Byte.unsigned i0) as v eqn:?H.
 symmetry in H0.
 rename i0 into b.
 pose proof (Zmod_unique _ _ _ _ H (Byte.unsigned_range _)).
 pose proof (Zmod_unique _ _ _ _ H0 (Byte.unsigned_range _)).
 assert (Byte.repr (Byte.unsigned a) = Byte.repr (Byte.unsigned b)) by congruence.
 repeat rewrite Byte.repr_unsigned in H4.
 subst b.
 f_equal. clear H1.
 apply IHi.
 omega.
Qed.

Lemma decode_int_uniq:
  forall i j, length i = length j -> decode_int i = decode_int j -> i=j.
Proof.
 unfold decode_int, rev_if_be.
 destruct Archi.big_endian.
 intros. rewrite <- (rev_involutive i). rewrite <- (rev_involutive j).
 f_equal.
 assert (length (rev i) = length (rev j)).
 repeat rewrite rev_length; auto.
 eapply int_of_bytes_uniq; eauto.
 apply int_of_bytes_uniq.
Qed.

Lemma decode_int_range:
  forall l N, N = two_p (8 * Z.of_nat (length l)) -> 0 <= decode_int l < N.
Proof.
intros; subst; revert l.
unfold decode_int.
assert (forall l, 0 <= int_of_bytes l < two_p (8 * Z.of_nat (length l))).
2: intros; rewrite <- rev_if_be_length; auto.
induction l.
simpl; omega.
simpl int_of_bytes. simpl length.
rewrite Nat2Z.inj_succ.
unfold Z.succ.
rewrite Z.mul_add_distr_l.
rewrite two_p_is_exp; try omega.
change (two_p (8*1)) with 256.
pose proof (Byte.unsigned_range a).
change Byte.modulus with 256 in H.
omega.
Qed.

Lemma sign_ext_injective:
 forall n i j,
    0 < n < Int.zwordsize ->
    0 <= i < two_p n ->
    0 <= j < two_p n ->
    Int.sign_ext n (Int.repr i) = Int.sign_ext n (Int.repr j) ->
    i=j.
Proof.
intros.
pose proof (Int.eqmod_sign_ext n (Int.repr i) H).
pose proof (Int.eqmod_sign_ext n (Int.repr j) H).
rewrite H2 in H3.
apply Int.eqmod_sym in H3.
pose proof (Int.eqmod_trans _ _ _ _ H3 H4).
rewrite Int.unsigned_repr in H5.
2: pose proof (two_p_monotone_strict n Int.zwordsize);
   change Int.max_unsigned with (two_p Int.zwordsize - 1);
   omega.
rewrite Int.unsigned_repr in H5.
2: pose proof (two_p_monotone_strict n Int.zwordsize);
   change Int.max_unsigned with (two_p Int.zwordsize - 1);
   omega.
apply Int.eqmod_small_eq in H5; auto.
Qed.

Lemma zero_ext_injective:
 forall n i j,
    0 <= n < Int.zwordsize ->
    0 <= i < two_p n ->
    0 <= j < two_p n ->
    Int.zero_ext n (Int.repr i) = Int.zero_ext n (Int.repr j) ->
    i=j.
Proof.
intros.
pose proof (Int.eqmod_zero_ext n (Int.repr i) H).
pose proof (Int.eqmod_zero_ext n (Int.repr j) H).
rewrite H2 in H3.
apply Int.eqmod_sym in H3.
pose proof (Int.eqmod_trans _ _ _ _ H3 H4).
rewrite Int.unsigned_repr in H5.
2: pose proof (two_p_monotone_strict n Int.zwordsize);
   change Int.max_unsigned with (two_p Int.zwordsize - 1);
   omega.
rewrite Int.unsigned_repr in H5.
2: pose proof (two_p_monotone_strict n Int.zwordsize);
   change Int.max_unsigned with (two_p Int.zwordsize - 1);
   omega.
apply Int.eqmod_small_eq in H5; auto.
Qed.

Lemma repr_decode_int_inj:
  forall l1 l2, length l1 = 4%nat -> length l2 = 4%nat ->
    Int.repr (decode_int l1) = Int.repr (decode_int l2) ->
    l1=l2.
Proof.
intros.
apply decode_int_uniq; [congruence | ].
rewrite <- (Int.unsigned_repr (decode_int l1)).
Focus 2.
pose proof (decode_int_range l1 _ (eq_refl _)).
rewrite H in H2.
change (two_p (8 * Z.of_nat 4)) with (Int.max_unsigned + 1) in H2.
omega.
rewrite <- (Int.unsigned_repr (decode_int l2)).
Focus 2.
pose proof (decode_int_range l2 _ (eq_refl _)).
rewrite H0 in H2.
change (two_p (8 * Z.of_nat 4)) with (Int.max_unsigned + 1) in H2.
omega.
congruence.
Qed.

Lemma repr_decode_int64_inj:
  forall l1 l2, length l1 = 8%nat -> length l2 = 8%nat ->
    Int64.repr (decode_int l1) = Int64.repr (decode_int l2) ->
    l1=l2.
Proof.
intros.
apply decode_int_uniq; [congruence | ].
rewrite <- (Int64.unsigned_repr (decode_int l1)).
Focus 2.
pose proof (decode_int_range l1 _ (eq_refl _)).
rewrite H in H2.
change (two_p (8 * Z.of_nat 8)) with (Int64.max_unsigned + 1) in H2.
omega.
rewrite <- (Int64.unsigned_repr (decode_int l2)).
Focus 2.
pose proof (decode_int_range l2 _ (eq_refl _)).
rewrite H0 in H2.
change (two_p (8 * Z.of_nat 8)) with (Int64.max_unsigned + 1) in H2.
omega.
congruence.
Qed.

Transparent Float.of_bits.
Transparent Float32.of_bits.

Lemma double_of_bits_inj:
  forall i j, Float.of_bits i = Float.of_bits j -> i=j.
Proof.
intros.
unfold Float.of_bits in H.
rewrite <- (Int64.repr_unsigned i).
rewrite <- (Int64.repr_unsigned j).
f_equal.
unfold Fappli_IEEE_bits.b64_of_bits in H.
rewrite <- (Fappli_IEEE_bits.bits_of_binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _) (Int64.unsigned i))
  by (apply Int64.unsigned_range).
rewrite <- (Fappli_IEEE_bits.bits_of_binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _) (Int64.unsigned j))
  by (apply Int64.unsigned_range).
f_equal; apply H.
Qed.

Require Import ZArith.
From compcert Require Import Fappli_IEEE Fcore_Zaux Fcore_generic_fmt.

Lemma binary_normalize_inj:
  forall s1 m1 e1 (h1 : bounded 24 128 m1 e1 = true),
  forall s2 m2 e2 (h2 : bounded 24 128 m2 e2 = true),
   binary_normalize 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s1 (Zpos m1)) e1 s1 =
   binary_normalize 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s2 (Zpos m2)) e2 s2 ->
  B754_finite 24 128 s1 m1 e1 h1 = B754_finite 24 128 s2 m2 e2 h2.
Proof.
intros s1 m1 e1 h1 s2 m2 e2 h2 Hn.
apply B2R_inj ; try easy.
assert (H: forall s m e h,
  B2R 24 128 (B754_finite 24 128 s m e h) =
  B2R 53 1024 (binary_normalize 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s (Zpos m)) e s)).
2: now rewrite 2!H, Hn.
clear.
intros s m e h.
generalize (binary_normalize_correct 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s (Zpos m)) e s).
rewrite round_generic ; auto with typeclass_instances.
rewrite  Fcore_Raux.Rlt_bool_true.
intros [-> _].
easy.
apply Raxioms.Rlt_trans with (1 := abs_B2R_lt_emax _ _ (B754_finite 24 128 s m e h)).
now apply Fcore_Raux.bpow_lt.
apply Fcore_FLT.generic_format_FLT.
assert (h' := generic_format_B2R 24 128 (B754_finite 24 128 s m e h)).
apply Fcore_FLT.FLT_format_generic in h'.
destruct h' as [f [H1 [H2 H3]]].
exists f.
rewrite <- H1.
repeat split.
apply Zlt_trans with (1 := H2).
now apply Zpower_lt.
now apply Zle_trans with (2 := H3).
easy.
Qed.

Lemma binary_normalize_finite:
  forall b m e,
  bounded (23 + 1) (2 ^ (8 - 1)) m e = true ->
 match
     binary_normalize 53 1024 eq_refl eq_refl mode_NE
          (cond_Zopp b (Z.pos m)) e b
 with B754_finite _ _ _ _ => True | _ => False
 end.
Proof.
intros s m e h.
generalize (binary_normalize_correct 53 1024 (eq_refl _) (eq_refl _) mode_NE (cond_Zopp s (Zpos m)) e s).
rewrite round_generic ; auto with typeclass_instances.
rewrite Fcore_Raux.Rlt_bool_true.
(****)
intros [H _].
assert (H': B2R 53 1024 (binary_normalize 53 1024 eq_refl eq_refl mode_NE (cond_Zopp s (Z.pos m)) e s) <> 0%R).
  rewrite H, <- (Fcore_float_prop.F2R_0 radix2 e).
  case s.
  now apply RIneq.Rlt_not_eq, Fcore_float_prop.F2R_lt_compat.
  now apply RIneq.Rgt_not_eq, Fcore_float_prop.F2R_lt_compat.
clear H.
destruct binary_normalize ; try easy ; now elim H'.
(****)
apply Raxioms.Rlt_trans with (1 := abs_B2R_lt_emax _ _ (B754_finite 24 128 s m e h)).
now apply Fcore_Raux.bpow_lt.
apply Fcore_FLT.generic_format_FLT.
assert (h' := generic_format_B2R 24 128 (B754_finite 24 128 s m e h)).
apply Fcore_FLT.FLT_format_generic in h'.
destruct h' as [f [H1 [H2 H3]]].
exists f.
rewrite <- H1.
repeat split.
apply Zlt_trans with (1 := H2).
now apply Zpower_lt.
now apply Zle_trans with (2 := H3).
easy.
Qed.

Lemma float32_preserves_payload:
 forall s pl,
    let '(s1,pl1) := Float.of_single_pl s pl in
      (s=s1 /\ (536870912 * (Pos.lor (proj1_sig pl) 4194304))%positive = proj1_sig pl1).
Proof.
 intros.
 unfold Float.of_single_pl.
 split; auto.
Qed.

Lemma pos_lor_inj:  (* not true *)
  forall k N (a b: nan_pl k),
     Zpower_nat 2 (Z.to_nat (k-2)) = Zpos N ->
     Pos.lor (proj1_sig a) N =  Pos.lor (proj1_sig b) N ->
    a=b.
Proof.
intros.
 destruct a as [a Ha]. destruct b as [b Hb].
 simpl in *.
 assert (a=b); [ | subst a; f_equal; apply Axioms.proof_irr].
Abort.

Inductive wishes_eq_horses := .

Lemma float32_payload_inj:
  wishes_eq_horses ->
  forall s1 pl1 s2 pl2,
    Float.of_single_pl s1 pl1= Float.of_single_pl s2 pl2 ->
    (s1,pl1) = (s2,pl2).
Proof.
intro WH; intros.
 pose proof (float32_preserves_payload s1 pl1).
 pose proof (float32_preserves_payload s2 pl2).
 rewrite H in H0. clear H.
 destruct (Float.of_single_pl s2 pl2).
 destruct H0,H1. subst.
 f_equal.
 rewrite <- H2 in H0; clear - WH H0.
 apply Pos.mul_reg_l in H0.
 contradiction WH.
Qed.

Lemma single_of_bits_inj:
  forall i j : Int.int, Float32.of_bits i = Float32.of_bits j -> i=j.
Proof.
intros.
unfold Float32.of_bits in H.
rewrite <- (Int.repr_unsigned i).
rewrite <- (Int.repr_unsigned j).
f_equal.
rewrite <- (Fappli_IEEE_bits.bits_of_binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _) (Int.unsigned i))
  by (apply Int.unsigned_range).
rewrite <- (Fappli_IEEE_bits.bits_of_binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _) (Int.unsigned j))
  by (apply Int.unsigned_range).
f_equal.
unfold Fappli_IEEE_bits.b32_of_bits in H.
match goal with |- ?A = ?B => remember A as u eqn:H9; remember B as v eqn:H10;
   clear H9 H10 end.
clear i j.

destruct u,v; auto; try congruence.
Qed.

Lemma Vint_inj: forall i j, Vint i = Vint j -> i=j.
Proof. congruence. Qed.

Lemma decode_val_uniq:
   (* Just not true any more, with Fragments *)
  forall ch b1 b2 v,
    v <> Vundef ->
    length b1 = size_chunk_nat ch ->
    length b2 = size_chunk_nat ch ->
    decode_val ch b1 = v ->
    decode_val ch b2 = v ->
    b1=b2.
Proof.
 intros.
 unfold size_chunk_nat in *.
 unfold decode_val in *.
 destruct (proj_bytes b1) eqn:B1.
subst v.
(*
unfold proj_pointer in H3.
destruct b1; try congruence.
destruct m; try congruence.
if_tac in H3; try congruence.
clear - H2 H3 H.
subst v.
unfold proj_pointer in *.
destruct b1; try congruence.
destruct m; try congruence.
destruct b2; try congruence. destruct m; try congruence.
destruct (check_pointer 4 b i (Pointer b i n :: b1)) eqn:?; try congruence.
destruct (check_pointer 4 b0 i0 (Pointer b0 i0 n0 :: b2)) eqn:?; try congruence.
inv H3.
clear H.
unfold check_pointer in *; simpl in *.
repeat match goal with
| H: ?A = true |- _ =>
  match A with
  | context [eq_block ?a ?b]  =>
     destruct (eq_block a b); simpl in *; try congruence
  | context [Int.eq_dec ?i ?j] =>
     destruct (Int.eq_dec i j); simpl in *; try congruence
  | context [match ?n with _ => _ end] =>
     destruct n; simpl in *; try congruence
  end
end.
} Unfocus.
destruct (proj_bytes b2) eqn:B2.
Focus 2. {
destruct ch; try congruence.
unfold proj_pointer in H3.
destruct b2; try congruence.
destruct m; try congruence.
if_tac in H3; try congruence.
} Unfocus.
pose proof (length_proj_bytes _ _ B1).
pose proof (length_proj_bytes _ _ B2).
rewrite <- H4 in *; rewrite <- H5 in *.
assert (l=l0).
Focus 2. {
clear - H6 B1 B2.
revert l0 b1 b2 B1 B2 H6; induction l; destruct l0; intros; inv H6.
destruct b1; inv B1. destruct b2; inv B2; auto.
destruct m; try congruence.
destruct (proj_bytes b2);  inv H0.
destruct m; inv H0.
destruct (proj_bytes b1);  inv H1.
destruct b1; inv B1.
destruct m; inv H0.
destruct (proj_bytes b1) eqn:?; inv H1.
destruct b2; inv B2.
destruct m; inv H0.
destruct (proj_bytes b2) eqn:?; inv H1.
specialize (IHl _ _ _ Heqo Heqo0).
f_equal; auto.
} Unfocus.
clear b1 b2 H4 H5 B1 B2.
clear H.
subst v.
destruct ch; try apply Vint_inj in H3;
simpl in H0,H1; unfold Pos.to_nat in H0,H1; simpl in H0,H1;
 (* this "try" takes care of all signed and unsigned bytes and shorts *)
try (apply decode_int_uniq; [ congruence | ];
(apply sign_ext_injective in H3 || apply zero_ext_injective in H3);
 [ congruence |  compute; split; congruence
 | apply decode_int_range; rewrite H1; reflexivity
 | apply decode_int_range; rewrite H0; reflexivity
 ]).

* (* Mint32 *)  apply repr_decode_int_inj; auto.
* (* Mint64 *) apply repr_decode_int64_inj; congruence.
* (* Mfloat32 *)
  inv H3.
  apply decode_int_uniq; [congruence | ].
  apply single_of_bits_inj in H2.
  apply repr_decode_int_inj in H2; auto.
  congruence.
  apply WH.
* (* Mfloat64 *)
  inv H3.
  apply decode_int_uniq; [congruence | ].
  apply double_of_bits_inj in H2.
  apply repr_decode_int64_inj in H2; auto.
  congruence.
Qed.
*)
Abort.

Lemma superprecise_ewand_lem1:
  forall S P: pred rmap, superprecise P ->
          S |-- P * TT ->
          S = (P * (ewand P S))%pred.
Proof.
intros.
apply pred_ext.
intros w ?. specialize (H0 w H1).
destruct H0 as [w1 [w2 [? [? _]]]].
exists w1; exists w2; split3; auto.
exists w1; exists w; split3; auto.
intros w [w1 [w2 [? [? ?]]]].
destruct H3 as [w3 [w4 [? [? ?]]]].
assert (w1=w3). eapply H; eauto.
apply join_core2 in H1; apply join_core2 in H3; unfold comparable; congruence.
subst w3.
pose proof (join_eq H1 H3); subst w4.
auto.
Qed.

Lemma superprecise_address_mapsto:
  wishes_eq_horses ->
  forall ch v sh loc,
   v<>Vundef -> superprecise (address_mapsto ch v sh loc).
Proof.
intro WH.
intros.
hnf; intros.
unfold address_mapsto in *.
destruct H0 as [b1 [[? [? ?]] ?]]; destruct H1 as [b2 [[? [? ?]] ?]].
(* just not true anymore, with Fragments *)
(*
assert (b1=b2) by (eapply decode_val_uniq; eauto).
subst b2.
assert (level w1 = level w2).
clear - H2; unfold comparable in H2.
rewrite <- level_core. rewrite <- (level_core w2).
congruence.
apply rmap_ext.
auto.
intro.
clear - H5 H8 H9 H2.
specialize (H5 l); specialize (H8 l).
hnf in H5,H8.
if_tac in H5.
destruct H5 as [p ?]. destruct H8 as [p' ?].
hnf in H0,H1.
rewrite H0,H1.
f_equal.
f_equal.
apply proof_irr.
congruence.
do 3 red in H5, H8.
unfold comparable in H2; clear - H5 H8 H2.
assert (core (w1 @ l) = core (w2 @ l)).
repeat rewrite core_resource_at.
congruence.
clear H2.
transitivity (core (w1 @ l)).
apply unit_core.
apply  identity_unit_equiv.
auto.
rewrite H.
symmetry.
apply unit_core.
apply  identity_unit_equiv.
auto.
Qed.

Require Import veric.extend_tc.
Require Import veric.seplog.

Lemma superprecise_mapsto:
 wishes_eq_horses ->
  forall sh t v1 v2,
    v2 <> Vundef ->
   superprecise (mapsto sh t v1 v2).
Proof.
intro WH.
assert (WH' := superprecise_address_mapsto WH); clear WH.
intros. rename H into Hv2.
hnf; intros.
unfold mapsto in *;
simpl in H,H0.
destruct (access_mode t); try contradiction.
destruct (type_is_volatile t); try contradiction.
destruct v1; try contradiction.
destruct H as [[_ H]|[Hz [u1 H]]]; try congruence.
destruct H0 as [[_ H0]|[Hz [u2 H0]]]; try congruence.
eapply WH'; eauto.
Qed.
*)
Abort.


From algebra Require Import Foundation.

Set Primitive Projections.
Set Universe Polymorphism.

Declare Scope cat.

Module Class.
  Section Laws.
    Context {O : Type} {H : O → O → Type}.
    Variable (idn : ∀ x, H x x) (seq : ∀ {x y z}, H x y → H y z → H x z).
    Record laws : Prop :=
      {seqL : ∀ {x y} (f : H x y), seq (idn _) f = f;
       seqR : ∀ {x y} (f : H x y), seq f (idn _) = f;
       seqA : ∀ {w x y z} (f : H w x) (g : H x y) (h : H y z), seq (seq f g) h = seq f (seq g h)}.
  End Laws.

  Record axioms (O : Type) (H : O → O → Type) :=
    Class
      {idn : ∀ x, H x x;
       seq : ∀ x y z, H x y → H y z → H x z;
       _laws : laws idn seq}.
End Class.

Record type := Pack {ob; hom; class : Class.axioms ob hom}.

Module Coercions.
  Coercion ob : type >-> Sortclass.
  Coercion hom : type >-> Funclass.
End Coercions.

Definition make_class :
  ∀ (O : Type)
    (H : O → O → Type)
    (idn : ⟨ "idn" ∷ ∀ {x}, H x x ⟩)
    (seq : ⟨ "seq" ∷ ∀ {x y z}, H x y → H y z → H x z ⟩),
    Class.laws (!idn) (!seq)
    → Class.axioms O H.
Proof.
  move=> O H [idn] [seq].
  econstructor; eauto.
Defined.

Import Coercions.

Section Operations.
  Context {𝒞 : type}.
  Definition idn := Class.idn _ _ (class 𝒞).
  Definition seq {x y z} (f : 𝒞 x y) (g : 𝒞 y z) := Class.seq _ _ (class 𝒞) _ _ _ f g.
  Definition cmp {x y z} (g : 𝒞 y z) (f : 𝒞 x y) := seq f g.
End Operations.

Module Notations.
  Infix "≫" := seq (at level 60).
  Infix "∘" := cmp (at level 60).
End Notations.

Import Notations.

Section Laws.
  Context {𝒞 : type}.

  Local Definition laws := Class._laws 𝒞 (hom 𝒞) (class 𝒞).
  Local Hint Resolve laws : core.

  Section UnitsLaws.
    Context {x y : 𝒞} {f : 𝒞 x y}.

    Fact seqL : idn _ ≫ f = f.
    Proof. by rewrite /seq /idn Class.seqL. Qed.

    Fact seqR : f ≫ idn _ = f.
    Proof. by rewrite /seq /idn Class.seqR. Qed.

    Fact cmpL : idn _ ∘ f = f.
    Proof. by rewrite /cmp seqR. Qed.

    Fact cmpR : f ∘ idn _ = f.
    Proof. by rewrite /cmp seqL. Qed.
  End UnitsLaws.

  Fact seqA : ∀ {w x y z} (f : 𝒞 w x) (g : 𝒞 x y) (h : 𝒞 y z), (f ≫ g) ≫ h = f ≫ (g ≫ h).
  Proof. move=> *; by rewrite /seq (Class.seqA _ _ laws). Qed.

  Local Fact unfold_cmp : ∀ x y z (f : 𝒞 x y) (g : 𝒞 y z), g ∘ f = f ≫ g.
  Proof. done. Qed.
End Laws.

Hint Rewrite @unfold_cmp @seqL @seqR @seqA : cat.

Definition to_tuple : type → {ob : Type & {hom : ob → ob → Type & {idn : ∀ x, hom x x & ∀ x y z, hom x y → hom y z → hom x z}}}.
Proof.
  move=> [? ? []]; econstructor; eauto.
Defined.

Lemma extensionality : ∀ 𝒞 𝒟, to_tuple 𝒞 = to_tuple 𝒟 → 𝒞 = 𝒟.
Proof.
  move=> [obC homC [idnC seqC clC]] [obD homD [idnD seqD clD]] Q.
  proj_eq Q obC obD.
  proj_eq Q homC homD.
  proj_eq Q idnC idnD.
  proj_eq Q seqC seqD.
  replace clC with clD; auto.
Qed.

Instance cat_ext : ExtLaw type _ :=
  {ext_law := extensionality}.

Module Exports.
  Export Notations.
  Export Coercions.
End Exports.

Ltac make :=
  unshelve apply: Pack.

Ltac axioms :=
  unshelve apply: make_class.

Example TYPE : type.
make.
- exact Type.
- move=> A B.
  exact (A → B).
- axioms.
  + axiom "idn"; auto.
  + axiom "seq"; auto.
  + abstract (split; auto).
Defined.

Example Op (𝒞 : type) : type.
make.
- exact: 𝒞.
- move=> x y.
  exact: (𝒞 y x).
- axioms.
  + axiom "idn"; apply: idn.
  + axiom "seq" => *; apply: seq; eauto.
  + abstract (split => *//=; by autorewrite with cat).
Defined.


Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Monads.OptionMonad.
Require Import MirrorCore.ExprI.

Set Implicit Arguments.
Set Strict Implicit.

Section AppAbs.
  Variable typ : Set.
  Context {RType_typ : RType typ}.

  Variable expr : Set.
  Context {Expr_expr : Expr typ expr}.

  Context {Typ2_fun : Typ2 _ RFun}.

  Class Abstraction :=
  { Abs : typ -> expr -> expr
  ; Abs_match : expr -> forall T, (typ -> expr -> T) -> T -> T
  }.

  Class AbstractionOk (A : Abstraction) :=
  { exprD_Abs : forall (tus : tenv typ) (tvs : tenv typ) e t t',
      exprD tus tvs t' (Abs t e) =
      typ2_match (Typ2:=Typ2_fun)
                 (fun T => option (exprT tus tvs T)) t'
                 (fun d r =>
                    bind (m := option)
                         (type_cast d t)
                         (fun cast =>
                            bind (m := option)
                                 (exprD tus (t :: tvs) r e)
                                 (fun val =>
                                    ret (fun us vs x =>
                                           val us (Hcons (F:=typD) (Relim (fun x => x) (Rsym cast) x) vs)))))
                  None
  ; Abs_match_iota : forall t e,
      Abs_match (Abs t e) = fun T f _ => f t e
  ; Abs_match_case : forall e,
         (exists t' e',
          e = Abs t' e' /\
          Abs_match e = fun T f _ => f t' e')
      \/ ((~exists t' e', e = Abs t' e') /\
          Abs_match e = fun T _ d => d)
  }.

  Class Application :=
  { App : expr -> expr -> expr
  ; App_match : expr -> forall T, (expr -> expr -> T) -> T -> T
  }.

  Definition exprT_Abs {tus tvs t u}
  : exprT tus (t :: tvs) (typD u) ->
    exprT tus tvs (typD (typ2 t u)) :=
    match eq_sym (typ2_cast (F:=RFun) t u) in _ = T
          return exprT tus (t :: tvs) (typD u) -> exprT tus tvs T
    with
    | eq_refl => fun f => fun us vs x => f us (Hcons x vs)
    end.

  Definition exprT_App {tus : tenv typ} {tvs : tenv typ} {T U : typ}
  : exprT tus tvs (typD (typ2 T U)) ->
    exprT tus tvs (typD T) ->
    exprT tus tvs (typD U) :=
    match eq_sym (typ2_cast (F:=RFun) T U) in _ = t
          return exprT tus tvs t ->
                 exprT tus tvs (typD T) ->
                 exprT tus tvs (typD U)
    with
    | eq_refl => fun F X us vs => (F us vs) (X us vs)
    end.

  Class ApplicationOk (A : Application) :=
  { exprD_App : forall (tus : tenv typ) (tvs : tenv typ) f x d r F X,
      exprD tus tvs (typ2 d r) f = Some F ->
      exprD tus tvs d x = Some X ->
      exprD tus tvs r (App f x) = Some (exprT_App F X)
  ; match_App_iota : forall f e, App_match (App f e) = fun T r _ => r f e
  ; match_App_case : forall e,
         (exists t' e',
          e = App t' e' /\
          App_match e = fun T f _ => f t' e')
      \/ ((~exists t' e', e = App t' e') /\
          App_match e = fun T _ d => d)
  }.

End AppAbs.

Arguments exprT_App {typ _ _ _ _ _ _} _ _ _ _ /.
Arguments exprT_Abs {typ _ _ _ _ _ _} _ _ _ /.
Arguments ApplicationOk {typ _ expr _ _} _ : rename.
Arguments AbstractionOk {typ _ expr _ _} _ : rename.


(** * Lifting saturation from categories to sigma/subcategories *)
Require Import Category.Core Category.Morphisms.
Require Import Category.Univalent.
Require Import Category.Sigma.Core Category.Sigma.OnObjects Category.Sigma.OnMorphisms.
Require Import HoTT.Types HoTT.Basics HoTT.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Notation pr1_type := Overture.pr1 (only parsing).

Local Open Scope path_scope.
Local Open Scope morphism_scope.

Local Open Scope function_scope.

(** TODO: Following a comment from Mike Shulman
    (https://github.com/HoTT/HoTT/pull/670##issuecomment-68907833),
    much of this can probably be subsumed by a general theorem proving
    that univalence lifts along suitable pseudomonic functors
    (http://ncatlab.org/nlab/show/pseudomonic+functor). *)

(** ** Lift saturation to sigma on objects whenever the property is an hProp *)
Section onobjects.
  Variable A : PreCategory.
  Variable Pobj : A -> Type.

  Global Instance iscategory_sigT_obj `{forall a, IsHProp (Pobj a), A_cat : IsCategory A}
  : IsCategory (sigT_obj A Pobj).
  Proof.
    intros s d.
    (* This makes typeclass search go faster. *)
    pose @isequiv_compose.
    refine (isequiv_homotopic
              ((issig_full_isomorphic (sigT_obj A Pobj) _ _ o (issig_full_isomorphic A _ _)^-1)
                 o (@idtoiso A s.1 d.1)
                 o pr1_path)
              _).
    intro x; destruct x.
    reflexivity.
  Defined.

  (** The converse is not true; consider [Pobj := fun _ => Empty]. *)
End onobjects.

(** ** Lift saturation to sigma on objects whenever the property is automatically and uniquely true of isomorphisms *)
Section onmorphisms.
  Variable A : PreCategory.
  Variable Pmor : forall s d, morphism A s d -> Type.

  Local Notation mor s d := { m : _ | Pmor s d m }%type.
  Context `(HPmor : forall s d, IsHSet (mor s d)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Hypothesis P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).

  Hypothesis P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.

  Hypothesis P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.

  Local Notation A' := (@sigT_mor A Pmor HPmor Pidentity Pcompose P_associativity P_left_identity P_right_identity).

  (** To have any hope of relating [IsCategory A] with [IsCategory
      A'], we assume that [Pmor] is automatically and uniquely true on
      isomorphisms. *)
  Context `{forall s d m, IsIsomorphism m -> Contr (Pmor s d m)}.

  Definition iscategory_sigT_mor_helper {s d}
  : @Isomorphic A' s d -> @Isomorphic A s d.
  Proof.
    refine ((issig_full_isomorphic A _ _) o _ o (issig_full_isomorphic A' _ _)^-1).
    exact (functor_sigma
             pr1_type
             (fun _ =>
                functor_sigma
                  pr1_type
                  (fun _ =>
                     functor_sigma
                       pr1_path
                       (fun _ => pr1_path)))).
  Defined.

  Local Instance isequiv_iscategory_sigT_mor_helper s d
  : IsEquiv (@iscategory_sigT_mor_helper s d).
  Proof.
    simple refine (isequiv_adjointify _ _ _ _).
    { intro e.
      exists (e : morphism _ _ _; center _).
      exists (e^-1%morphism; center _);
        simple refine (path_sigma _ _ _ _ _);
        first [ apply left_inverse
              | apply right_inverse
              | by apply path_ishprop ]. }
    { intro; by apply path_isomorphic. }
    { intros x; apply path_isomorphic.
      exact (path_sigma' _ 1 (contr _)). }
  Defined.

  Global Instance iscategory_sigT_mor `{A_cat : IsCategory A}
  : IsCategory A'.
  Proof.
    intros s d.
    (* Use [equiv_compose] rather than "o" to speed up typeclass search. *)
    refine (isequiv_homotopic
              (equiv_compose iscategory_sigT_mor_helper^-1 (@idtoiso _ _ _))
              _).
    intro x; apply path_isomorphic; cbn.
    destruct x; refine (path_sigma' _ 1 (contr _)).
  Defined.

  Definition iscategory_from_sigT_mor `{A'_cat : IsCategory A'}
  : IsCategory A.
  Proof.
    intros s d.
    refine (isequiv_homotopic
              (iscategory_sigT_mor_helper
                 o (@idtoiso A' _ _))
              _).
    intro x; apply path_isomorphic; cbn.
    destruct x; reflexivity.
  Defined.

  Global Instance isequiv_iscategory_sigT_mor `{Funext}
  : IsEquiv (@iscategory_sigT_mor).
  Proof.
    refine (isequiv_iff_hprop _ (@iscategory_from_sigT_mor)).
  Defined.
End onmorphisms.

(** ** Lift saturation to sigma on both objects and morphisms *)
Section on_both.
  Variable A : PreCategory.
  Variable Pobj : A -> Type.

  Local Notation obj := { x : _ | Pobj x }%type (only parsing).

  Variable Pmor : forall s d : obj, morphism A s.1 d.1 -> Type.

  Local Notation mor s d := { m : _ | Pmor s d m }%type (only parsing).
  Context `(HPmor : forall s d, IsHSet (mor s d)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x.1; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Hypothesis P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).

  Hypothesis P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.

  Hypothesis P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.

  Local Notation A' := (@sigT A Pobj Pmor HPmor Pidentity Pcompose P_associativity P_left_identity P_right_identity).

  (** We must assume some relation on the properties; we assume that
      the path space of the extra data on objects is classified by
      isomorphisms of the extra data on objects. *)
  Local Definition Pmor_iso_T s d m m' left right :=
    ({ e : Pmor s d m
     | { e' : Pmor d s m'
       | { _ : transport (Pmor _ _) ((left : m' o m = 1)%morphism) (Pcompose e' e) = Pidentity _
         | transport (Pmor _ _) ((right : m o m' = 1)%morphism) (Pcompose e e') = Pidentity _ } } }).

  Global Arguments Pmor_iso_T / .

  Local Definition Pmor_iso_T' x (xp xp' : Pobj x)
    := { e : Pmor (x; xp) (x; xp') 1
       | { e' : Pmor (x; xp') (x; xp) 1
         | { _ : Pcompose e' e = Pcompose (Pidentity _) (Pidentity _)
           | Pcompose e e' = Pcompose (Pidentity _) (Pidentity _) } } }.

  Global Arguments Pmor_iso_T' / .

  Local Definition Pidtoiso x (xp xp' : Pobj x) (H : xp = xp')
  : Pmor_iso_T' xp xp'.
  Proof.
    destruct H.
    exists (Pidentity _).
    exists (Pidentity _).
    split; reflexivity.
  Defined.

  Global Arguments Pidtoiso / .

  (** TODO: generalize this to a theorem [forall A P, IsHSet A -> IsHSet { x : A | P x } -> forall x, IsHSet (P x)], [inO_unsigma] of ##672 *)
  Local Instance ishset_pmor {s d m} : IsHSet (Pmor s d m).
  Proof.
    intros p q.
    apply hprop_allpath.
    let H := constr:(_ : forall x y : mor s d, IsHProp (x = y)) in
    pose proof (@path_ishprop _ (H (m; p) (m; q))) as H'.
    intros x y.
    specialize (H' (path_sigma' _ 1 x) (path_sigma' _ 1 y)).
    unfold path_sigma', path_sigma in H'.
    apply (ap (path_sigma_uncurried (Pmor s d) (m; p) (m; q)))^-1 in H'.
    assert (H'' : H'..1 = idpath) by apply path_ishprop.
    exact (transport (fun H'1 => transport _ H'1 _ = _) H'' H'..2).
  Defined.

  Local Definition Pmor_iso_adjust x xp xp'
  : (Pmor_iso_T (x; xp) (x; xp') 1 1 (left_identity _ _ _ _) (right_identity _ _ _ _))
      <~> Pmor_iso_T' xp xp'.
  Proof.
    refine (equiv_functor_sigma' (equiv_idmap _) _); intro.
    refine (equiv_functor_sigma' (equiv_idmap _) _); intro.
    refine (equiv_functor_sigma' (equiv_iff_hprop _ _) (fun _ => equiv_iff_hprop _ _));
      cbn; intro H';
      first [ apply moveL_transport_V in H'
                | apply moveR_transport_p ];
      refine (H' @ _);
      first [ refine (_ @ ((P_left_identity (identity (x; _)))^)..2)
                | refine ((((P_left_identity (identity (x; _)))^)..2)^ @ _) ];
      refine (ap (fun p => transport _ p _) (path_ishprop _ _)).
  Defined.

  Global Arguments Pmor_iso_adjust / .

  Local Definition iso_A'_code {s d}
  : (@Isomorphic A' s d)
    -> { e : @Isomorphic A s.1 d.1
       | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }.
  Proof.
    intro e.
    simple refine (_; _).
    { exists (e : morphism _ _ _).1.
      exists (e^-1%morphism).1.
      - exact (@left_inverse _ _ _ e e)..1.
      - exact (@right_inverse _ _ _ e e)..1. }
    { exists (e : morphism _ _ _).2.
      exists (e^-1%morphism).2; cbn.
      exists (((@left_inverse _ _ _ e e))..2).
      exact (@right_inverse _ _ _ e e)..2. }
  Defined.

  Local Definition iso_A'_decode_helper {s d}
        (e : { e : @Isomorphic A s.1 d.1
             | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse })
  : @IsIsomorphism A' _ _ (e.1:morphism A s.1 d.1; (e.2).1).
  Proof.
    eexists. Unshelve.
    3:exact (e.1^-1%morphism; e.2.2.1).
    { refine (path_sigma' _ left_inverse e.2.2.2.1). }
    { refine (path_sigma' _ right_inverse e.2.2.2.2). }
  Defined.

  Local Definition iso_A'_decode {s d}
  : { e : @Isomorphic A s.1 d.1
    | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }
    -> (@Isomorphic A' s d).
  Proof.
    intro e.
    eexists. Unshelve.
    2:exact (e.1 : morphism _ _ _; e.2.1).
    apply iso_A'_decode_helper.
  Defined.

  Local Definition equiv_iso_A'_eisretr_helper {s d}
        (x : {e : @Isomorphic A s.1 d.1
             | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }%type)
  : transport
      (fun e : @Isomorphic A s.1 d.1 =>
         Pmor_iso_T s d e e^-1 left_inverse right_inverse)
      (path_isomorphic (iso_A'_code (iso_A'_decode x)).1 x.1 1)
      (iso_A'_code (iso_A'_decode x)).2 = x.2.
  Proof.
    simple refine (path_sigma _ _ _ _ _); cycle 1.
    (* Speed up typeclass search: *)
    1:pose @trunc_sigma; pose @istrunc_paths;
      simple refine (path_sigma _ _ _ _ (path_ishprop _ _)).
    all:repeat match goal with
                 | [ |- (transport ?P ?p ?z).1 = _ ] => rewrite (@ap_transport _ P _ _ _ p (fun _ x => x.1))
                 | [ |- (transport ?P ?p ?z).2.1 = _ ] => rewrite (@ap_transport _ P _ _ _ p (fun _ x => x.2.1))
                 | [ |- transport (fun _ => ?x) _ _ = _ ] => rewrite transport_const
                 | [ |- transport (fun x => ?f (@morphism_inverse _ _ _ (@morphism_isomorphic _ _ _ x) _)) _ _ = _ ]
                   => rewrite (@transport_compose _ _ _ _ f (fun x => (@morphism_inverse _ _ _ (@morphism_isomorphic _ _ _ x) (@isisomorphism_isomorphic _ _ _ x))))
                 | [ |- transport (?f o ?g) _ _ = _ ] => rewrite (@transport_compose _ _ _ _ f g)
                 | [ |- transport (fun x => ?f (?g x)) _ _ = _ ] => rewrite (@transport_compose _ _ _ _ f g)
                 | [ |- context[ap (@morphism_isomorphic ?a ?b ?c) (path_isomorphic ?i ?j ?x)] ]
                   => change (ap (@morphism_isomorphic a b c)) with ((path_isomorphic i j)^-1%function);
                     rewrite (@eissect _ _ (path_isomorphic i j) _ x)
                 | [ |- context[ap (fun e : Isomorphic _ _ => @morphism_inverse ?C ?s ?d _ _) (path_isomorphic ?i ?j ?x)] ]
                   => rewrite (@ap_morphism_inverse_path_isomorphic C s d i j x 1)
                 | [ |- transport ?P 1 ?x = ?y ] => change (x = y)
                 | [ |- (((iso_A'_code (iso_A'_decode ?x)).2).2).1 = ((?x.2).2).1 ] => reflexivity
                 | [ |- (((iso_A'_code (iso_A'_decode ?x)).2).1) = ((?x.2).1) ] => reflexivity
               end.
  Qed.

  Local Definition equiv_iso_A' {s d}
  : (@Isomorphic A' s d)
      <~> { e : @Isomorphic A s.1 d.1
          | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }.
  Proof.
    refine (equiv_adjointify iso_A'_code iso_A'_decode _ _).
    { intro.
      simple refine (path_sigma _ _ _ _ _).
      { apply path_isomorphic; reflexivity. }
      { apply equiv_iso_A'_eisretr_helper. }  }
    { intro.
      apply path_isomorphic.
      reflexivity. }
  Defined.

  Context `{Pisotoid : forall x xp xp', IsEquiv (@Pidtoiso x xp xp')}.

  Local Arguments Pmor_iso_T : simpl never.

  Global Instance iscategory_sigT `{A_cat : IsCategory A}
  : IsCategory A'.
  Proof.
    intros s d.
    simple notypeclasses refine (isequiv_homotopic
              ((equiv_iso_A'^-1)
                 o (functor_sigma _ _)
                 o (path_sigma_uncurried _ _ _)^-1)
              _); [exact _ | | | exact _ | |].
    (* [try exact _] leaves the third remaining goal unchanged, but takes ~9s to do so. *)
    { exact (@idtoiso A _ _). }
    { destruct s as [s0 s1], d as [d0 d1]; cbn.
      intro p; destruct p; cbn.
      refine ((@Pmor_iso_adjust s0 s1 d1)^-1 o _).
      refine (@Pidtoiso _ _ _). }
    { (* Do this in small steps to make it fast. *)
      ntc_refine isequiv_compose. 1:apply isequiv_inverse.
      ntc_refine isequiv_compose. 2:apply isequiv_inverse.
      ntc_refine isequiv_functor_sigma. 1:apply A_cat.
      destruct s, d.
      simpl Overture.pr1.
      intro p; destruct p.
      eapply @isequiv_compose.
      - exact _.
      - eapply @isequiv_inverse. }
    { intro p; apply path_isomorphic; destruct p.
      reflexivity. }
  Defined.
End on_both.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Init.Logic.
Require Import Coq.Arith.PeanoNat.
Require Import VerifiedVerifier.Maps.

Inductive register : Set :=
| rax
| rbx
| rcx
| rdx
| rbp
| rsp
| rsi
| rdi
| rip
| r8
| r9
| r10
| r11
| r12
| r13
| r14
| r15.

Inductive value : Set :=
| Const : nat -> value.

Inductive opcode : Set :=
| Add : opcode
| Sub : opcode
| Mult : opcode
| Div : opcode.

Fixpoint update {A} (l : list A) (i : nat) (v : A) : list A :=
match l, i with
| nil , _ => l
| h :: t, 0 => v :: t
| h :: t, S i' => update t i' v
end.

(* List from https://en.wikibooks.org/wiki/X86_Assembly/Control_Flow#Jump_if_Zero *)
Inductive conditional :=
| Not_Equal : register -> register -> conditional
| Equal : register -> register -> conditional
| Greater : register -> register -> conditional       (*signed*)
| Greater_Equal : register -> register -> conditional (*signed*)
| Above : register -> register -> conditional         (*unsigned*)
| Above_Equal : register -> register -> conditional   (*unsigned*)
| Lesser : register -> register -> conditional        (*signed*)
| Lesser_Equal : register -> register -> conditional  (*signed*)
| Below : register -> register -> conditional         (*unsigned*)
| Below_Equal : register -> register -> conditional   (*unsigned*)
| Counter_Register_Zero.

Definition label := nat.

Inductive instr_class : Type :=
| Heap_Read : register -> register -> register -> register -> instr_class
| Heap_Write : register -> register -> register -> register -> instr_class
| Heap_Check : register -> instr_class
| Call_Check : register -> instr_class
| Reg_Move : register -> register -> instr_class
| Reg_Write : register -> value -> instr_class
| Stack_Expand_Static : nat -> instr_class
| Stack_Expand_Dynamic : nat -> instr_class
| Stack_Contract : nat -> instr_class
| Stack_Read : register -> nat -> instr_class
| Stack_Write : nat -> register -> instr_class
| Op : opcode -> list register -> list register -> instr_class
| Indirect_Call : register -> instr_class
| Direct_Call : nat -> instr_class
| Branch : conditional -> label -> label -> instr_class
| Jmp : label -> instr_class
| Get_Globals_Base : register -> register -> instr_class
| Globals_Read : register -> nat -> register -> instr_class
| Globals_Write : register -> nat -> register -> instr_class
| Ret : instr_class.

Definition terminating_instr_class i :=
match i with
| Branch _ _ _ | Jmp _ | Ret => true
| _ => false
end.

Definition nonterminating_instr_class i :=
negb (terminating_instr_class i).

Record instr_ty := {
  instr : instr_class;
  addr : nat;
}.

Definition basic_block := list instr_ty.

Definition wf_instr_ty (i : instr_ty) (nodes : list basic_block) :=
match i.(instr) with
| Branch _ t_label f_label => (t_label < length nodes) /\ (f_label < length nodes)
| Jmp j_label => j_label < length nodes
| Ret => True
| _ => False
end.

Fixpoint wf_bb (bb : basic_block) (nodes : list basic_block) :=
match bb with
| i :: bb' => wf_instr_ty i nodes /\ wf_bb bb' nodes
| nil => True
end.

Structure ControlFlowGraph := {
  V : list basic_block;
  E : list (nat * nat);
(*  E : list ({n : nat | n < length V} * {n : nat | n < length V}); *)
  wf_cfg : forall bb, In bb V -> wf_bb bb V;
}.

Definition function := ControlFlowGraph.

Structure program := {
  Funs : list ControlFlowGraph;
  wf_addrs : forall f f' v v' i i' instr instr',
      In f Funs ->
      In f' Funs ->
      In v f.(V) ->
      In v' f'.(V) ->
      Some instr = (nth_error v i) ->
      Some instr' = (nth_error v' i') ->
      instr.(addr) = instr'.(addr) ->
      (f = f' /\
       v = v' /\
       i = i');
}.

Definition register_eq_dec : forall (x y : register), {x=y} + {x<>y}.
  intros; decide equality.
Defined.

Definition conditional_eq_dec : forall (x y : conditional), {x=y} + {x<>y}.
  intros; decide equality; try apply register_eq_dec.
Defined.

Definition value_eq_dec : forall (x y: value), {x=y} + {x<>y}.
  intros; decide equality; try apply register_eq_dec; try apply Nat.eq_dec.
Defined.

Definition instr_class_eq_dec : forall (x y : instr_class), {x=y} + {x<>y}.
  intros; decide equality; try apply register_eq_dec; try apply value_eq_dec; try apply string_dec;
  try apply conditional_eq_dec; decide equality; decide equality.
Defined.

Definition instr_ty_eq_dec : forall (x y : instr_ty), {x=y} + {x<>y}.
  intros; decide equality. decide equality. apply instr_class_eq_dec.
Defined.

Inductive flag : Set :=
| of
| sf
| zf
| pf
| cf.

Lemma register_get_after_set_eq : forall A (abs_regs : total_map register A) reg v,
  (t_update register_eq_dec abs_regs reg v) reg = v.
Proof.
  intros A abs_regs reg v. unfold t_update. destruct (register_eq_dec reg reg).
  - reflexivity.
  - exfalso. apply n. reflexivity.
Qed.

Lemma register_get_after_set_neq : forall A (abs_regs : total_map register A) reg1 reg2 v,
    reg1 <> reg2 ->
    (t_update register_eq_dec abs_regs reg2 v) reg1 = abs_regs reg1.
Proof.
  intros A abs_regs reg1 reg2 v Heq. unfold t_update. destruct (register_eq_dec reg2 reg1).
  - exfalso. apply Heq. auto.
  - reflexivity.
Qed.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md descbrides the contents of each file and
   provides instructions to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - UNIT RULES                                           *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import useless.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - UNIT RULES - DEFINITIONS                             *)
(* --------------------------------------------------------------------- *)

Section UnitRules.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation nlist:= (list non_terminal).
Notation tlist:= (list terminal).

Inductive unit (g: cfg non_terminal terminal) (a: non_terminal): non_terminal -> Prop:=
| unit_rule: forall (b: non_terminal),
             rules g a [inl b] -> unit g a b
| unit_trans: forall b c: non_terminal,
              unit g a b ->
              unit g b c ->
              unit g a c.

Inductive g_unit_rules (g: cfg _ _): non_terminal -> sf -> Prop :=
| Lift_direct' :
       forall left: non_terminal,
       forall right: sf,
       (forall r: non_terminal,
       right <> [inl r]) -> rules g left right ->
       g_unit_rules g left right
| Lift_indirect':
       forall a b: non_terminal,
       unit g a b ->
       forall right: sf,
       rules g b right ->
       (forall c: non_terminal,
       right <> [inl c]) ->
       g_unit_rules g a right.

Lemma unit_exists:
forall g: cfg _ _,
forall a b: non_terminal,
unit g a b ->
exists c : sf, rules g a c.
Proof.
intros g a b H.
induction H.
- exists [inl b].
  exact H.
- exact IHunit1.
Qed.

Lemma g_unit_finite:
forall g: cfg _ _,
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In (start_symbol g) ntl /\
forall left: non_terminal,
forall right: sf,
g_unit_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite g) as [n [ntl [tl H1]]].
exists n, ntl, tl.
split.
- destruct H1 as [H1 _].
  exact H1.
- destruct H1 as [_ H1].
  intros left right H2.
  inversion H2.
  + subst.
    specialize (H1 left right H0).
    destruct H1 as [H4 [H5 H6]].
    split.
    * exact H4.
    * {
      split.
      - exact H5.
      - exact H6.
      }
  + subst.
    apply unit_exists in H.
    destruct H as [c H4].
    split.
    * specialize (H1 b right H0).
      destruct H1 as [H1 _].
      exact H1.
    * {
      split.
      - specialize (H1 left c H4).
        destruct H1 as [_ [H1 _]].
        exact H1.
      - specialize (H1 b right H0).
        destruct H1 as [_ [_ H1]].
        exact H1.
      }
Qed.

Definition g_unit (g: cfg _ _): cfg _ _ := {|
start_symbol:= start_symbol g;
rules:= g_unit_rules g;
rules_finite:= g_unit_finite g
|}.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - UNIT RULES - LEMMAS AND THEOREMS                     *)
(* --------------------------------------------------------------------- *)

Lemma unit_not_unit:
forall g: cfg _ _,
forall a b: non_terminal,
~ unit (g_unit g) a b.
Proof.
intros g a0 b0 H.
induction H.
- inversion H.
  + specialize (H0 b).
    destruct H0.
    reflexivity.
  + specialize (H2 b).
    destruct H2.
    reflexivity.
- exact IHunit1.
Qed.

Lemma unit_derives:
forall g: cfg _ _,
forall a b: non_terminal,
unit g a b ->
derives g [inl a] [inl b].
Proof.
intros g a b H.
induction H.
- apply derives_start.
  exact H.
- apply derives_trans with (s2:=[inl b]).
  + exact IHunit1.
  + exact IHunit2.
Qed.

Lemma rules_g_unit_g:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules (g_unit g) left right ->
rules g left right \/ derives g [inl left] right.
Proof.
intros g left right H.
simpl in H.
inversion H.
- left.
  exact H1.
- right.
  subst.
  replace right with ([] ++ right ++ []).
  + apply derives_step with (left:=b).
    * apply unit_derives in H0.
      exact H0.
    * exact H1.
  + rewrite app_nil_l.
    rewrite app_nil_r.
    reflexivity.
Qed.

Lemma rules_g_unit_g':
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules (g_unit g) left right ->
rules g left right \/
exists left': non_terminal, unit g left left' /\ rules g left' right.
Proof.
intros g left right H.
inversion H.
- left.
  exact H1.
- right.
  exists b.
  split.
  + exact H0.
  + exact H1.
Qed.

Lemma rules_g_unit_not_unit:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
(rules (g_unit g) left right) ->
(~ exists n: non_terminal, right = [inl n]).
Proof.
intros g left right H1 H2.
inversion H1.
- subst.
  destruct H2 as [n H2].
  specialize (H n).
  contradiction.
- subst.
  destruct H2 as [n H2].
  specialize (H3 n).
  contradiction.
Qed.

Lemma generates_g_unit_g:
forall g: cfg _ _,
forall s: sf,
generates (g_unit g) s -> generates g s.
Proof.
unfold generates.
intros g s H.
simpl in H.
remember [inl (start_symbol g)] as w1.
induction H.
- apply derives_refl.
- apply rules_g_unit_g in H0.
  destruct H0 as [H0 | H0].
  + apply derives_step with (left:=left).
    * apply IHderives.
      exact Heqw1.
    * exact H0.
  + apply derives_subs with (s3:=[inl left]).
    * apply IHderives.
      exact Heqw1.
    * exact H0.
Qed.

Lemma rules_g_g_unit:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules g left right ->
(forall n: non_terminal, right <> [inl n]) ->
rules (g_unit g) left right.
Proof.
intros g left right H1 H2.
simpl.
apply Lift_direct'.
- exact H2.
- exact H1.
Qed.

Lemma derives3_g_g_unit:
forall g: cfg _ _,
forall n: non_terminal,
forall s: sentence,
derives3 g n s -> derives3 (g_unit g) n s.
Proof.
intros g.
intros n s H.
apply derives3_ind_2 with (g:=g) (P:=derives3 (g_unit g)) (P0:=derives3_aux (g_unit g)).
- intros n0 lt H1.
  apply derives3_rule.
  apply rules_g_g_unit in H1.
  + exact H1.
  + destruct lt; discriminate.
- intros n0 ltnt lt H1 H2 H3.
  destruct ltnt.
  + apply rules_g_g_unit in H1.
    * inversion H2.
      subst.
      apply derives3_rule.
      exact H1.
    * discriminate.
  + destruct ltnt.
    * {
      destruct s0.
      - apply exists_rule_derives3_aux in H2.
        destruct H2 as [H2 | H2].
        + assert (H10: rules (g_unit g) n0 (map term_lift lt)).
            {
            apply Lift_indirect' with (b:=n1).
            * apply unit_rule.
              exact H1.
            * exact H2.
            * destruct lt; discriminate.
            }
          apply derives3_rule.
          exact H10.
        + destruct H2 as [right [H4 H5]].
          apply exists_rule_derives3_aux in H3.
          destruct H3 as [H3 | H3].
          * apply rules_g_unit_g' in H3.
            {
            destruct H3 as [H3 | H3].
            - assert (H10: rules (g_unit g) n0 (map term_lift lt)).
                {
                apply Lift_indirect' with (b:=n1).
                - apply unit_rule.
                  exact H1.
                - exact H3.
                - intros c0.
                  destruct lt.
                  + discriminate.
                  + discriminate.
                }
              apply derives3_rule.
              exact H10.
            - destruct H3 as [left' [H6 H7]].
              assert (H10: rules (g_unit g) n0 (map term_lift lt)).
                {
                apply Lift_indirect' with (b:=left').
                - apply unit_trans with (b:=n1).
                  + apply unit_rule.
                    exact H1.
                  + exact H6.
                - exact H7.
                - intros c0.
                  destruct lt; discriminate.
                }
              apply derives3_rule.
              exact H10.
            }
          * destruct H3 as [right0 [H6 H7]].
            assert (H6':=H6).
            apply rules_g_unit_not_unit in H6'.
            apply rules_g_unit_g' in H6.
            {
            destruct H6 as [H6 | H6].
            - apply derives3_step with (ltnt:=right0).
              + apply Lift_indirect' with (b:=n1).
                * apply unit_rule.
                  exact H1.
                * exact H6.
                * apply not_exists_forall_not.
                  exact H6'.
              + exact H7.
            - apply derives3_step with (ltnt:=right0).
              + destruct H6 as [left' [H8 H9]].
                apply Lift_indirect' with (b:=left').
                * {
                  apply unit_trans with (b:=n1).
                  - apply unit_rule.
                    exact H1.
                  - exact H8.
                  }
                * exact H9.
                * apply not_exists_forall_not.
                  exact H6'.
              + exact H7.
            }
      - apply rules_g_g_unit in H1.
        + apply derives3_step with (ltnt:=[inr t]).
          * exact H1.
          * exact H3.
        + discriminate.
      }
    * {
      apply rules_g_g_unit in H1.
      - apply derives3_step with (ltnt:=(s0 :: s1 :: ltnt)).
        + exact H1.
        + exact H3.
      - discriminate.
      }
- apply derives3_aux_empty.
- intros t ltnt lt H1 H2.
  apply derives3_aux_t.
  exact H2.
- intros n0 lt lt' ltnt H1 H2 H3 H4.
  apply derives3_aux_nt.
  + exact H2.
  + exact H4.
- exact H.
Qed.

Lemma derives_g_g_unit:
forall g: cfg _ _,
forall s: sentence,
forall n: non_terminal,
derives g [inl n] (map term_lift s) -> derives (g_unit g) [inl n] (map term_lift s).
Proof.
intros g s n.
repeat rewrite derives_equiv_derives3.
apply derives3_g_g_unit.
Qed.

Theorem g_equiv_unit:
forall g: cfg _ _,
g_equiv (g_unit g) g.
Proof.
unfold g_equiv.
unfold produces.
intros g s.
split.
- apply generates_g_unit_g.
- apply derives_g_g_unit.
Qed.

Definition has_no_unit_rules (g: cfg _ _): Prop:=
forall left n: non_terminal,
forall right: sf,
rules g left right -> right <> [inl n].

Lemma g_unit_has_no_unit_rules:
forall g: cfg _ _,
has_no_unit_rules (g_unit g).
Proof.
unfold has_no_unit_rules.
intros g left n right H.
destruct right.
- apply nil_cons.
- inversion_clear H.
  + specialize (H0 n).
    exact H0.
  + specialize (H2 n).
    exact H2.
Qed.

Theorem g_unit_correct:
forall g: cfg _ _,
g_equiv (g_unit g) g /\
has_no_unit_rules (g_unit g).
Proof.
intros g.
split.
- apply g_equiv_unit.
- apply g_unit_has_no_unit_rules.
Qed.

End UnitRules.


From Coq Require Export NArith List.

From stdpp Require Import gmap.

Set Implicit Arguments.

#[global] Open Scope N_scope.

Notation "'input' 'Player' '1' 'starting' 'position' ':' n1 'Player' '2' 'starting' 'position' ':' n2" := (n1%N, n2%N)
  (at level 200, n1 at level 0, only parsing).

Definition example := input
Player 1 starting position: 4
Player 2 starting position: 8
.

Record board := MkBoard
  { p1 : N
  ; p2 : N
  ; s1 : N
  ; s2 : N
  }.

Definition mk_board '((p1,p2) : N * N) : board :=
  {| p1 := p1 ; p2 := p2 ; s1 := 0 ; s2 := 0 |}.

#[global] Instance EqDecision_board : EqDecision board.
Proof.
  solve_decision.
Defined.

#[global] Instance Countable_board : Countable board.
Proof.
  apply (inj_countable (A := N * N * N * N) (fun b => (p1 b, p2 b, s1 b, s2 b))
           (fun '(p1,p2,s1,s2) => Some (MkBoard p1 p2 s1 s2))).
  intros []; reflexivity.
Defined.

Definition advance (b : board) (n : N) : board :=
  let p1' := (p1 b + n - 1) mod 10 + 1 in
  {| p1 := p2 b
  ;  p2 := p1'
  ;  s1 := s2 b
  ;  s2 := s1 b + p1'
  |}.

Record board1 := MkBoard1
  { b1 : board
  ; rolls : N
  ; d : N
  }.

Definition step1 (b : board1) : board1 :=
  {| b1 := advance (b1 b) (3 * rolls b + 1)
  ;  rolls := 3 + rolls b
  ;  d := (d b + 3) mod 10
  |}.

Definition play1 i : board1 :=
  N.iter 2000 (fun go b => if 1000 <=? s2 (b1 b) then b else go (step1 b))
    (fun b => b (* should not happen *))
    {| b1 := mk_board i ; rolls := 0 ; d := 1 |}.

Definition solve i : N :=
  let b := play1 i in
  s1 (b1 b) * rolls b.

(* Compute let '(p1,p2):= example in play p1 p2. *)
(* Compute solve example. *)

(* Recursion and memoization *)

Definition endo (X : Type) : Type := (X -> X).

Class Monad M : Type :=
  { ret : forall {A}, A -> M A
  ; bind : forall {A B}, M A -> (A -> M B) -> M B
  }.

Declare Scope monad_scope.
#[global] Open Scope monad_scope.

Notation "'let*' x ':=' u 'in' v" := (bind u (fun x => v)) (at level 200) : monad_scope.

Fixpoint traverse {M} `{Monad M} {A B} (f : A -> M B) (xs : list A) : M (list B) :=
  match xs with
  | [] => ret []
  | x :: xs =>
    let* y := f x in
    let* ys := traverse f xs in
    ret (y :: ys)
  end.

Record identity (A : Type) : Type := Mk_identity { run_identity : A }.

Instance Monad_identity : Monad identity :=
  {| ret _ x := Mk_identity x
  ;  bind _ _ u k := k (run_identity u)
  |}.

Fixpoint naive_fix (fuel : nat) {A R} (r0 : R) (gf : endo (A -> identity R)) : A -> R :=
  fun x =>
    run_identity (gf (fun x => Mk_identity match fuel with
        | O => r0
        | S fuel => naive_fix fuel r0 gf x
        end) x).

Record state (S A : Type) : Type := Mk_state { run_state : S -> S * A }.

Instance Monad_state {S} : Monad (state S) :=
  {| ret _ x := Mk_state (fun s => (s, x))
  ;  bind _ _ u k := Mk_state (fun s =>
       let '(s, x) := run_state u s in
       run_state (k x) s) |}.

Definition memom (A R : Type) `{Countable A} : Type -> Type := state (gmap A R).

Fixpoint _memo_fix (fuel : nat) {A R} `{Countable A}
  (r0 : R) (gf : endo (A -> state (gmap A R) R)) : A -> state (gmap A R) R :=
  fun x => Mk_state (fun s =>
    match lookup x s with
    | Some y => (s, y)
    | None =>
      let __memo_fix x := match fuel with O => ret r0 | S fuel => _memo_fix fuel r0 gf x end in
      let '(s, y) := run_state (gf __memo_fix x) s in
      (insert x y s, y)
    end).

Definition memo_fix (fuel : nat) {A R} `{Countable A}
  (r0 : R) (gf : endo (A -> state (gmap A R) R)) : A -> R :=
  fun x => snd (run_state (_memo_fix fuel r0 gf x) empty).

Fixpoint addwave (xs ys : list N) :=
  match xs, ys with
  | x :: xs, y :: ys => x + y :: addwave xs ys
  | nil, ys => ys
  | xs, nil => xs
  end.

Definition microwave (xs : list N) : list N :=
  addwave (addwave xs (0 :: xs)) (0 :: 0 :: xs).

Definition threedice : list (N * N) := Eval cbv in
  combine (3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) (microwave (microwave (microwave (1 :: nil)))).

Definition sum_worlds (xs : list (N * N)) : N * N :=
  fold_left (fun '(x,y) '(x',y') => (x+x', y+y')) xs (0,0).

(* Starting from board [b], numbers of worlds in which each player wins *)
Definition __play2 {M} `{Monad M} : endo (board -> M (N * N)%type) := fun __play2 b =>
  if 21 <=? s2 b then ret (0, 1) else
    (* Weight and flip *)
    let wflip w '(v1, v2) := (v2 * w, v1 * w) in
    let* rs := traverse (fun '(d, w) => let* r := __play2 (advance b d) in ret (wflip w r))
                 threedice in
    ret (sum_worlds rs).

Definition _play2 : board -> N * N := memo_fix 42 (0, 0) __play2.
Definition play2 i := _play2 (mk_board i).

Definition solve2 i : N :=
  let '(v1, v2) := play2 i in
  if v1 <? v2 then v2 else v1.

(* Compute solve2 example. *)

Definition solve12 i := (solve i, solve2 i).


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

(***
Modulus : 2^198 - 17
Base: 49.5
***)

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

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

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

    mul_code := None;

    square_code := None;

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

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


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import finset.
Require Import connect.
Require Import hypermap.
Require Import geometry.
Require Import color.
Require Import chromogram.
Require Import coloring.
Require Import kempe.
Require Import cfmap.
Require Import cfcolor.
Require Import cfcontract.
Require Import ctree.
Require Import kempetree.

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

(* We only use C-reductibility; the source data has been completed *)
(* with an arbitrary contraction. *)

Section CfReducible.

Variable cf : config.

Definition check_reducible :=
  if contract_ctree cf is Some cct then
    ctree_disjoint (kempe_tree (cfprog cf)) cct
  else false.

Definition cfreducible := c_reducible (cfring cf) (cfcontract cf).

Lemma check_reducible_valid : check_reducible -> cfreducible.
Proof.
rewrite /check_reducible /cfreducible; move: (contract_ctreeP cf).
move: (cfcontract cf) (contract_ctree cf) => cc.
case=> // [cct] [Hcc Hkcc] Hkg; split; first done.
move=> et Het; case: Het (ctree_mem_disjoint Hkg (Hkcc _ Het)) => [k _ Det].
have Eet: size (behead et) = pred (cprsize (cfprog cf)).
  rewrite size_behead Det size_trace size_maps.
  by rewrite /cfring rev_rev -size_ring_cpmap.
move/(kempe_treeP Eet) {Eet Hkg Hkcc}; rewrite -/(cfmap cf).
have <-: rot 1 et = ctrace (behead et).
  have: sumt et =d Color0 by apply/eqP; rewrite Det; apply: sumt_trace.
  case Det': et => [|e et'] /=.
    move: (congr1 size Det'); rewrite Det size_trace size_maps /cfring rev_rev.
    by rewrite head_cpring.
  by rewrite -eq_addc0 rot1_adds /ctrace; move/eqcP=> <-.
move{k Det} => Het P HP HPet; pose P' (et' : colseq) := P (rotr 1 et').
have HP': kempe_closed P'.
  move=> et'; case/HP=> [HPet'h [w Het'w HwPet']].
  split; first by move=> h; rewrite /P' /permt -maps_rotr; apply: HPet'h.
  exists (gram_rot w); first by rewrite -(rot_rotr 1 et') match_gram_rot.
  move=> et''; rewrite -{1}(rot_rotr 1 et'') match_gram_rot; exact: HwPet'.
rewrite -(rotr_rot 1 et) in HPet.
case: {et Het HP' HPet}(Het _ HP' HPet) => [et [k Hk Det] HP'et].
exists (rotr 1 et); last done; exists k; first done.
by rewrite /cfring rev_rev Det maps_rot trace_rot rotr_rot.
Qed.

End CfReducible.

(* This predicate hides the (expensive) reducibility evaluation. *)

Section IndexConfig.

Import ConfigSyntax.

Definition cf000 := Config 0 H.

End IndexConfig.

Definition reducible_in_range j1 j2 (cfs : configseq) :=
  forall i, j1 <= i -> i < j2 -> cfreducible (sub cf000 cfs i).

Lemma check_reducible_in_range : forall j1 j2 (cfs : configseq),
   (forall i, let n := j2 - j1 in
    n <= i \/ check_reducible (sub cf000 (take n (drop j1 cfs)) i)) ->
 reducible_in_range j1 j2 cfs.
Proof.
move=> j1 j2 cfs Hcfs i Hij1 Hij2; set n := j2 - j1; set i' := i - j1.
have Hj12: j1 <= j2 by apply ltnW; apply: leq_trans Hij2.
have Hi'n: i' < n by rewrite /i' -(leq_subS Hij1) leq_sub_add /n leq_add_sub.
case: {Hcfs}(Hcfs i'); rewrite -/n; first by rewrite leqNgt Hi'n.
rewrite sub_take // sub_drop /i' leq_add_sub //; exact: check_reducible_valid.
Qed.

Ltac CheckReducible :=
  apply check_reducible_in_range; simpl;
  repeat (case; [right; by compute | try by left]).

Lemma cat_reducible_range : forall j1 j2 cfs,
 reducible_in_range j1 j2 cfs ->
 forall j3, reducible_in_range j2 j3 cfs -> reducible_in_range j1 j3 cfs.
Proof. move=> j1 j2 cfs Hj12 j3 Hj23 i Hij1 Hij3; case (ltnP i j2); auto. Qed.

Ltac CatReducible h1 h2 h3 h4 h5 :=
  apply (cat_reducible_range h1); apply (cat_reducible_range h2);
  apply (cat_reducible_range h3); apply (cat_reducible_range h4);
  exact h5.

Set Strict Implicit.
Unset Implicit Arguments.


(** ** Natural Deduction for FOL *)

From FOL Require Export FullFOL.

Inductive peirce := class | intu.
Inductive bottom := expl | lconst.
Existing Class peirce.
Existing Class bottom.

Section ND_def.
  Context {Sigma : Signature}.

  Definition form_shift : nat -> term :=
    fun n => var_term (S n).

  Notation "↑" := (form_shift).

  Reserved Notation "A ⊢ phi" (at level 61).

  (* ** Definition *)

  Implicit Type p : peirce.
  Implicit Type b : bottom.

  Inductive prv : forall (p : peirce) (b : bottom), list (form) -> form -> Prop :=
  | II {p b} A phi psi : phi::A ⊢ psi -> A ⊢ phi --> psi
  | IE {p b} A phi psi : A ⊢ phi --> psi -> A ⊢ phi -> A ⊢ psi
  | AllI {p b} A phi : [psi[↑] | psi ∈ A] ⊢ phi -> A ⊢ ∀ phi
  | AllE {p b} A t phi : A ⊢ ∀ phi -> A ⊢ phi[t..]
  | ExI {p b} A t phi : A ⊢ phi[t..] -> A ⊢ ∃ phi
  | ExE {p b} A phi psi : A ⊢ ∃ phi -> phi::[theta[↑] | theta ∈ A] ⊢ psi[↑] -> A ⊢ psi
  | Exp {p} A phi : prv p expl A ⊥ -> prv p expl A phi
  | Ctx {p b} A phi : phi el A -> A ⊢ phi
  | CI {p b} A phi psi : A ⊢ phi -> A ⊢ psi -> A ⊢ phi ∧ psi
  | CE1 {p b} A phi psi : A ⊢ phi ∧ psi -> A ⊢ phi
  | CE2 {p b} A phi psi : A ⊢ phi ∧ psi -> A ⊢ psi
  | DI1 {p b} A phi psi : A ⊢ phi -> A ⊢ phi ∨ psi
  | DI2 {p b} A phi psi : A ⊢ psi -> A ⊢ phi ∨ psi
  | DE {p b} A phi psi theta : A ⊢ phi ∨ psi -> phi::A ⊢ theta -> psi::A ⊢ theta -> A ⊢ theta
  | Pc {b} A phi psi : prv class b A (((phi --> psi) --> phi) --> phi)
  where "A ⊢ phi" := (prv _ _ A phi).

  Arguments prv {_ _} _ _.

  Hint Constructors prv.

  Notation "A ⊢ phi" := (prv A phi) (at level 61).
  Notation "A '⊢(' p , b ')' phi" := (@prv p b A phi) (at level 30).
  Notation "A ⊢CE phi" := (@prv class expl A phi) (at level 30).
  Notation "A ⊢CL phi" := (@prv class lconst A phi) (at level 30).
  Notation "A ⊢IE phi" := (@prv intu expl A phi) (at level 30).

  Definition tprv p b T phi := (exists A, A ⊏ T /\ @prv p b A phi).
  Arguments tprv {_ _} _ _.

  Notation "T ⊩ phi" := (tprv T phi) (at level 30).
  Notation "T '⊩(' s , b ')' phi" := (@tprv s b T phi)  (at level 30).
  Notation "T ⊩CE phi" := (@tprv class expl T phi) (at level 30).
  Notation "T ⊩CL phi" := (@tprv class lconst T phi) (at level 30).
  Notation "T ⊩IE phi" := (@tprv intu expl T phi) (at level 30).

  Section Weakening.
    Context {p : peirce} {b : bottom}.

    Theorem Weak A B phi :
      A ⊢ phi -> A <<= B -> B ⊢ phi.
    Proof.
      intros H. revert B.
      induction H; intros B HB; try unshelve (solve [econstructor; intuition]); try now econstructor.
      - eapply AllI; eauto using incl_map.
      - eapply ExE; eauto using incl_map.
    Qed.

    Lemma up_term_term (t : term) xi :
      t[↑][up_term xi] = t[xi][↑].
    Proof.
      now asimpl.
    Qed.

    Lemma up_term_form xi psi :
      psi[↑][up_term xi] = psi[xi][↑].
    Proof.
      now asimpl.
    Qed.

    Theorem subst_Weak A phi xi :
      A ⊢ phi -> [phi[xi] | phi ∈ A] ⊢ phi[xi].
    Proof.
      induction 1 in xi |-*; comp.
      1-2,7-15: eauto using in_map.
      - apply AllI. setoid_rewrite map_map in IHprv. erewrite map_map, map_ext.
        apply IHprv. intros ?. comp. now apply ext_form.
      - specialize (IHprv xi). apply AllE with (t0 := t [xi]) in IHprv. comp. now asimpl in IHprv.
      - specialize (IHprv xi). eapply ExI with (t0 := t [xi]). asimpl. now asimpl in IHprv.
      - eapply ExE in IHprv1. eassumption. rewrite map_map.
        specialize (IHprv2 (up_term xi)). setoid_rewrite <- (up_term_form xi psi).
        erewrite map_map, map_ext in IHprv2. apply IHprv2.
        apply up_term_form.
    Qed.

    Lemma Weak_T T1 T2 phi :
      T1 ⊩ phi -> T1 ⊑ T2 -> T2 ⊩ phi.
    Proof.
      intros (A & HA1 & HA2) HT2. exists A; firstorder.
    Qed.

    Definition cycle_shift n x :=
      if Dec (n = x) then var_term 0 else var_term (S x).

    Hint Unfold cycle_shift.

    Context {eq_dec_Funcs : eq_dec Funcs}.
    Context {eq_dec_Preds : eq_dec Preds}.

    Lemma cycle_shift_shift n phi :
      unused n phi -> phi[cycle_shift n] = phi[↑].
    Proof.
      intros H. apply (subst_unused_single H). intros m ?. unfold cycle_shift. now decide (n = m).
    Qed.

    Lemma cycle_shift_subject n phi :
      unused (S n) phi -> phi[(var_term n)..][cycle_shift n] = phi.
    Proof.
      intros H. asimpl. rewrite (@subst_unused_single _ _ _ _ ids _ _ H). 1: now asimpl.
      intros m H'; comp; decide (n = n); try congruence. destruct m; [reflexivity |].
        comp; decide (n = m); comp; congruence.
    Qed.

    Lemma nameless_equiv_all A phi n :
      unused_L n A -> unused (S n) phi -> ((A ⊢ phi[(var_term n)..]) <-> [phi[↑] | phi ∈ A] ⊢ phi).
    Proof.
      intros HL Hphi. split.
      - intros H % (subst_Weak (cycle_shift n)). rewrite cycle_shift_subject,
          (map_ext_in _ (subst_form form_shift)) in H. 1,3: assumption. intros ? ? % HL.
        now apply cycle_shift_shift.
      - intros H % (subst_Weak ((var_term n)..)). rewrite map_map in *. rewrite (map_ext _ id), map_id in H.
        assumption. intuition comp.
        erewrite ext_form. now asimpl. intros []; now asimpl.
    Qed.

    Lemma nameless_equiv_ex A phi psi n :
      unused_L n A -> unused n phi -> unused (S n) psi
      -> (psi[(var_term n)..]::A) ⊢ phi <-> (psi::[p[↑] | p ∈ A]) ⊢ phi[↑].
    Proof.
      intros HL Hphi Hpsi. split.
      - intros H % (subst_Weak (cycle_shift n)). cbn in *.
        rewrite (map_ext_in _ (subst_form form_shift)), cycle_shift_subject, cycle_shift_shift in H; trivial.
        intros a Ha. specialize (HL a Ha). now rewrite cycle_shift_shift.
      - intros H % (subst_Weak ((var_term n)..)). cbn in *.
        rewrite map_map, (map_ext _ id), map_id in H.
        + assert (phi[↑][(var_term n)..] = phi) as <-.
          asimpl. erewrite ext_form. now asimpl. intros []; now asimpl.
          eassumption.
        + intros. comp. erewrite ext_form. now asimpl. intros []; now asimpl.
    Qed.

    Lemma nameless_equiv_all' A phi :
      exists t, A ⊢ phi[t..] <-> [p[↑] | p ∈ A] ⊢ phi.
    Proof.
      destruct (find_unused_L (phi::A)) as [n HN].
      exists (var_term n). apply nameless_equiv_all.
      - intros psi H. apply HN; auto.
      - apply HN; auto.
    Qed.

    Lemma nameless_equiv_ex' A phi psi :
      exists t, (psi[t..]::A) ⊢ phi <-> (psi::[p[↑] | p ∈ A]) ⊢ phi[↑].
    Proof.
      destruct (find_unused_L (phi::psi::A)) as [n HN].
      exists (var_term n). apply nameless_equiv_ex.
      - intros theta H. apply HN; auto.
      - apply HN; auto.
      - apply HN; auto.
    Qed.

  End Weakening.

  Lemma prv_cut {p : peirce} {b : bottom} A phi psi :
    A ⊢ phi -> (phi :: A) ⊢ psi -> A ⊢ psi.
  Proof.
    eauto.
  Qed.

  Lemma tprv_list_T {p : peirce} {b : bottom} A phi :
    list_T A ⊩ phi -> A ⊢ phi.
  Proof.
    intros (B & HB1 & HB2). apply (Weak HB2). firstorder.
  Qed.

  Definition capture_subs n x := var_term (x + n).

  Lemma capture_extract {p : peirce} {b : bottom} n A phi :
    A ⊢ subst_form (capture_subs n) (capture n phi) -> A ⊢ subst_form (capture_subs 0) phi.
  Proof.
    induction n; comp; intuition. apply IHn. apply (AllE (var_term n)) in H. asimpl in H.
    erewrite ext_form. 1: apply H. intros [| x]; unfold capture_subs; cbn; f_equal; omega.
  Qed.

  Context {eq_dec_Funcs : eq_dec Funcs}.
  Context {eq_dec_Preds : eq_dec Preds}.

  Lemma close_extract {p : peirce} {b : bottom} A phi :
    A ⊢ close phi -> A ⊢ phi.
  Proof.
    intros H. assert (Hclosed : closed (close phi)) by apply close_closed.
    unfold close in *. destruct (find_unused phi) as [n Hn]; cbn in *.
    rewrite <- subst_unused_closed' with (xi := capture_subs n) in H. 2: firstorder.
    apply capture_extract in H. rewrite idSubst_form in H; intuition.
    destruct x; unfold capture_subs; f_equal; omega.
  Qed.

  Lemma big_imp_extract {p : peirce} {b : bottom} A B phi :
    B ⊢ (big_imp A phi) -> (rev A ++ B) ⊢ phi.
  Proof.
    induction A in B |-*.
    - tauto.
    - cbn. intros Hprv. rewrite <- app_assoc. comp.
      apply IHA. eapply IE. 1: apply (Weak Hprv); intuition.
      now apply Ctx.
  Qed.

  Lemma prv_from_single {p : peirce} { b : bottom} A phi :
    nil ⊢ close (A ⟹ phi) -> A ⊢ phi.
  Proof.
    intros Hprv % close_extract. apply big_imp_extract in Hprv.
    eapply Weak. apply Hprv. rewrite app_nil_r. now intros ? ? % in_rev.
  Qed.
End ND_def.

Hint Constructors prv.

Arguments prv {_ _ _} _ _.
Notation "A ⊢ phi" := (prv A phi) (at level 30).
Notation "A '⊢(' p , b ')' phi" := (@prv _ p b A phi) (at level 30).
Notation "A ⊢CE phi" := (@prv _ class expl A phi) (at level 30).
Notation "A ⊢CL phi" := (@prv _ class lconst A phi) (at level 30).
Notation "A ⊢IE phi" := (@prv _ intu expl A phi) (at level 30).

Arguments tprv {_ _ _} _ _.
Notation "T ⊩ phi" := (tprv T phi) (at level 30).
Notation "T '⊩(' s , b ')' phi" := (@tprv _ s b T phi)  (at level 30).
Notation "T ⊩CE phi" := (@tprv _ class expl T phi) (at level 30).
Notation "T ⊩CL phi" := (@tprv _ class lconst T phi) (at level 30).
Notation "T ⊩IE phi" := (@tprv _ intu expl T phi) (at level 30).

(* ** Proof Tacticts *)

Ltac ointro_all :=
  match goal with
  | [ |- ?A ⊢ ∀ ?phi] => apply AllI; cbn; asimpl
  end.

Ltac ointro_impl :=
  match goal with
  | [ |- _  ⊢ (_ --> _)] => apply II
  | [ |- _  ⊢ (¬ _)] => apply II
  end.

Ltac ointro := ointro_impl + ointro_all + fail "Nothing to intro!".
Ltac ointros := repeat ointro.

Ltac ctx_index' n :=
  match n with
  | O => now left
  | S ?m => right; ctx_index' m
  end.
Ltac ctx_index n := apply Ctx; ctx_index' n.
Ltac ctx := apply Ctx; intuition.

Ltac oapply n := eapply IE; [ctx_index n|].

Ltac ospecialize n t :=
  eapply prv_cut; [eapply (@AllE _ _ _ _ t); ctx_index n|]; cbn; asimpl.

Ltac ouse H := eapply Weak; [apply H |]; intuition.
Ltac oimport H := eapply prv_cut; [ouse H |].
Ltac oassert form := eapply (@prv_cut _ _ _ _ form).
Ltac oexfalso := apply Exp.
Ltac opeirce form := eapply IE; [apply (@Pc _ _ _ _ form) | apply II].

Lemma DN {Sigma : Signature} A phi :
  A ⊢CE ¬ (¬ phi) -> A ⊢CE phi.
Proof.
  intros H. oimport H. opeirce Fal. oexfalso. oapply 1. ctx.
Qed.

Ltac oindirect := apply DN, II.

Notation "c∃ phi" := (¬ ∀ ¬ phi) (at level 56, right associativity).

Lemma ExE' {Sigma : Signature} A phi psi :
  A ⊢CE (c∃ phi) -> (phi :: [phi[↑] | phi ∈ A]) ⊢CE psi[↑] -> A ⊢CE psi.
Proof.
  intros Hex Hinst.
  oindirect. oimport Hex. oapply 0.
  ointros. oapply 2. ouse Hinst.
Qed.

Ltac odestruct n := eapply ExE'; [ctx_index n|]; cbn; asimpl.

Lemma ExI' {Sigma : Signature} {p : peirce} {b : bottom} A t phi :
  A ⊢ phi [t..] -> A ⊢ c∃ phi.
Proof.
  intros Hc. apply II. ospecialize 0 t. oapply 0. ouse Hc.
Qed.

Ltac oexists t :=
  eapply (@ExI' _ _ _ _ t); cbn; asimpl.

Ltac osplit := eapply CI.
Ltac oleft := eapply DI1.
Ltac oright := eapply DI2.

Lemma AXM {Sigma : Signature} A phi psi :
  (phi :: A) ⊢CE psi -> (¬ phi :: A) ⊢CE psi -> A ⊢CE psi.
Proof.
  intros Ht Hf. oindirect. oassert (¬ phi). ointros. oapply 1.
  ouse Ht. oapply 1. ouse Hf.
Qed.

Ltac oxm form :=
  apply (@AXM _ _ form).

Lemma DP {Sigma : Signature} phi :
  [] ⊢CE c∃ (phi --> (∀ phi)[↑]).
Proof.
  oxm (c∃ ¬ phi).
  - odestruct 0. oexists (var_term 0). ointros. oexfalso. oapply 1. ctx.
  - oexists (var_term 0). ointros. oindirect. oapply 2. oexists (var_term 0). ctx.
Qed.

(* ** Theory manipulation *)

Section TheoryManipulation.
  Context {Sigma : Signature}.
  Context {p : peirce} {b : bottom}.
  Context {HF : eq_dec Funcs} {HP : eq_dec Preds}.

  Lemma prv_T_impl T phi psi :
    (T ⋄ phi) ⊩ psi -> T ⊩ (phi --> psi).
  Proof.
    intros (A & HA1 & HA2). exists (rem A phi); split.
    - intros f [[] % HA1 Hf2] % in_rem_iff; subst; intuition.
    - eapply II, Weak. 1: apply HA2. transitivity (phi :: A). 1: eauto. apply rem_equi.
  Qed.

  Lemma prv_T_remove T phi psi :
    T ⊩ phi -> T ⋄ phi ⊩ psi -> T ⊩ psi.
  Proof.
    intros (A & HA1 & HA2) (B & HB1 & HB2) % prv_T_impl.
    use_theory (A ++ B). oimport HA2. oimport HB2. oapply 0. ctx.
  Qed.

  Lemma prv_T_comp T phi psi xi :
    T ⋄ phi ⊩ xi -> T ⋄ psi ⊩ phi -> T ⋄ psi ⊩ xi.
  Proof.
    intros (A & HA1 & HA2) % prv_T_impl (B & HB1 & HB2) % prv_T_impl.
    use_theory (psi :: A ++ B). oimport HA2. oimport HB2. oapply 1. oapply 0. ctx.
  Qed.

  Lemma elem_prv T phi :
    phi ∈ T -> T ⊩ phi.
  Proof.
    intros ?. use_theory [phi]. ctx.
  Qed.
End TheoryManipulation.

(* ** Refutation completeness *)

Section RefutationComp.
  Context {Sigma : Signature}.
  Context {HF : eq_dec Funcs} {HP : eq_dec Preds}.

  Lemma refutation_prv T phi :
    T ⊩CE phi <-> (T ⋄ ¬ phi) ⊩CE ⊥.
  Proof.
    split.
    - intros (A & HA1 & HA2). use_theory (¬ phi :: A). oimport HA2. oapply 1. ctx.
    - intros (A & HA1 & HA2) % prv_T_impl. use_theory A. now apply DN.
  Qed.
End RefutationComp.

(* ** Double Negation Translation *)

Section DNT.
  Context {Sigma : Signature}.

  Fixpoint dnt phi :=
    match phi with
    | ⊥ => ⊥
    | Pred P v => ¬ ¬ Pred P v
    | phi --> psi => dnt phi --> dnt psi
    | phi ∧ psi => dnt phi ∧ dnt psi
    | phi ∨ psi => ¬ (¬ dnt phi ∧ ¬ dnt psi)
    | ∀ phi => ∀ dnt phi
    | ∃ phi => ¬ ∀ ¬ dnt phi
    end.

  Lemma dnt_subst phi sigma :
    dnt (phi[sigma]) = (dnt phi)[sigma].
  Proof.
    induction phi in sigma |-*; comp; congruence.
  Qed.

  Lemma form_ind_subst' (P : form -> Prop) :
    P ⊥ -> (forall p v, P (Pred p v)) ->
    (forall phi psi, P phi -> P psi -> P (phi --> psi)) ->
    (forall phi psi, P phi -> P psi -> P (phi ∧ psi)) ->
    (forall phi psi, P phi -> P psi -> P (phi ∨ psi)) ->
    (forall phi,  P phi -> P (∀ phi)) ->
    (forall phi, (forall sigma, P phi[sigma]) -> P (∃ phi)) ->
    forall phi, P phi.
  Proof.
    intros H1 H2 H3 H4 H5 H6 H7 phi.
    induction phi using (@size_induction _ size).
    destruct phi; trivial.
    - apply H3; apply H; cbn; lia.
    - apply H4; apply H; cbn; lia.
    - apply H5; apply H; cbn; lia.
    - apply H6. eauto.
    - apply H7. intros t. apply H.
      cbn. setoid_rewrite subst_size. lia.
  Qed.

  Lemma dnt_float A phi :
    A ⊢IE (¬ ¬ dnt phi) -> A ⊢IE dnt phi.
  Proof.
    intros Hprv. revert A Hprv. induction phi using form_ind_subst'; intros A Hprv. 1-7:comp.
    - eauto.
    - oimport Hprv. ointros. oapply 1. ointros. oapply 0. ctx.
    - oimport Hprv. ointros. apply IHphi2. ointros. oapply 2. ointros. oapply 1.
      oapply 0. ctx.
    - oimport Hprv. eapply CI.
      + eapply IHphi1. ointros.
        oapply 1. ointros. oapply 1. eapply CE1. ctx.
      + eapply IHphi2. ointros.
        oapply 1. ointros. oapply 1. eapply CE2. ctx.
    - oimport Hprv. ointros. oapply 1. ointros.
      oapply 0. ctx.
    - oimport Hprv. ointros. comp. apply IHphi. ointros. oapply 1.
      ointros. ospecialize 0 (var_term 0). oapply 2. ctx.
    - oimport Hprv. cbn. ointros. oapply 1. ointros.
      oapply 0. ctx.
  Qed.

  Ltac clean_dnt_correct :=
    repeat (match goal with
            | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl)
            end).

  Lemma dnt_to_IE A phi :
    A ⊢CE phi -> map dnt A ⊢IE dnt phi.
  Proof.
    remember expl; remember class. induction 1; subst; comp.
    -  eauto 3 using in_map; clean_dnt_correct.
    -  eauto using in_map; clean_dnt_correct.
    - apply AllI. rewrite map_map in *. erewrite map_ext. apply IHprv; try reflexivity. now setoid_rewrite <- dnt_subst.
    - apply AllE with (t0 := t) in IHprv. now setoid_rewrite dnt_subst. all:reflexivity.
    - ointros. ospecialize 0 t. oapply 0. setoid_rewrite dnt_subst in IHprv. ouse IHprv.
    - oimport IHprv1. eapply dnt_float. ointros.
      oapply 1. ointros. oapply 1. setoid_rewrite dnt_subst in IHprv2. ouse IHprv2.
      intros ? [-> | (? & <- & ?) % in_map_iff]; eauto.
      eapply in_map_iff in H2 as (? & <- & ?).
      repeat right. eapply in_map_iff. exists (dnt x0). setoid_rewrite dnt_subst; eauto.
    -  eauto using in_map; clean_dnt_correct.
    -  eauto using in_map; clean_dnt_correct.
    -  eauto using in_map; clean_dnt_correct.
    -  eauto using in_map; clean_dnt_correct.
    -  eauto using in_map; clean_dnt_correct.
    - ointros. eapply IE. eapply CE1. ctx. eapply Weak. eapply IHprv; try reflexivity. firstorder.
    - ointros. eapply IE. eapply CE2. ctx. eapply Weak. eapply IHprv; try reflexivity. firstorder.
    - oimport IHprv1. eapply dnt_float. ointros.
      oapply 1. osplit.
      + ointros. oapply 1. eapply Weak. eapply IHprv2. reflexivity. reflexivity. firstorder.
      + ointros. oapply 1. eapply Weak. eapply IHprv3. reflexivity. reflexivity. firstorder.
    - change (((dnt phi --> dnt psi) --> dnt phi) --> dnt phi) with (dnt (((phi --> psi) --> phi) --> phi)).
      apply dnt_float. comp. ointros. oapply 0. ointros. oapply 0. ointros. oexfalso. oapply 2.
      ointros. ctx.
  Qed.

  Lemma IE_to_CE A phi :
    A ⊢IE phi -> A ⊢CE phi.
  Proof.
    induction 1; eauto.
  Qed.

  Lemma dnt_CE A phi :
    A ⊢CE dnt phi <-> A ⊢CE phi.
  Proof.
    induction phi in A |-*; cbn in *.
    - reflexivity.
    - split. 1: eauto using DN. intros Hprv. ointros. oapply 0. ouse Hprv.
    - split; intros Hprv; oimport Hprv. all: ointros; apply IHphi2; oapply 1; apply IHphi1; ctx.
    - split; intros Hprv; oimport Hprv. all: osplit. 1,3: eapply IHphi1, CE1. 3,4: eapply IHphi2, CE2.
      all:ctx.
    - split; intros Hprv; oimport Hprv.
      + oindirect. oapply 1. osplit.
        * ointros. oapply 1.  oleft. eapply IHphi1. ctx.
        * ointros. oapply 1. oright. eapply IHphi2. ctx.
      + ointros. eapply DE.
        * ctx.
        * eapply IE with (phi := dnt phi1). eapply CE1. ctx. eapply IHphi1. ctx.
        * eapply IE with (phi := dnt phi2). eapply CE2. ctx. eapply IHphi2. ctx.
    - split; intros Hprv; oimport Hprv. all: ointros; apply IHphi; ospecialize 0 (var_term 0); ctx.
    - split; intros Hprv; oimport Hprv.
      + oindirect. oapply 1. ointros. oapply 1.
        eapply ExI with (t := var_term 0). asimpl. eapply IHphi. ctx.
      + ointros. eapply ExE. ctx. cbn.
        ospecialize 1 (var_term 0). oapply 0. eapply IHphi. ctx.
  Qed.

  Lemma dnt_remove_ctx A B phi :
    (A ++ map dnt B) ⊢CE phi -> (A ++ B) ⊢CE phi.
  Proof.
    induction B in A |-*; cbn.
    - now rewrite app_nil_r.
    - intros H. specialize (IHB (A ++ [a])). do 2 rewrite <- app_assoc in IHB. apply IHB.
      apply prv_cut with (dnt a). 1: apply dnt_CE; ctx; intuition. apply (Weak H).
      intros ? [| []] % in_app_or; subst; intuition. repeat (right; apply in_or_app). now right.
  Qed.

  Lemma dnt_to_CE A phi :
    map dnt A ⊢IE dnt phi -> A ⊢CE phi.
  Proof.
    intros H % IE_to_CE. now apply dnt_remove_ctx with (A := nil), dnt_CE.
  Qed.
End DNT.


Require Import List Recdef Div2 Setoid Omega Permutation.
Set Implicit Arguments.

(** Morphisms are handly since we can use rewrite to massage the goal
  * and the hypotheses.
 **)
(*
(* The following are now in the standard library. *)
Add Parametric Relation A: (list A) (@Permutation A)
   reflexivity proved by (@Permutation_refl A)
   symmetry proved by (@Permutation_sym A)
   transitivity proved by (@perm_trans A)
 as perm_rel.

Add Parametric Morphism A: (@cons A)
  with signature (@eq A) ==> (@Permutation A) ==> (@Permutation A)
  as cons_mor.
Proof.
  intros; apply perm_skip; assumption.
Qed.

Add Parametric Morphism A: (@length A)
  with signature (@Permutation A) ==> (@eq nat)
  as length_mor.
Proof.
  intros; apply Permutation_length; assumption.
Qed.
*)
Add Parametric Morphism A: (@app A)
  with signature (@Permutation A) ==> (@Permutation A) ==> (@Permutation A)
  as app_mor.
Proof.
  intros; apply Permutation_app; assumption.
Qed.

(* When we want to apply ex falso to a false arithmetic expression. *)
Tactic Notation "omega_false" :=
  let F:=fresh "omega_false"
  in assert (F: 0%nat=1%nat);
     [ omega | discriminate F ].

(* A custom tactic to unfold / eta-expand pairs. *)
Ltac pair_tac :=
  match goal with
   | [ |-  context [match ?l with (x,y) => (?a::x,?b::y) end] ]
          => replace (let (x,y):=l in (a::x,b::y))
                 with (a::fst l,b::snd l); simpl;
               [idtac | destruct l; simpl; reflexivity]
   | [ H:context [match ?l with (x,y) => (?a::x,?b::y) end] |- ?g]
          => replace (let (x,y):=l in (a::x,b::y))
                 with (a::fst l,b::snd l) in H; simpl;
               [idtac | destruct l; simpl; reflexivity]
   | [ H: (?x,?y) = ?E |- context [fst ?E] ]
          => replace (fst E) with x; [idtac | rewrite <- H; reflexivity]
   | [ H: ?E = (?x,?y) |- context [fst ?E] ]
          => replace (fst E) with x; [idtac | rewrite H; reflexivity]
   | [ H: (?x,?y) = ?E |- context [snd ?E] ]
          => replace (snd E) with y; [idtac | rewrite <- H; reflexivity]
   | [ H: ?E = (?x,?y) |- context [snd ?E] ]
          => replace (snd E) with y; [idtac | rewrite H; reflexivity]
   | [ H: ?E = (?x,?y) |- ?g ]
          => replace x with (fst E); [idtac | rewrite H; reflexivity];
             replace y with (snd E); [idtac | rewrite H; reflexivity]
  end.

Definition transitive (A:Type) (rel: A -> A -> bool) :=
  forall x y z, rel x y = true -> rel y z = true -> rel x z = true.

Definition antisym (A:Type) (rel: A -> A -> bool) :=
  forall x y, rel x y = true -> rel y x = true -> x = y.

(* A custom inductive scheme working on two lists with the same length. *)
Theorem ind_2list A: forall P: list A -> list A -> Prop,
  P nil nil
    -> (forall l l' a b, P l l' -> P (a::l) (b::l'))
    -> forall l l', length l = length l' -> P l l'.
Proof.
  intros P ? Pi l l' Hle.
  do 2 generalize Hle; set (n:=length l') in Hle|-*.
  unfold n at 2; clear Hle; generalize n; clear n; intro n; revert l l'.
  induction n; intros l l' ? ?.
    destruct l; destruct l'; simpl in *|-; discriminate || auto.
 destruct l; destruct l'; simpl in *|-; discriminate || auto.
Qed.

Section sort.
  Variable A: Type.
  Variable order: A -> A -> bool.
  Notation "x << y" := (order x y) (at level 70).

  Variable order_total: forall a b, {(a<<b)=true} + {(b<<a)=true}.

  Lemma false2true: forall a b, (a<<b)=false -> (b<<a)=true.
  Proof.
    intros a b H.
    destruct (order_total a b) as [Hf|]; auto.
    rewrite Hf in H; discriminate.
  Qed.
  Hint Resolve order_total false2true: order.

  (** A naive definition for sorted lists. **)
  Inductive Sorted: list A -> Prop :=
    |sorted_nil: Sorted nil
    |sorted_singl: forall a, Sorted (a::nil)
    |sorted_ind: forall a b l, (a<<b)=true -> Sorted (b::l)
                                           -> Sorted (a::b::l).
  Hint Resolve sorted_nil sorted_singl sorted_ind: sort.

  (* Some easy lemmas. *)
  Lemma sorted_hd: forall a q,
    Sorted q -> (a<<hd a q)=true -> Sorted (a::q).
  Proof.
    intros a [|] Hq H; simpl;
      try apply sorted_ind; auto with sort.
  Qed.

  Lemma sorted_hd_rm: forall l a,
    Sorted (a::l) -> Sorted l.
  Proof.
    intros [|?[|]] a H; auto with sort.
    inversion H; assumption.
  Qed.
  Hint Resolve sorted_hd sorted_hd_rm: sort.

  Lemma sorted_split_rm: transitive order ->
    forall l l' a, Sorted (l++a::l') -> Sorted (l++l').
  Proof.
    intros Ho l l' a H; induction l as [|? l IH]; simpl in *|-*.
      inversion H; auto with sort.
    destruct l; simpl in *|-*; auto with sort.
      destruct l'; simpl; auto with sort.
      inversion H as [| |? ? ? ? H'].
      inversion H'; constructor; auto.
      apply Ho with (y:=a); assumption.
    inversion H as [| |? ? ? ? H']; apply IH in H'.
    constructor; auto.
  Qed.

  Lemma sorted_in: transitive order ->
    forall a l, Sorted (a::l) -> forall x, In x l -> (a<<x)=true.
  Proof.
    intros Ho a l H x Hin; induction l as [|b q IH].
      inversion Hin.
    destruct (in_inv Hin) as [Hin'|Hin'].
      rewrite <- Hin'; inversion H; assumption.
    apply IH; auto.
    change (a::q) with ((a::nil)++q).
    apply sorted_split_rm with (a:=b); simpl; auto.
  Qed.

  Lemma sorted_split: forall l x l', Sorted l -> Sorted l' ->
      (forall a, In a l -> (a<<x)=true) ->
      (forall a', In a' l' -> (x<<a')=true) ->
    Sorted (l++x::l').
  Proof.
    intros l x l'; revert l; induction l as [|? l IH];
      intros Hs Hs' Hin Hin'; simpl.
      destruct l'; auto with sort.
      constructor; auto; apply Hin'; simpl; auto.
    destruct l; simpl in *|-*.
      apply sorted_hd; simpl.
        destruct l'; auto with sort.
      apply Hin; simpl; auto.
    constructor.
      inversion Hs; auto.
    apply IH; auto || inversion Hs; auto.
  Qed.

  Lemma perm_singl: forall (a:A) l, Permutation (a::nil) l -> l=a::nil.
  Proof.
    intros a [|?[|]] H.
        symmetry in H; elim (Permutation_nil_cons H).
      destruct (Permutation_in _ H (in_eq a nil)) as [|Hf].
        f_equal; assumption.
      elim Hf.
    assert (Hf:=Permutation_length H); simpl in Hf; discriminate.
  Qed.

  (* Sorting is unique. *)
  Theorem sorted_uniq: transitive order -> antisym order ->
    forall l l', Permutation l l' -> Sorted l -> Sorted l' -> l=l'.
  Proof.
    intros Ho Ha l l' Hll'.
    assert(Hle:=Permutation_length Hll').
    revert l l' Hle Hll'.
    apply (ind_2list
            (fun l l' => Permutation l l'->Sorted l->Sorted l'->l=l'));
      auto.
    intros l l' a b H Hll' Hl Hl'.
    assert(Hab:a=b).
      assert(Hin: In a (b::l')).
        apply (Permutation_in (l:=a::l)); [idtac | simpl]; auto.
      simpl in Hin; destruct Hin as [|Hin]; auto.
      assert(Hin': In b (a::l)).
        apply (Permutation_in (l:=b::l')); [symmetry | simpl]; auto.
      simpl in Hin'; destruct Hin' as [|Hin']; auto.
      apply Ha; [apply (sorted_in Ho Hl) | apply (sorted_in Ho Hl')]; auto.
    rewrite Hab in *|-*; clear Hab; f_equal.
    apply H.
    exact (Permutation_cons_inv Hll').
    exact (sorted_hd_rm Hl).
    exact (sorted_hd_rm Hl').
  Qed.

  Section insert.
    (** Insert sort **)

    Fixpoint insert (x:A) (l:list A) {struct l} : list A :=
      match l with
        nil  => x::nil
      | a::q => if x << a
                then x :: l
                else a :: insert x q
      end.
     Functional Scheme insert_ind := Induction for insert Sort Prop.

    Fixpoint insert_sort l : list A :=
      match l with
        nil  => nil
      | a::q => insert a (insert_sort q)
      end.

    (** It permutes the input list **)
    Theorem insert_sort_perm: forall l, Permutation l (insert_sort l).
    Proof.
      intro l; induction l as [|a l IH]; simpl.
      reflexivity.
      set(l':=l); unfold l' at 1; rewrite IH; unfold l'; clear l'.
      set(l':=insert_sort l); clear IH.
      functional induction insert a l' as [| | ? ? ? ? ? IH];
        simpl; try reflexivity.
     rewrite <- IH; constructor.
    Qed.

    Lemma insert_hd: forall a x l,
      hd x (insert a l) = a   \/   hd x (insert a l) = hd x l.
    Proof.
      intros a ? l.
      functional induction insert a l; simpl; auto.
    Qed.

    (** Correction of 'insert' **)
    Lemma insert_correct: forall a l,
      Sorted l -> Sorted (insert a l).
    Proof.
      intros a l.
      functional induction insert a l as [| | l b [|c q] _ Hb IH];
        simpl; auto with sort; intro H.
        constructor; auto with sort order.
      apply sorted_hd.
        apply IH; exact (sorted_hd_rm H).
      destruct (insert_hd a b (c::q)) as [H0|H0];
        simpl in H0; rewrite H0; auto with order.
      inversion H; assumption.
    Qed.

    (** Correction of 'insert_sort' **)
    Theorem insert_sort_correct: forall l, Sorted (insert_sort l).
    Proof.
      intro l; induction l; simpl; auto with sort.
      apply insert_correct; assumption.
    Qed.
  End insert.

  Section merge.
    (** Merge sort. **)

    (** Division into 2 lists of ~1/2 length. **)
    Fixpoint divide (l:list A) {struct l} : list A*list A :=
      match l with
        nil     => (nil, nil)
      | a::nil  => (a::nil, nil)
      | a::b::q => let (q1,q2):=divide q
                   in (a::q1, b::q2)
      end.
    Functional Scheme divide_ind := Induction for divide Sort Prop.

    (** Length conservation. **)
    Lemma divide_sum: forall (l:list A),
      length l = length (fst (divide l)) + length (snd (divide l)).
    Proof.
      intro l; functional induction divide l as [| | ? ? ? ? ? ? ? IH]; simpl; auto.
      rewrite IH; do 2 pair_tac; auto with arith.
    Qed.

    (** Divide is balanced. **)
    Theorem divide_balanced: forall (l:list A),
      length (fst (divide l)) <=  S (div2 (length l))
           /\ length (snd (divide l)) <= div2 (length l).
    Proof.
      intro l; functional induction divide l; simpl; auto.
      pair_tac; omega.
    Qed.

    (** Divide returns a partitition of the input list. **)
    Lemma divide_perm: forall l:list A,
      Permutation l (fst (divide l) ++ snd (divide l)).
    Proof.
      intro l; functional induction divide l as [| | ? ? ? ? ? ? ? IH];
        simpl; try reflexivity.
      pair_tac; rewrite (Permutation_cons_app _ _ _ IH); reflexivity.
    Qed.

    Definition sum_length A (c:(list A)*(list A)) := length (fst c) + length (snd c).

    (** Merge of 2 lists; if the inputs are sorted, so is the output. **)
    (* It would be better to use nested structural inductions, but 'functional
     * scheme' does not support higher order (currified) elimination principles.
     *)
    Function merge (c: (list A)*(list A)) {measure sum_length c} : list A :=
      let (l1,l2) := c
      in
      match l1 with
        nil    => l2
      | h1::t1 =>
            match l2 with
              nil    => l1
            | h2::t2 => if h1 << h2
                        then h1 :: merge (t1,l2)
                        else h2 :: merge (l1,t2)
            end
      end.
    Proof.
      (* Now, we have to prove that the recursive calls are smaller. *)
      unfold sum_length; intros; simpl; omega.
      unfold sum_length; intros; simpl; omega.
    Defined.

    (** The output is a concatenation of the inputs, modulo permutation. **)
    Lemma merge_perm: forall c,
      Permutation (merge c) (fst c ++ snd c).
    Proof with try reflexivity.
      intro c; functional induction merge c; simpl in *|-*...
          rewrite <- app_nil_end...
        constructor; assumption.
      rewrite <- Permutation_cons_app; [idtac|reflexivity]; rewrite perm_swap.
      constructor; assumption.
    Qed.

    Lemma merge_hd: forall c x,
      hd x (merge c) = hd x (fst c)   \/   hd x (merge c) = hd x (snd c).
    Proof with auto.
      intro c; functional induction merge c; simpl...
    Qed.

    (* Merge is correct. *)
    Lemma merge_correct: forall c,
      Sorted (fst c) -> Sorted (snd c) -> Sorted (merge c).
    Proof.
      intro c; functional induction merge c
        as [| | ? ? ? ? h1 t1 ? ? ? ? ? IH | ? ? ? ? h1 t1 ? h2 t2 ? ? IH];
        simpl in *|-*; auto; intros Hs1 Hs2; apply sorted_hd.
            apply IH; eauto with sort.
          destruct t1; auto.
          match goal with [ |- context [merge ?c] ] => destruct (merge_hd c h1) as [H|H] end;
            rewrite H; simpl; [inversion Hs1|idtac]; auto with sort.

      apply IH; eauto with sort.
      destruct t2; auto with order.
      match goal with [ |- context [merge ?c] ] => destruct (merge_hd c h2) as [H|H] end;
          rewrite H; simpl; [idtac|inversion Hs2]; auto with sort order.
    Qed.

    (** Some trivial lemmas about divide. **)
    Lemma lemma_divide_fst: forall (l:list A),
      1<length l -> length (fst (divide l)) < length l.
    Proof.
      intros [|? [|? l]] ?; simpl in *|-*; try omega_false.
      pair_tac; simpl.
      functional induction divide l;
        intros; simpl; try pair_tac; auto with arith.
    Qed.

    Lemma lemma_divide_snd: forall (l:list A),
      1<length l -> length (snd (divide l)) < length l.
    Proof.
     intros [|? [|? l]] ?; simpl in *|-*; try omega_false.
      pair_tac; simpl.
      functional induction divide l;
        intros; simpl; try pair_tac; auto with arith.
    Qed.

    (** merge_sort **)
    Function merge_sort (l:list A) {measure length l} : list A :=
      match l with
        nil   => nil
      | a::nil => a::nil
      | _ => let (l1,l2):=divide l
             in merge (merge_sort l1,merge_sort l2)
    end.
    Proof.
        intros; pair_tac; apply (lemma_divide_snd); simpl; auto with arith.
      intros; pair_tac; apply (lemma_divide_fst); simpl; auto with arith.
    Defined.

    (** It permutes the input list. **)
    Theorem merge_sort_perm: forall l, Permutation l (merge_sort l).
    Proof.
      intro l; functional induction merge_sort l; simpl; auto; try reflexivity.
      rewrite merge_perm; simpl.
      rewrite (divide_perm l); simpl; do 2 pair_tac.
      apply Permutation_app; assumption.
    Qed.

    (* Correction *)
    Theorem merge_sort_correct: forall l, Sorted (merge_sort l).
    Proof.
      intro l; functional induction merge_sort l; simpl; auto with sort.
      apply merge_correct; simpl; assumption.
    Qed.

  End merge.

  Section quick.
    (** Quick sort **)

    (* Filter the elements less and greater than x. *)
    Fixpoint split x l {struct l} : list A * list A :=
      match l with
        nil  => (nil,nil)
      | h::t => let (ll,lg) := split x t
                in if h<<x then (h::ll,lg)
                           else (ll,h::lg)
      end.
    Functional Scheme split_ind := Induction for split Sort Prop.

    (** Length conservation. **)
    Lemma split_sum: forall x (l:list A),
      length l = length (fst (split x l)) + length (snd (split x l)).
    Proof.
      intros x l; functional induction split x l as [| ? ? ? ? IH | ? ? ? ? IH];
        simpl; auto; rewrite IH; do 2 pair_tac; auto with arith.
    Qed.

    (** Split returns a partitition of the input list. **)
    Lemma split_perm: forall x (l:list A),
      Permutation l (fst (split x l) ++ snd (split x l)).
    Proof.
      intros x l; functional induction split x l as [| ? ? ? ? IH | ? ? ? ? IH];
        simpl; try reflexivity.
        rewrite IH; do 2 pair_tac; reflexivity.
      rewrite (Permutation_cons_app _ _ _ IH); do 2 pair_tac; reflexivity.
    Qed.

    (** Some trivial lemmas about split. **)
    Lemma lemma_split_fst: forall x (l:list A),
      length (fst (split x l)) <= length l.
    Proof.
      intros x l; functional induction split x l;
        simpl; try pair_tac; auto with arith.
    Qed.

    Lemma lemma_split_snd: forall x (l:list A),
      length (snd (split x l)) <= length l.
    Proof.
      intros x l; functional induction split x l;
        simpl; try pair_tac; auto with arith.
    Qed.

    (* Split is correct. *)
    Lemma split_correct_fst: forall x l,
      forall a, In a (fst (split x l)) -> (a<<x)=true.
    Proof.
      intros x l; functional induction split x l as [| ? ? ? ? IH | ? ? ? ? IH];
        intros a H; auto; simpl in *|-*.
        destruct H.
          rewrite <- H; auto.
        apply IH; pair_tac; auto.
      apply IH; pair_tac; auto.
    Qed.

    Lemma split_correct_snd: forall x l,
      forall a, In a (snd (split x l)) -> (x<<a)=true.
    Proof.
      intros x l; functional induction split x l as [| ? ? ? ? IH | ? ? ? ? IH];
        intros a H; auto; simpl in *|-*.
        apply IH; pair_tac; auto.
      destruct H.
        rewrite <- H; auto with order.
      apply IH; pair_tac; auto.
    Qed.

    (* The quick sort itself. *)
    Function quick_sort (l:list A) {measure length l} : list A :=
      match l with
          nil => nil
      | h::t  => let (ll,lg) := split h t
                 in quick_sort ll ++ h :: quick_sort lg
      end.
    Proof.
      intros; pair_tac; eapply le_lt_trans; [apply lemma_split_snd | simpl; auto].
      intros; pair_tac; eapply le_lt_trans; [apply lemma_split_fst | simpl; auto].
    Defined.

    (** It permutes the input list. **)
    Theorem quick_sort_perm: forall l, Permutation l (quick_sort l).
    Proof.
      intro l; functional induction quick_sort l as [| ? ? ? ? ? ? ? IH1 IH2];
        simpl; try reflexivity.
      rewrite <- IH1; rewrite <- IH2.
     pair_tac; apply Permutation_cons_app; apply split_perm.
    Qed.

    (* Correction. *)
    Theorem quick_sort_correct: forall l, Sorted (quick_sort l).
    Proof.
      intro l; functional induction quick_sort l; simpl; auto with sort.
      apply sorted_split; auto || intros ? H;
        [apply (split_correct_fst _ t) | apply (split_correct_snd _ t)]; pair_tac.
      apply (@Permutation_in _ (quick_sort ll)); auto || symmetry; apply quick_sort_perm.
      apply (@Permutation_in _ (quick_sort lg)); auto || symmetry; apply quick_sort_perm.
    Qed.

  End quick.

End sort.

(** Run tests, using the virtual machine (vm_compute). **)

Eval vm_compute
  in insert_sort Compare_dec.leb (3::8::1::7::2::9::6::0::4::9::1::5::nil).

Eval vm_compute
  in (merge_sort Compare_dec.leb (1::9::3::5::6::2::9::1::0::8::4::7::nil)).

Eval vm_compute
  in (quick_sort Compare_dec.leb (3::4::7::0::9::4::3::8::5::1::2::6::nil)).