Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.Notations.

Module ZRange.
  Local Open Scope Z_scope.
  Local Open Scope zrange_scope.

  Local Notation eta v := r[ lower v ~> upper v ].

  Definition flip (v : zrange) : zrange
    := r[ upper v ~> lower v ].

  Definition union (x y : zrange) : zrange
    := let (lx, ux) := eta x in
       let (ly, uy) := eta y in
       r[ Z.min lx ly ~> Z.max ux uy ].

  Definition intersection (x y : zrange) : zrange
    := let (lx, ux) := eta x in
       let (ly, uy) := eta y in
       r[ Z.max lx ly ~> Z.min ux uy ].

  Definition normalize (v : zrange) : zrange
    := r[ Z.min (lower v) (upper v) ~> Z.max (upper v) (lower v) ].

  Definition normalize' (v : zrange) : zrange
    := union v (flip v).

  Lemma normalize'_eq : normalize = normalize'. Proof. reflexivity. Defined.

  Definition abs (v : zrange) : zrange
    := let (l, u) := eta v in
       r[ 0 ~> Z.max (Z.abs l) (Z.abs u) ].

  Definition opp (v : zrange) : zrange
    := let (l, u) := eta v in
       r[ -u ~> -l ].

  Definition map (f : Z -> Z) (v : zrange) : zrange
    := let (l, u) := eta v in
       r[ f l ~> f u ].

  Definition two_corners (f : Z -> Z) (v : zrange) : zrange
    := let (l, u) := eta v in
       r[ Z.min (f l) (f u) ~> Z.max (f u) (f l) ].

  Definition two_corners' (f : Z -> Z) (v : zrange) : zrange
    := normalize' (map f v).

  Lemma two_corners'_eq : two_corners = two_corners'. Proof. reflexivity. Defined.

  Definition four_corners (f : Z -> Z -> Z) (x y : zrange) : zrange
    := let (lx, ux) := eta x in
       union (two_corners (f lx) y)
             (two_corners (f ux) y).

  Definition eight_corners (f : Z -> Z -> Z -> Z) (x y z : zrange) : zrange
    := let (lx, ux) := eta x in
       union (four_corners (f lx) y z)
             (four_corners (f ux) y z).

  Definition upper_lor_land_bounds (x y : BinInt.Z) : BinInt.Z
    := 2^(1 + Z.log2_up (Z.max x y)).
  Definition extreme_lor_land_bounds (x y : zrange) : zrange
    := let mx := ZRange.upper (ZRange.abs x) in
       let my := ZRange.upper (ZRange.abs y) in
       {| lower := -upper_lor_land_bounds mx my ; upper := upper_lor_land_bounds mx my |}.
  Definition extremization_bounds (f : zrange -> zrange -> zrange) (x y : zrange) : zrange
    := let (lx, ux) := x in
       let (ly, uy) := y in
       if ((lx <? 0) || (ly <? 0))%Z%bool
       then extreme_lor_land_bounds x y
       else f x y.
  Definition land_bounds : zrange -> zrange -> zrange
    := extremization_bounds
         (fun x y
          => let (lx, ux) := x in
             let (ly, uy) := y in
             {| lower := Z.min 0 (Z.min lx ly) ; upper := Z.max 0 (Z.min ux uy) |}).

  Definition split_bounds (r : zrange) (split_at : BinInt.Z) : zrange * zrange :=
    if upper r <? split_at
    then if (0 <=? lower r)%Z
         then (r, {| lower := 0; upper := 0 |})
         else ( {| lower := 0; upper := split_at - 1 |},
                {| lower := 0; upper := Z.max ( -(lower r / split_at)) (upper r / split_at) |} )
    else ( {| lower := 0; upper := split_at - 1 |},
           {| lower := 0; upper := Z.max ( -(lower r / split_at)) (upper r / split_at) |} ).
End ZRange.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import QArith.QArith_base QArith.Qround Crypto.Util.QUtil.
Require Import Crypto.Arithmetic.BaseConversion.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Arithmetic.Saturated.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.ZUtil.EquivModulo.
Require Import Crypto.Util.ZUtil.Opp.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.PeelLe.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.

Require Import Crypto.Util.Notations.
Local Open Scope Z_scope.

(* TODO: rename this module? (Should it be, e.g., [Rows.freeze]?) *)
Module Freeze.
  Section Freeze.
    Context weight {wprops : @weight_properties weight}.

    Definition freeze n mask (m p:list Z) : list Z :=
      let '(p, carry) := Rows.sub weight n p m in
      let '(r, carry) := Rows.conditional_add weight n mask (-carry) p m in
      r.

    Lemma freezeZ m s c y :
      m = s - c ->
      0 < c < s ->
      s <> 0 ->
      0 <= y < 2*m ->
      ((y - m) + (if (dec (-((y - m) / s) = 0)) then 0 else m)) mod s
      = y mod m.
    Proof using Type.
      clear; intros.
      transitivity ((y - m) mod m);
        repeat first [ progress intros
                     | progress subst
                     | rewrite Z.opp_eq_0_iff in *
                     | break_innermost_match_step
                     | progress autorewrite with zsimplify_fast
                     | rewrite Z.div_small_iff in * by auto
                     | progress (Z.rewrite_mod_small; push_Zmod; Z.rewrite_mod_small)
                     | progress destruct_head'_or
                     | lia ].
    Qed.

    Lemma length_freeze n mask m p :
      length m = n -> length p = n -> length (freeze n mask m p) = n.
    Proof using wprops.
      cbv [freeze Rows.conditional_add Rows.add]; eta_expand; intros.
      distr_length; try assumption; cbn; intros; destruct_head'_or; destruct_head' False; subst;
        distr_length.
      erewrite Rows.length_sum_rows by (reflexivity || eassumption || distr_length); distr_length.
    Qed.
    Lemma eval_freeze_eq n mask m p
          (n_nonzero:n<>0%nat)
          (Hmask : List.map (Z.land mask) m = m)
          (Hplen : length p = n)
          (Hmlen : length m = n)
      : Positional.eval weight n (@freeze n mask m p)
        = (Positional.eval weight n p - Positional.eval weight n m +
           (if dec (-((Positional.eval weight n p - Positional.eval weight n m) / weight n) = 0) then 0 else Positional.eval weight n m))
            mod weight n.
            (*if dec ((Positional.eval weight n p - Positional.eval weight n m) / weight n = 0)
          then Positional.eval weight n p - Positional.eval weight n m
          else Positional.eval weight n p mod weight n.*)
    Proof using wprops.
      pose proof (@weight_positive weight wprops n).
      cbv [freeze Z.equiv_modulo]; eta_expand.
      repeat first [ solve [auto]
                   | rewrite Rows.conditional_add_partitions
                   | rewrite Rows.sub_partitions
                   | rewrite Rows.sub_div
                   | rewrite eval_partition
                   | progress distr_length
                   | progress pull_Zmod (*
                   | progress break_innermost_match_step
                   | progress destruct_head'_or
                   | lia
                   | f_equal; lia
                   | rewrite Z.div_small_iff in * by (auto using (@weight_positive weight ltac:(assumption)))
                   | progress Z.rewrite_mod_small *) ].
    Qed.

    Lemma eval_freeze n c mask m p
          (n_nonzero:n<>0%nat)
          (Hc : 0 < Associational.eval c < weight n)
          (Hmask : List.map (Z.land mask) m = m)
          (modulus:=weight n - Associational.eval c)
          (Hm : Positional.eval weight n m = modulus)
          (Hp : 0 <= Positional.eval weight n p < 2*modulus)
          (Hplen : length p = n)
          (Hmlen : length m = n)
      : Positional.eval weight n (@freeze n mask m p)
        = Positional.eval weight n p mod modulus.
    Proof using wprops.
      pose proof (@weight_positive weight wprops n).
      rewrite eval_freeze_eq by assumption.
      erewrite freezeZ; try eassumption; try lia.
      f_equal; lia.
    Qed.

    Lemma freeze_partitions n c mask m p
          (n_nonzero:n<>0%nat)
          (Hc : 0 < Associational.eval c < weight n)
          (Hmask : List.map (Z.land mask) m = m)
          (modulus:=weight n - Associational.eval c)
          (Hm : Positional.eval weight n m = modulus)
          (Hp : 0 <= Positional.eval weight n p < 2*modulus)
          (Hplen : length p = n)
          (Hmlen : length m = n)
      : @freeze n mask m p = Partition.partition weight n (Positional.eval weight n p mod modulus).
    Proof using wprops.
      pose proof (@weight_positive weight wprops n).
      pose proof (fun v => Z.mod_pos_bound v (weight n) ltac:(lia)).
      pose proof (Z.mod_pos_bound (Positional.eval weight n p) modulus ltac:(lia)).
      subst modulus.
      erewrite <- eval_freeze by eassumption.
      cbv [freeze]; eta_expand.
      rewrite Rows.conditional_add_partitions by (auto; rewrite Rows.sub_partitions; auto; distr_length).
      rewrite !eval_partition by assumption.
      apply Partition.partition_Proper; [ assumption .. | ].
      cbv [Z.equiv_modulo].
      pull_Zmod; reflexivity.
    Qed.
  End Freeze.
End Freeze.
#[global]
Hint Rewrite Freeze.length_freeze : distr_length.

Section freeze_mod_ops.
  Import Positional.
  Import Freeze.
  Local Coercion Z.of_nat : nat >-> Z.
  Local Coercion QArith_base.inject_Z : Z >-> Q.
  (* Design constraints:
     - inputs must be [Z] (b/c reification does not support Q)
     - internal structure must not match on the arguments (b/c reification does not support [positive]) *)
  Context (limbwidth_num limbwidth_den : Z)
          (limbwidth_good : 0 < limbwidth_den <= limbwidth_num)
          (s : Z)
          (c : list (Z*Z))
          (n : nat)
          (bitwidth : Z)
          (m_enc : list Z)
          (m_nz:s - Associational.eval c <> 0) (s_nz:s <> 0)
          (Hn_nz : n <> 0%nat)
          (Hs_big : 1 < s).
  Local Notation bytes_weight := (@weight 8 1).
  Local Notation weight := (@weight limbwidth_num limbwidth_den).
  Let m := (s - Associational.eval c).

  Context (Hs : s = weight n).
  Context (c_small : 0 < Associational.eval c < weight n)
          (m_enc_bounded : List.map (BinInt.Z.land (Z.ones bitwidth)) m_enc = m_enc)
          (m_enc_correct : Positional.eval weight n m_enc = m)
          (Hm_enc_len : length m_enc = n).

  Definition wprops_bytes := (@wprops 8 1 ltac:(clear; lia)).
  Local Notation wprops := (@wprops limbwidth_num limbwidth_den limbwidth_good).

  Local Notation wunique := (@weight_unique limbwidth_num limbwidth_den limbwidth_good).
  Local Notation wunique_bytes := (@weight_unique 8 1 ltac:(clear; lia)) (only parsing).

  Local Hint Immediate (wprops) : core.
  Local Hint Immediate (wprops_bytes) : core.
  Local Hint Immediate (weight_0 wprops) : core.
  Local Hint Immediate (weight_positive wprops) : core.
  Local Hint Immediate (weight_multiples wprops) : core.
  Local Hint Immediate (weight_divides wprops) : core.
  Local Hint Immediate (weight_0 wprops_bytes) : core.
  Local Hint Immediate (weight_positive wprops_bytes) : core.
  Local Hint Immediate (weight_multiples wprops_bytes) : core.
  Local Hint Immediate (weight_divides wprops_bytes) : core.
  Local Hint Immediate (wunique) (wunique_bytes) : core.
  Local Hint Resolve (wunique) (wunique_bytes) : core.

  Definition bytes_n
    := Eval cbv [Qceiling Qdiv inject_Z Qfloor Qmult Qopp Qnum Qden Qinv Pos.mul]
      in Z.to_nat (Qceiling (Z.log2_up s / 8)).

  Lemma weight_bytes_weight_matches
    : weight n <= bytes_weight bytes_n.
  Proof using limbwidth_good Hs.
    clear -limbwidth_good Hs.
    cbv [weight bytes_n] in *; subst s.
    autorewrite with zsimplify_const.
    rewrite Z.log2_up_pow2, !Z2Nat.id, !Z.opp_involutive by (Z.div_mod_to_quot_rem; nia).
    Z.peel_le.
    Z.div_mod_to_quot_rem; nia.
  Qed.

  Definition to_bytes (v : list Z)
    := BaseConversion.convert_bases weight bytes_weight n bytes_n v.

  Definition from_bytes (v : list Z)
    := BaseConversion.convert_bases bytes_weight weight bytes_n n v.

  Definition freeze_to_bytesmod (f : list Z) : list Z
    := to_bytes (freeze weight n (Z.ones bitwidth) m_enc f).

  Definition to_bytesmod (f : list Z) : list Z
    := to_bytes f.

  Definition from_bytesmod (f : list Z) : list Z
    := from_bytes f.

  Lemma bytes_pos : (0 < bytes_n)%nat.
  Proof using Hs_big.
    clear -Hs_big.
    cbv [bytes_n].
    pose proof (Z.log2_up_pos s Hs_big).
    zify; rewrite ?Z2Nat.id in *. (* This line only needed in < 8.11 *)
    all: Z.div_mod_to_quot_rem; try nia.
  Qed.

  Lemma bytes_nz : bytes_n <> 0%nat.
  Proof using Hs_big. generalize bytes_pos; clear; lia. Qed.

  Lemma bytes_n_big : weight n <= bytes_weight bytes_n.
  Proof using limbwidth_good Hn_nz Hs.
    clear -limbwidth_good Hn_nz Hs.
    cbv [bytes_n bytes_weight] in *; subst s.
    Z.peel_le.
    rewrite Z.log2_up_pow2 by (Z.div_mod_to_quot_rem; nia).
    autorewrite with zsimplify_fast.
    rewrite Z2Nat.id by (Z.div_mod_to_quot_rem; nia).
    Z.div_mod_to_quot_rem; nia.
  Qed.

  Lemma eval_to_bytes
    : forall (f : list Z)
        (Hf : length f = n),
      eval bytes_weight bytes_n (to_bytes f) = eval weight n f.
  Proof using limbwidth_good Hs_big.
    generalize wprops wprops_bytes; clear -limbwidth_good Hs_big.
    intros.
    cbv [to_bytes].
    rewrite BaseConversion.eval_convert_bases
      by (auto using bytes_nz; distr_length; auto using wprops).
    reflexivity.
  Qed.

  Lemma to_bytes_partitions
    : forall (f : list Z)
             (Hf : length f = n)
             (Hf_small : 0 <= eval weight n f < s),
      to_bytes f = Partition.partition bytes_weight bytes_n (Positional.eval weight n f).
  Proof using Hs_big limbwidth_good.
    clear -Hs_big limbwidth_good.
    intros; cbv [to_bytes].
    pose proof bytes_nz.
    apply BaseConversion.convert_bases_partitions; eauto; try lia.
    split; [ | eapply Z.lt_le_trans ]; [ apply Hf_small.. | ].
    cbv [bytes_weight bytes_n].
    pose proof (Z.log2_up_pos s Hs_big).
    rewrite Z2Nat.id by (Z.div_mod_to_quot_rem; nia).
    autorewrite with zsimplify_fast.
    etransitivity; [ now apply Z.log2_up_spec | ].
    Z.peel_le.
    Z.div_mod_to_quot_rem; nia.
  Qed.

  Lemma eval_to_bytesmod
    : forall (f : list Z)
             (Hf : length f = n)
             (Hf_small : 0 <= eval weight n f < s),
      eval bytes_weight bytes_n (to_bytesmod f) = eval weight n f
      /\ to_bytesmod f = Partition.partition bytes_weight bytes_n (Positional.eval weight n f).
  Proof using Hs_big limbwidth_good.
    split; apply eval_to_bytes || apply to_bytes_partitions; assumption.
  Qed.

  Lemma eval_freeze_to_bytesmod_and_partitions
    : forall (f : list Z)
        (Hf : length f = n)
        (Hf_bounded : 0 <= eval weight n f < 2 * m),
      (eval bytes_weight bytes_n (freeze_to_bytesmod f)) = (eval weight n f) mod m
      /\ freeze_to_bytesmod f = Partition.partition bytes_weight bytes_n (Positional.eval weight n f mod m).
  Proof using m_enc_correct Hs_big limbwidth_good Hn_nz Hs c_small Hm_enc_len m_enc_bounded.
    clear -m_enc_correct Hs_big limbwidth_good Hn_nz Hs c_small Hm_enc_len m_enc_bounded.
    pose proof eval_to_bytes as eval_to_bytes.
    pose proof to_bytes_partitions as to_bytes_partitions.
    intros; subst m; rewrite Hs in *.
    cbv [freeze_to_bytesmod].
    rewrite eval_to_bytes, to_bytes_partitions;
      erewrite ?eval_freeze by eauto using wprops;
      autorewrite with distr_length; eauto.
    Z.div_mod_to_quot_rem; nia.
  Qed.

  Lemma eval_freeze_to_bytesmod
    : forall (f : list Z)
        (Hf : length f = n)
        (Hf_bounded : 0 <= eval weight n f < 2 * m),
      (eval bytes_weight bytes_n (freeze_to_bytesmod f)) = (eval weight n f) mod m.
  Proof using m_enc_correct Hs_big limbwidth_good Hn_nz Hs c_small Hm_enc_len m_enc_bounded.
    intros; now apply eval_freeze_to_bytesmod_and_partitions.
  Qed.

  Lemma freeze_to_bytesmod_partitions
    : forall (f : list Z)
        (Hf : length f = n)
        (Hf_bounded : 0 <= eval weight n f < 2 * m),
      freeze_to_bytesmod f = Partition.partition bytes_weight bytes_n (Positional.eval weight n f mod m).
  Proof using m_enc_correct Hs_big limbwidth_good Hn_nz Hs c_small Hm_enc_len m_enc_bounded.
    intros; now apply eval_freeze_to_bytesmod_and_partitions.
  Qed.

  Lemma eval_from_bytes
    : forall (f : list Z)
        (Hf : length f = bytes_n),
      eval weight n (from_bytes f) = eval bytes_weight bytes_n f.
  Proof using limbwidth_good Hs_big Hn_nz.
    generalize wprops wprops_bytes; clear -Hs_big limbwidth_good Hn_nz.
    intros.
    cbv [from_bytes].
    rewrite BaseConversion.eval_convert_bases
      by (auto using bytes_nz; distr_length; auto using wprops).
    reflexivity.
  Qed.

  Lemma from_bytes_partitions
    : forall (f : list Z)
             (Hf_small : 0 <= eval bytes_weight bytes_n f < weight n),
      from_bytes f = Partition.partition weight n (Positional.eval bytes_weight bytes_n f).
  Proof using limbwidth_good Hn_nz.
    clear -limbwidth_good Hn_nz.
    intros; cbv [from_bytes].
    apply BaseConversion.convert_bases_partitions; eauto; lia.
  Qed.

  Lemma eval_from_bytesmod
    : forall (f : list Z)
             (Hf : length f = bytes_n),
      eval weight n (from_bytesmod f) = eval bytes_weight bytes_n f.
  Proof using Hn_nz Hs_big limbwidth_good. apply eval_from_bytes. Qed.

  Lemma from_bytesmod_partitions
    : forall (f : list Z)
             (Hf_small : 0 <= eval bytes_weight bytes_n f < weight n),
      from_bytesmod f = Partition.partition weight n (Positional.eval bytes_weight bytes_n f).
  Proof using limbwidth_good Hn_nz. apply from_bytes_partitions. Qed.

  Lemma eval_from_bytesmod_and_partitions
    : forall (f : list Z)
             (Hf : length f = bytes_n)
             (Hf_small : 0 <= eval bytes_weight bytes_n f < weight n),
      eval weight n (from_bytesmod f) = eval bytes_weight bytes_n f
      /\ from_bytesmod f = Partition.partition weight n (Positional.eval bytes_weight bytes_n f).
  Proof using limbwidth_good Hn_nz Hs_big.
    now (split; [ apply eval_from_bytesmod | apply from_bytes_partitions ]).
  Qed.
End freeze_mod_ops.
#[global]
Hint Rewrite eval_freeze_to_bytesmod eval_to_bytes eval_to_bytesmod eval_from_bytes eval_from_bytesmod : push_eval.


Require Import GeoCoq.Axioms.continuity_axioms.
Require Import GeoCoq.Axioms.parallel_postulates.
Require Export GeoCoq.Meta_theory.Parallel_postulates.SPP_ID.
Require Export GeoCoq.Meta_theory.Parallel_postulates.TCP_tarski.
Require Export GeoCoq.Meta_theory.Parallel_postulates.alternate_interior_angles_proclus.
Require Export GeoCoq.Meta_theory.Continuity.angle_archimedes.
Require Export GeoCoq.Meta_theory.Continuity.archimedes.
Require Export GeoCoq.Meta_theory.Continuity.aristotle.
Require Export GeoCoq.Meta_theory.Parallel_postulates.euclid_5_original_euclid.
Require Export GeoCoq.Meta_theory.Parallel_postulates.existential_triangle_rah.
Require Export GeoCoq.Meta_theory.Parallel_postulates.par_perp_perp_TCP.
Require Export GeoCoq.Meta_theory.Parallel_postulates.playfair_alternate_interior_angles.
Require Export GeoCoq.Meta_theory.Parallel_postulates.playfair_bis_playfair.
Require Export GeoCoq.Meta_theory.Parallel_postulates.playfair_universal_posidonius_postulate.
Require Export GeoCoq.Meta_theory.Parallel_postulates.proclus_SPP.
Require Export GeoCoq.Meta_theory.Parallel_postulates.rah_triangle.
Require Export GeoCoq.Meta_theory.Parallel_postulates.tarski_euclid.
Require Export GeoCoq.Meta_theory.Parallel_postulates.triangle_playfair_bis.
Require Export GeoCoq.Meta_theory.Parallel_postulates.triangle_existential_triangle.
Require Export GeoCoq.Meta_theory.Parallel_postulates.universal_posidonius_postulate_par_perp_perp.
Require Export GeoCoq.Tarski_dev.Annexes.defect.

Section Legendre.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Theorem stronger_legendre_s_first_theorem :
  aristotle_s_axiom ->
  forall A B C D E F,
    SumA C A B A B C D E F ->
    SAMS D E F B C A.
Proof.
  intros ari A B C D E F.
  apply (t22_20 (aristotle__obtuse_case_elimination ari)).
Qed.

Theorem legendre_s_first_theorem :
  archimedes_axiom ->
  forall A B C D E F,
    SumA C A B A B C D E F ->
    SAMS D E F B C A.
Proof.
  intros archi A B C D E F.
  apply (t22_20 (archi__obtuse_case_elimination archi)).
Qed.

Theorem legendre_s_second_theorem :
  postulate_of_existence_of_a_triangle_whose_angles_sum_to_two_rights ->
  triangle_postulate.
Proof.
  intro H; exact (rah__triangle (existential_triangle__rah H)).
Qed.

Lemma legendre_s_third_theorem_aux :
  aristotle_s_axiom ->
  triangle_postulate ->
  euclid_s_parallel_postulate.
Proof.
  intros HA HT.
  apply aristotle__greenberg in HA.
  apply triangle__playfair_bis in HT; trivial.
  apply playfair_bis__playfair in HT.
  apply euclid_5__original_euclid, tarski_s_euclid_implies_euclid_5.
  apply triangle_circumscription_implies_tarski_s_euclid.
  apply inter_dec_plus_par_perp_perp_imply_triangle_circumscription.
  { apply strong_parallel_postulate_implies_inter_dec.
    apply proclus_s_postulate_implies_strong_parallel_postulate.
    apply alternate_interior__proclus; trivial.
    apply playfair__alternate_interior, HT.
  }
  apply universal_posidonius_postulate__perpendicular_transversal_postulate.
  apply playfair__universal_posidonius_postulate, HT.
Qed.

Theorem legendre_s_third_theorem :
  archimedes_axiom ->
  triangle_postulate ->
  euclid_s_parallel_postulate.
Proof.
  intros; apply legendre_s_third_theorem_aux; [apply t22_24|]; assumption.
Qed.

Lemma legendre_aux :
  ~ hypothesis_of_obtuse_saccheri_quadrilaterals ->
  forall A B C D B1 C1 P Q R S T U V W X,
    ~ Col A B C -> CongA A C B C B D ->
    Cong A C B D -> TS B C A D -> Out A B B1 -> Out A C C1 -> Bet B1 D C1 ->
    Defect A B C P Q R -> Defect A B1 C1 S T U -> SumA P Q R P Q R V W X ->
    SAMS P Q R P Q R /\ LeA V W X S T U.
Proof.
  intros noah A B C D B1 C1 P Q R S T U V W X HNCol HConga HCong HTS HOutB HOutC HBet HDef HDef1 HSuma.
  destruct (l11_49 A C B D B C) as [HCong1 [HConga1 HConga2]]; CongA; Cong.
    assert_diffs; auto.
  assert (HPar : Par_strict A C B D).
  { apply par_not_col_strict with B; Col.
    apply par_left_comm, l12_21_b; Side; CongA.
  }
  assert (HPar' : Par_strict A B C D).
  { apply par_not_col_strict with C; Col.
    apply par_left_comm, l12_21_b; Side; CongA.
  }
  assert (HNCol2:= HPar'); assert (HNCol3 := HPar'); assert (HNCol4 := HPar').
  apply par_strict_not_col_2 in HNCol2; apply par_strict_not_col_3 in HNCol3; apply par_strict_not_col_4 in HNCol4.
  assert (HB : ~ Col B1 B D /\ TS B D B1 C1 /\ Bet A B B1).
  { assert_diffs.
    apply par_strict_symmetry, (par_strict_col_par_strict B D A C C1) in HPar; Col.
    assert (HNCol' := par_strict_not_col_4 B D A C1 HPar).
    assert (B <> B1) by (intro; subst B1; apply HNCol'; Col).
    assert (~ Col B1 B D) by (intro; apply HNCol4; ColR).
    assert (TS B D B1 C1) by (repeat split; Col; exists D; Col).
    repeat (split; auto).
    apply col_two_sides_bet with D; Col.
    apply l9_8_2 with C1; Side.
  }
  destruct HB as [HNCol5 [HTS1 HBetB]].
  assert (HC : ~ Col C D B1 /\ C <> C1 /\ Bet A C C1).
  { assert_diffs.
    apply par_strict_symmetry, (par_strict_col_par_strict C D A B B1) in HPar'; Col.
    assert (HNCol' := par_strict_not_col_4 C D A B1 HPar').
    assert (C <> C1) by (intro; subst C1; apply HNCol'; Col).
    repeat split; auto.
    apply col_two_sides_bet with D; Col.
    apply l9_8_2 with B1; Side.
    repeat split; Col.
      intro; apply HNCol3; ColR.
    exists D; Col.
  }
  destruct HC as [HNCol6 [HCC1 HBetC]].
  assert_diffs.
  destruct (ts2__ex_bet2 B C D B1) as [Z [HZ1 HZ2]].
    apply l9_8_2 with C1; Side; apply one_side_symmetry, l12_6, par_strict_col_par_strict with A; Col; Par.
    { apply l9_31.
        apply l9_17 with C1; trivial.
        exists A; repeat split; Col; try (intro; apply HNCol; ColR);
        [exists B|exists C]; split; Col; Between.
      apply one_side_symmetry, l12_6, par_strict_col_par_strict with A; Col; Par.
    }

  rename H into HAB1.
  destruct (ex_defect A B1 C) as [G [H [I HDef2]]]; auto.
  destruct (ex_defect B1 C C1) as [J [K [L HDef3]]]; auto.
  destruct (ex_defect C B B1) as [M [N [O HDef4]]]; auto.
  destruct (ex_defect B1 C D) as [A' [B' [C' HDef5]]]; auto.
  destruct (ex_defect C D C1) as [D' [E' [F' HDef6]]]; auto.
  destruct (ex_defect B1 B D) as [M' [N' [O' HDef7]]]; auto.
  assert (Hd := defect_distincts A B1 C G H I HDef2).
  assert (Hd2 := defect_distincts C B B1 M N O HDef4).
  assert (Hd3 := defect_distincts B1 C D A' B' C' HDef5).
  spliter; clean.
  destruct (ex_suma G H I A' B' C') as [G' [H' [I' HSuma1]]]; auto.
  destruct (ex_suma M N O A' B' C') as [J' [K' [L' HSuma2]]]; auto.

  destruct (t22_16_1bis noah A B1 C1 C G H I J K L S T U) as [HIsi3 HSuma3]; trivial.
  destruct (t22_16_1bis noah B1 C C1 D A' B' C' D' E' F' J K L) as [HIsi4 HSuma4]; trivial.
  destruct (t22_16_1bis noah A C B1 B P Q R M N O G H I) as [HIsi5 HSuma5]; trivial.
    apply defect_perm_132, HDef.
    apply defect_perm_132, HDef2.
  assert (HIsi1 : SAMS G H I A' B' C').
    apply sams_lea2__sams with G H I J K L; Lea.
    apply sams_suma__lea123789 with D' E' F'; trivial.
  assert (HIsi2 : SAMS M N O A' B' C').
    apply sams_lea2__sams with G H I A' B' C'; Lea.
    apply sams_suma__lea456789 with P Q R; trivial.
  assert (HSuma6 : SumA G' H' I' D' E' F' S T U).
    apply suma_assoc_2 with G H I A' B' C' J K L; trivial.
  assert (HIsi6 : SAMS G' H' I' D' E' F').
    apply sams_assoc_2 with G H I A' B' C' J K L; trivial.
  assert (HSuma7 : SumA P Q R J' K' L' G' H' I').
    apply suma_assoc_1 with M N O A' B' C' G H I; trivial.
  assert (HIsi7 : SAMS P Q R J' K' L').
    apply sams_assoc_1 with M N O A' B' C' G H I; trivial.
  destruct (t22_16_2 noah C B B1 D M' N' O' A' B' C' P Q R M N O Z J' K' L') as [HIsi8 HSuma8]; trivial.
    apply defect_perm_231, (conga3_defect__defect A B C); CongA.
    apply defect_perm_231, HDef5.
  assert (HLea : LeA P Q R J' K' L') by (apply sams_suma__lea123789 with M' N' O'; trivial).

  split.
    suma.assert_diffs.
    apply sams_lea2__sams with P Q R J' K' L'; Lea.
  apply lea_trans with G' H' I'.
    apply sams_lea456_suma2__lea with P Q R P Q R J' K' L'; trivial.
  apply sams_suma__lea123789 with D' E' F'; trivial.
Qed.

Lemma legendre_aux1 : forall A B C B' C',
  ~ Col A B C -> Out A B B' -> Out A C C' ->
  exists D', InAngle D' B A C /\ CongA A C' B' C' B' D' /\
             Cong A C' B' D' /\ TS B' C' A D'.
Proof.
  intros A B C B' C' HNCol HOutB HOutC.
  assert_diffs.
  assert (HNCol' : ~ Col A B' C') by (intro; assert_diffs; apply HNCol; ColR).
  destruct (midpoint_existence B' C') as [M HM].
  destruct (symmetric_point_construction A M) as [D' HD].
  assert (HNCol1 : ~ Col A M B') by (intro; assert_diffs; apply HNCol'; ColR).
  assert (HNCol2 : ~ Col D' B' C') by (intro; assert_diffs; apply HNCol'; ColR).
  exists D'.
  assert_diffs; destruct HM; destruct HD; split.
    apply l11_25 with D' B' C'; try (apply out_trivial); auto.
    repeat split; auto.
    exists M; split; trivial.
    right; apply bet_out; auto.
  destruct (l11_49 A M C' D' M B') as [HCong1 [HConga1 HConga2]]; Cong.
    apply l11_14; Between.
  split.
    apply (l11_10 A C' M M B' D'); Out; CongA.
  split; Cong.
  repeat split; Col.
  exists M; split; Col.
Qed.

Lemma legendre_aux2 :
  ~ hypothesis_of_obtuse_saccheri_quadrilaterals ->
  forall A B C,
    ~ Col A B C ->  Acute B A C ->
    (forall T,
       InAngle T B A C ->
       exists X Y : Tpoint, Out A B X /\ Out A C Y /\ Bet X T Y) ->
    forall P Q R S T U,
      Defect A B C P Q R -> GradAExp P Q R S T U ->
      exists B' C' P' Q' R',
        (Out A B B' /\ Out A C C' /\
         Defect A B' C' P' Q' R' /\ LeA S T U P' Q' R').
Proof.
  intros noah A B C HNCol HAcute legendre P Q R S T U HDef.
  induction 1; rename A0 into P; rename B0 into Q; rename C0 into R.
    exists B; exists C; exists P; exists Q; exists R; assert_diffs.
    repeat (split; [Out|]); Lea.
  rename D into S; rename E into T; rename F into U.
  destruct IHGradAExp as [B' [C' [P' [Q' [R' [HOutB [HOutC [HDef' HLea]]]]]]]]; trivial.
  destruct (legendre_aux1 A B C B' C') as [D' [HInangle [HConga [HCong HTS]]]]; trivial.
  assert (HNCol' : ~ Col A B' C') by (destruct HTS; Col).
  destruct (legendre D' HInangle) as [B'' [C'' [HOutB' [HOutC' HBet]]]].
  assert (Hd := defect_distincts A B' C' P' Q' R' HDef'); spliter; assert_diffs.
  destruct (ex_defect A B'' C'') as [P'' [Q'' [R'' HDef'']]]; auto.
    intro; subst; apply HNCol; ColR.
  exists B''; exists C''; exists P''; exists Q''; exists R''.
  repeat (split; trivial).
  destruct (ex_suma P' Q' R' P' Q' R') as [V [W [X HSuma1]]]; auto.
  destruct (legendre_aux noah A B' C' D' B'' C'' P' Q' R' P'' Q'' R'' V W X) as [HIsi1 HLea1]; trivial.
    apply l6_7 with B; Out.
    apply l6_7 with C; Out.
  apply lea_trans with V W X; trivial.
  apply sams_lea2_suma2__lea with S T U S T U P' Q' R' P' Q' R'; trivial.
Qed.

Lemma legendre_s_fourth_theorem_aux :
  archimedes_axiom ->
  legendre_s_parallel_postulate ->
  postulate_of_right_saccheri_quadrilaterals.
Proof.
  intros archi legendre.
  destruct legendre as [B [A [C [HNCol [HAcute legendre]]]]].
  assert_diffs.
  destruct (ex_defect A B C) as [P [Q [R HDef]]]; auto.
  destruct (col_dec P Q R) as [HCol|HNCol1].
  - apply archi__obtuse_case_elimination in archi.
    apply (defect_ncol_out__rah A B C P Q R); Col.
    apply not_bet_out; Col.
    intro HBet.
    apply HNCol.
    apply defect_perm_213 in HDef.
    destruct HDef as [D [E [F [[G [H [I [HSuma1 HSuma2]]]] HSuppa]]]].
    apply out_col, l6_6, out_lea__out with D E F.
      apply (bet_suppa__out P Q R); [|apply suppa_sym]; assumption.
    apply sams_suma__lea456789 with G H I; trivial.
    apply (t22_20 archi); trivial.
  - destruct (archi__gradaexp_destruction archi P Q R HNCol1) as [S [T [U [HGAE HObtuse]]]].
    apply archi__obtuse_case_elimination in archi.
    apply not_col_permutation_4 in HNCol.
    destruct (legendre_aux2 archi A B C HNCol HAcute legendre P Q R S T U HDef HGAE) as [B' [C' HInter]].
    destruct HInter as [P' [Q' [R' [HOutB [HOutC [HDef' HLea]]]]]].
    apply (lea_obtuse_obtuse P' Q' R'), obtuse__nsams in HObtuse; auto.
    exfalso.
    apply HObtuse.
    destruct (legendre_aux1 A B C B' C') as [D' [HInangle [HConga [HCong HTS]]]]; trivial.
    assert (HNCol' : ~ Col A B' C') by (destruct HTS; Col).
    destruct (legendre D' HInangle) as [B'' [C'' [HOutB' [HOutC' HBet]]]].
    assert_diffs.
    destruct (ex_defect A B'' C'') as [S' [T' [U' HDef'']]]; auto.
      intro; subst; apply HNCol; ColR.
    destruct (ex_suma P' Q' R' P' Q' R') as [V [W [X HSuma]]]; auto.
    destruct (legendre_aux archi A B' C' D' B'' C'' P' Q' R' S' T' U' V W X); trivial;
    [apply l6_7 with B|apply l6_7 with C]; Out.
Qed.

Theorem legendre_s_fourth_theorem :
  archimedes_axiom ->
  legendre_s_parallel_postulate ->
  postulate_of_existence_of_a_triangle_whose_angles_sum_to_two_rights.
Proof.
  intros; apply triangle__existential_triangle, rah__triangle, legendre_s_fourth_theorem_aux; assumption.
Qed.

End Legendre.


Inductive t : nat -> Type :=
| nil : t 0
| cons : forall n, nat -> t n -> t (S n).


Require Import IZF.
Require Import IZFOmega.
Require Import Lists.List.

Module IZFConstructionsF (ST: IZF).
  Import ST.
  Module IZFOmegaM := IZFOmegaF ST.
  Include IZFOmegaM.

  Inductive ind_rule : Type :=
  | ind : (set -> ind_rule) -> ind_rule
  | ext : forall {S}, (forall x, x ∈ S -> ind_rule) -> ind_rule
  | ins : set -> ind_rule.

  Reserved Notation "⦅ x ⦆ y" (at level 60).
  Program Fixpoint interp_rule (r: ind_rule) (X: set) : set :=
    match r with
    | ind f => ⋃ (replacement (fun x (_: x ∈ X) => ⦅f x⦆X))
    | ins x => x +> ∅
    | ext f => ⋃ (replacement (fun x H => ⦅f x H⦆X))
    end
  where "⦅ x ⦆ y" := (interp_rule x y).

  Reserved Notation "⟦ x ⟧ y" (at level 60).
  Fixpoint interp_rules (rs: list ind_rule) (X: set) : set :=
    match rs with
    | nil => ∅
    | r::rs => (⦅r⦆X) ∪ (⟦rs⟧X)
    end
  where "⟦ x ⟧ y" := (interp_rules x y).

  Fixpoint rule_prop (r: ind_rule) (X: set) (S: set) : Prop :=
    match r with
    | ind f => forall x, x ∈ X -> rule_prop (f x) X S
    | ins x => x ∈ S
    | ext f => forall x H, rule_prop (f x H) X S
    end.

  Fixpoint rules_prop_suc (rs: list ind_rule) (X: set) (S: set) : Prop :=
    match rs with
    | nil => True
    | r::rs => rule_prop r X S /\ rules_prop_suc rs X S
    end.

  Definition rules_prop rs X := rules_prop_suc rs X (⟦rs⟧X).

  Notation "'has' x , y" := (ind (fun x => y)) (at level 200, x at level 69).
  Notation "'for' x '∈' y , z" := (ext (fun x (_: x ∈ y) => z)) (at level 200, x at level 69).

  Definition nat_Γ X := ⟦(has n, ins ⟨∅,n⟩) :: (ins ⟨∅ +> ∅, ∅⟩) :: nil⟧X.

  Definition nat := lfp nat_Γ.

  Lemma s_in_nat_Γ : forall {n x}, n ∈ x -> ⟨∅,n⟩ ∈ nat_Γ x.
  Proof.
    unfold nat_Γ.
    intros.
    assert (⟨∅,n⟩ ∈ ⟨∅,n⟩ +> ∅) by eauto with zf.
    assert (⟨∅,n⟩ +> ∅ ∈ replacement (fun n (_: n ∈ x) => ⟨ ∅, n ⟩ +> ∅)).
    apply replacement_propG.
    exists n. exists H. eauto with zf.
    assert (⟨ ∅, n ⟩ ∈ (⋃ replacement (fun (n0 : set) (_ : n0 ∈ x) => ⟨ ∅, n0 ⟩ +> ∅))).
    eauto with zf.
    apply union2_propG.
    left.
    auto.
  Qed.

  Lemma suc_in_ϵ_Suc : forall {n x},
      n ∈ ϵ_iter nat_Γ x -> ⟨∅,n⟩ ∈ ϵ_iter nat_Γ (Suc x).
  Proof.
    intros.
    rewrite ϵ_iter_prop.
    assert (⟨∅,n⟩ ∈ nat_Γ (ϵ_iter nat_Γ x)).
    exact (s_in_nat_Γ H).
    assert (nat_Γ (ϵ_iter nat_Γ x) ∈ replacement (fun y (_ : y ∈ Suc x) => nat_Γ (ϵ_iter nat_Γ y))).
    apply replacement_propG.
    exists x. exists x_in_Suc_x. auto.
    eauto with zf.
  Qed.

  Lemma s_in_nat : forall {n}, n ∈ nat -> ⟨∅,n⟩ ∈ nat.
  Proof.
    unfold nat.
    intros.
    apply union_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    assert (Suc x0 ∈ ω) by eauto with zf.
    assert (⟨∅,n⟩ ∈ ϵ_iter nat_Γ (Suc x0)).
    apply suc_in_ϵ_Suc.
    rewrite H. auto.
    assert (ϵ_iter nat_Γ (Suc x0) ∈ replacement (fun x (_: x ∈ ω) => ϵ_iter nat_Γ x)).
    apply replacement_propG.
    exists (Suc x0). exists H1. eauto with zf.
    eauto with zf.
  Qed.

  Lemma z_in_nat : ⟨∅ +> ∅, ∅⟩ ∈ nat.
  Proof.
    unfold nat.
    apply union_propG.
    exists (nat_Γ ∅). split.
    apply replacement_propG.
    exists (∅ +> ∅).
    assert (∅ +> ∅ ∈ ω) by eauto with zf.
    exists H.
    rewrite ϵ_iter_prop.
    apply equiv_ext.
    split; intros.
    apply union_propH in H0.
    destruct H0.
    destruct H0.
    apply replacement_propH in H0.
    destruct H0.
    destruct H0.
    assert (x0 ≡ ∅).
    destruct (insert_propH x1).
    apply empty_prop in H2.
    contradiction.
    auto.
    rewrite H2 in *.
    rewrite ϵ_iter_prop in H0.
    rewrite replacement_of_empty in H0.
    rewrite union_empty in H0.
    subst x.
    auto.
    apply union_propG.
    exists (nat_Γ ∅). split.
    apply replacement_propG.
    exists ∅. assert (∅ ∈ ∅ +> ∅) by eauto with zf.
    exists H1.
    rewrite ϵ_iter_prop.
    rewrite replacement_of_empty.
    rewrite union_empty.
    auto.
    auto.
    unfold nat_Γ.
    simpl.
    rewrite replacement_of_empty.
    rewrite union_empty.
    apply union2_propG.
    right.
    apply union2_propG.
    left.
    eauto with zf.
  Qed.

  Lemma nat_nojunk : forall {x}, x ∈ nat -> x ≡ ⟨∅+>∅,∅⟩ \/ exists x0, x ≡ ⟨∅,x0⟩ /\ x0 ∈ nat.
  Proof.
    intros.
    unfold nat in H.
    unfold lfp in H.
    apply union_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x0.
    rewrite ϵ_iter_prop in H0.
    apply union_propH in H0.
    destruct H0. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    unfold nat_Γ in H.
    subst x0. apply union2_propH in H0.
    destruct H0.
    apply union_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    simpl in *. right.
    subst x0. apply insert_propH in H0.
    destruct H0.
    apply empty_prop in H.
    contradiction.
    exists x5. split. auto.
    unfold nat.
    assert (x3 ∈ ω).
    apply subset_infinity in x2.
    apply x2 in x4. auto.
    unfold lfp.
    apply union_propG.
    exists ( ϵ_iter (fun X : set => (⋃ replacement (fun (x : set) (_ : x ∈ X) => ⟨ ∅, x ⟩ +> ∅)) ∪ ((⟨ ∅ +> ∅, ∅ ⟩ +> ∅) ∪ ∅)) x3).
    split.
    apply replacement_propG.
    exists x3. exists H0. auto.
    auto.
    apply union2_propH in H.
    destruct H.
    apply insert_propH in H.
    destruct H.
    apply empty_prop in H.
    contradiction.
    left. auto.
    apply empty_prop in H.
    contradiction.
  Qed.

  Lemma nat_fixpoint : nat_Γ nat = nat.
  Proof.
    apply equiv_ext.
    split; intros.
    unfold nat_Γ in H.
    simpl in H.
    apply union2_propH in H.
    destruct H.
    apply union_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x.
    apply insert_propH in H0.
    destruct H0.
    auto.
    apply empty_prop in H.
    contradiction.
    subst z.
    apply s_in_nat.
    auto.
    apply union2_propH in H.
    destruct H.
    apply insert_propH in H.
    destruct H.
    auto.
    apply empty_prop in H.
    contradiction.
    subst z.
    apply z_in_nat.
    auto.
    apply empty_prop in H.
    contradiction.
    unfold nat_Γ.
    apply union2_propG.
    apply nat_nojunk in H.
    destruct H.
    subst z.
    right.
    apply union2_propG.
    left.
    simpl.
    eauto with zf.
    destruct H. destruct H.
    left.
    simpl.
    subst z.
    assert (⟨∅,x⟩ ∈ ⟨∅,x⟩ +> ∅) by eauto with zf.
    assert (⟨∅,x⟩ +> ∅ ∈ replacement (fun (x0 : set) (_ : x0 ∈ nat) => ⟨ ∅, x0 ⟩ +> ∅)).
    apply replacement_propG.
    exists x. exists H0. auto.
    eauto with zf.
  Qed.

  Definition tree_Γ X := ⟦(has x, has y, ins ⟨∅, ⟨x, y⟩⟩) :: (ins ⟨∅+>∅,∅⟩) :: nil⟧X.

  Definition trees := lfp tree_Γ.

  Lemma leaf_in_tree_Γ : forall {x}, ⟨∅+>∅,∅⟩ ∈ tree_Γ x.
  Proof.
    intros.
    unfold tree_Γ.
    simpl.
    apply union2_propG.
    right.
    apply union2_propG.
    left.
    eauto with zf.
  Qed.

  Lemma leaf_in_trees : ⟨∅+>∅,∅⟩ ∈ trees.
  Proof.
    unfold trees.
    unfold lfp.
    apply union_propG.
    exists (⟨∅+>∅,∅⟩+>∅).
    split.
    apply replacement_propG.
    exists (∅+>∅).
    assert (∅+>∅∈ω) by eauto with zf.
    exists H. rewrite ϵ_iter_prop.
    apply equiv_ext.
    split; intros.
    apply union_propH in H0.
    destruct H0. destruct H0.
    apply replacement_propH in H0.
    destruct H0. destruct H0.
    subst x.
    apply insert_propH in x1.
    destruct x1. apply empty_prop in H0.
    contradiction.
    subst x0.
    rewrite ϵ_iter_empty in H1.
    unfold tree_Γ in H1.
    simpl in H1.
    apply union2_propH in H1.
    destruct H1.
    rewrite replacement_of_empty in H0.
    rewrite union_empty in H0.
    apply empty_prop in H0.
    contradiction.
    apply union2_propH in H0.
    destruct H0.
    auto.
    apply empty_prop in H0.
    contradiction.
    apply insert_propH in H0.
    destruct H0.
    apply empty_prop in H0.
    contradiction.
    subst z.
    apply union_propG.
    exists (⟨∅+>∅,∅⟩+>∅).
    split.
    apply replacement_propG.
    exists ∅. assert (∅∈∅+>∅) by eauto with zf.
    exists H0. rewrite ϵ_iter_empty. unfold tree_Γ.
    simpl. rewrite replacement_of_empty. rewrite union_empty.
    assert (forall x, x ∪ ∅ ≡ x).
    intros. apply equiv_ext.
    split; intros.
    apply union2_propH in H1.
    destruct H1.
    auto.
    apply empty_prop in H1.
    contradiction.
    apply union2_propG.
    auto.
    rewrite (H1 _).
    assert (forall x, ∅ ∪ x ≡ x).
    intros. apply equiv_ext.
    split; intros.
    apply union2_propH in H2.
    destruct H2.
    apply empty_prop in H2.
    contradiction.
    auto.
    apply union2_propG.
    eauto with zf.
    rewrite (H2 _).
    auto.
    eauto with zf.
    eauto with zf.
  Qed.

  Lemma branch_in_tree_Γ :
    forall {x y z}, x ∈ z -> y ∈ z -> ⟨∅,⟨x,y⟩⟩ ∈ tree_Γ z.
  Proof.
    intros.
    unfold tree_Γ.
    simpl.
    apply union2_propG.
    left.
    apply union_propG.
    exists (⋃ replacement (fun (x1 : set) (_ : x1 ∈ z) => ⟨ ∅, ⟨ x, x1 ⟩ ⟩ +> ∅)).
    split.
    apply replacement_propG.
    exists x. exists H. auto.
    apply union_propG.
    exists (⟨ ∅, ⟨ x, y ⟩ ⟩ +> ∅).
    split.
    apply replacement_propG.
    exists y. exists H0. auto.
    eauto with zf.
  Qed.

  Lemma branch_in_suc :
    forall {x y z}, x ∈ ϵ_iter tree_Γ z -> y ∈ ϵ_iter tree_Γ z -> ⟨∅,⟨x,y⟩⟩ ∈ ϵ_iter tree_Γ (Suc z).
  Proof.
    intros.
    rewrite ϵ_iter_prop.
    apply union_propG.
    exists (tree_Γ (ϵ_iter tree_Γ z)).
    split.
    apply replacement_propG.
    exists z. assert (z ∈ Suc z) by eauto with zf.
    exists H1. auto.
    apply branch_in_tree_Γ; auto.
  Qed.

  Lemma branch_in_tree :
    forall {x y}, x ∈ trees -> y ∈ trees -> ⟨∅,⟨x,y⟩⟩ ∈ trees.
  Proof.
    unfold trees.
    unfold lfp.
    intros.
    apply union_propH in H.
    destruct H. destruct H.
    apply union_propH in H0.
    destruct H0. destruct H0.
    apply replacement_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H0.
    destruct H0. destruct H0.
    subst x0. subst x1.
    apply union_propG.
    destruct (has_meet x3 x5).
    destruct H.
    exists (ϵ_iter tree_Γ (Suc x0)).
    split.
    apply replacement_propG.
    exists (Suc x0). assert (Suc x0 ∈ ω) by eauto with zf.
    exists H3. auto.
    destruct H0.
    pose (in_ϵ_iter_sup H1 H0).
    pose (in_ϵ_iter_sup H2 H3).
    rewrite ϵ_iter_prop.
    apply union_propG.
    exists (tree_Γ (ϵ_iter tree_Γ x0)).
    split.
    apply replacement_propG.
    exists x0. assert (x0 ∈ Suc x0) by eauto with zf.
    exists H4. auto. exact (branch_in_tree_Γ m m0).
  Qed.

  Lemma tree_fixpoint : tree_Γ trees ≡ trees.
  Proof.
    apply equiv_ext.
    split; intros.
    unfold tree_Γ in H.
    simpl in H.
    apply union2_propH in H.
    destruct H.
    apply union_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x.
    apply union_propH in H0.
    destruct H0. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x.
    apply insert_propH in H0.
    destruct H0.
    apply empty_prop in H.
    contradiction.
    subst z.
    apply branch_in_tree; auto.
    apply union2_propH in H.
    destruct H.
    apply insert_propH in H.
    destruct H.
    apply empty_prop in H.
    contradiction.
    subst z.
    apply leaf_in_trees.
    apply empty_prop in H.
    contradiction.
    unfold trees in H.
    unfold lfp in H.
    apply union_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x.
    rewrite ϵ_iter_prop in H0.
    apply union_propH in H0.
    destruct H0. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x.
    unfold tree_Γ at 1 in H0.
    simpl in H0.
    apply union2_propH in H0.
    destruct H0.
    apply union_propH in H.
    destruct H. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x. apply union_propH in H0.
    destruct H0. destruct H.
    apply replacement_propH in H.
    destruct H. destruct H.
    subst x.
    apply insert_propH in H0.
    destruct H0.
    apply empty_prop in H.
    contradiction.
    subst z.
    apply in_in_ω_in_ω in x3.
    apply branch_in_tree_Γ.
    unfold trees.
    unfold lfp.
    apply union_propG.
    exists (ϵ_iter tree_Γ x2).
    split.
    apply replacement_propG.
    exists x2. exists x3. auto.
    auto.
    unfold trees.
    unfold lfp.
    apply union_propG.
    exists (ϵ_iter tree_Γ x2).
    split.
    apply replacement_propG.
    exists x2. exists x3. auto.
    auto.
    auto.
    apply union2_propH in H.
    destruct H.
    apply insert_propH in H.
    destruct H.
    apply empty_prop in H.
    contradiction.
    subst z.
    apply leaf_in_tree_Γ.
    apply empty_prop in H.
    contradiction.
  Qed.

End IZFConstructionsF.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import finfun bigop prime binomial ssralg finset fingroup finalg.
From mathcomp Require Import perm zmodp matrix.
Require Import Reals Fourier.
Require Import Reals_ext ssr_ext ssralg_ext Rssr log2 Rbigop proba entropy.
Require Import binary_entropy_function channel hamming channel_code.

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

(** * Capacity of the binary symmetric channel *)

Local Open Scope channel_scope.

Module BSC.

Section BSC_sect.

Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.
Variable p : R.
Hypothesis p_01 : 0 <= p <= 1.

(** Definition of the Binary Symmetric Channel (BSC) *)

(* NB: bdist <-> BSC? *)

Definition f (a : A) := fun a' => if a == a' then 1 - p else p.

Lemma f0 (a a' : A) : 0 <= f a a'.
Proof. rewrite /f. case: ifP => _; case: p_01 => ? ?; fourier. Qed.

Lemma f1 (a : A) : \rsum_(a' | a' \in A) f a a' = 1.
Proof.
move: (enum_uniq A).
move: (card_A).
rewrite /index_enum -enumT.
rewrite cardE.
case: (enum A) => // h [] // h' [] //= _.
rewrite inE andbC /= => h_h'.
rewrite big_cons /= big_cons /= big_nil.
rewrite /f.
case: ifP.
+ move/eqP => ?; subst h.
  rewrite (negbTE h_h'); by field.
+ move/negP/negP => a_h.
  suff : a == h' by move=> ->; by field.
  apply/negPn/negP => Habs.
  have : (3 <= #|A|)%nat.
    rewrite (cardD1 a) /= (cardD1 h) /= inE eqtype.eq_sym a_h /=.
    by rewrite (cardD1 h') /= inE eq_sym h_h' /= inE eq_sym Habs.
  by rewrite card_A.
Qed.

Definition c : `Ch_1(A, A) := fun a => makeDist (f0 a) (f1 a).

End BSC_sect.

End BSC.

Lemma closed p : 0 < p < 1 -> 0 <= p <= 1.
Proof. case => ?; split; by apply Rlt_le. Qed.

Local Open Scope channel_scope.
Local Open Scope entropy_scope.

Section bsc_capacity_proof.

Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.
Variable P : dist A.
Variable p : R.
Hypothesis p_01' : 0 < p < 1.

Let p_01 := closed p_01'.

Lemma HP_HPW : `H P - `H(P , BSC.c card_A p_01) = - H2 p.
Proof.
rewrite {1}/entropy {1}/entropy /=.
rewrite -(pair_big xpredT xpredT (fun a b =>
  (if a == b then 1 - p else p) * P a * log ((if a == b then 1 - p else p) * P a))) /=.
set a := \rsum_(_ in _) _. set b := \rsum_(_ <- _) _.
apply trans_eq with (- (a + (-1) * b)); first by field.
rewrite /b {b} big_distrr /= /a {a} -big_split /=.
rewrite /index_enum -enumT Two_set.enum.
rewrite big_cons /= big_cons /= big_cons /= big_cons /= big_nil /= big_cons /= big_cons /= big_nil /= big_nil /=.
rewrite !addR0 !eqxx.
rewrite !(negbTE (Two_set.val0_neq_val1 card_A)).
move: (Two_set.val0_neq_val1 card_A).
rewrite eq_sym.
move/negbTE => ->.
rewrite /H2.
have Hpmf1 : P (Two_set.val0 card_A) + P (Two_set.val1 card_A) = 1.
  rewrite -(pmf1 P) /index_enum -enumT Two_set.enum big_cons /= big_cons /= big_nil /=; by field.
case: (Req_EM_T (P (Two_set.val0 card_A)) 0) => H1.
  rewrite H1.
  rewrite !(mul0R, mulR0, addR0, add0R).
  rewrite H1 add0R in Hpmf1.
  rewrite Hpmf1 log_1.
  rewrite !(mul0R, mulR0, addR0, add0R, mul1R, mulR1).
  field.
rewrite log_mult; last 2 first.
  case: p_01' => ? ?; fourier.
  apply Rlt_le_neq => //.
  by apply Rle0f.
  by auto.
rewrite log_mult; last 2 first.
  case: p_01' => ? ?; fourier.
  apply Rlt_le_neq => //.
  by apply Rle0f.
  by auto.
case: (Req_EM_T (P (Two_set.val1 card_A)) 0) => H2.
  rewrite H2.
  rewrite !(mul0R, mulR0, addR0, add0R).
  rewrite H2 addR0 in Hpmf1.
  rewrite Hpmf1.
  rewrite log_1.
  rewrite !(mul0R, mulR0, addR0, add0R, mul1R, mulR1).
  field.
rewrite log_mult; last 2 first.
  case: p_01' => ? ?; fourier.
  apply Rlt_le_neq => //.
  by apply Rle0f.
  by auto.
rewrite log_mult; last 2 first.
  case: p_01' => ? ?; fourier.
  apply Rlt_le_neq; last by auto.
  by apply Rle0f.
transitivity (p * (P (Two_set.val0 card_A) + P (Two_set.val1 card_A)) * log p  + (1 - p) * (P (Two_set.val0 card_A) + P (Two_set.val1 card_A)) * log (1 - p) ).
  by field.
rewrite Hpmf1; by field.
Qed.

Lemma IPW : `I(P ; BSC.c card_A p_01) = `H(P `o BSC.c card_A p_01) - H2 p.
Proof.
rewrite /mut_info addRC.
set a := `H(_ `o _).
apply trans_eq with (a + (`H P - `H(P , BSC.c card_A p_01))); first by field.
by rewrite HP_HPW.
Qed.

Lemma H_out_max : `H(P `o BSC.c card_A p_01) <= 1.
Proof.
rewrite {1}/OutDist.d {1}/OutDist.f {1}/entropy /=.
rewrite /index_enum -enumT Two_set.enum.
rewrite big_cons /= big_cons /= big_cons /= big_cons /= big_nil /=.
rewrite big_cons /= big_cons /= big_nil /= big_nil /= !addR0.
rewrite /BSC.f.
rewrite !eqxx.
rewrite !(negbTE (Two_set.val0_neq_val1 card_A)).
move: (Two_set.val0_neq_val1 card_A).
rewrite eq_sym.
move/negbTE => ->.
have -> : p * P (Two_set.val0 card_A) + (1 - p) * P (Two_set.val1 card_A) = 1 - ((1 - p) * P (Two_set.val0 card_A) + p * P (Two_set.val1 card_A)).
  rewrite -{2}(_ : P (Two_set.val0 card_A) + P (Two_set.val1 card_A) = 1); last first.
    rewrite -(pmf1 P) /index_enum -enumT Two_set.enum big_cons /= big_cons /= big_nil /=; by field.
  field.
have H01 : 0 < ((1 - p) * P (Two_set.val0 card_A) + p * P (Two_set.val1 card_A)) < 1.
  have Htmp : P (Two_set.val0 card_A) + P (Two_set.val1 card_A) = 1.
    rewrite -(pmf1 P) /index_enum -enumT Two_set.enum big_cons /= big_cons /= big_nil /=; by field.
  move: (Rle0f P (Two_set.val0 card_A)) => H1.
  move: (dist_max P (Two_set.val1 card_A)) => H4.
  move: (dist_max P (Two_set.val0 card_A)) => H3.
  case: p_01' => Hp1 Hp2.
  split.
    case/Rle_lt_or_eq_dec : H1 => H1.
    - apply Rplus_lt_le_0_compat.
      apply Rmult_lt_0_compat; fourier.
      apply Rmult_le_pos; fourier.
    - rewrite -H1 mulR0 add0R.
      have -> : P (Two_set.val1 card_A) = 1 by rewrite -Htmp -H1 add0R.
      by rewrite mulR1.
  rewrite -{2}Htmp.
  case: (Req_EM_T (P (Two_set.val0 card_A)) 0) => Hi.
    rewrite Hi mulR0 !add0R.
    rewrite Hi add0R in Htmp.
    by rewrite Htmp mulR1.
  case: (Req_EM_T (P (Two_set.val1 card_A)) 0) => Hj.
    rewrite Hj addR0 in Htmp.
    rewrite Hj mulR0 !addR0 Htmp mulR1.
    fourier.
    case/Rle_lt_or_eq_dec : H1 => H1.
    - apply Rplus_le_lt_compat.
      + rewrite -{2}(mul1R (P (Two_set.val0 card_A))).
        apply Rmult_le_compat_r; fourier.
      + rewrite -{2}(mul1R (P (Two_set.val1 card_A))).
        apply Rmult_lt_compat_r => //.
        apply Rlt_le_neq => //.
        by apply Rle0f.
        by auto.
    - rewrite -H1 mulR0 2!add0R.
      have -> : P (Two_set.val1 card_A) = 1 by rewrite -Htmp -H1 add0R.
      by rewrite mulR1.
rewrite (_ : forall a b, - (a + b) = - a - b); last by move=> *; field.
rewrite -Ropp_mult_distr_l_reverse.
set q := (1 - p) * P (Two_set.val0 card_A) + p * P (Two_set.val1 card_A).
eapply (Rle_trans _ (H2 q)); last by apply H2_max.
rewrite /H2 !Ropp_mult_distr_l; apply Req_le; field.
Qed.

Lemma bsc_out_H_half' : 0 < INR 1 / INR 2 < 1.
Proof. rewrite /= (_ : INR 1 = 1) // (_ : INR 2 = 2) //; split; fourier. Qed.

Lemma H_out_binary_uniform :
  `H(Uniform.d card_A `o BSC.c card_A p_01) = 1.
Proof.
rewrite {1}/OutDist.d {1}/OutDist.f {1}/entropy /=.
rewrite /index_enum -enumT Two_set.enum.
rewrite big_cons /= big_cons /= big_cons /= big_cons /= big_nil /= big_cons /= big_cons /= big_nil /= big_nil /=.
rewrite !addR0 /BSC.f !eqxx !(negbTE (Two_set.val0_neq_val1 card_A)).
move: (Two_set.val0_neq_val1 card_A).
rewrite eq_sym.
move/negbTE => ->.
rewrite -!mulRDl (_ : 1 - p + p = 1); last by field.
rewrite mul1R (_ : p + (1 - p) = 1); last by field.
rewrite mul1R -!mulRDl /Uniform.f card_A.
rewrite (_ : INR 1 = 1) // (_ : INR 2 = 2) // /Rdiv mul1R log_Rinv; last by fourier.
rewrite log_2 /=; field.
Qed.

End bsc_capacity_proof.

Section bsc_capacity_theorem.

Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.
Variable p : R.
Hypothesis p_01' : 0 < p < 1.
Let p_01 := closed p_01'.

(** The capacity of a Binary Symmetric Channel: *)

Theorem BSC_capacity : capacity (BSC.c card_A p_01) (1 - H2 p).
Proof.
rewrite /capacity; split.
- move=> d.
  move: (@IPW _ card_A d _ p_01') => tmp.
  suff : `H(d `o BSC.c card_A p_01) <= 1.
    move=> ?.
    unfold p_01 in *.
    fourier.
  by apply H_out_max.
- move=> d Hd.
  move: (@IPW _ card_A (Uniform.d card_A) _ p_01').
  rewrite H_out_binary_uniform => <-.
  by apply Hd.
Qed.

End bsc_capacity_theorem.

Section dH_BSC.

Variable p : R.
Hypothesis p_01 : (0 <= p <= 1)%R.

Let card_F2 : #| 'F_2 | = 2%nat. by rewrite card_Fp. Qed.

Let W := BSC.c card_F2 p_01.

Variable M : finType.
Variable n : nat.
Variable c : code [finType of 'F_2] [finType of 'F_2] M n.

Let f := enc c.

Local Open Scope vec_ext_scope.

Lemma DMC_BSC_prop : forall m tb,
  let d := dH tb (f m) in
  W ``^ n (tb | (f m)) = ((1 - p) ^ (n - d) * p ^ d)%R.
Proof.
move=> m tb d.
rewrite /DMC.c; unlock => /=.
rewrite /DMC.f /= /BSC.f /=.
transitivity ((\rmul_(i < n | (f m) ``_ i == tb ``_ i) (1 - p)) *
              (\rmul_(i < n | (f m) ``_ i != tb ``_ i) p))%R.
  rewrite (bigID [pred i | (f m) ``_ i == tb ``_ i]) /=.
  f_equal.
  by apply eq_bigr => //= i ->.
  by apply eq_bigr => //= i /negbTE ->.
congr (_ * _).
by rewrite big_const /= iter_Rmult /= card_dHC.
by rewrite big_const /= iter_Rmult /= card_dH_vec.
Qed.

Local Close Scope vec_ext_scope.

End dH_BSC.


Require Import Zdiv.
Require Import List.
Require Import Arith.
Require Import Zquot.
Require Import NPeano.
Require Import PeanoNat.
Import Nat.
Require Export ucp.
Require Export logic.
Require Export list_facts.

Inductive evenl A :=
| Enil : evenl A
| Econsc : A -> A -> evenl A -> evenl A.

Definition divides_dec n m : {n mod m = 0}+{n mod m <> 0}.
Proof.
  apply eq_nat_dec.
Defined.

Require Import Omega.
Lemma pltppq : forall p q, (0 <= q -> p <= p + q)%Z.
Proof.
  intros. omega.
Qed.

Lemma Zneglt0 : forall p, (Z.neg p < 0)%Z.
Proof.
  intros. unfold Z.lt. simpl. reflexivity.
Qed.

Lemma ltneqgt : forall p q, (p < q -> p > q -> False)%Z.
Proof.
  intros. omega.
Qed.

Lemma exneggt0 : forall p, (Z.neg p > 0)%Z -> False.
Proof.
  intros. apply (ltneqgt (Z.neg p) 0%Z).
  apply Zneglt0.
  assumption.
Qed.

Lemma prodsgn : forall n m, (0 < n -> 0 < n * m -> 0 < m)%Z.
Proof.
  destruct n, m; auto; try omega.
  intros. elim (exneggt0 p). omega.
Qed.

Lemma ltadd : forall p q, (p <= p + q <-> 0 <= q)%Z.
Proof.
  intros. omega.
Qed.

Lemma prodSn : forall n m, (0 < n -> 0 < m -> n <= n * m)%Z.
Proof.
  intros. destruct n, m;
          auto;
          try omega;
          try solve [ elim (exneggt0 p0); omega ];
          try solve [ elim (exneggt0 p); omega ].
  clear.
  destruct p0 using Pos.peano_ind; [ omega | clear IHp0 ].
  assert (Z.pos (Pos.succ p0) = 1 + Z.pos p0)%Z.
    simpl. destruct p0; auto.
  rewrite H. clear H. rewrite Zmult_plus_distr_r.
  rewrite Zmult_comm. assert (forall z, (1 * z = z)%Z); [ intros; omega | ].
  rewrite H. clear H.
  rewrite ltadd. simpl. unfold Z.le. simpl. intro. discriminate.
Qed.

Lemma itenat2Z :
  forall A n m (tv fv : A),
    (if eq_nat_dec n m then tv else fv) = (if Z.eq_dec (Z.of_nat n) (Z.of_nat m) then tv else fv).
Proof.
  intros. destruct eq_nat_dec.
  subst. destruct Z.eq_dec. reflexivity. elim n. reflexivity.
  destruct Z.eq_dec; [ | reflexivity ].
  elim n0. omega.
Qed.

Lemma OeqOZ : Z.of_nat 0 = 0%Z. simpl. reflexivity. Qed.

Lemma divides_lt : forall m n, n <> 0 -> m <> 0 -> n mod m = 0 -> m <= n.
Proof.
  intros m n nnz mneq0 mdiv.
  destruct (Nat.div_exact n m mneq0) as [ _ mdivthenndivexact ].
  assert (divexact := mdivthenndivexact mdiv). clear mdivthenndivexact.
  assert (smallthen0 := Nat.div_small n m).
  destruct (lt_dec n m) as [ small | notsmall ].
  rewrite (smallthen0 small) in divexact. elim nnz. rewrite divexact. rewrite mult_comm. simpl. reflexivity.
  revert notsmall. clear. intros. omega.
Qed.

Lemma gtnotdivides' : forall n m, n <> 0 -> n < m -> (forall x, m <= x -> n mod x <> 0).
Proof.
  intros n m nnz nltm x mlex.
  assert (m <> 0) as mnz. omega.
  assert (n < x) as nltx. omega.
  assert (x <> 0) as xnz. omega.
  rewrite <- (Nat.mod_small_iff _ _ xnz) in nltx.
  rewrite nltx. assumption.
Qed.

Lemma gtnotdivides : forall n m, n <> 0 -> n < m -> n mod m <> 0.
Proof.
  intros.
  apply (gtnotdivides' n m H H0 m). constructor.
Qed.

Fixpoint conformants''x {P : nat -> Prop} (dec : forall n, {P n}+{~P n}) nn : list nat :=
  match nn with
    | O => nil
    | S nn' => let l' := conformants''x dec nn'
               in if dec nn'
                  then nn'::l'
                  else l'
  end.

Lemma conformants'
         {P : nat -> Prop}
         (dec : forall n, {P n}+{~P n})
         (nn : nat)
: confprops'' (conformants''x dec nn) P nn.

Proof.
  unfold confprops''. induction nn.
  - simpl. split; [ | split; [ | split ] ]; auto. intros. omega.
  - destruct IHnn as [ set [ ltx [ conf meat ] ] ]. split; [ | split; [ | split ] ]; simpl; remember (conformants''x dec nn) as l'; clear Heql'.
    + destruct (dec nn); [ | assumption ].
      simpl. rewrite set. destruct (inb eq_nat_dec nn _) eqn:inbeq; [ | reflexivity ].
      exfalso. revert inbeq ltx dec. clear. intros.
      apply forallneqthennotin with (A := nat) (dec:=eq_nat_dec) (l:=l') (a:=nn).
      * apply PthenQthenFAPthenFAQ with (P := fun x => x < nn).
        clear. intros. omega.
        assumption.
      * assumption.
    + destruct (dec nn);
      [ constructor; [ omega | ] | ];
        apply PthenQthenFAPthenFAQ with (P:=fun x => x < nn);
        try solve [ intros; omega ]; assumption.
    + destruct (dec nn); [ | assumption ].
      constructor; assumption.
    + intros. destruct (dec nn).
      * destruct (eq_nat_dec nn n). left. assumption.
        right. apply meat. omega. assumption.
      * destruct (eq_nat_dec nn n). elim n0. rewrite e. assumption.
        apply meat. omega. assumption.
Qed.

Definition divisors_raw {n} (nnz : n <> 0) := conformants''x (divides_dec n) (S n).

Lemma divisorspf :
  forall {n} (nnz : n <> 0),
    confprops (divisors_raw nnz) (fun x => n mod x = 0).
Proof.
  unfold confprops.
  intros n nnz.
  unfold divisors_raw.
  assert (gtnd := fun m => gtnotdivides _ m nnz). unfold lt in gtnd.
  assert (Hx := @conformants' _ (divides_dec n) (S n)).
  assert (Hy := @conformants _ _ gtnd _ Hx).
  unfold confprops in Hy.
  destruct Hy as [ set [ ldiv divIn ] ].
  split; [ assumption | ].
  apply confiff. assumption. assumption.
Qed.

Lemma nsq : forall n, (S n) * (S n) = n*n + 2*n + 1.
Proof.
  intros. ring.
Qed.

Lemma nsqsub : forall n, (S n)*(S n) - n*n = 2*n + 1.
Proof.
  intros. rewrite nsq. omega.
Qed.

Lemma div_modnz : forall n k, n <> 0 -> k <> 0 -> n mod k = 0 -> n / k <> 0.
Proof.
  intros n k nnz knz kdivn.
  rewrite <- (Nat.div_exact n k knz) in kdivn.
  destruct (n / k). rewrite mult_comm in kdivn. simpl in kdivn. subst. assumption.
  intro. discriminate.
Qed.

Lemma deqndndd : forall n d, n <> 0 -> n mod d = 0 -> d = n / (n / d).
Proof.
  intros n d nnz ddiv.
  destruct (eq_nat_dec d 0) as [ dz | dnz ]. subst. simpl. reflexivity.
  rewrite <- (Nat.div_exact n d dnz) in ddiv.
  rewrite ddiv at 1.
  rewrite Nat.div_mul. reflexivity.
  apply div_modnz; [ assumption | assumption | ].
  rewrite <- Nat.div_exact; assumption.
Qed.

Lemma deneqden :
  forall n d1 d2,
    n <> 0 ->
    d1 <> 0 ->
    n mod d1 = 0 ->
    d2 <> 0 ->
    n mod d2 = 0 ->
    n / d1 = n / d2 ->
    d1 = d2.
Proof.
  intros n d1 d2 nnz d1nz d1d d2nz d2d deq.
  assert (n / d2 <> 0) as ndd2nz.
    apply (div_modnz _ _ nnz d2nz d2d).
  assert (dm1 := div_mod n d1 d1nz).
  assert (dm2 := div_mod n d2 d2nz).
  rewrite dm2 in dm1 at 1. clear dm2.
  rewrite deq in dm1. clear deq.
  rewrite d1d in dm1. rewrite d2d in dm1. clear d1d d2d.
  rewrite plus_comm in dm1. simpl in dm1. rewrite plus_comm in dm1. simpl in dm1.
  rewrite mult_comm in dm1. rewrite (mult_comm d1) in dm1.
  rewrite Nat.mul_cancel_l in dm1.
  rewrite dm1. reflexivity.
  assumption.
Qed.

Lemma divisorpair : forall n k, n mod k = 0 -> n mod (n / k) = 0.
Proof.
  intros n k kdiv.
  destruct (eq_nat_dec n 0) as [ nz | nnz ]. subst.
    destruct k. simpl. reflexivity. simpl. reflexivity.
  destruct (eq_nat_dec k 0) as [ kz | knz ]. subst. simpl. reflexivity.
  assert (ndivkexact := Nat.div_exact n k knz).
  assert (ndknz := div_modnz n k nnz knz kdiv).
  rewrite <- Nat.div_exact; [ | assumption ]. rewrite mult_comm.
  rewrite <- deqndndd; try assumption.
  rewrite ndivkexact; assumption.
Qed.

Lemma nfsq : forall n k, k <> 0 -> n mod k = 0 -> k = n / k -> n = k * k.
Proof.
  intros n k knz kdiv keqndk. rewrite <- (Nat.div_exact n k knz) in kdiv.
  rewrite <- keqndk in kdiv. assumption.
Qed.

Lemma fsqn : forall n k, n = k * k -> k = n / k.
Proof.
  intros n k neqkk.
  destruct (eq_nat_dec k 0).
  subst. simpl. reflexivity.
  rewrite neqkk. rewrite Nat.div_mul. reflexivity.
  assumption.
Qed.

Lemma fsqd : forall n k, n = k * k -> n mod k = 0.
Proof.
  intros. rewrite H.
  destruct (eq_nat_dec k 0).
  subst. simpl. reflexivity.
  apply Nat.mod_mul. assumption.
Qed.

Lemma sqiff : forall n k, k <> 0 -> ((n mod k = 0 /\ n mod (n / k) = 0 /\ k = n / k) <-> n = k * k).
Proof with auto.
  intros n k knz.
  split; [ intros [ kdiv [ ndkdiv keqndk ] ] | intro nsq ].
  - apply nfsq...
  - split; [ | split; [ apply divisorpair | apply fsqn ] ]; auto; apply fsqd...
Qed.

Lemma sqrtuniq : forall n k l, n = k * k -> n = l * l -> k = l.
Proof.
  intros n k l ksq lsq. intros.
  rewrite <- Nat.sqrt_square with l.
  rewrite <- Nat.sqrt_square with k.
  rewrite <- ksq. rewrite <- lsq.
  reflexivity.
Qed.

Lemma divy : forall n k l, n = k * l -> n mod k = 0 /\ n mod l = 0.
Proof.
  intros.
  destruct (eq_nat_dec k 0) as [ kz | knz ]. subst. simpl. split; auto. destruct l; auto. simpl. rewrite minus_diag. reflexivity.
  destruct (eq_nat_dec l 0) as [ lz | lnz ]. subst. simpl. split; auto. rewrite mult_comm. simpl. destruct k; auto. simpl. rewrite minus_diag. reflexivity.
  assert (Hk := Nat.mod_mul l k knz).
  assert (Hl := Nat.mod_mul k l lnz).
  rewrite mult_comm in Hk.
  rewrite <- H in *. split; assumption.
Qed.

Lemma divdiv :
  forall n k m (knz : k <> 0) (nnz : n <> 0),
    k mod m = 0 ->
    n mod k = 0 ->
    n mod m = 0.
Proof.
  intros n k m knz nnz mdivk kdivn.
  destruct (eq_nat_dec m 0) as [ mz | mnz ].
    subst. simpl. reflexivity.
  rewrite <- (Nat.div_exact _ _ mnz) in mdivk.
  rewrite <- (Nat.div_exact _ _ knz) in kdivn.
  rewrite mdivk in kdivn.
  rewrite kdivn. rewrite <- mult_assoc. rewrite mult_comm.
  apply Nat.mod_mul. assumption.
Qed.

Lemma divsdivs :
  forall n k (knz : k <> 0) (nnz : n <> 0),
    n mod k = 0 ->
    incl (divisors_raw knz) (divisors_raw nnz).
Proof.
  intros n k knz nnz kdiv.
  destruct (divisorspf knz) as [ _ kdivpf ].
  destruct (divisorspf nnz) as [ _ ndivpf ].
  unfold incl. rewrite <- Forall_forall.
  apply FAfe with (fun x => n mod x = 0). intros. rewrite <- ndivpf. assumption.
  assert (Forall (fun x => k mod x = 0) (divisors_raw knz)) as famodin.
    rewrite Forall_forall. intros. rewrite kdivpf. assumption.
  apply PthenQthenFAPthenFAQ with (fun x => k mod x = 0); auto.
  intros. apply divdiv with k; auto.
Qed.

Lemma divlcontainsn :
  forall n (nnz : n <> 0),
    let l := divisors_raw nnz in
    (In 0 l /\ In 1 l /\ In n l).
Proof.
  intros.
  destruct (divisorspf nnz) as [ _ iff ].
  unfold l.
  split; [ | split ]; rewrite <- iff; auto.
  apply Nat.mod_same. assumption.
Qed.

Lemma sqz :
  forall n,
    sqrt n = 0 <-> n = 0.
Proof.
  intros.
  split; intro.
  - destruct n; auto.
    destruct n; auto.
    assert (Hx := Nat.sqrt_le_mono 1 (S (S n))).
    assert (1 <= S (S n)); [ omega | ].
    assert (Hy := Hx H0). rewrite H in Hy.
    rewrite Nat.sqrt_1 in Hy.
    omega.
  - rewrite H.
    rewrite Nat.sqrt_0. reflexivity.
Qed.

Lemma sqval :
  forall n,
    sqrt n <= n / sqrt n.
Proof.
  intros.
  destruct (eq_nat_dec n 0). simpl. subst. rewrite Nat.sqrt_0. auto.
  assert (sqrt n <> 0). intro. rewrite sqz in H. subst. elim n0. reflexivity.
  destruct (sqrt_spec n); [ omega | ]. unfold lt in *.
  assert (Hx :=  Nat.div_le_lower_bound _ _ _ H H0). assumption.
Qed.

Lemma sq_exact :
  forall n,
    n mod (sqrt n) = 0 ->
    sqrt n <= n / sqrt n <= 2 + sqrt n.
Proof.
  intros n sqdiv.
  destruct (eq_nat_dec n 0). subst. rewrite Nat.sqrt_0. split. simpl. constructor. simpl. repeat constructor.
  assert (sqrt n <> 0). rewrite sqz. assumption.
  assert (ndsqdiv := divisorpair _ _ sqdiv).
  assert (Hx := sqval n).
  assert (Hy := Nat.div_exact n (sqrt n) H).
  assert (n / sqrt n <> 0). apply div_modnz; auto.
  assert (Hz := Nat.div_exact n (n / sqrt n) H0).
  generalize sqdiv. intro neqsq. rewrite <- Hy in neqsq. clear Hy.
  generalize ndsqdiv. intro neqnsq. rewrite <- Hz in neqnsq. clear Hz.
  destruct (sqrt_spec n); [ omega | ]. unfold lt in H2. simpl in H2.
  assert (n <= sqrt n + sqrt n * S (sqrt n)). omega. clear H2.
  assert (sqrt n <= n / sqrt n <= 2 + sqrt n). split.
    assumption. assert (Hxx := Nat.div_le_mono n (sqrt n + sqrt n * S (sqrt n)) _ H H3).
    assert (sqrt n + sqrt n * S (sqrt n) = sqrt n * (2 + (sqrt n))).
      assert (2 + sqrt n = 1 + S (sqrt n)). omega. rewrite H2. rewrite mult_plus_distr_l.
      rewrite (mult_comm _ 1). simpl. rewrite (plus_comm _ 0). simpl. reflexivity.
      rewrite H2 in Hxx. rewrite mult_comm in Hxx. rewrite Nat.div_mul in Hxx; auto.
  assumption.
Qed.

Lemma sqrt_corr :
  forall n k,
    n = k * k ->
    k = sqrt n.
Proof.
  intros.
  assert (hh := Nat.sqrt_square k). rewrite <- H in *. rewrite hh. reflexivity.
Qed.

Lemma sqrt_corr_sq :
  forall n,
    n <> sqrt n * sqrt n -> (forall k, n <> k * k).
Proof.
  intros. intro.
  elim H. clear H.
  assert (sqrt n = sqrt (k * k)). rewrite H0. reflexivity.
  rewrite H. rewrite Nat.sqrt_square. assumption.
Qed.

Lemma perfect_root_dec :
  forall n,
    {k | n = k * k}+{forall k, n <> k * k}.
Proof.
  intros.
  destruct (eq_nat_dec n (sqrt n * sqrt n)).
  - left. exists (sqrt n). assumption.
  - right. apply sqrt_corr_sq. assumption.
Defined.

Lemma not_square_then_m_neq_ndm :
  forall n,
    (forall k, n <> k * k) ->
    (forall m,
       m <> 0 ->
       n mod m = 0 ->
       m <> n / m).
Proof.
  intros n nsq m mnz mdiv.
  intro meqndm.
  assert (Hx := nfsq n _ mnz mdiv meqndm).
  elim (nsq m).
  assumption.
Qed.

Lemma meqndmsq :
  forall n m,
    m <> 0 ->
    n mod m = 0 ->
    m = n / m ->
    m = (sqrt n).
Proof.
  intros n m mnz mdiv meqndm.
  assert (Hx := nfsq _ _ mnz mdiv meqndm).
  assert (Hy := sqrt_corr _ _ Hx).
  assumption.
Qed.

Definition divisors_nz {n} (nnz : n <> 0) := remove eq_nat_dec 0 (divisors_raw nnz).
Definition divisors_nsr {n} (nnz : n <> 0) := let nzd := divisors_nz nnz in
                                              if eq_nat_dec n (sqrt n * sqrt n)
                                              then remove eq_nat_dec (sqrt n) nzd
                                              else nzd.

Lemma divisors_nz_nz :
  forall n (nnz : n <> 0) a,
    In a (divisors_nz nnz) -> a <> 0.
Proof.
  intros. intro. unfold divisors_nz in H.
  rewrite H0 in H.
  ainral.
Qed.

Lemma divisors_nsr_nz :
  forall n (nnz : n <> 0) a,
    In a (divisors_nsr nnz) -> a <> 0.
Proof.
  intros. intro. unfold divisors_nsr in H. unfold divisors_nz in H.
  rewrite H0 in H.
  destruct (eq_nat_dec n _); [ | ainral ].
  rewrite remove_assoc in H. ainral.
Qed.

Lemma divisors_nz_ainndain :
  forall n (nnz : n <> 0) a,
    In a (divisors_nz nnz) -> In (n / a) (divisors_nz nnz).
Proof.
  intros n nnz0 a pf.
  destruct (divisorspf nnz0) as [ lzset indiv ].
  assert (anz := divisors_nz_nz _ nnz0 _ pf).
  unfold divisors_nz in *.
  ainrbl.
  generalize pf; intro. rewrite <- indiv in pf0.
  assert (Hx := divisorpair _ _ pf0).
  assert (Hy := div_modnz _ _ nnz0 anz pf0).
  rewrite indiv in Hx. rewrite <- remove_corr_neq; [ | neqneq ].
  assumption.
Qed.

Lemma divisors_nsr_ainndain :
  forall n (nnz : n <> 0) a,
    In a (divisors_nsr nnz) -> In (n / a) (divisors_nsr nnz).
Proof.
  intros n nnz0 a pf.
  destruct (divisorspf nnz0) as [ lzset indiv ].
  assert (anz := divisors_nsr_nz _ nnz0 _ pf).
  unfold divisors_nsr in *. unfold divisors_nz in *.
  destruct (eq_nat_dec n (sqrt n * sqrt n)) as [ nsq' | nnsq' ].
  - rewrite remove_assoc in pf. ainrbl.
    destruct (eq_nat_dec (sqrt n) a) as [ xeqa | xnea ].
    + rewrite xeqa in *. ainral.
    + assert (anex := neqflip _ _ _ xnea). ainrbl.
      generalize pf; intro. rewrite <- indiv in pf0.
      assert (ndad := divisorpair _ _ pf0). rewrite indiv in ndad.
      assert (ndanz := div_modnz _ _ nnz0 anz pf0).
      rewrite remove_assoc. rewrite <- remove_corr_neq; [ | neqneq ].
      destruct (eq_nat_dec (sqrt n) (n / a)); [ | rewrite <- remove_corr_neq; assumption ].
      rewrite (fsqn _ _ nsq') in e.
      rewrite (deneqden _ _ (sqrt n) nnz0 anz pf0) in xnea.
      * elim xnea. reflexivity.
      * intro srz. rewrite srz in nsq'. simpl in nsq'. elim nnz0. assumption.
      * apply fsqd. assumption.
      * rewrite e. reflexivity.
  - apply divisors_nz_ainndain. assumption.
Qed.

Lemma divisors_nz_ainadiv :
  forall n (nnz : n <> 0) a,
    In a (divisors_nz nnz) -> n mod a = 0.
Proof.
    intros n nnz a ainl.
    assert (anz := divisors_nz_nz _ nnz _ ainl).
    destruct (divisorspf nnz) as [ lzset indiv ].
    unfold divisors_nz in ainl.
    rewrite indiv.
    ainrbl. assumption.
Qed.

Lemma divisors_nsr_ainadiv :
  forall n (nnz : n <> 0) a,
    In a (divisors_nsr nnz) -> n mod a = 0.
Proof.
    intros n nnz a ainl.
    assert (anz := divisors_nsr_nz _ nnz _ ainl).
    destruct (divisorspf nnz) as [ lzset indiv ].
    unfold divisors_nsr in ainl. unfold divisors_nz in ainl.
    rewrite indiv.
    destruct (eq_nat_dec n (sqrt n * sqrt n)) as [ nsq | nnsq ].
    - destruct (eq_nat_dec a (sqrt n)) as [ asr | nasr ].
      + rewrite <- asr in ainl. ainral.
      + ainrbl. ainrbl. assumption.
    - ainrbl. assumption.
Qed.

Lemma divisors_nsr_is_set :
  forall n (nnz : n <> 0),
    is_set eq_nat_dec (divisors_nsr nnz) = true.
Proof.
  intros.
  destruct (divisorspf nnz) as [ lzset _ ].
  unfold divisors_nsr. unfold divisors_nz.
  destruct eq_nat_dec; repeat apply setrm; assumption.
Qed.

Lemma divisorcount :
  forall n (nnz : n <> 0) l,
    l = divisors_nsr nnz ->
    Even (length l).

Proof.
  intros n nnz0 l leq.
  destruct (divisorspf nnz0) as [ lzset indiv ].

  assert (inpirr := UIP_inp _ eq_nat_dec _ (divisors_nsr_is_set _ nnz0)).
  rewrite <- leq in inpirr.

  assert (forall a, In a l -> a <> 0) as innz.
    rewrite leq. apply divisors_nsr_nz.

  assert (forall a (pf : In a l), In (n / a) l) as ainndain.
    rewrite leq. apply divisors_nsr_ainndain.

  assert (forall a, In a l -> n / a <> 0) as inndnz.
    intros. apply innz. apply ainndain. assumption.

  assert (forall a, In a l -> n mod a = 0) as inldiv.
   rewrite leq. apply (divisors_nsr_ainadiv).

  assert (Hx := redundant_list _ l). destruct Hx as [ x e ].
  set (pair := fun x : {x | In x l} => n / (proj1_sig x)).

  assert (forall x, In (pair x) l) as pairin.
    intros x0. destruct x0 as [ xx xxinl ].
    unfold pair. simpl. apply ainndain.
    assumption.

  unfold divisors_nsr in leq. unfold divisors_nz in leq.
  assert ({f : {x | In x l} -> {x | In x l} | forall a, a <> f a /\ a = f (f a) /\ (In a x -> In (f a) x)}) as pairsig.
  unshelve refine (exist _ (fun x => exist _ (pair x) (*pairin*)_) _); [ auto | ]. intro. split; [ | split ].
  - unfold pair. destruct a. unfold proj1_sig in *.
    assert (anz := innz _ i). assert (ndanz := inndnz _ i). assert (adiv := inldiv _ i). assert (ndadiv := divisorpair _ _ adiv).
    destruct (eq_nat_dec x0 (n / x0)) as [ x0eqndx0 | x0nendx0 ].
    + exfalso.
      assert (nsq := nfsq _ _ anz adiv x0eqndx0).
      assert (x0eqsr := meqndmsq _ _ anz adiv x0eqndx0). rewrite x0eqsr in *.
      rewrite leq in i. revert i nsq. clear.
      intros. destruct eq_nat_dec. ainral.
      elim n0. assumption.
    + apply nesigne. simpl. assumption.

  - unfold pair. simpl. destruct a. simpl.
    apply eqsigeq; [ auto | ]. simpl.
    apply deqndndd.
    assumption.
    apply inldiv. assumption.

  - intros. unfold pair.
    destruct a. simpl.
    assert (j := ainndain _ i).
    apply inlinsigl; auto.
    rewrite e. assumption.

  - destruct pairsig as [ pair' pairpairs ].
    assert (forall a b : {x|In x l}, {a=b}+{a<>b}) as eq_signat_dec.
      intros. destruct a, b. destruct (eq_nat_dec x0 x1).
        left. revert e0 inpirr. clear. intros. subst. apply eqsigeq; auto.
        right. apply nesigne. assumption.
    assert (forall a, a <> pair' a) as pnid. intro. destruct (pairpairs a) as [ ni _ ]. assumption.
    assert (forall a, a = pair' (pair' a)) as pinv. intro. destruct (pairpairs a) as [ _ [ pinv _ ] ]. assumption.
    assert (forall a, In a x -> In (pair' a) x) as ainpain. intro. destruct (pairpairs a) as [ _ [ _ inin ] ]. assumption.
    assert (pinv' := if_involutive _ _ pinv).
    assert (iftheneven := paired_even' ({x|In x l}) eq_signat_dec pair' pnid pinv' x).
    rewrite <- e at 1. rewrite map_length.
    apply iftheneven. split.

    + assert (is_set eq_nat_dec l = true) as lset. rewrite leq. destruct (eq_nat_dec n (sqrt n * sqrt n)); repeat apply setrm; assumption.
      rewrite <- e in lset. revert lset inpirr. clear. intros lset inpirr. remember (proj1_sig (P:=fun x : nat => In x l)) as y.
      induction x. simpl. reflexivity.
      simpl in *.
      destruct (inb _ _ (map y x)) eqn:x0inl. discriminate.
      rewrite (IHx lset). clear lset IHx.
      destruct (inb _ _ x) eqn:x0inx; auto.
      rewrite <- x0inl. rewrite <- x0inx.
      revert Heqy inpirr. clear. intros. induction x. simpl. reflexivity.
      simpl. rewrite IHx. clear IHx.
      destruct a, a0. rewrite Heqy. simpl.
      destruct (eq_nat_dec x0 x1).
        subst. assert (Hx := inbeqIn _ eq_nat_dec x1 l). rewrite (inpirr x1 i0 i). destruct (eq_signat_dec _ _); [ reflexivity | ].
        elim n. reflexivity.
      destruct (eq_signat_dec _ _); [ | reflexivity ].
      assert (x0inx := nesigne _ _ (exist (fun x : nat => In x l) x0 i) (exist _ x1 i0) n).
      simpl in x0inx. elim x0inx. assumption.

    + unfold paired_list. intros a ainx.
      apply ainpain. assumption.
Grab Existential Variables.
Qed.

Definition issq n := exists k, n = k * k.

Lemma issq_dec :
  forall n, {issq n}+{~issq n}.
Proof.
  intros. destruct (perfect_root_dec n).
  - left. unfold issq. destruct s. exists x. assumption.
  - right. intro. unfold issq in H. destruct H. elim (n0 x). assumption.
Qed.

Lemma nlesqn :
  forall n, n <= n * n.
Proof.
  induction n. simpl. constructor.
  simpl. rewrite mult_comm. simpl. remember (n*n). clear Heqn0. omega.
Qed.

Lemma nltsqn :
  forall n, 1 < n -> n < n * n.
Proof.
  induction n. simpl. intros. omega.
  intros. destruct (eq_nat_dec 1 n).
  - subst. simpl. omega.
  - assert (1 < n). omega.
    assert (Hx := IHn H0).
    simpl. rewrite mult_comm. simpl. omega.
Qed.

Lemma sqmon_left :
  forall n m, n < m -> n * n < m * m.
Proof.
  induction n. simpl. intros. destruct m. omega. simpl. remember (m * _). omega.
  intros. simpl. rewrite mult_comm. simpl. destruct m. exfalso. omega.
  assert (n < m). omega.
  assert (Hx := IHn _ H0). simpl. rewrite (mult_comm m _). simpl. remember (n*n). remember (m*m).
  omega.
Qed.

Lemma sqmon_right :
  forall n m, n * n < m * m -> n < m.
Proof.
  intros.
  assert (Hx := Nat.sqrt_le_mono (n*n) (m*m)).
  repeat rewrite Nat.sqrt_square in Hx.
  destruct (eq_nat_dec n m). subst. exfalso. clear Hx. omega.
  assert (n * n <= m * m). omega.
  assert (Hy := Hx H0). omega.
Qed.

Lemma apbsq :
  forall a b, (a + b) * (a + b) = a*a + 2*a*b + b*b.
Proof.
  induction a. simpl. reflexivity.
  intros. simpl. apply f_equal. repeat rewrite <- plus_assoc. apply f_equal2. reflexivity.
  rewrite (plus_comm _ 0). simpl. rewrite mult_comm. simpl. rewrite IHa. clear IHa.
  repeat rewrite (mult_comm _ (S _)). simpl.
  repeat rewrite (plus_comm _ (S a)). simpl.
  rewrite (plus_comm _ 0). simpl. omega.
Qed.

Lemma sqdiff :
  forall n m, n * n < m * m -> m * m = n * n + 2 * n * (m - n) + (m - n) * (m - n).
Proof.
  intros.
  assert (Hx := sqmon_right _ _ H).
  assert (m = n + (m - n)). omega.
  rewrite H0 in *.
  remember (m - n). clear.
  assert (Hx := apbsq n n0).
  rewrite Hx. assert (forall a b, a + b - a = b). clear. intros. omega.
  rewrite H. reflexivity.
Qed.

Lemma sqrtmid :
  forall x n, n * n < x < (S n) * (S n) -> ~issq x.
Proof.
  intros. intro. unfold issq in H0. destruct H0. destruct H.
  subst.
  assert (Hxx := sqmon_right _ _ H). clear H.
  assert (Hyy := sqmon_right _ _ H1). clear H1.
  omega.
Qed.

Lemma sqSnsq :
  forall n, n <> 0 -> issq n -> ~issq (S n).
Proof.
  intros n nnz nsq. intro Snnsq. unfold issq in *. destruct nsq as [ sqn nsq ], Snnsq as [ sqSn Snnsq ].
  assert (sqn * sqn < sqSn * sqSn) as xsqltx0sq. omega.
  assert (sqltsqS := sqmon_right _ _ xsqltx0sq).
  assert (sqSn = sqn + (sqSn - sqn)) as sqSn'eq. omega.
  rewrite sqSn'eq in *. remember (sqSn - sqn) as sqSn'. clear sqSn sqSn'eq HeqsqSn'.
  rewrite apbsq in Snnsq. rewrite nsq in Snnsq.
  assert (sqn <> 0) as sqnnz. intro sqnz. rewrite sqnz in nsq. simpl in nsq. elim nnz. assumption.
  assert (S (sqn * sqn) = sqn * sqn + 1) as Ssqnsq. omega.
  rewrite Ssqnsq in Snnsq. revert Snnsq sqnnz. clear. intros.
  rewrite <- plus_assoc in Snnsq.
  rewrite Nat.add_cancel_l in Snnsq.
  destruct sqSn'. rewrite mult_comm in Snnsq. simpl in Snnsq. discriminate.
  rewrite plus_comm in Snnsq.
  destruct sqn. elim sqnnz. reflexivity.
  clear sqnnz.
  simpl in Snnsq. rewrite plus_comm in Snnsq. simpl in Snnsq. discriminate.
Qed.

Lemma nextsq :
  forall n,
    issq n ->
    (forall k,
       0 < k <= 2 * (sqrt n) ->
       ~issq (n + k)).
Proof.
  intros n nsq k klims nsqnk. destruct nsqnk as [ sr' nsqnk ].
  destruct nsq as [ srn nsq ].
  assert (Hx := Nat.sqrt_square srn). rewrite nsq in *. rewrite Hx in *. clear Hx nsq.
  assert (Hx := sqrtmid (srn * srn + k) srn).
  assert (srn * srn < srn * srn + k < S srn * S srn).
    simpl. rewrite (mult_comm _ (S _)). simpl.
    simpl in klims. rewrite (plus_comm _ 0) in klims. simpl in klims.
    remember (srn * srn). revert klims. clear. intros. omega.
  assert (Hy := Hx H). clear Hx H. elim Hy. exists sr'. assumption.
Qed.

Lemma divisorparity_nsq :
  forall n (nnz : n <> 0),
    ~issq n ->
    Even (length (divisors_nz nnz)).
Proof.
  intros n nnz nnsq.
  assert (evenall := divisorcount _ nnz (divisors_nsr nnz)).
  unfold divisors_nsr in evenall.
  destruct (eq_nat_dec _ _).
  - elim nnsq. unfold issq. exists (sqrt n). assumption.
  - apply evenall. reflexivity.
Qed.

Lemma divisorparity_sq :
  forall n (nnz : n <> 0),
    issq n ->
    ~Even (length (divisors_nz nnz)).
Proof.
  intros n nnz nnsq. intro nzev.
  assert (evenall := divisorcount _ nnz (divisors_nsr nnz)).
  unfold divisors_nsr in evenall.
  destruct (eq_nat_dec _ _).
  - destruct (divisorspf nnz) as [ lzset indiv ].
    assert (In (sqrt n) (divisors_nz nnz)).
      unfold divisors_nz in *.
      assert (srdiv := fsqd _ _ e).
      assert (srin := fsqd _ _ e). rewrite indiv in srin.
      assert (sqrt n <> 0) as srnz. rewrite sqz. assumption.
      rewrite <- remove_corr_neq. assumption. neqneq.
    assert (lset := setrm _ _ _ lzset 0).
    assert (Hx := lrm _ eq_nat_dec _ lset (sqrt n) H).
    unfold divisors_nz in *.
    rewrite Hx in nzev. clear Hx.
    remember (length (remove _ _ _)). revert nzev evenall. clear. intros.
    induction n0; firstorder.

  - elim n0. unfold issq in nnsq. destruct nnsq.
    assert (Hx := sqrt_corr _ _ H).
    rewrite Hx in H. assumption.
Qed.

Lemma sqne :
  forall n (nnz : n <> 0),
    issq n <-> ~Even (length (divisors_nz nnz)).
Proof.
  intros.
  assert (Hx := iffif {x | x <> 0} (fun nnz => issq (proj1_sig nnz)) (fun nnz => Even (length (divisors_nz (proj2_sig nnz))))). simpl in *.

  set (x := exist (fun x => x <> 0) n nnz).
  assert ((forall a : {x | x <> 0}, {issq (proj1_sig a)} + {~ issq (proj1_sig a)})) as issq_dec_sig.
    clear Hx. intros. destruct a. simpl. apply issq_dec.
  assert (Hy := Hx issq_dec_sig). clear Hx issq_dec_sig.

  assert (forall a : {x | x <> 0}, {Even (length (divisors_nz (proj2_sig a)))} + {~ Even (length (divisors_nz (proj2_sig a)))}) as evendec.
    clear.
    intros. destruct a. simpl.
    remember (length _). clear.
    assert (Hx := Nat.even_spec).
    destruct (even n0) eqn:n0ev.
      left. rewrite Hx in n0ev. assumption.
      right. intro. rewrite <- Hx in H. rewrite H in n0ev. discriminate n0ev.
  assert (Hx := Hy evendec). clear Hy evendec.

  assert (forall a : {x | x <> 0}, issq (proj1_sig a) -> ~ Even (length (divisors_nz (proj2_sig a)))) as divisorparity_sq'.
    intros. destruct a. simpl in *. apply divisorparity_sq; assumption.
  assert (Hy := Hx divisorparity_sq'). clear Hx divisorparity_sq'.

  assert (forall a : {x | x <> 0}, ~ issq (proj1_sig a) -> Even (length (divisors_nz (proj2_sig a)))) as divisorparity_nsq'.
    intros. apply divisorparity_nsq; assumption.
  assert (Hx := Hy divisorparity_nsq' x). clear Hy divisorparity_nsq'.

  unfold x in Hx. simpl in Hx. assumption.
Qed.

Lemma add_lt_mul :
  forall a, 2 < a -> a + a < a * a.
Proof.
  intros.
  assert (1 < a). omega.
  assert (Hx := Nat.add_le_mul a a H0 H0). clear H0.
  destruct (eq_nat_dec (a + a) (a * a)); [ | omega ].
  rewrite e in *.
  revert H e Hx. induction a using (nat_interval_ind 3).
  - intros. destruct a; [ omega | ]. destruct a; [ omega | ]. destruct a; omega.
  - intros. destruct a; [ omega | ]. destruct a; [ omega | ]. destruct a; try omega.
    exfalso. revert e. clear. intros.
    simpl in *. injection e. clear e. intro e.
    rewrite Nat.add_cancel_l in e. injection e. clear e. intro e.
    assert (a = a + 0). rewrite plus_comm. simpl. reflexivity.
    rewrite H in e at 1.
    rewrite Nat.add_cancel_l in e. discriminate.
Qed.

Lemma minsqdiff :
  forall a b,
    issq a ->
    issq b ->
    a < b ->
    a <> 0 ->
   2 * NPeano.Nat.sqrt b < S (S (b - a)).
Proof.
  intros.
  destruct H, H0.
  rewrite H, H0 in *.
  assert (Hx := sqdiff _ _ H1).
  rewrite NPeano.Nat.sqrt_square.
  rewrite Hx.
  assert (x * x + 2 * x * (x0 - x) + (x0 - x) * (x0 - x) - x * x = 2 * x * (x0 - x) + (x0 - x) * (x0 - x)). clear. simpl. repeat rewrite (plus_comm _ 0). simpl. rewrite <- plus_assoc. rewrite plus_comm.
  rewrite NPeano.Nat.add_sub. reflexivity.
  rewrite H3.
  assert (Hy := sqmon_right _ _ H1).
  assert (x0 = x + (x0 - x)). revert Hy. clear. intro. omega.
  rewrite H4 in *. remember (x0 - x). clear H4 x0 Heqn.
  assert (x + n - x = n). rewrite plus_comm. rewrite (NPeano.Nat.add_sub n x). reflexivity.
  rewrite H4.
  clear Hx H H0 H1 H3 H4 a b. destruct n. rewrite plus_comm in Hy. simpl in Hy. omega.
  rewrite plus_comm. unfold plus at 1. fold plus. clear Hy.
  simpl. repeat rewrite (plus_comm _ 0). simpl. repeat rewrite (mult_comm _ (S _)). simpl.
  rewrite plus_comm. simpl. rewrite (plus_comm _ (S (n + _))). simpl.
  assert (n + x + (n + x) < S (n + (n + n * n) + (x + x + n * (x + x)))).
  rewrite mult_plus_distr_l. remember (n * n). remember (n * x). omega.
  omega.
Defined.

Lemma xmodmeqk_Sxmodmeq0 :
  forall x m,
    S (x mod m) = m ->
    (S x) mod m = 0.
Proof.
  intros. destruct m. simpl. reflexivity.
  assert (S m <> 0) as mnz. intro. discriminate.
  assert (Hx := Nat.add_mod_idemp_l x 1 _ mnz).
  repeat rewrite (plus_comm _ 1) in Hx. unfold plus in Hx.
  assert (x mod (S m) = m). simpl in *. injection H. intro. assumption.
  rewrite H0 in *.
  rewrite <- Hx.
  rewrite Nat.mod_same; [ | assumption ].
  reflexivity.
Qed.

Lemma xmodmnem_SxmodmeqSxmodm :
  forall x m,
    m <> 0 ->
    S (x mod m) <> m ->
    (S x) mod m = S (x mod m).
Proof.
  intros.
  assert (Hx := Nat.add_mod_idemp_l x 1 _ H).
  repeat rewrite (plus_comm _ 1) in Hx. unfold plus in Hx.
  rewrite <- Hx.
  remember (x mod m).
  assert (n < m).
    assert (0 <= x). omega.
    assert (0 < m). omega.
    destruct (mod_bound_pos _ _ H1 H2). rewrite Heqn. assumption.
  assert (S n < m). omega.
  assert (Hz := Nat.mod_small _ _ H2). assumption.
Qed.

Lemma apbmodmeqb_amodmz :
  forall a b m, (a + b) mod m = b mod m -> a mod m = 0.
Proof.
  intros. destruct m. simpl. reflexivity.
  destruct m. simpl. reflexivity.
  assert (1 < S (S m)). omega. remember (S (S m)) as m'. clear m Heqm'. rename m' into m.
  rewrite Nat.add_mod in H; [ | omega ].
  assert (m <> 0); [ omega | ].
  assert (Hx := Nat.mod_upper_bound a _ H1).
  assert (Hy := Nat.mod_upper_bound b _ H1).
  remember (a mod m) as a'. clear a Heqa'. rename a' into a.
  remember (b mod m) as b'. clear b Heqb'. rename b' into b.

  assert (Ha := div_mod a _ H1).
  assert (Hb := div_mod b _ H1).
  assert (Hxx := div_mod (a + b) _ H1). rewrite H in Hxx.
  repeat rewrite (plus_comm _ b) in Hxx.
  assert (Hyy := plus_reg_l _ _ _ Hxx). clear Hxx. rewrite plus_comm in Hyy.
  destruct (eq_nat_dec ((a + b) / m) 0). rewrite e in Hyy. rewrite mult_comm in Hyy. simpl in Hyy. assumption.
  destruct (eq_nat_dec ((a + b) / m) 1). rewrite e in Hyy. rewrite mult_comm in Hyy. simpl in Hyy. rewrite plus_comm in Hyy. simpl in Hyy. rewrite Hyy in Hx. revert Hx. clear. intro. omega.
  assert ((a + b) < 2 * m). omega.
  rewrite mult_comm in H2.
  assert (Hxz := Nat.div_lt_upper_bound _ _ _ H1 H2). omega.
Qed.


Definition var := nat.

Require Import ZArith.

Scheme Equality for nat.
Scheme Equality for bool.

Inductive aexp : Set :=
  | aexp_Int : Z -> aexp
  | aexp_Var : var -> aexp
  | aexp_Plus : aexp -> aexp -> aexp
  | aexp_Div : aexp -> aexp -> aexp.

Lemma aexp_eq_dec : forall a a' : aexp,
  { a = a' } + { a <> a' }.
intros.
decide equality.
apply Z_eq_dec.
apply nat_eq_dec.
Qed.

Fixpoint is_value_aexp (ae : aexp):  bool :=
  match ae with
    | aexp_Int _ => true
    | _ => false
  end.

Inductive bexp : Set :=
  | bexp_Bool : bool -> bexp
  | bexp_Less : aexp -> aexp -> bexp
  | bexp_Not : bexp -> bexp
  | bexp_And : bexp -> bexp -> bexp.

Lemma bexp_eq_dec : forall b b' : bexp,
  { b = b' } + { b <> b' }.
intros.
decide equality.
apply bool_eq_dec.
apply aexp_eq_dec.
apply aexp_eq_dec.
Qed.

Fixpoint is_value_bexp (be : bexp):  bool :=
  match be with
    | bexp_Bool _ => true
    | _ => false
  end.

Inductive stmt : Set :=
  | stmt_Skip : stmt
  | stmt_Assign : var -> aexp -> stmt
  | stmt_Seq : stmt -> stmt -> stmt
  | stmt_Ite : bexp -> stmt -> stmt -> stmt
  | stmt_While : bexp -> stmt -> stmt.

Lemma stmt_eq_dec : forall s s' : bexp,
  { s = s' } + { s <> s' }.
intros.
decide equality.
apply bool_eq_dec.
apply aexp_eq_dec.
apply aexp_eq_dec.
Qed.

Fixpoint is_value_stmt (s : stmt):  bool :=
  match s with
    | stmt_Skip => true
    | _ => false
  end.

Inductive pgm : Set :=
  | pgm_Program : list var -> stmt -> pgm.

Lemma pgm_eq_dec : forall p p' : bexp,
  { p = p' } + { p <> p' }.
intros.
decide equality.
apply bool_eq_dec.
apply aexp_eq_dec.
apply aexp_eq_dec.
Qed.

Fixpoint is_value_pgm (p : pgm) : bool :=
  match p with
    | pgm_Program l s =>
      match l with
        | nil => is_value_stmt s
        | _ => false
      end
  end.

Inductive type : Set :=
  | t_aexp : type
  | t_bexp : type
  | t_stmt : type
  | t_pgm : type.

Definition t_denote (t : type) : Set :=
  match t with
  | t_aexp => aexp
  | t_bexp => bexp
  | t_stmt => stmt
  | t_pgm => pgm
  end.

Definition is_value (t : type) : (t_denote t) -> bool :=
  match t with
    | t_aexp => is_value_aexp
    | t_bexp => is_value_bexp
    | t_stmt => is_value_stmt
    | t_pgm => is_value_pgm
  end.

Inductive E { hole_t : type } : type -> Set :=
  | E_Hole :
    E hole_t

  | E_PlusL (ae : aexp) :
    (E t_aexp) -> E t_aexp
  | E_PlusR (ae : aexp) :
    (* is_value_aexp ae = true -> *)
    (E t_aexp) -> E t_aexp

  | E_DivL (ae : aexp) :
    (E t_aexp) -> E t_aexp
  | E_DivR (ae : aexp) :
    (* is_value_aexp ae = true -> *)
    (E t_aexp) -> E t_aexp

  | E_LessL (ae : aexp) :
    (E t_aexp) -> E t_bexp
  | E_LessR (ae : aexp) :
    (* is_value_aexp ae = true -> *)
    (E t_aexp) -> E t_bexp

  | E_Not :
    (E t_bexp) -> E t_bexp

  | E_AndL (be : bexp) :
    (E t_bexp) -> E t_bexp
  | E_AndR (be : bexp) :
    (* is_value_bexp be = true -> *)
    (E t_bexp) -> E t_bexp

  | E_SeqL :
    stmt -> (E t_stmt) -> E t_stmt

  | E_Pgm :
    (E t_stmt) -> E t_pgm.

Fixpoint fill t t' (ec : @E t t') (e : t_denote t) : t_denote t' :=
  match ec with
    | E_Hole => e
    | E_PlusL ae ec' => aexp_Plus (fill t t_aexp ec' e) ae
    | E_PlusR ae ec' => aexp_Plus ae (fill t t_aexp ec' e)
    | E_DivL ae ec' => aexp_Div (fill t t_aexp ec' e) ae
    | E_DivR ae ec' => aexp_Div ae (fill t t_aexp ec' e)

    | E_LessL ae ec' => bexp_Less (fill t t_aexp ec' e) ae
    | E_LessR ae ec' => bexp_Less ae (fill t t_aexp ec' e)
    | E_Not ec' => bexp_Not (fill t t_bexp ec' e)
    | E_AndL be ec' => bexp_And (fill t t_bexp ec' e) be
    | E_AndR be ec' => bexp_And be (fill t t_bexp ec' e)

    | E_SeqL s ec' => stmt_Seq (fill t t_stmt ec' e) s

    | E_Pgm ec' => pgm_Program nil (fill t t_stmt ec' e)
  end.

Check @E_Hole.
Check (@E_Hole t_aexp).

Require Import Bool.
Require Import CpdtTactics.

Fixpoint split_aexp (a : aexp) : option (@E t_aexp t_aexp * aexp)%type :=
  match a with
    | aexp_Var x => Some (@E_Hole t_aexp, aexp_Var x)
    | aexp_Int z => None
    | aexp_Plus a1 a2 =>
      match split_aexp a1 with
        | None =>
          match split_aexp a2 with
            | None => Some (@E_Hole t_aexp, aexp_Plus a1 a2)
            | Some (ec, a') => Some ((E_PlusR a1 ec), a')
          end
        | Some (ec, a') =>
          Some (E_PlusL a2 ec, a')
      end
    | aexp_Div a1 a2 =>
      match split_aexp a1 with
        | None =>
          match split_aexp a2 with
            | None => Some (@E_Hole t_aexp, aexp_Div a1 a2)
            | Some (ec, a') => Some ((E_DivR a1 ec), a')
          end
        | Some (ec, a') =>
          Some (E_DivL a2 ec, a')
      end
  end.

Lemma split_aexp_correct : forall a,
  ((split_aexp a = None) -> is_value_aexp a = true) /\
  (forall ec a',
    (split_aexp a = Some (ec, a') ->
      (fill t_aexp t_aexp ec a' = a) /\
      is_value_aexp a' = false)).
Proof.
  Local Hint Extern 10 (_ = _) => match goal with
    | [ H : context[match ?E with pair _ _ => _ end] |- _ ] =>
      destruct E; crush
  end.
  Local Hint Extern 10 (_ = _) => match goal with
    | [ H : context[match ?E with Some _ => _ | None => _ end] |- _ ] =>
      let x := fresh "s" in
        remember (E) as x; destruct x; crush
  end.
  Local Hint Extern 10 (aexp_Plus _ _ = aexp_Plus _ _) => f_equal;
    match goal with
      | [ H : _ |- _ ] => apply H; crush
    end.
  Local Hint Extern 10 (is_value_aexp _ = _) =>
    match goal with
      | [ H : context[Some (pair ?E ?A) = Some (pair _ _) -> fill _ _ _ _ = _ /\ is_value_aexp _ = _] |- _ ] => specialize (H E A (eq_refl _ )); decompose [and] H; crush
    end.
  Local Hint Extern 10 (aexp_Div _ _ = aexp_Div _ _) => f_equal;
    match goal with
      | [ H : _ |- _ ] => apply H; crush
    end.
  induction a; crush.
Qed.

Fixpoint split_bexp (be : bexp) : option { t : type & (@E t t_bexp * (t_denote t))%type } :=
  match be with
    | bexp_Bool b => None
    | bexp_And be1 be2 =>
      match split_bexp be1 with
        | None =>
          match split_bexp be2 with
            | None => Some (existT _ t_bexp (E_Hole, bexp_And be1 be2))
            | Some (existT t (ec, e)) => Some (existT _ t (E_AndR be1 ec, e))
          end
        | Some (existT t (ec, e)) => Some (existT _ t (E_AndL be2 ec, e))
      end
    | bexp_Less ae1 ae2 =>
      match split_aexp ae1 with
        | None =>
          match split_aexp ae2 with
            | None => Some (existT _ t_bexp (E_Hole, bexp_Less ae1 ae2))
            | Some (ec, e) => Some (existT _ t_aexp (E_LessR ae1 ec, e))
          end
        | Some (ec, e) => Some (existT _ t_aexp (E_LessL ae2 ec, e))
      end
    | bexp_Not be =>
      match split_bexp be with
        | None => Some (existT _ t_bexp (E_Hole, bexp_Not be))
        | Some (existT t (ec, e)) => Some (existT _ t (E_Not ec, e))
      end
  end.

Scheme Bexp_rect_dep := Induction for bexp Sort Type.

Scheme sigT_rect_dep := Induction for sigT Sort Type.

Lemma belea' : forall t t',
  t = t' -> t_denote t = t_denote t'.
intros.
rewrite H.
reflexivity.
Qed.

(* Definition property (t : type) := t_denote t -> Prop. *)

(* Check property. *)
(* Print property. *)

(* Lemma belea : forall t, forall (P : property t), *)
(*   forall t', *)
(*     P (t_denote t) -> *)
(*     t = t' -> *)
(*     P (t_denote t'). *)

(* Derive Inversion leminv with (forall t ec e0 a0, *)
(*   @eq (@sigT type (fun x : type => @E x t_bexp)) *)
(*          (@existT type (fun x : type => @E x t_bexp) t_aexp *)
(*             (@E_LessL t_aexp a0 e0)) *)

Lemma type_dec : forall t t' : type,
  { t = t' } + { t <> t' }.
decide equality.
Qed.

Lemma split_bexp_correct : forall be,
  ((split_bexp be = None) -> is_value_bexp be = true) /\
  (forall t : type,
    forall (ec : @E t t_bexp) (e : t_denote t),
    (split_bexp be = Some (existT _ t (ec, e)) ->
      (fill t t_bexp ec e = be) /\
      is_value t e = false)).
Proof.
  simpl.
  induction be.
  crush.
  split.
  crush.
  intros.
  split.
  simpl in H.
  remember (split_aexp a) as s.
  destruct s.
  destruct p.
  inversion H.
  Require Import EqdepFacts.
  simpl.

  Require Import Eqdep_dec.
  Set Printing All.
  simpl.

  assert (@eq Set (@E t t_bexp) (@E t_aexp t_bexp)).
  rewrite H1.
  reflexivity.

  Check (inj_pair2_eq_dec type type_dec).

  Check (inj_pair2_eq_dec type type_dec (fun t : type => @E t t_bexp) t_aexp
    (@E_LessL t_aexp a0 e0) ec).
  simpl.

  Hint Extern 0 (_ = _) => match goal with
    | [ H : context[match ?E with pair _ _ => _ end] |- _ ] =>
      destruct E; crush
  end.
  Hint Extern 0 (_ = _) => match goal with
    | [ H : context[match ?E with Some _ => _ | None => _ end] |- _ ] =>
      let x := fresh "s" in
        remember (E) as x; destruct x; crush
  end.
  Hint Extern 10 (bexp_Less _ _ = bexp_Less _ _) => f_equal;
    match goal with
      | [ H : _ |- _ ] => apply H; crush
    end.
  (* Hint Extern 10 (is_value_aexp _ = _) => *)
  (*   match goal with *)
  (*     | [ H : context[Some (pair ?E ?A) = Some (pair _ _) -> fill _ _ _ _ = _ /\ is_value_aexp _ = _] |- _ ] => specialize (H E A (eq_refl _ )); decompose [and] H; crush *)
  (*   end. *)
  (* Hint Extern 10 (aexp_Div _ _ = aexp_Div _ _) => f_equal; *)
  (*   match goal with *)
  (*     | [ H : _ |- _ ] => apply H; crush *)
  (*   end. *)
  induction be using Bexp_rect_dep.
  crush.
  split. crush. simpl. intros. split.
  match goal with
    | [ H : context[match ?E with Some _ => _ | None => _ end] |- _ ] =>
      let x := fresh "s" in
        remember (E) as x; destruct x
  end.
match goal with
    | [ H : context[match ?E with pair _ _ => _ end] |- _ ] =>
      destruct E
  end.
simpl.
simpl in H.
inversion H.
Set Printing All.
simpl.
Derive Inversion leminv with (forall t ec e0 a0,
  @eq (@sigT type (fun x : type => @E x t_bexp))
         (@existT type (fun x : type => @E x t_bexp) t_aexp
            (@E_LessL t_aexp a0 e0))
         (@existT type (fun x : type => @E x t_bexp) t ec)).
Check leminv.

injection H2.
inversion H2 using leminv.
assert (bexp (fill t t_bexp (@E_LessL t a0 e0) e) (bexp_Less a a0)).
Check sigT_rect_dep.
rewrite <- H1 in H2.
inversion H2 using (@sigT_rect_dep type t_denote).
rewrite H1 in H.
Set Printing All.
assert (t = t_aexp -> (ec : @E t) = ((E_LessL a0 e0) : @E t_aexp t_bexp)).
Qed.

Lemma split_bexp_correct : forall be,

Inductive env : Set :=
  | env_Empty : env
  | env_Bind : var -> Z -> env -> env.

Inductive binds : var -> Z -> env -> Prop :=
  | binds_Base : forall v z e,
    binds v z (env_Bind v z e)
  | binds_Rec : forall v v' z z' e,
    not (eq v v') ->
    binds v z e ->
    binds v z (env_Bind v' z' e).

Definition configuration t := (t_denote t * env)%type.

Inductive basic_step_aexp : configuration t_aexp -> configuration t_aexp -> Prop :=
| Plus :
  forall z1 z2 e,
    basic_step_aexp (aexp_Plus (aexp_Int z1) (aexp_Int z2), e) (aexp_Int (Zplus z1 z2), e)
| Lookup :
  forall z v e,
    binds v z e ->
    basic_step_aexp (aexp_Var v, e) (aexp_Int z, e)
| Div :
  forall z1 z2 e,
    Zeq_bool z2 0 = false ->
    basic_step_aexp (aexp_Div (aexp_Int z1) (aexp_Int z2), e) (aexp_Int (Zdiv z1 z2), e)
with basic_step_bexp : configuration t_bexp -> configuration t_bexp -> Prop :=
| Not :
  forall b e,
    basic_step_bexp ((bexp_Not (bexp_Bool b)), e) ((bexp_Bool (negb b)), e)
| And :
  forall b1 b2 e,
    basic_step_bexp (bexp_And (bexp_Bool b1) (bexp_Bool b2), e) (bexp_Bool (andb b1 b2), e)
| Less :
  forall z1 z2 e,
    basic_step_bexp (bexp_Less (aexp_Int z1) (aexp_Int z2), e) (bexp_Bool (Zle_bool z1 z2), e)
with basic_step_stmt : configuration t_stmt -> configuration t_stmt -> Prop :=
| Assign :
  forall v z e,
    basic_step_stmt (stmt_Assign v (aexp_Int z), e) (stmt_Skip, env_Bind v z e)
| Seq :
  forall s e,
    basic_step_stmt (stmt_Seq stmt_Skip s, e) (s, e)
| Ite_true :
  forall s1 s2 e,
    basic_step_stmt (stmt_Ite (bexp_Bool true) s1 s2, e) (s1, e)
| Ite_false :
  forall s1 s2 e,
    basic_step_stmt (stmt_Ite (bexp_Bool false) s1 s2, e) (s2, e)
| While :
  forall b s e,
    basic_step_stmt (stmt_While b s, e) (stmt_Ite b (stmt_Seq s (stmt_While b s)) stmt_Skip, e)
with basic_step_pgm : configuration t_pgm -> configuration t_pgm -> Prop :=
| DeclareVar :
  forall lv s e v,
    basic_step_pgm (pgm_Program (cons v lv) s, e) (pgm_Program lv s, env_Bind v 0%Z e).

Definition basic_step (t : type) : (configuration t) -> (configuration t) -> Prop :=
  match t with
    | t_aexp => basic_step_aexp
    | t_bexp => basic_step_bexp
    | t_stmt => basic_step_stmt
    | t_pgm => basic_step_pgm
  end.

Inductive full_step : configuration t_pgm -> configuration t_pgm -> Prop :=
| Context :
  forall e e' : env,
    forall t_exp (exp exp' : t_denote t_exp),
      basic_step t_exp (exp, e) (exp', e') ->
      forall ec : @E t_exp t_pgm,
        full_step ((fill t_exp t_pgm ec exp), e) ((fill t_exp t_pgm ec exp'), e').

Require Import Relation_Definitions.
Require Import Relation_Operators.

Definition results p e p' e' :=
  (clos_refl_trans _ full_step (p, e) (p', e')) /\ is_value_pgm p' = true.

Notation X := 0.
Notation Y := 1.
Notation Z := 2.
Notation "a + b" := (aexp_Plus a b).
Notation "a / b" := (aexp_Div a b).
Notation "a && b" := (bexp_And a b).
Notation "! b" := (bexp_Not b) (at level 60).
Notation "a <= b" := (bexp_Less a b).
Notation Skip := (stmt_Skip).
Notation "a ; b" := (stmt_Seq a b) (at level 60, right associativity).
Notation "v <- a" := (stmt_Assign v a) (at level 60).
Notation "'if' b 'then' s1 'else' s2" := (stmt_Ite b s1 s2) (at level 60).
Notation "'while' b 'do' s" := (stmt_While b s) (at level 60).
Notation "'val' z" := (aexp_Int z) (at level 60).
Notation "'VAR' v" := (aexp_Var v) (at level 60).
Notation "'declare' l 'program' p" := (pgm_Program l p) (at level 60).

Notation "[ ]" := nil.
Notation "a :: b" := (cons a b).
Notation "[ a , .. , b ]" := (a :: .. (b :: []) ..).

Definition simple_program :=
  (
    declare
      ( [ X , Y , Z ] )
    program (
      (X <- val 10) ;
      (Y <- val 20) ;
      (Z <- (VAR X) + (VAR Y))
    )
  ).

Definition empty_program :=
  (
    declare ( [] )
    program ( stmt_Skip )
  ).

Example ex1 :
  exists env,
    results simple_program env_Empty empty_program env /\
    binds Z 30 env.
remember (env_Bind Z 0 (env_Bind Y 0 (env_Bind X 0 env_Empty))) as env_Init.
exists (env_Bind Z 30 (env_Bind Y 20 (env_Bind X 0 env_Init))).
unfold results.
split.
split.
eapply rt_step.
unfold simple_program.