(* Lists of booleans and related theory. *)

Set Implicit Arguments.

Require Import StdNat.
Require Export List.
Require Export Bvector.
Require Import Omega.
Require Import EqDec.
Require Import Fold.
Require Import Coq.NArith.Ndigits.
Require Import ZArith.
Local Open Scope list_scope.

Definition Blist := list bool.

Definition Blist_eq_dec := (list_eq_dec bool_dec).

Definition Bvector_eq_dec(n : nat)(v1 v2 : Bvector n) : {v1 = v2} + {v1 <> v2}.
apply (EqDec_dec (Bvector_EqDec n)).
Defined.

(* shiftOut gets bits from the head of the list. *)
(* return None when we run out *)
Fixpoint shiftOut(s : Blist)(n : nat) : option (Bvector n * Blist) :=
  match n with
    | 0 => Some ((@Vector.nil bool), s)
    | S n' =>
      match s with
        | nil => None
        | b :: s' =>
          match (shiftOut s' n') with
            | Some (v', s'') => Some (Vector.cons _ b _ v', s'')
            | None => None
          end
      end
  end.

Theorem shiftOut_app : forall (n : nat)(s1 s1' s2 : Blist) v,
  shiftOut s1 n = Some (v, s1') ->
  shiftOut (s1 ++ s2) n = Some (v, s1' ++ s2).

  induction n; simpl in *; intuition.
  destruct s1; simpl in *.
  inversion H; clear H; subst.
  destruct s2; simpl.
  trivial.
  trivial.
  inversion H; clear H; subst.
  rewrite app_comm_cons.
  trivial.

  destruct s1; simpl in *.
  discriminate.
  case_eq (shiftOut s1 n); intuition.
  rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  erewrite IHn; eauto.

  rewrite H0 in H.
  discriminate.

Qed.

Lemma shiftOut_lt : forall ls n,
  length ls < n ->
  shiftOut ls n = None.

  induction ls; intuition; simpl in *.
  destruct n.
  omega.
  trivial.
  destruct n.
  omega.
  rewrite IHls.
  trivial.
  omega.
Qed.

Lemma shiftOut_Some : forall (ls : Blist) n,
  length ls >= n ->
  exists p, shiftOut ls n = Some p.

  induction ls; intuition; simpl in *.
  assert (n = O).
  omega.
  subst.
  exists ([], nil).
  trivial.

  destruct n.
  exists ([], a :: ls).
  trivial.
  assert (length ls >= n).
  omega.
  destruct (IHls n).
  trivial.
  destruct x.
  econstructor.
  rewrite H1.
  eauto.
Qed.

Theorem shiftOut_None_inv : forall n ls,
  shiftOut ls n = None ->
  n > length ls.

  induction n; destruct ls; intuition; simpl in *; try discriminate.
  apply gt_n_S.
  eapply IHn.
  case_eq (shiftOut ls n); intuition; trivial.
  rewrite H0 in H.
  destruct p.
  discriminate.
Qed.

Theorem shiftOut_Some_inv : forall n ls v ls',
  shiftOut ls n = Some (v, ls') ->
  (n <= length ls)%nat.

  induction n; destruct ls; intuition; simpl in *; try discriminate.

  apply le_n_S.
  case_eq (shiftOut ls n); intuition.
  destruct p.
  eauto.

  rewrite H0 in H.
  discriminate.
Qed.

Theorem shiftOut_correct_inv : forall n ls ls' v,
  shiftOut ls n = Some (v, ls') ->
  ls = (Vector.to_list v) ++ ls'.

  induction n; destruct ls; intuition; simpl in *.

  inversion H; clear H; subst.
  simpl.
  trivial.

  inversion H; clear H; subst.
  simpl.
  trivial.

  discriminate.

  case_eq (shiftOut ls n); intuition.
  rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  simpl.
  f_equal.
  apply IHn in H0.
  subst.
  trivial.

  rewrite H0 in H.
  discriminate.
Qed.

Lemma to_list_length : forall (A : Set)(m : nat)(v : Vector.t A m),
  length (Vector.to_list v) = m.

  induction m; intuition.
  rewrite (vector_0 v).
  simpl.
  trivial.

  destruct (vector_S v).
  destruct H.
  subst.
  simpl.

  f_equal.
  eapply IHm.
Qed.

Definition of_list_length (A : Set)(m : nat)(ls : list A)(pf : length ls = m) : Vector.t A m :=
  match pf with
    | eq_refl => Vector.of_list ls
  end.

Definition of_sig_list (A : Set)(m : nat)(l : {ls : list A | length ls = m}) : Vector.t A m :=
  match l with
    | exist ls pf => (of_list_length ls pf)
  end.

Lemma vector_hd_cons_eq : forall(A : Set)(v : Vector.t A 1),
  v = Vector.cons _ (Vector.hd v) _ (Vector.nil A).

  intuition.
  destruct (vector_S v).
  destruct H.
  subst.
  destruct (vector_0 x0).
  simpl.
  trivial.
Qed.

Lemma shiftOut_0 : forall (s : Blist),
  shiftOut s 0 = Some ([], s).

  intuition.
  destruct s; simpl in *; trivial.
Qed.

Theorem shiftOut_S_None : forall (n : nat)(s s1 : Blist)(v1 : Bvector 1),
  shiftOut s 1 = Some (v1, s1) ->
  shiftOut s1 n = None ->
  shiftOut s (S n) = None.
Admitted.

Theorem shiftOut_1_None : forall (n1 n2 : nat)(s : Blist),
  shiftOut s n1 = None ->
  n2 >= n1 ->
  shiftOut s n2 = None.
Admitted.

(* Todo : we need a general theorem that covers these sorts of facts.  Something like:
   shiftOut s n1 = Some(_, s1) ->
   shiftOut s1 n2 = x ->
   shiftOut s (n1 + n2) = x *)

Theorem shiftOut_S : forall (n : nat)(s s1 s2 : Blist)(v1 : Bvector 1)(v2 : Bvector n),
  shiftOut s 1 = Some (v1, s1) ->
  shiftOut s1 n = Some (v2, s2) ->
  shiftOut s (S n) = Some (Vector.cons _ (Vector.hd v1) _  v2, s2).

  destruct n; intuition; simpl in *.
  eapply eq_trans.
  eapply H.
  specialize (shiftOut_0 s1); intuition.
  rewrite H0 in H1.
  inversion H1; clear H1; subst.
  f_equal.
  f_equal.
  eapply vector_hd_cons_eq.

  destruct s; intuition; simpl in *.
  discriminate.
  rewrite shiftOut_0 in H.
  inversion H; clear H; subst.
  rewrite H0.
  f_equal.
Qed.

Fixpoint oneList(n : nat) : Blist :=
  match n with
    | 0 => nil
    | S n' => true :: (oneList n')
  end.

Theorem oneList_length : forall n,
  length (oneList n) = n.

  induction n; intuition; simpl in *.
  auto.
Qed.

(* TODO: remove oneVector and replace it with Bvect_true *)
Fixpoint oneVector(n : nat) : Bvector n :=
  match n with
    | 0 => Vector.nil bool
    | S n' => Vector.cons _ true _ (oneVector n')
  end.

Theorem shiftOut_oneList : forall (n : nat),
  shiftOut (oneList n) n = Some (oneVector n, nil).

  induction n; intuition; simpl in *.
  rewrite IHn.
  trivial.
Qed.

Fixpoint getAllBlists(n : nat) : (list Blist) :=
  match n with
    | 0 => nil :: nil
    | S n' => (map (cons true) (getAllBlists n')) ++
      (map (cons false) (getAllBlists n'))
  end.

Fixpoint getAllBlists_app(n : nat) : list Blist :=
  match n with
    | 0 => nil :: nil
    | S n' => (map (fun ls => ls ++ (true :: nil)) (getAllBlists_app n')) ++
      (map (fun ls => ls ++ (false :: nil)) (getAllBlists_app n'))
  end.

Fixpoint getAllBvectors(n : nat) : (list (Bvector n)) :=
  match n with
    | 0 => (Vector.nil bool) :: nil
    | S n' => (map (Vector.cons _ true _) (getAllBvectors n')) ++
      (map (Vector.cons _ false _) (getAllBvectors n'))
  end.

Lemma getAllBvectors_length : forall n,
  length (getAllBvectors n) = (expnat 2 n).

  induction n; intuition; simpl in *.
  rewrite app_length.
  repeat rewrite map_length.
  rewrite plus_0_r.
  f_equal; eauto.
Qed.

Lemma getAllBvectors_length_nz : forall n,
  length (getAllBvectors n) > 0.

  induction n; intuition; simpl in *.
  rewrite app_length.
  repeat rewrite map_length.
  rewrite <- plus_0_r.
  eapply gt_trans.
  eapply plus_gt_compat_l.
  apply IHn.
  repeat rewrite plus_0_r.
  apply IHn.
Qed.

Theorem in_getAllBvectors : forall (n : nat)(v : Bvector n),
  In v (getAllBvectors n).

  induction v; intuition; simpl.
  auto.
  eapply in_or_app; intuition.
  destruct h.
  left.
  eapply in_map; eauto.
  right.
  eapply in_map; eauto.
Qed.

Lemma vector_tl_eq : forall (A : Set)(n : nat)(v1 v2 : Vector.t A (S n)),
  v1 = v2 ->
  Vector.tl v1 = Vector.tl v2.

  intuition.
  specialize (vector_S v1).
  specialize (vector_S v2).
  intuition.
  destruct H0. destruct H0.
  destruct H1. destruct H1.
  subst.
  simpl.
  trivial.
Qed.

Lemma vector_cons_eq : forall (A : Set)(n : nat)(v1 v2 : Vector.t A n)(a1 a2 : A),
  Vector.cons A a1 n v1 = Vector.cons A a2 n v2 ->
  v1 = v2.

  intuition.

  apply vector_tl_eq in H.
  simpl in *.
  trivial.

Qed.

Lemma vector_cons_ne : forall (A : Set)(n : nat)(a1 a2 : Vector.t A n)(a : A),
  a1 <> a2 ->
  Vector.cons A a n a1 <> Vector.cons A a n a2.

  intuition.
  eapply H.
  eapply vector_cons_eq.
  eauto.
Qed.

Lemma map_NoDup : forall (A B : Set)(ls : list A)(f : A -> B),
  NoDup ls ->
  (forall a1 a2, a1 <> a2 -> (f a1) <> (f a2)) ->
  NoDup ((map f) ls).

  induction ls; intuition; simpl in *.

  econstructor.

  inversion H; subst; clear H.
  econstructor.
  intuition.
  apply in_map_iff in H.
  destruct H.
  intuition.
  eapply H0; eauto.
  intuition.
  subst.
  intuition.

  eapply IHls; eauto.
Qed.

Lemma getAllBvectors_NoDup : forall (n : nat),
  NoDup (getAllBvectors n).

  induction n; intuition; simpl in *.
  econstructor.
  eapply in_nil.
  econstructor.

  eapply app_NoDup.
  eapply map_NoDup; eauto.
  intros.
  eapply vector_cons_ne; eauto.

  eapply map_NoDup; eauto.
  intros.

  eapply vector_cons_ne; eauto.

  intuition.
  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  inversion H.

  intuition.
  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  inversion H.
Qed.

Require Import Permutation.

Lemma getAllBlists_NoDup : forall n,
  NoDup (getAllBlists n).

  induction n; intuition; simpl in *.
  econstructor.
  simpl.
  intuition.
  econstructor.

  eapply app_NoDup; intuition.

  eapply map_NoDup; intuition.
  eapply H.
  inversion H0; subst; intuition.

  eapply map_NoDup; intuition.
  eapply H.
  inversion H0; subst; intuition.

  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  discriminate.

  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  discriminate.

Qed.

Lemma getAllBlists_app_NoDup : forall n,
  NoDup (getAllBlists_app n).

  induction n; intuition; simpl in *.
  econstructor.
  simpl.
  intuition.
  econstructor.

  eapply app_NoDup; intuition.

  eapply map_NoDup; intuition.
  eapply H.
  apply app_inj_tail in H0.
  intuition.

  eapply map_NoDup; intuition.
  eapply H.
  eapply app_inj_tail in H0.
  intuition.

  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  apply app_inj_tail in H; intuition.

  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  apply app_inj_tail in H; intuition.

Qed.

Lemma getAllBlists_perm : forall n,
  Permutation (getAllBlists n) (getAllBlists_app n).

  intuition.
  eapply NoDup_Permutation.

  apply getAllBlists_NoDup.
  apply getAllBlists_app_NoDup.

  Lemma getAllBlists_app_rel_map : forall n,
    rel_map (fun ls1 ls2 => ls1 = (rev ls2)) (getAllBlists_app n) (getAllBlists n).

    induction n; intuition; simpl in *.
    econstructor.
    econstructor.
    simpl.
    trivial.

    eapply rel_map_app.
    eapply rel_map_map2.

    eapply rel_map_impl; eauto; intuition.
    subst.
    simpl.
    trivial.

    eapply rel_map_map2.

    eapply rel_map_impl; eauto; intuition.
    subst.
    simpl.
    trivial.
  Qed.

  Lemma getAllBlists_rel_map : forall n,
    rel_map (fun ls1 ls2 => ls1 = (rev ls2)) (getAllBlists n) (getAllBlists_app n).

    induction n; intuition; simpl in *.
    econstructor.
    econstructor.
    trivial.

    eapply rel_map_app.
    eapply rel_map_map2.
    eapply rel_map_impl; eauto; intuition.
    subst.
    rewrite rev_unit.
    trivial.

    eapply rel_map_map2.
    eapply rel_map_impl; eauto; intuition.
    subst.
    rewrite rev_unit.
    trivial.

  Qed.

  intuition.

  specialize (getAllBlists_rel_map n); intuition.
  specialize (rel_map_in_inv H0 x); intuition.
  destruct H2.
  intuition.
  subst.

  Lemma getAllBlists_app_In_length : forall n ls,
    In ls (getAllBlists_app n) ->
    length ls = n.

    induction n; intuition; simpl in *.
    destruct H; subst; intuition.

    apply in_app_or in H;
    destruct H;
    apply in_map_iff in H;
    destruct H;
    intuition;

    subst;
    rewrite app_length; simpl;
    rewrite plus_comm; simpl;
    f_equal;
    eapply IHn; eauto.
  Qed.

  Lemma getAllBlists_app_length_In : forall n ls,
    length ls = n ->
    In ls (getAllBlists_app n).

    induction n; intuition; simpl in *;
    destruct ls; simpl in *; intuition; try omega.

    Lemma ls_last_exists : forall (A : Type)(ls : list A) n,
      length ls = (S n) ->
      exists a ls', (length ls' = n /\ ls = ls' ++ (a :: nil)).

      induction ls; intuition; simpl in *.
      omega.

      destruct n.
      destruct ls; simpl in *; try omega.
      exists a. exists nil.
      simpl.
      intuition.

      inversion H; clear H.
      edestruct IHls; intuition.
      eauto.
      destruct H.
      intuition.
      exists x.
      exists (a :: x0).
      subst.
      simpl.
      intuition.
    Qed.

    edestruct (ls_last_exists (b :: ls)).
    simpl.
    eauto.
    destruct H0.
    intuition.
    rewrite H2.
    eapply in_or_app.
    destruct x; [left | right];
    eapply in_map_iff;
    econstructor; intuition.

  Qed.

  eapply getAllBlists_app_length_In.
  rewrite rev_length.
  eapply getAllBlists_app_In_length.
  eauto.

  Lemma getAllBlists_In_length : forall n ls,
    In ls (getAllBlists n) ->
    length ls = n.

    induction n; intuition; simpl in *.
    destruct H; subst; intuition.

    apply in_app_or in H;
    destruct H;
    apply in_map_iff in H;
    destruct H;
    intuition;

    subst;
    simpl;
    f_equal;
    eapply IHn; eauto.
  Qed.

  Lemma getAllBlists_length_In : forall n ls,
    length ls = n ->
    In ls (getAllBlists n).

    induction n; intuition; simpl in *;
    destruct ls; simpl in *; intuition; try omega.

    apply in_or_app.

    destruct b; [left | right];
    eapply in_map_iff; eauto.
  Qed.

  specialize (getAllBlists_app_rel_map n); intuition.
  specialize (rel_map_in_inv H0 x); intuition.
  destruct H2.
  intuition.
  subst.
  eapply getAllBlists_length_In.
  rewrite rev_length.
  eapply getAllBlists_In_length.
  eauto.
Qed.

Theorem getAllBlists_length : forall n,
  length (getAllBlists n) = (expnat 2 n).

  induction n; intuition; simpl in *.
  rewrite app_length.
  repeat rewrite map_length.
  rewrite plus_0_r.
  rewrite <- IHn.
  trivial.
Qed.

Lemma vector_cons_eq_inv : forall (A : Set)(n : nat)(a1 a2 : A)(v1 v2 : Vector.t A n),
  Vector.cons A a1 n v1 = Vector.cons A a2 n v2 ->
  a1 = a2 /\ v1 = v2.

  intuition.
  inversion H; trivial.

  Fixpoint tailOpt(A : Set)(n : nat)(v : Vector.t A n) : option (Vector.t A (pred n)):=
    match v with
      | [] => None
              | Vector.cons _ _ v => Some v
    end.

  assert (tailOpt (Vector.cons A a1 n v1) = tailOpt (Vector.cons A a2 n v2)).

  Lemma tailOpt_eq : forall (A : Set)(n : nat)(v1 v2 : Vector.t A n),
    v1 = v2 ->
    tailOpt v1 = tailOpt v2.

    intuition.
    subst.
    trivial.
  Qed.
  eapply tailOpt_eq.
  trivial.

  simpl in *.
  inversion H0; clear H0; subst.
  trivial.

Qed.

Lemma pair_eq_inv : forall (A B : Type)(a1 a2 : A)(b1 b2 : B),
  (a1, b1) = (a2, b2) ->
  a1 = a2 /\ b1 = b2.

  intros.
  inversion H; clear H; subst.
  intuition.
Qed.

Lemma opt_eq_inv : forall (A : Type)(a1 a2 : A),
  Some a1 = Some a2 ->
  a1 = a2.

  intuition.
  inversion H; clear H; subst.
  trivial.
Qed.

Lemma shiftOut_ls_eq : forall n ls1 ls2 v ls1' ls2',
  shiftOut ls1 n = Some (v, ls1') ->
  shiftOut ls2 n = Some (v, ls2') ->
  (firstn n ls1) = (firstn n ls2).

  induction n; intuition; simpl in *.
  destruct ls1; simpl in *; try discriminate.
  destruct ls2; simpl in *; try discriminate.
  case_eq (shiftOut ls1 n); intuition.
  rewrite H1 in H.
  case_eq (shiftOut ls2 n); intuition.
  rewrite H2 in H0.
  destruct p.
  destruct p0.
  inversion H; clear H; subst.

  apply opt_eq_inv in H0.
  apply pair_eq_inv in H0; intuition.
  apply vector_cons_eq_inv in H; intuition; subst.

  f_equal.
  eapply IHn.
  eapply H1.
  eapply H2.

  rewrite H2 in H0.
  discriminate.
  rewrite H1 in H.
  discriminate.
Qed.

Lemma le_refl_gen : forall n1 n2,
  (n1 = n2 ->
    n1 <= n2)%nat.

  intuition.
Qed.

Lemma shiftOut_to_list : forall n (v : Bvector n),
  shiftOut (VectorDef.to_list v) n = Some (v, nil).

  intuition.

  edestruct (shiftOut_Some (VectorDef.to_list v)).
  eapply le_refl_gen.
  symmetry.
  eapply (to_list_length v).
  destruct x.
  rewrite H.
  apply shiftOut_correct_inv in H.

  Lemma app_first_eq : forall (A : Type)(ls2 ls1 ls3 : list A),
    ls1 = ls2 ++ ls3 ->
    length ls1 = length ls2 ->
    ls1 = ls2 /\ ls3 = nil.

    intros; subst.
    assert (ls3 = nil).
    rewrite app_length in H0.
    assert (length ls3 = O).
    omega.
    destruct ls3; simpl in *; try omega; trivial.
    subst.
    rewrite app_nil_r.
    intuition.
  Qed.

  apply app_first_eq in H.
  intuition; subst.

  Lemma to_list_eq_inv : forall (A : Set) n (v1 v2 : Vector.t A n),
    VectorDef.to_list v1 = VectorDef.to_list v2 ->
          v1 = v2.

    induction n; intuition.
    rewrite (vector_0 v2).
    rewrite (vector_0 v1).
    trivial.

    destruct (vector_S v1).
    destruct (vector_S v2).
    destruct H0.
    destruct H1.
    subst.
    unfold VectorDef.to_list in *.
    inversion H; clear H; subst.
    f_equal.
    eauto.

  Qed.

  apply to_list_eq_inv in H0; subst.
  trivial.

  repeat rewrite to_list_length.
  trivial.
Qed.

Lemma shiftOut_app_None : forall ls1 ls2 n,
  shiftOut (ls1 ++ ls2) n = None ->
  shiftOut ls1 n = None.

  induction ls1; intuition; simpl in *.
  destruct n; destruct ls2; try discriminate; trivial.

  destruct n.
  discriminate.

  case_eq (shiftOut (ls1 ++ ls2) n); intuition.
  rewrite H0 in H.
  destruct p.
  discriminate.
  rewrite H0 in H.
  erewrite IHls1.
  trivial.
  eauto.

Qed.

Lemma BVxor_same_id : forall n (v : Bvector n),
  BVxor n v v = Bvect_false n.

  induction n; intuition.
  rewrite (vector_0 v).
  simpl.
  unfold Bvect_false.
  simpl.
  trivial.

  destruct (vector_S v).
  destruct H.
  rewrite H.
  unfold Bvect_false.
  simpl.
  rewrite IHn.
  rewrite xorb_nilpotent.
  trivial.

Qed.

Lemma BVxor_comm : forall n (v1 v2 : Bvector n),
  BVxor n v1 v2 = BVxor n v2 v1.

  induction n; intuition.
  rewrite (vector_0 v1).
  rewrite (vector_0 v2).
  trivial.

  destruct (vector_S v1).
  destruct H.
  destruct (vector_S v2).
  destruct H0.
  subst.
  simpl.
  rewrite IHn.
  rewrite xorb_comm.
  trivial.
Qed.

Lemma BVxor_id_r : forall n (v : Bvector n),
  BVxor n v (Bvect_false n) = v.

  induction n; intuition.
  rewrite (vector_0 v).
  unfold Bvect_false.
  simpl.
  trivial.

  destruct (vector_S v).
  destruct H.
  unfold Bvect_false.
  subst.
  simpl.
  rewrite IHn.
  rewrite xorb_false_r.
  trivial.
Qed.

Lemma BVxor_id_l : forall n (v : Bvector n),
  BVxor n (Bvect_false n) v = v.

  intuition.
  rewrite BVxor_comm.
  apply BVxor_id_r.
Qed.

Lemma BVxor_assoc : forall n (v1 v2 v3 : Bvector n),
  BVxor n (BVxor n v1 v2) v3 = BVxor n v1 (BVxor n v2 v3).

  induction n; intuition.
  rewrite (vector_0 v1).
  rewrite (vector_0 v2).
  rewrite BVxor_same_id.
  rewrite BVxor_id_l.
  rewrite (vector_0).
  rewrite (vector_0 v3).
  trivial.

  destruct (vector_S v1).
  destruct H.
  destruct (vector_S v2).
  destruct H0.
  destruct (vector_S v3).
  destruct H1.
  subst.
  simpl.
  rewrite IHn.
  rewrite xorb_assoc.
  trivial.
Qed.

Lemma BVxor_id_r_inv : forall n (v1 v2 : Bvector n),
  BVxor n v1 v2 = v1 ->
  v2 = (Bvect_false n).

  intuition.
  rewrite <- BVxor_id_l at 1.
  rewrite <- (BVxor_same_id v1).
  rewrite BVxor_assoc.
  f_equal; intuition.
Qed.

Lemma BVxor_id_inv : forall n (v1 v2 : Bvector n),
  BVxor n v1 v2 = Bvect_false n ->
  v1 = v2.

  intuition.
  rewrite <- BVxor_id_l at 1.
  rewrite <- (BVxor_id_l v2).
  rewrite <- (BVxor_same_id v2) at 1.
  rewrite BVxor_assoc.
  rewrite BVxor_comm.
  f_equal; intuition.
  rewrite BVxor_comm.
  trivial.
Qed.

Definition lognat(n : nat) : nat :=
  N.size_nat (N.of_nat n).

Definition bvToNat(k : nat)(v : Bvector k) :=
  N.to_nat (Bv2N k v).

Lemma Bv2N_zero : forall (n : nat),
  Bv2N n (Bvect_false n) = N0.

  induction n; intuition; simpl in *.
  unfold N.double in *.
  unfold Bvect_false in *.
  rewrite IHn.
  trivial.
Qed.

Lemma bvNat_zero : forall n,
  bvToNat (Bvect_false n) = O.

  intuition.
  unfold bvToNat.
  assert (N.to_nat N0 = O).
  simpl.
  trivial.
  rewrite <- H.
  f_equal.
  eapply Bv2N_zero.

Qed.

Definition natToBv(k : nat)(v : nat) : Bvector k :=
  N2Bv_gen k (N.of_nat v).

Lemma Bv2N_app_false : forall n1 n2 (v1 : Bvector n1),
  Bv2N (n1 + n2) (Vector.append v1 (Bvect_false n2)) = Bv2N n1 v1.

  induction n1; intuition.
  rewrite (vector_0 v1).
  simpl.
  apply Bv2N_zero.

  destruct (vector_S v1).
  destruct H.
  rewrite H.
  simpl.
  destruct x.
  rewrite IHn1.
  trivial.
  rewrite IHn1.
  trivial.

Qed.

Lemma Bv2N_N2Bv_gen : forall n0 k,
  n0 >= N.size_nat k ->
  Bv2N n0 (N2Bv_gen n0 k) = k.

  intuition.
  assert (exists x, n0 = N.size_nat k + x)%nat.
  exists (minus n0 (N.size_nat k)).
  omega.
  destruct H0.
  rewrite H0.
  rewrite N2Bv_N2Bv_gen_above.
  rewrite Bv2N_app_false.
  apply Bv2N_N2Bv.
Qed.

Lemma bvToNat_natToBv_inverse : forall n k,
  n >= lognat k ->
  bvToNat (natToBv n k) = k.

  intuition.
  unfold bvToNat, natToBv.
  rewrite Bv2N_N2Bv_gen.
  apply Nnat.Nat2N.id.
  trivial.
Qed.

Lemma Nat_size_nat_monotonic : forall n1 n2,
  (n1 < n2)%N ->
  (N.size_nat n1 <= N.size_nat n2)%nat.

  intuition.
  destruct n1; simpl.
  omega.
  destruct n2; simpl.
  inversion H.
  eapply Pos.size_nat_monotone.
  intuition.
Qed.

Lemma lognat_monotonic : forall n1 n2,
  (n1 < n2 ->
    lognat n1 <= lognat n2)%nat.

  intuition.
  unfold lognat.
  eapply Nat_size_nat_monotonic.
  specialize (Nnat.Nat2N.inj_compare n1 n2); intuition.
  apply nat_compare_lt in H.
  rewrite H in H0.
  case_eq (N.of_nat n1 ?= N.of_nat n2)%N; intuition;
    congruence.
Qed.

Lemma natToBv_bvToNat_inverse : forall n k,
  (natToBv n (bvToNat k)) = k.

  intuition.
  unfold natToBv, bvToNat.
  rewrite Nnat.N2Nat.id.
  apply N2Bv_Bv2N.
Qed.

Lemma bvToNat_natToBv_eq : forall n (v : Bvector n) k,
  bvToNat v = k ->
  v = natToBv n k.

  intuition.
  rewrite <- H.
  symmetry.
  apply natToBv_bvToNat_inverse.
Qed.


Require Import ZArith.

Definition pos_div4 (n:positive) : Z :=
 match n with
            | xO (xO p) => Zpos p
            | xI (xO p) => Zpos p
            | xO (xI p) => Zpos p
            | xI (xI p) => Zpos p
            | other => 0%Z
         end.

Eval compute in (pos_div4 56%positive).
Eval compute in (pos_div4 55%positive).
Eval compute in (pos_div4 49%positive).
Eval compute in (pos_div4 3%positive).
Eval compute in (pos_div4 4%positive).


Set Implicit Arguments.

Require Import List.
Require Import Arith.
Require Import Max.
Require Import LibTactics.

(** nat *)
Notation "k == i" := (eq_nat_dec k i) (at level 70).

Ltac case_nat :=
  let ldestr X Y := destruct (X == Y); [try subst X | idtac] in
  match goal with
  | |- context [?X == ?Y]      => ldestr X Y
  | H: context [?X == ?Y] |- _ => ldestr X Y
  end.

Notation emptyset := nil.

(** generating fresh nats *)
Section Exist_fresh.

  Fixpoint MAX (L : list nat) : nat :=
    match L with
    | nil        => O
    | cons hd tl => max hd (MAX tl)
    end.

  Lemma ex_fresh_var_1 : forall x L,
    In x L -> (x <= MAX L).
  Proof.
  induction L; intros.
    inversion H; simpl.
    destruct (max_dec a (MAX L)); destruct H; simpl.
        subst; rewrite e; apply le_refl.
        eapply le_trans; [ apply IHL; trivial | apply le_max_r].
        subst; apply le_max_l.
        eapply le_trans; [apply IHL; trivial | apply le_max_r].
  Qed.

  Lemma ex_fresh_var_2 : forall x L,
    MAX L < x -> ~ In x L.
  Proof.
  induction L; intuition; simpl.
    inversion H0; simpl; subst.
      eelim (le_not_lt). eapply ex_fresh_var_1. apply H0. trivial.
    apply IHL. apply le_lt_trans with (m := (MAX (a :: L))). simpl; apply le_max_r. assumption.
    inversion H0; subst.
      eelim le_not_lt. eapply ex_fresh_var_1. apply H0. trivial.
      trivial.
  Qed.

  Lemma pick_fresh : forall (L : list nat),
    exists n, ~ In n L.
  Proof.
  induction L; intros.
    exists O; auto.
    exists (S (MAX (a :: L))); intuition.
    elim ex_fresh_var_2 with (x := (S (MAX (a :: L)))) (L := (a :: L)).
      apply lt_n_Sn.
      trivial.
  Qed.

End Exist_fresh.

(** list nat *)
Lemma list_remove_in : forall n n0 S,
  In n S -> n <> n0 -> In n (remove eq_nat_dec n0 S).
Proof.
  induction S; intros; auto.
  simpl; case_nat.
    apply IHS; [destruct (in_inv H); congruence; auto | auto].
    destruct (n == a).
      subst; eauto with v62.
      simpl; right; apply IHS; [destruct (in_inv H); [congruence | auto] | auto].
Qed.

Lemma list_remove_in_inv: forall S n0 n,
  In n (remove eq_nat_dec n0 S) -> In n S.
Proof.
  intros; induction S; auto.
  destruct (n == a).
    subst; auto using in_eq.
    simpl in *.
    case_nat.
      right; auto.
      right; elim (in_inv H); intuition congruence.
Qed.

Lemma list_remove_in_inv_2: forall l n0 n,
  In n (remove eq_nat_dec n0 l) ->
  n <> n0.
Proof.
  red; intros; subst; firstorder.
  contradict H.
  induction l; simpl; intros; auto; destruct (n0 == a); simpl; firstorder.
Qed.

Lemma in_sub_remove : forall (x y:nat) l m,
  (In x l -> In x m) ->
  In x (remove eq_nat_dec y l) ->
  In x (remove eq_nat_dec y m).
Proof.
  induction l; simpl; intros; intuition.
  destruct (y==a); simpl in *; auto.
  elim H0; intros; auto.
  subst.
  auto using list_remove_in.
Qed.

Lemma list_remove_app : forall x l l',
  remove eq_nat_dec x (l ++ l') = remove eq_nat_dec x l ++ remove eq_nat_dec x l'.
Proof.
  induction l.
  simpl; auto.
  intro; simpl.
  case_nat; auto.
  rewrite IHl; eauto using app_comm_cons.
Qed.

Lemma list_remove_repeat : forall x l,
  remove eq_nat_dec x (remove eq_nat_dec x l) = remove eq_nat_dec x l.
Proof.
  induction l.
  simpl; auto.
  simpl; case_nat; auto.
    simpl; case_nat; try congruence; auto.
Qed.

Lemma list_remove_twice : forall x y l,
  remove eq_nat_dec x (remove eq_nat_dec y l) = remove eq_nat_dec y (remove eq_nat_dec x l).
Proof.
  induction l.
  simpl; auto.
  simpl; case_nat.
    repeat case_nat; auto.
      simpl; repeat case_nat; try congruence; auto.
    repeat case_nat; simpl; repeat case_nat; try congruence; auto.
Qed.

Lemma emptyset_plus : emptyset ++ emptyset = (emptyset:list nat).
Proof.
  simpl; auto.
Qed.

(** swap_nat *)
Definition swap_nat (n m k : nat) : nat :=
  if n == k then m else if m == k then n else k.

Lemma swap_in_eq : forall n0 m k n,
  k <> n -> swap_nat n0 m k <> swap_nat n0 m n.
Proof.
  unfold swap_nat; intros.
  repeat case_nat; congruence.
Qed.

Lemma swap_map_remove : forall l m n,
  m <> n -> ~ In n l -> remove eq_nat_dec n (map (swap_nat n m) l) = remove eq_nat_dec m l.
Proof.
  induction l.
  intros; simpl; trivial.
  intros.
  assert (n <> a) by firstorder using remove_In.
  assert (~ In n l) by firstorder.
  destruct (m == a).

    simpl map at 1.
    replace (swap_nat n m a) with n.
    simpl remove at 1; case_nat; try congruence.
    simpl remove at 2; case_nat; try congruence.
    auto.
    unfold swap_nat.
    case_nat; try congruence.
    case_nat; try congruence.

    simpl map at 1.
    assert (swap_nat n m a = a).
      unfold swap_nat; case_nat; try congruence; case_nat; congruence.
    rewrite H3.
    simpl remove; case_nat; try congruence; case_nat; try congruence.
    f_equal; auto.
Qed.

Lemma swap_not_in : forall m n k l,
  ~ In k l -> ~ In (swap_nat m n k) (map (swap_nat m n) l).
Proof.
  intros; induction l.
  simpl; auto.
  simpl; unfold swap_nat at 1.
  assert (k <> a) by firstorder.
  assert (~ In k l) by firstorder.
  case_nat.

    assert (n <> swap_nat a n k).
    unfold swap_nat; repeat case_nat; congruence.
    firstorder.

    assert ((if n == a then m else a) <> swap_nat m n k).
    unfold swap_nat; repeat case_nat; congruence.
    firstorder.
Qed.

Lemma swap_map_idem : forall l n m,
  map (swap_nat m n) (map (swap_nat m n) l) = l.
Proof.
  induction l; simpl; intros; f_equal; auto.
  intros; unfold swap_nat; repeat case_nat; congruence.
Qed.

Lemma swap_eq_remove_map : forall l m n,
  ~ In m l -> remove eq_nat_dec n l = remove eq_nat_dec m (map (swap_nat n m) l).
Proof.
  induction l; intros; simpl; auto.
  unfold swap_nat at 1.
  case_nat; case_nat; try case_nat; try congruence.
  simpl in H; intuition.
  simpl in H; intuition.
  unfold swap_nat at 1; case_nat; try congruence; case_nat; try congruence.
  erewrite IHl; firstorder.
Qed.

Lemma swap_app_remove_map : forall n m k l,
  map (swap_nat n m) (remove eq_nat_dec k l)
    = remove eq_nat_dec (swap_nat n m k) (map (swap_nat n m) l).
Proof.
  induction l; simpl; auto.
  case_nat.
    case_nat; try congruence.
    case_nat.
      forwards H : (swap_in_eq n m n0); congruence.
      simpl; rewrite IHl; auto.
Qed.

(** remove O and then map-decrement *)
Notation map_pred_remove_zero l := (map pred (remove eq_nat_dec O l)).

Lemma swap_remove_map_pred_remove_zero : forall n L,
  remove eq_nat_dec n (map_pred_remove_zero L) = map_pred_remove_zero (remove eq_nat_dec (S n) L).
Proof.
induction L; auto.
destruct a; simpl; auto.
  destruct (n == a); simpl; auto.
    rewrite IHL; auto.
Qed.

Lemma notIn_n_pred_notIn_S_n : forall n L,
  ~ In n (map pred L) -> ~ In (S n) L.
Proof.
induction L; simpl; intuition.
  destruct a; simpl; intuition.
    inversion H1.
Qed.

Lemma notIn_remove_notIn : forall n m L,
  n <> m -> ~ In n (remove eq_nat_dec m L) -> ~ In n L.
Proof.
induction L; simpl.
  intuition.
  destruct (m == a); simpl; subst; intuition.
Qed.

Lemma notIn_remove_notIn_remain : forall n m L,
  ~ In n L -> ~ In n (remove eq_nat_dec m L).
Proof.
induction L; simpl.
  intuition.
  destruct (m == a); simpl; subst; intuition.
Qed.

Lemma notIn_remove_self : forall n L,
  ~ In n (remove eq_nat_dec n L).
Proof.
  induction L; simpl; intros; auto; destruct (n == a); simpl; firstorder.
Qed.

Lemma notIn_dist : forall A, forall (x :A) L L',
  ~ In x (L ++ L') -> ~ In x L /\ ~ In x L'.
Proof.
induction L; simpl; intuition.
Qed.

Lemma map_eq_nil : forall A, forall f (L : list A), (map f L = (nil : list A)) -> (L = nil).
Proof.
induction L; simpl; intuition.
  inversion H.
Qed.

(** list *)
Lemma list_permuting_in_app_cons_cons : forall T (x:T) l a b l',
  In x (l ++ a :: b :: l') ->
  In x (l ++ b :: a :: l').
Proof.
  induction l; simpl; intros.
  firstorder.
  firstorder.
Qed.

Lemma list_cons_move_app : forall T (x:T) l l',
  l ++ x :: l' = (l ++ x :: nil) ++ l'.
Proof.
  induction l; intros; simpl; auto.
  f_equal; auto.
Qed.

Lemma list_cons_cons_move_app : forall T (y:T) l l',
  y :: l ++ l' = (y :: l) ++ l'.
Proof.
  simpl; auto.
Qed.

(** In *)
Ltac destructIn tac :=
  match goal with
    | H: In ?X emptyset |- _ => inversion H
    | H: In ?X (?L1 ++ ?L2) |- _ =>
      apply in_app_or in H; destruct H; destructIn tac
    | H: In ?X (?X :: ?L) |- _ =>
      clear H; destructIn tac
    | H: In ?X (?Y :: ?L) |- _ =>
      apply in_inv in H; destruct H; destructIn tac
    | |- In ?X (?Y :: ?L) =>
      try solve [ apply in_eq; destructIn tac | apply in_cons; destructIn tac ]
    | |- In ?X (?L1 ++ ?L2) =>
      apply in_or_app; try solve [ left; destructIn tac | right; destructIn tac ]
    | _ => tac
  end.

Tactic Notation "Destruct" "In" "by" tactic(tac) := destructIn tac.

(** notIn  *)
Lemma not_in_not_eq : forall A (X : A) (Y : A) L,
  X <> Y -> ~ In X L -> ~ In X (Y :: L).
Proof.
  firstorder.
Qed.

Lemma not_in_and_app : forall A L L' (X : A),
  ~ In X L -> ~ In X L' -> ~ In X (L ++ L').
Proof.
  induction L; firstorder.
Qed.

Lemma not_in_inv : forall A (X : A) (Y : A) L,
  ~ In X (Y :: L) -> X <> Y /\ ~ In X L.
Proof.
  firstorder.
Qed.

Lemma not_in_app_and : forall A, forall (x :A) L L',
  ~ In x (L ++ L') -> ~ In x L /\ ~ In x L'.
Proof.
  firstorder.
Qed.

Ltac destructNotIn tac :=
  let goal_destr_cons := (apply not_in_not_eq) in
  let goal_destr_concat := (apply not_in_and_app) in
  let hypo_destr_cons H := destruct (not_in_inv H); clear H in
  let hypo_destr_concat H := destruct (not_in_app_and _ _ _ H); clear H in
  match goal with
    | H: ?X <> ?X |- _ => congruence
    | H: ~ In ?X (?Y :: ?L) |- _ => hypo_destr_cons H; (destructNotIn tac)
    | H: ~ In ?X (?L1 ++ ?L2) |- _ => hypo_destr_concat H; (destructNotIn tac)
    | |- ~ In ?X (?Y :: ?L) => goal_destr_cons; [ tac | destructNotIn tac ]
    | |- ~ In ?X (?L1 ++ ?L2) => goal_destr_concat; (destructNotIn tac)
    | _ => tac
  end.

Tactic Notation "Destruct" "notIn" "by" tactic(tac) := destructNotIn tac.

Lemma list_always_incl_emptyset : forall A (l : list A), incl emptyset l.
Proof.
  induction l; eauto with v62.
Qed.


Module Basics.

(* Для начала, как обычно, заново определим ложь, конъюнкцию и дизъюнкцию *)
(* Наши определения будут немного отличаться от предыдущих *)

Definition False : Prop := forall P:Prop, P.

Definition not : Prop -> Prop := fun A:Prop => A -> False.

Notation "~' x" := (not x) (at level 75, right associativity).

(* Конъюнкция *)
Definition and : Prop->Prop->Prop := fun A B:Prop => forall P:Prop, (A -> B -> P) -> P.

Notation "A /_\ B" := (and A B) (at level 80).

(* Аксиома A → B → A /\ B *)
Theorem andI : forall (A B : Prop), A -> B -> A /_\ B.
Proof.
    exact (fun A B a b P H => H a b).
    (* Также можно доказать так:
    intros A B a b.
    unfold and.
    intros P H.
    exact (H a b).
    *)
Qed.

(* Дизъюнция *)
Definition or : Prop->Prop->Prop := fun (A B : Prop) => forall P:Prop, (A -> P) -> (B -> P) -> P.

Notation "A \_/ B" := (or A B) (at level 85).

(* Аксиома A → A \/ B *)
Theorem orIL : forall (A B : Prop), A -> A \_/ B.
Proof.
    exact (fun A B a P H1 H2 => H1 a).
Qed.

(* Аксиома B → A \/ B *)
Theorem orIR : forall (A B : Prop), B -> A \_/ B.
Proof.
    exact (fun A B b P H1 H2 => H2 b).
Qed.

(* Эквивалентность через конъюнкцию *)
Definition iff : Prop->Prop->Prop := fun (A B:Prop) => (A -> B) /_\ (B -> A).

Notation "A <=> B" := (iff A B) (at level 95).

(* Теперь начнем развлекаться со множествами *)

(* Для начала определим множество *)
Parameter set : Type.

(* Равенство двух множеств *)
(* Любое суждение, верное для одного множества, верно и для другого *)
Definition eq : set->set->Prop := fun (x y : set) => forall Q:set -> Prop, Q x -> Q y.

Notation "x == y" := (eq x y) (at level 70).
Notation "x /= y" := (~' x == y) (at level 70).

(* Докажем рефлексивность такого равенства *)
Theorem eqI : forall x:set, x == x.
Proof.
    exact (fun x q H => H).
Qed.

(* И симметричность *)
Theorem eq_sym : forall x y:set, x == y -> y == x.
Proof.
    (* CW *)
    exact (fun x y H => H (fun y => eq y x) (eqI x)).
Qed.

(* Определим квантор существования для set *)
Definition ex : (set->Prop)->Prop := fun P:set->Prop => forall Q:Prop, (forall x, P x -> Q) -> Q.

Notation "'exists' x , p" := (ex (fun x => p))
  (at level 200, x ident).

(* P x -> \exists x P x *)
Theorem exI : forall P:set->Prop, forall x:set, P x -> exists x, P x.
Proof.
    exact (fun P x H1 Q H2 => H2 x H1).
Qed.

(* Такой же квантор существования, только для функций вида set -> set *)
Definition ex_f : ((set->set)->Prop)->Prop := fun P:(set->set)->Prop => forall Q:Prop, (forall x, P x -> Q) -> Q.

Notation "'existsf' x , p" := (ex_f (fun x => p))
  (at level 200, x ident).

Theorem exI_f : forall P:(set->set)->Prop, forall F:set->set, P F -> existsf F, P F.
Proof.
    (* CW *)
    exact (fun P F H1 Q H2 => H2 F H1).
Qed.

(* Квантор единственного существования *)
Definition exu : (set->Prop)->Prop := fun P:set->Prop => (exists x, P x) /_\ (forall x y:set, P x -> P y -> x == y).

Notation "'exists!' x , p" := (exu (fun x => p))
  (at level 200, x ident).

Theorem exuI : forall P:set->Prop, (exists x, P x) -> (forall x y:set, P x -> P y -> x == y) -> exists! x, P x.
Proof.
    (* CW *)
    intros P.
    exact (andI (ex P) (forall x y:set, P x -> P y -> x == y)).
Qed.

(* Оператор описания множества *)
(* Пригодится позже в доказательствах, пока можно пропустить *)
Parameter Descr : ((set->Prop)->set).

Axiom DescrR : forall P:set->Prop, (exists! x, P x) -> P (Descr P).

(* Определим базовые отношения, свойства и операции над множествами *)

(* In - отношение "x принадлежит множеству y" *)

Parameter In : set->set->Prop.

Notation "x ':e' y" := (In x y) (at level 70).
Notation "x '/:e' y" := (~' (In x y)) (at level 70).

(* Subq - отношение "A вложено в B" *)

Definition Subq : set->set->Prop :=
fun X Y => forall x:set, x :e X -> x :e Y.

Notation "X 'c=' Y" := (Subq X Y) (at level 70).
Notation "X '/c=' Y" := (~' (Subq X Y)) (at level 70).

Lemma Subq_ref : forall X:set, X c= X.
    intros X x H1. exact H1.
Qed.

Lemma Subq_tra : forall X Y Z:set, X c= Y -> Y c= Z -> X c= Z.
    (* CW *)
    intros X Y Z H1 H2 x H3. apply H2. apply H1. exact H3.
Qed.

(* Равенство множеств - это вложенность множеств друг в друга *)

Axiom set_ext : forall X Y:set, X c= Y -> Y c= X -> X == Y.

(* Равенство в другую сторону *)

Theorem set_ext_inv : forall X Y:set, X == Y -> (X c= Y /_\ Y c= X).
Proof.
    (* HW *)
    admit.
Qed.

(* Индукция по множеству *)

Axiom In_ind : forall P:set->Prop, (forall X:set, (forall x, x :e X -> P x) -> P X) -> forall X:set, P X.

Parameter Empty : set.

Axiom EmptyAx : ~' exists x, x :e Empty.

Lemma EmptyE : forall x:set, x /:e Empty.
    (* CW *)
    exact (fun x H => EmptyAx (exI (fun x => x :e Empty) x H)).
Qed.

(* Union(X) - операция объединения всех подмножеств X *)
(* То есть Union(X) = {x | \exists Y: x \in Y, Y \in X} *)

Parameter Union : set->set.

Axiom UnionEq : forall X:set, forall x:set, x :e Union X <=> exists Y, x :e Y /_\ Y :e X.

Lemma A_and_B_A : forall A B:Prop, A /_\ B -> A.
Proof.
    unfold and.
    intros.
    pose (t := H A).
    intuition.
Qed.

Lemma A_and_B_B : forall A B:Prop, A /_\ B -> B.
Proof.
    unfold and.
    intros.
    pose (t := H B).
    intuition.
Qed.

Lemma UnionE :
forall X x:set, x :e (Union X) -> exists Y, x :e Y /_\ Y :e X.
Proof.
    (* CW *)
    exact (fun X x : set =>
    UnionEq X x (x :e Union X -> exists Y, x :e Y /_\ Y :e X)
      (fun (H1 : x :e Union X -> exists Y, x :e Y /_\ Y :e X)
         (_ : (exists Y, x :e Y /_\ Y :e X) -> x :e Union X) => H1)).
Qed.

Lemma UnionI :
forall X x Y:set, x :e Y -> Y :e X -> x :e (Union X).
Proof.
    (* CW *)
    exact (fun (X x Y : set) (H1 : x :e Y) (H2 : Y :e X) =>
    UnionEq X x (x :e Union X)
      (fun (_ : x :e Union X -> exists Y, x :e Y /_\ Y :e X)
         (H4 : (exists Y, x :e Y /_\ Y :e X) -> x :e Union X) =>
       H4
         (exI (fun Y0 : set => x :e Y0 /_\ Y0 :e X) Y
            (andI (x :e Y) (Y :e X) H1 H2)))).
Qed.

(* Power(X) - множество всех подмножеств X *)

Parameter Power : set->set.

Axiom PowerEq : forall X Y:set, Y :e Power X <=> Y c= X.

Lemma PowerE : forall X Y:set, Y :e Power X -> Y c= X.
Proof.
    intros.
    pose (t := PowerEq X Y).
    unfold iff in t.
    pose (tt := A_and_B_A _ _ t).
    exact (tt H).
Qed.

Lemma PowerI : forall X Y:set, Y c= X -> Y :e (Power X).
    intros.
    pose (t := PowerEq X Y).
    unfold iff in t.
    pose (tt := A_and_B_B _ _ t).
    exact (tt H).
Qed.

Lemma In_Power : forall X:set, X :e Power X.
Proof.
    (* CW *)
    intros X. apply PowerI. apply Subq_ref.
Qed.

(* Sep(X, P) = {x | x :e X, P x} *)

Parameter Sep : set -> (set -> Prop) -> set.

Notation "{ x :i X | P }" := (Sep X (fun x:set => P)).

Axiom SepEq : forall X:set, forall P:set -> Prop, forall x, x :e {z :i X | P z} <=> x :e X /_\ P x.

Lemma SepI : forall X:set, forall P:set -> Prop, forall x:set,
 x :e X -> P x -> x :e {z :i X|P z}.
Proof.
    (* CW *)
    exact (fun (X : set) (P : set -> Prop) (x : set) (H1 : x :e X) (H2 : P x) =>
    SepEq X P x (x :e Sep X P)
      (fun (_ : x :e Sep X P -> x :e X /_\ P x)
         (H3 : x :e X /_\ P x -> x :e Sep X P) => H3 (andI (x :e X) (P x) H1 H2))).
Qed.

Lemma SepE : forall X:set, forall P:set -> Prop, forall x:set,
 x :e {z :i X|P z} -> x :e X /_\ P x.
Proof.
    (* CW *)
    intros X P x H1. apply (SepEq X P x). exact (fun H2 _ => H2 H1).
Qed.

Lemma SepE1 : forall X:set, forall P:set -> Prop, forall x:set,
 x :e {z :i X|P z} -> x :e X.
Proof.
    (* CW *)
    exact (fun (X : set) (P : set -> Prop) (x : set) (H1 : x :e Sep X P) =>
    SepEq X P x (x :e X)
      (fun (H2 : x :e Sep X P -> x :e X /_\ P x)
         (_ : x :e X /_\ P x -> x :e Sep X P) =>
       H2 H1 (x :e X) (fun (H3 : x :e X) (_ : P x) => H3))).
Qed.

Lemma SepE2 : forall X:set, forall P:set -> Prop, forall x:set,
 x :e {z :i X|P z} -> P x.
Proof.
    (* CW *)
    exact (fun (X : set) (P : set -> Prop) (x : set) (H1 : x :e Sep X P) =>
    SepEq X P x (P x)
      (fun (H2 : x :e Sep X P -> x :e X /_\ P x)
         (_ : x :e X /_\ P x -> x :e Sep X P) =>
       H2 H1 (P x) (fun (_ : x :e X) (H3 : P x) => H3))).
Qed.

(* Repl(X, F) = {F x | x :e X} *)

Parameter Repl : set->(set->set)->set.

Notation "{ F | x :i X }" := (Repl X (fun x:set => F)).

Axiom ReplEq :
forall X:set, forall F:set->set, forall y:set, y :e {F z|z :i X} <=> exists x, x :e X /_\ y == F x.

Lemma ReplE :
forall X:set, forall F:set->set, forall y:set, y :e {F z|z :i X} -> exists x, x :e X /_\ y == F x.
Proof.
    (* HW *)
    exact (fun (X : set) (F : set -> set) (y : set) =>
    ReplEq X F y
      (y :e Repl X (fun x : set => F x) -> exists x, x :e X /_\ y == F x)
      (fun
         (H1 : y :e Repl X (fun x : set => F x) ->
               exists x, x :e X /_\ y == F x)
         (_ : (exists x, x :e X /_\ y == F x) ->
              y :e Repl X (fun x : set => F x)) => H1)).
Qed.

Lemma ReplI :
forall X:set, forall F:set->set, forall x:set, x :e X -> F x :e {F x|x :i X}.
Proof.
    (* HW *)
    exact (fun (X : set) (F : set -> set) (x : set) (H1 : x :e X) =>
    ReplEq X F (F x) (F x :e Repl X (fun x0 : set => F x0))
      (fun
         (_ : F x :e Repl X (fun x0 : set => F x0) ->
              exists x0, x0 :e X /_\ F x == F x0)
         (H4 : (exists x0, x0 :e X /_\ F x == F x0) ->
               F x :e Repl X (fun x0 : set => F x0)) =>
       H4
         (exI (fun x0 : set => x0 :e X /_\ F x == F x0) x
            (andI (x :e X) (F x == F x) H1 (eqI (F x)))))).
Qed.

(* Прикольные леммки для разных операций над пустыми множествами *)
(* Пригодятся позже, когда определим ординалы *)

Lemma Subq_Empty : forall X:set, Empty c= X.
Proof.
    (* CW *)
    exact (fun (X x : set) (H : x :e Empty) => EmptyE x H (x :e X)).
Qed.

Lemma Empty_Power : forall X:set, Empty :e Power X.
Proof.
    (* CW *)
    intros X. apply PowerI. apply Subq_Empty.
Qed.

Lemma Repl_Empty : forall F:set -> set, {F x|x :i Empty} == Empty.
Proof.
    (* HW *)
    exact (fun F : set -> set =>
    set_ext (Repl Empty F) Empty
      (fun (x : set) (H1 : x :e Repl Empty F) =>
       ReplE Empty F x H1 (x :e Empty)
         (fun (y : set) (H1' : y :e Empty /_\ x == F y) =>
          H1' (x :e Empty)
            (fun (H2 : y :e Empty) (_ : x == F y) => EmptyE y H2 (x :e Empty))))
      (fun (x : set) (H1 : x :e Empty) => EmptyE x H1 (x :e Repl Empty F))).
Qed.

(* Неупорядоченная пара *)

Definition TSet : set := {X :i Power (Power Empty) | Empty :e X \_/ Empty /:e X}.
Definition UPair : set->set->set :=
 fun y z:set =>
 {Descr (fun w:set => forall p:set->Prop, (Empty /:e X -> p y) -> (Empty :e X  -> p z) -> p w)|X :i TSet}.

Notation "{ x , y }" := (UPair x y).

Lemma UPairE :
forall x y z:set, x :e {y,z} -> x == y \_/ x == z.
Proof.
    (* HW *)
    intros x y z H1. apply ReplE in H1. apply H1.
    intros u H2. apply H2. intros H3 H4.
    apply (SepE _ _ _ H3). intros H5 H6. apply (eq_sym _ _ H4).
    apply (DescrR (fun v:set => forall p:set->Prop, (Empty /:e u -> p y) -> (Empty :e u  -> p z) -> p v)).
    - apply exuI.
      + apply H6.
        * intros H7. apply (exI _ z). intros p _ H8. exact (H8 H7).
        * intros H7. apply (exI _ y). intros p H8 _. exact (H8 H7).
      + intros v w H7 H8. apply H7.
        * { intros H9 p H10. apply H8.
            - intros _. exact H10.
            - intros H11. apply (H9 H11).
          }
        * { intros H9 p H10. apply H8.
            - intros H11. apply (H11 H9).
            - intros _. exact H10.
          }
    - intros _. apply orIL. apply eqI.
    - intros _. apply orIR. apply eqI.
Qed.

Lemma UPairI1 :
forall y z:set, y :e {y,z}.
Proof.
    (* HW *)
    intros y z.
    assert (H1:Descr (fun v => forall p:set->Prop, (Empty /:e Empty -> p y) -> (Empty :e Empty  -> p z) -> p v) == y).
    {
      apply (DescrR (fun v => forall p:set->Prop, (Empty /:e Empty -> p y) -> (Empty :e Empty  -> p z) -> p v)).
      - apply exuI.
        + apply (exI _ y). intros p H2 _. apply H2. apply EmptyE.
        + intros v w H2 H3. apply H2.
          * { intros H4 p H5. apply H3.
              - intros _. exact H5.
              - intros H6. apply (EmptyE _ H6).
            }
          * intros H4. apply (EmptyE _ H4).
      - intros _. apply eqI.
      - intros H2. apply (EmptyE _ H2).
    }
    apply (H1 (fun w => w :e UPair y z)).
    change ((fun u => Descr (fun v => forall p:set->Prop, (Empty /:e u -> p y) -> (Empty :e u  -> p z) -> p v)) Empty :e UPair y z).
    apply ReplI. apply SepI.
    - apply Empty_Power.
    - apply orIR. apply EmptyE.
Qed.

Lemma UPairI2 :
forall y z:set, z :e {y,z}.
Proof.
    (* HW *)
    intros y z.
    assert (H1:Descr (fun v => forall p:set->Prop, (Empty /:e Power Empty -> p y) -> (Empty :e Power Empty  -> p z) -> p v) == z).
    {
      apply (DescrR (fun v => forall p:set->Prop, (Empty /:e Power Empty -> p y) -> (Empty :e Power Empty  -> p z) -> p v)).
      - apply exuI.
        + apply (exI _ z). intros p _ H2. apply H2. apply Empty_Power.
        + intros v w H2 H3. apply H2.
          * intros H4. apply H4. apply Empty_Power.
          * { intros H4 p H5. apply H3.
              - intros H6. apply H6. apply Empty_Power.
              - intros _. exact H5.
            }
      - intros H2. apply H2. apply Empty_Power.
      - intros _. apply eqI.
    }
    apply (H1 (fun w => w :e UPair y z)).
    change ((fun u => Descr (fun v => forall p:set->Prop, (Empty /:e u -> p y) -> (Empty :e u  -> p z) -> p v)) (Power Empty) :e UPair y z).
    apply ReplI. apply SepI.
    - apply In_Power.
    - apply orIL. apply Empty_Power.
Qed.

Lemma UPairEq :
forall x y z, x :e {y,z} <=> x == y \_/ x == z.
Proof.
    (* CW *)
    intros x y z. apply andI. apply UPairE. intros H1. apply H1.
    intros H2. apply H2. apply UPairI1.
    intros H2. apply H2. apply UPairI2.
Qed.

(* sing(Y) = {Y, Y} *)

Definition Sing : set->set := fun y:set => {y,y}.

Notation "{| y |}" := (Sing y).

Lemma SingI : forall y, y :e {| y |}.
Proof.
  intros y. unfold Sing. apply UPairI1.
Qed.

Lemma SingE : forall x y, x :e {| y |} -> x == y.
Proof.
  intros x y H1. apply (UPairE _ _ _ H1). exact (fun H => H). exact (fun H => H).
Qed.

Lemma SingEq : forall x y, x :e {| y |} <=> x == y.
Proof.
    (* CW *)
    intros x y. apply andI. apply SingE. intros H. apply H. apply SingI.
Qed.

(* binunion(X, Y) = Union({X, Y}) *)

Definition binunion : set -> set -> set := fun X Y => Union {X,Y}.

Notation "X :u: Y" := (binunion X Y) (at level 40).

Lemma binunionI1 : forall X Y z, z :e X -> z :e X :u: Y.
    (* CW *)
    exact (fun (X Y z : set) (H1 : z :e X) => UnionI (UPair X Y) z X H1 (UPairI1 X Y)).
Qed.

Lemma binunionI2 : forall X Y z, z :e Y -> z :e X :u: Y.
    (* CW *)
    exact (fun (X Y z : set) (H1 : z :e Y) => UnionI (UPair X Y) z Y H1 (UPairI2 X Y)).
Qed.

Lemma binunionE : forall X Y z, z :e X :u: Y -> z :e X \_/ z :e Y.
    (* HW *)
    exact (fun (X Y z : set) (H1 : z :e binunion X Y) =>
    UnionE (UPair X Y) z H1 (z :e X \_/ z :e Y)
      (fun (w : set) (H1' : z :e w /_\ w :e UPair X Y) =>
       H1' (z :e X \_/ z :e Y)
         (fun (H2 : z :e w) (H3 : w :e UPair X Y) =>
          UPairE w X Y H3 (z :e X \_/ z :e Y)
            (fun H4 : w == X =>
             orIL (z :e X) (z :e Y) (H4 (fun X0 : set => z :e X0) H2))
            (fun H4 : w == Y =>
             orIR (z :e X) (z :e Y) (H4 (fun Y0 : set => z :e Y0) H2))))).
Qed.

Lemma binunionEq : forall X Y z, z :e X :u: Y <=> z :e X \_/ z :e Y.
    (* CW *)
    intros X Y z. apply andI. apply binunionE. intros H1. apply H1. apply binunionI1. apply binunionI2.
Qed.

(* TODO : setminus, famunion, ordinals, more and more fun to follow *)

End Basics.

Export Basics.


Require Export Singletons.
Require Export Separation.

(* This file contains exercises from Paul Halmos book, Naive Set Theory, and
   from a few other places. *)

Theorem union_empty : Union ∅ = ∅.
Proof.
  extension.
  - apply Union_E in H. destruct H. inv H.
    contradiction (Empty_E x0).
  - apply Union_I with (Y := ∅). auto.
    contradiction (Empty_E x).
Qed.

Hint Resolve union_empty.

Theorem union_sing : forall A, Union (Sing A) = A.
Proof. intros. compute. extension; obvious_BUR. Qed.

Hint Resolve union_sing.

Theorem union_one : Union One = ∅.
Proof. compute. apply union_sing. Qed.

Theorem union_X_two : forall X, X ∈ Two → Union X = ∅.
Proof.
  intros. unfold Two in H.
  apply UPair_E in H.
  inversion H.
  rewrite <- union_empty.
  f_equal. assumption. rewrite H0.
  compute. apply union_sing.
Qed.

Theorem union_two : Union Two = One.
Proof.
  compute. extension.
  apply Union_E in H. destruct H. inv H.
    apply UPair_E in H1. inv H1.
      contradiction (Empty_E x).
      assumption.
  apply Union_I with (Y := {∅, ∅}).
    assumption.
    apply UPair_I2.
Qed.

Theorem union_comm : forall A B, A ∪ B = B ∪ A.
Proof. obvious_BUR. Qed.

Theorem union_assoc : forall A B C, A ∪ (B ∪ C) = (A ∪ B) ∪ C.
Proof. obvious_BUR. Qed.

Theorem union_idem : forall A, A ∪ A = A.
Proof. obvious_BUR. Qed.

Theorem union_incl : forall A B, A ⊆ B ↔ A ∪ B = B.
Proof.
  intros. split; intros. obvious_BUR.
  compute. intros. rewrite <- H. union_1.
Qed.

Definition Inter (M : set) : set :=
  Sep (Union M) (fun x : set => ∀ A : set, A ∈ M → x ∈ A).

Lemma Inter_I : ∀ x M, inh_set M → (∀ A, A ∈ M → x ∈ A) → x ∈ Inter M.
Proof.
  intros. unfold Inter.
  apply Sep_I. inv H. specialize (H0 x0).
    apply Union_I with (Y := x0); auto.
    auto.
Qed.

Hint Resolve Inter_I.

Lemma Inter_E : ∀ x M, x ∈ Inter M → inh_set M ∧ ∀ A, A ∈ M → x ∈ A.
Proof.
  intros. unfold Inter in H.
  apply Sep_E in H. inv H.
  apply Union_E in H0. destruct H0. inv H.
  split.
    specialize (H1 x0).
    unfold inh_set. exists x0. auto.
  auto.
Qed.

Hint Resolve Inter_E.

Definition BinInter (A B : set) : set := Inter (UPair A B).

Lemma BinInter_I : ∀ A B a: set, a ∈ A ∧ a ∈ B → a ∈ BinInter A B.
Proof.
  intros. unfold BinInter. inv H.
  apply Inter_I.
    unfold inh_set. exists A. pair_1.
    intros. pair_e H.
Qed.

Hint Resolve BinInter_I.

Lemma BinInter_E : ∀ A B x, x ∈ BinInter A B → x ∈ A ∧ x ∈ B.
Proof.
  intros. unfold BinInter in H.
  apply Inter_E in H. inv H.
  unfold inh_set in H0. destruct H0.
  split; obvious_BUR.
Qed.

Hint Resolve BinInter_E.

Notation "X ∩ Y" := (BinInter X Y) (at level 69).

Ltac inter := apply BinInter_I ; split ; try auto.
Ltac inter_e H :=
  apply BinInter_E in H ; try (first [ inv H | destruct H ]) ; try auto.

Ltac obvious :=
  repeat (try obvious_BUR; match goal with
  | [ H : ?X ∈ (?A ∩ ?B) |- _ ] => inter_e H
  | [ |- ?X ∈ (?A ∩ ?B) ] => inter
  end; auto).

Theorem inter_zero : forall A, A ∩ ∅ = ∅.
Proof.
  intros. extension.
  inter_e H. inter.
  contradiction (Empty_E x).
Qed.

Theorem inter_comm : forall A B, A ∩ B = B ∩ A.
Proof. intros. extension; obvious. Qed.

Theorem inter_assoc : forall A B C, A ∩ (B ∩ C) = (A ∩ B) ∩ C.
Proof. intros. extension; obvious. Qed.

Theorem inter_idem : forall A, A ∩ A = A.
Proof. intros. extension; obvious. Qed.

Theorem inter_incl : forall A B, A ⊆ B ↔ A ∩ B = A.
Proof.
  intros. split; intros. extension; obvious.
  unfold Subq. intros. rewrite <- H in H0. inter_e H0.
Qed.

Theorem union_distr : forall A B C, A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C).
Proof. intros. extension; obvious. Qed.

Theorem inter_distr : forall A B C, A ∪ (B ∩ C) = (A ∪ B) ∩ (A ∪ C).
Proof. intros. extension; obvious. Qed.

(* Exercise.  A necessary and sufficient condition that (A ∩ B) ∪ C = A ∩ (B ∪
   C) is that C ⊆ A.  Observe that the condition has nothing to do with the
   set B.
*)
Theorem union_assoc_ns : forall A B C, (A ∩ B) ∪ C = A ∩ (B ∪ C) ↔ C ⊆ A.
Proof.
  intros. split; intros.
  - apply inter_incl.
    extension.
    + obvious.
    + apply BinInter_I. split.
        assumption.
        apply extensionality_E in H. inv H.
          unfold Subq in *.
          specialize (H1 x).
          specialize (H2 x).
          apply BinInter_E in H1.
            inv H1. auto.
            apply Union_I with (Y := C).
              assumption.
              apply UPair_I2.
  - rewrite union_distr.
    extension.
    + rewrite inter_comm with (B := C).
      pose (inter_incl C A). inv i.
      rewrite H1; assumption.
    + rewrite inter_comm with (B := C) in H0.
      pose (inter_incl C A). inv i.
      rewrite H1 in H0; assumption.
Qed.


(*|
#################################################
In Coq, How to construct an element of 'sig' type
#################################################

:Link: https://stackoverflow.com/q/44967359
|*)

(*|
Question
********

With a simple inductive definition of a type ``A``:
|*)

Require Import EqNat. (* .none *)
Inductive A : Set := mkA : nat -> A.

(* get ID of A *)
Definition getId (a : A) : nat := match a with mkA n => n end.

(*| And a subtype definition: |*)

(* filter that test ID of *A* is 0 *)
Definition filter (a : A) : bool :=
  if beq_nat (getId a) 0 then true else false.

(* cast bool to Prop *)
Definition IstrueB (b : bool) : Prop := if b then True else False.

(* subtype of *A* that only interests those who pass the filter *)
Definition subsetA : Set := { a : A | IstrueB (filter a) }.

(*|
I try this code to cast element of ``A`` to ``subsetA`` when
``filter`` passes, but failed to convenience Coq that it is a valid
construction for an element of 'sig' type:
|*)

Fail Definition cast (a : A) : option subsetA :=
  match filter a with
  | true => Some (exist _ a (IstrueB (filter a)))
  | false => None
  end. (* .unfold *)

(*|
So, Coq expects an actual proof of type ``IstrueB (filter a)``, but
what I provide there is type ``Prop``.

Could you shed some lights on how to provide such type? thank you.
|*)

(*|
Answer
******

First of all, there is the standard `is_true
<https://coq.inria.fr/library/Coq.Init.Datatypes.html#is_true>`__
wrapper. You can use it explicitly like so:
|*)

Reset subsetA. (* .none *)
Definition subsetA : Set := { a : A | is_true (filter a) }.

(*| or implicitly using the coercion mechanism: |*)

Reset subsetA. (* .none *)
Coercion is_true : bool >-> Sortclass.
Definition subsetA : Set := { a : A | filter a }.

(*|
Next, non-dependent pattern-mathching on ``filter a`` doesn't
propagate ``filter a = true`` into the ``true`` branch. You have at
least three options:

1. Use tactics to build your ``cast`` function:

  .. coq::
|*)

Definition cast (a : A) : option subsetA.
  destruct (filter a) eqn:prf.
  - exact (Some (exist _ a prf)).
  - exact None.
Defined.

(*|
2. Use dependent pattern-matching explicitly (search for "convoy
   pattern" on Stackoverflow or in `CDPT
   <http://adam.chlipala.net/cpdt/>`__):

   .. coq::
|*)

Definition cast' (a : A) : option subsetA :=
  match filter a as fa
        return (filter a = fa -> option subsetA)
  with
  | true => fun prf => Some (exist _ a prf)
  | false => fun _ => None
  end eq_refl.

(*|
3. Use the Program facilities:

   .. coq::
|*)

Require Import Coq.Program.Program.

Program Definition cast'' (a : A) : option subsetA :=
  match filter a with
  | true => Some (exist _ a _)
  | false => None
  end.

(*|
----

**A:** There is also ``Is_true`` in ``Bool``.
|*)


From Hammer Require Import Hammer.

Require Import NAxioms NSub NZSqrt.

Module NSqrtProp (Import A : NAxiomsSig')(Import B : NSubProp A).

Module Import Private_NZSqrt := Nop <+ NZSqrtProp A A B.

Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l.
Ltac wrap l := intros; apply l; auto'.

Lemma sqrt_spec' : forall a, √a*√a <= a < S (√a) * S (√a).
Proof. hammer_hook "NSqrt" "NSqrt.NSqrtProp.sqrt_spec'".   wrap sqrt_spec. Qed.

Definition sqrt_unique : forall a b, b*b<=a<(S b)*(S b) -> √a == b
:= sqrt_unique.

Lemma sqrt_square : forall a, √(a*a) == a.
Proof. hammer_hook "NSqrt" "NSqrt.NSqrtProp.sqrt_square".   wrap sqrt_square. Qed.

Definition sqrt_le_mono : forall a b, a<=b -> √a <= √b
:= sqrt_le_mono.

Definition sqrt_lt_cancel : forall a b, √a < √b -> a < b
:= sqrt_lt_cancel.

Lemma sqrt_le_square : forall a b, b*b<=a <-> b <= √a.
Proof. hammer_hook "NSqrt" "NSqrt.NSqrtProp.sqrt_le_square".   wrap sqrt_le_square. Qed.

Lemma sqrt_lt_square : forall a b, a<b*b <-> √a < b.
Proof. hammer_hook "NSqrt" "NSqrt.NSqrtProp.sqrt_lt_square".   wrap sqrt_lt_square. Qed.

Definition sqrt_0 := sqrt_0.
Definition sqrt_1 := sqrt_1.
Definition sqrt_2 := sqrt_2.

Definition sqrt_lt_lin : forall a, 1<a -> √a<a
:= sqrt_lt_lin.

Lemma sqrt_le_lin : forall a, √a<=a.
Proof. hammer_hook "NSqrt" "NSqrt.NSqrtProp.sqrt_le_lin".   wrap sqrt_le_lin. Qed.

Definition sqrt_mul_below : forall a b, √a * √b <= √(a*b)
:= sqrt_mul_below.

Lemma sqrt_mul_above : forall a b, √(a*b) < S (√a) * S (√b).
Proof. hammer_hook "NSqrt" "NSqrt.NSqrtProp.sqrt_mul_above".   wrap sqrt_mul_above. Qed.

Lemma sqrt_succ_le : forall a, √(S a) <= S (√a).
Proof. hammer_hook "NSqrt" "NSqrt.NSqrtProp.sqrt_succ_le".   wrap sqrt_succ_le. Qed.

Lemma sqrt_succ_or : forall a, √(S a) == S (√a) \/ √(S a) == √a.
Proof. hammer_hook "NSqrt" "NSqrt.NSqrtProp.sqrt_succ_or".   wrap sqrt_succ_or. Qed.

Definition sqrt_add_le : forall a b, √(a+b) <= √a + √b
:= sqrt_add_le.

Lemma add_sqrt_le : forall a b, √a + √b <= √(2*(a+b)).
Proof. hammer_hook "NSqrt" "NSqrt.NSqrtProp.add_sqrt_le".   wrap add_sqrt_le. Qed.

Include NZSqrtUpProp A A B Private_NZSqrt.

End NSqrtProp.


(*
 * Code for The Hoare State Monad (Proof Pearl), Wouter Swierstra
 * Reference:
 *   https://webspace.science.uu.nl/~swier004//publications/2009-tphols.v
 *)

Require Import Program.
Require Import Arith.
Require Import List.
Require Import Psatz.

Inductive Tree (a : Set) : Set :=
| Leaf : a -> Tree a
| Node : Tree a -> Tree a -> Tree a.

Arguments Leaf [a] _.
Arguments Node [a] _ _.

Compute Node (Leaf 2) (Leaf 1).

Module Sec2_TheStateMonad.

  Fixpoint relabel {a : Set} (t : Tree a) (s : nat) : Tree nat * nat :=
    match t with
    | Leaf _ => (Leaf s, 1 + s)
    | Node l r =>
        let (l', s') := relabel l s in
        let (r', s'') := relabel r s' in
        (Node l' r', s'')
    end.

  Compute relabel (Node (Leaf 100) (Leaf 34)) 0.
  Compute relabel (Node (Leaf 123) (Leaf 567)) 0.

  Definition State (s a : Set) : Type := s -> a * s.
  Definition ret (s a : Set) : a -> State s a :=
    fun x => fun s => (x, s).
  Definition bind (s a b : Set) : State s a -> (a -> State s b) -> State s b :=
    fun c1 c2 => fun s1 => let (x, s2) := c1 s1 in c2 x s2.

  Arguments ret [s a] _ _.
  Arguments bind [s a b] _ _ _.

  Notation "e1 '>>=' e2" := (bind e1 e2) (at level 80, right associativity).
  Notation "e1 '>>' e2" := (bind e1 (fun _ => e2)) (at level 80, right associativity).

  Definition get (s : Set) : State s s := fun s => (s, s).
  Definition put (s : Set) : s -> State s unit := fun s => fun _ => (tt, s).

  Arguments get {s}.
  Arguments put {s}.

  Fixpoint relabelM {a : Set} (t : Tree a) : State nat (Tree nat) :=
    match t with
    | Leaf _ => get >>= fun n =>
               put (S n) >>
               ret (Leaf n)
    | Node l r => relabelM l >>= fun l' =>
                 relabelM r >>= fun r' =>
                 ret (Node l' r')
    end.

  Compute relabelM (Node (Leaf 456) (Leaf 123)) 0.

End Sec2_TheStateMonad.

Module Sec3_TheChallenge.
  Import Sec2_TheStateMonad.
  (*
   * How can we prove relabelM is correct?
   * What's the specification of relabelM?
   *)

  Fixpoint flatten {a : Set} (t : Tree a) : list a :=
    match t with
    | Leaf x => x :: nil
    | Node l r => flatten l ++ flatten r
    end.

  Lemma relabelM_correct : forall {a : Set} (t : Tree a) (n : nat),
      NoDup (flatten (fst (relabelM t n))).
  Proof. Admitted.

  (* The flatten result tree corresponds to some list *)
  (* No duplication in this flatten tree *)
  (* The invariance of tree shape *)

End Sec3_TheChallenge.

Module Sec456.

  (* Strong specification: the type of the relabelM function
   * should capture its behavior.
   *)

  Definition Pre (s : Set) : Type := s -> Prop.
  Definition Post (s a : Set) : Type := s -> a -> s -> Prop.

  (* Requires an initial state that satisfies a given precondition.
   * Guarantees that the resulting pair satisfies a postcondition
   * relating the initial state (i), resulting value (x), and final state (f).
   *)
  Program Definition HoareState (s : Set) (pre : Pre s) (a : Set) (post : Post s a) : Set :=
    forall i : { t : s | pre t }, { (x, f) : a * s | post i x f }.

  (* Now defining `ret` and `bind` of HoareState *)

  Definition top {s : Set} : @Pre s := fun s => True.

  Program Definition ret (s : Set) (a : Set) :
    forall x, HoareState s top a (fun i y f => i = f /\ y = x) :=
    fun x => fun s => (x, s).

  (* First try of `bind`:
   * HoareState1 P1 a Q1 -> (a -> HoareState P2 b Q2) -> HoareStae ... b ...
   * P2 and Q2 cannot use the result of the first computation, so let's generalize it:
   * HoareState1 P1 a Q1 ->
     (forall (x : a), (a -> HoareState (P2 x) b (Q2 x)) ->
     HoareStae ... b ...
   *)

  (* What should be the precondition and postcondition of the _composite_ computation (... b ...)?
     - its precondition should contain the precondition of the _first_ computation:
         P1 s1

     - it should also contain that the postcondition of the _first_ computation implies
       the precondition of the _second_ computation:
         forall x s2, Q1 s1 x s2 -> P2 x s2

     - Thus combining them obtains the precondition:
         (fun s1 => P1 s1 /\ forall x s2, Q1 s1 x s2 -> P2 x s2)

     - its postcondition existentially quantifies the state and value after _first_ computation,
       so that they satisfies Q1:
         exists x, exists s2, Q1 s1 x s2

     - its postcondition should also satisfy the postcondition of the _second_ computation,
         (fun s1 y s3 => exists x, exists s2, Q1 s1 x s2 /\ Q2 x s2 y s3)
   *)

  Program Definition bind : forall s a b P1 P2 Q1 Q2,
      (HoareState s P1 a Q1) ->
      (forall (x : a), HoareState s (P2 x) b (Q2 x)) ->
      HoareState s
                 (fun s1 => P1 s1 /\ forall x s2, Q1 s1 x s2 -> P2 x s2)
                 b
                 (fun s1 y s3 => exists x, exists s2, Q1 s1 x s2 /\ Q2 x s2 y s3)
    := fun s a b P1 P2 Q1 Q2 =>
       fun c1 c2 s1 => match c1 s1 with (x, s2) => c2 x s2 end.

  Next Obligation.
  Proof.
    apply p0. destruct c1 as [H1 H2]. simpl in *. subst. apply H2.
  Defined.
  Next Obligation.
  Proof with simpl in *.
    destruct c1 as [H1 H2]... destruct c2 as [[b0 s0] P2rh]...
    subst. exists x, s2. intuition.
  Defined.

  Arguments ret [s a] _ _.
  Arguments bind [s a b] {P1 P2 Q1 Q2} _ _ _ .

  Notation "e1 '>>=' e2" := (bind e1 e2) (at level 80, right associativity).
  Notation "e1 '>>' e2" := (bind e1 (fun _ => e2)) (at level 80, right associativity).

  Program Definition get (s : Set) :
    HoareState s top s (fun i x f => i = f /\ x = i)
    := fun s => (s, s).

  Program Definition put (s : Set) (x : s) :
    HoareState s top unit (fun _ _ f => f = x)
    := fun _ => (tt, x).

  Arguments get {s} _.
  Arguments put {s} _ _.

  (* That's it! *)

  (* Revisiting relabelM *)

  Fixpoint size {a : Set} (t : Tree a) : nat :=
    match t with
    | Leaf x => 1
    | Node l r => size l + size r
    end.

  Fixpoint flatten {a : Set} (t : Tree a) : list a :=
    match t with
    | Leaf x => x :: nil
    | Node l r => flatten l ++ flatten r
    end.

  Fixpoint seq (x n : nat) : list nat :=
    match n with
    | 0 => nil
    | S k => x :: seq (S x) k
    end.

  Compute seq 5 10.
  Compute seq 0 8.

  Lemma SeqSplit : forall y x z, seq x (y + z) = seq x y ++ seq (x + y) z.
  Proof with simpl; auto.
    induction y... intros x z... rewrite IHy, plus_Snm_nSm...
  Qed.

  Program Fixpoint relabelM {a : Set} (t : Tree a) :
    HoareState nat top (Tree nat)
               (fun i t f => f = i + size t /\ flatten t = seq i (size t))
    := match t with
       | Leaf _ => get >>= fun n =>
                  put (S n) >>
                  ret (Leaf n)
       | Node l r => relabelM l >>= fun l' =>
                    relabelM r >>= fun r' =>
                    ret (Node l' r')
       end.
  Next Obligation.
  Proof. intuition. Defined.
  Next Obligation.
  Proof with simpl in *; auto.
    destruct_call (bind (s := nat))...
    clear relabelM l r H.
    destruct_conjs...
    (* now we must prove that the postcondition holds for the tree
     * Node l r under the assumption that it holds for recursive
     * calls to l and r *)
    rename y into l, H1 into r, H into lState, H3 into rState.
    rename H0 into sizeL, H4 into sizeR, H2 into flattenL, H7 into flattenR.
    rename H5 into finalState, H6 into finalRes.
    rewrite finalRes.
    split...
    - lia.
    - rewrite flattenL, flattenR, sizeL, SeqSplit...
  Defined.

  (* Section 6 *)

  (* How can we prove the result t satisfies Nodup (flatten t)? *)
  (* We need to weaken the postcondition and
     strengthen the precondition explicitly, by using `do` *)

  Program Definition do (s a : Set) (P1 P2 : Pre s) (Q1 Q2 : Post s a) :
    (forall i, P2 i -> P1 i) -> (forall i x f, Q1 i x f -> Q2 i x f) ->
    HoareState s P1 a Q1 -> HoareState s P2 a Q2
    := fun str wkn c => c.
  Next Obligation.
  Proof with simpl; auto.
    destruct_call c... destruct x0 as [x1 f]...
  Defined.

  (* See complete proof in
     https://webspace.science.uu.nl/~swier004//publications/2009-tphols.v
   *)

End Sec456.

(* Some following related work:
   - F*
   - Dijkstra Monads for Free (POPL 17)
   - Dijkstra Monads for All (ICFP 19)
   - A Predicate Transformer Semantics for Effects (ICFP 19)
   ...
*)


Require Import List.
Require Import String.
Open Scope string_scope.

Require Import StructTactics.

Inductive expr : Set :=
| Var : string -> expr
| App : expr -> expr -> expr
| Lam : string -> expr -> expr.

Coercion Var : string >-> expr.

Notation "X @ Y" := (App X Y) (at level 49).
Notation "\ X , Y" := (Lam X Y) (at level 50).

Check (\"x", \"y", "x").
Check (\"x", \"y", "y").
Check ((\"x", "x" @ "x") @ (\"x", "x" @ "x")).

(** e1[e2/x] *)
Fixpoint subst (e : expr) (from : string) (to : expr)  : expr :=
  match e with
  | Var x => if string_dec from x then to else e
  | App e1 e2 => App (subst e1 from to) (subst e2 from to)
  | Lam x e => if string_dec from x then e else Lam x (subst e from to)
  end.

(**
Call By Name
<<
       e1 --> e1'
  ---------------------
    e1 e2 --> e1' e2

  -----------------------------
    (\x. e1) e2 --> e1[e2/x]
>>
*)

Inductive step_cbn : expr -> expr -> Prop :=
| CBN_crunch:
    forall e1 e1' e2,
      step_cbn e1 e1' ->
      step_cbn (App e1 e2) (App e1' e2)
| CBN_subst:
    forall x e1 e2,
      step_cbn (App (Lam x e1) e2) (subst e1 x e2).

Notation "e1 ==> e2" := (step_cbn e1 e2) (at level 51).

Lemma step_cbn_det:
  forall e e1,
  e ==> e1 ->
  forall e2,
  e ==> e2 ->
  e1 = e2.
Proof.
  induction 1; intros.
  - invc H0.
    + f_equal. apply IHstep_cbn; auto.
    + invc H.
  - invc H.
    + invc H3.
    + reflexivity.
Qed.

(**
Call By Value
<<

v ::= \ x . e

       e1 --> e1'
  ---------------------
    e1 e2 --> e1' e2

       e2 --> e2'
  ---------------------
    v e2 --> v e2'

  -----------------------------
    (\x. e1) v --> e1[v/x]
>>
*)

Inductive value : expr -> Prop :=
| VLam :
    forall x e,
      value (Lam x e).

Inductive step_cbv : expr -> expr -> Prop :=
| CBV_crunch_l:
    forall e1 e1' e2,
      step_cbv e1 e1' ->
      step_cbv (App e1 e2) (App e1' e2)
| CBV_crunch_r:
    forall v e2 e2',
      value v ->
      step_cbv e2 e2' ->
      step_cbv (App v e2) (App v e2')
| CBV_subst:
    forall x e1 v,
      value v ->
      step_cbv (App (Lam x e1) v) (subst e1 x v).

Notation "e1 --> e2" := (step_cbv e1 e2) (at level 51).


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* ** Luca's theorem *)

Require Import Arith Nat Lia List.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd prime binomial sums rel_iter.

From Undecidability.H10.ArithLibs
  Require Import Zp.

Set Implicit Arguments.

Local Notation power := (mscal mult 1).
Local Notation expo := (mscal mult 1).

Section fact.

  Let factorial_cancel n a b : fact n * a = fact n * b -> a = b.
  Proof.
    apply Nat.mul_cancel_l.
    generalize (fact_gt_0 n); intro; lia.
  Qed.

  Notation Π := (msum mult 1).

  Notation mprod_an := (fun a n => Π n (fun i => i+a)).

  Fact mprod_factorial n : fact n = mprod_an 1 n.
  Proof.
    induction n as [ | n IHn ].
    + rewrite msum_0; auto.
    + rewrite msum_plus1; auto.
      rewrite Nat.mul_comm, <- IHn, fact_S.
      f_equal; lia.
  Qed.

  Variable (p : nat) (Hp : p <> 0).

  Notation "〚 x 〛" := (nat2Zp Hp x).

  Let expo_p_cancel n a b : expo n p * a = expo n p * b -> a = b.
  Proof.
    apply Nat.mul_cancel_l.
    generalize (power_ge_1 n Hp); intros; lia.
  Qed.

  Fact mprod_factorial_Zp i n :〚mprod_an (i*p+1) n〛=〚fact n〛.
  Proof.
    rewrite mprod_factorial.
    induction n as [ | n IHn ].
    + do 2 rewrite msum_0; auto.
    + do 2 (rewrite msum_plus1; auto).
      do 2 rewrite nat2Zp_mult; f_equal; auto.
      apply nat2Zp_inj.
      rewrite (Nat.add_comm n), <- Nat.add_assoc, Nat.add_comm.
      rewrite <- rem_plus_div; auto.
      * f_equal; lia.
      * apply divides_mult, divides_refl.
  Qed.

  Notation φ := (fun n r => mprod_an (n*p+1) r).
  Notation Ψ := (fun n => Π n (fun i => mprod_an (i*p+1) (p-1))).

  Let phi_Zp_eq n r :〚φ n r〛=〚fact r〛.
  Proof. apply mprod_factorial_Zp. Qed.

  Fact mprod_factorial_mult n : fact (n*p) = expo n p * fact n * Ψ n.
  Proof using Hp.
    induction n as [ | n IHn ].
    + rewrite Nat.mul_0_l, msum_0, mscal_0, fact_0; auto.
    + replace (S n*p) with (n*p+p) by ring.
      rewrite mprod_factorial, msum_plus, <- mprod_factorial; auto.
      replace p with (S (p-1)) at 2 by lia.
      rewrite msum_plus1; auto.
      rewrite <- Nat.add_assoc.
      replace (p-1+1) with p by lia.
      replace (n*p+p) with ((S n)*p) by ring.
      rewrite mscal_S, fact_S, msum_S.
      rewrite IHn.
      repeat rewrite Nat.mul_assoc.
      rewrite (Nat.mul_comm _ p).
      repeat rewrite <- Nat.mul_assoc.
      do 2 f_equal.
      rewrite (Nat.mul_comm (S n)).
      repeat rewrite <- Nat.mul_assoc; f_equal.
      repeat rewrite Nat.mul_assoc; f_equal.
      rewrite msum_ext with (f := fun i => n*p+i+1)
                            (g := fun i => i+(n*p+1)).
      2: intros; ring.
      rewrite <- msum_plus1; auto.
  Qed.

  Lemma mprod_factorial_euclid n r : fact (n*p+r) = expo n p * fact n * φ n r * Ψ n.
  Proof using Hp.
    rewrite mprod_factorial, msum_plus; auto.
    rewrite <- mprod_factorial.
    rewrite msum_ext with (f := fun i => n*p+i+1)
                          (g := fun i => i+(n*p+1)).
    2: intros; ring.
    rewrite mprod_factorial_mult; auto; ring.
  Qed.

  Notation Zp := (Zp_zero Hp).
  Notation Op := (Zp_one Hp).
  Notation "∸" := (Zp_opp Hp).
  Infix "⊗" := (Zp_mult Hp) (at level 40, left associativity).
  Notation expoZp := (mscal (Zp_mult Hp) (Zp_one Hp)).

  Hint Resolve Nat_mult_monoid : core.

  Let Psi_Zp_eq n :〚Ψ n〛= expoZp n〚fact (p-1)〛.
  Proof.
    induction n as [ | n IHn ].
    + rewrite msum_0, mscal_0; auto.
    + rewrite msum_plus1, nat2Zp_mult.
      rewrite mscal_plus1; auto.
      2: apply Zp_mult_monoid.
      2: apply Nat_mult_monoid.
      f_equal; auto.
  Qed.

  Hypothesis (Hprime : prime p).

  Let phi_Zp_invertible n r : r < p -> Zp_invertible Hp 〚φ n r〛.
  Proof.
    intros H; simpl; rewrite phi_Zp_eq.
    apply Zp_invertible_factorial; auto.
  Qed.

  Let Psi_Zp_invertible n : Zp_invertible Hp 〚Ψ n〛.
  Proof.
    simpl; rewrite (Psi_Zp_eq n).
    apply Zp_expo_invertible, Zp_invertible_factorial; auto; lia.
  Qed.

  (* rewrite the binomial theorem

               fact k * fact (n-k) * binomial n k = fact n

      when

         k = K*p + k0
         n = N*p + n0

      with

      1)  K <= N & k0 <= n0

      we get n-k = (N-K)*p + (n0-k0) and

        expo K     p * fact K     * φ K      k0     * Ψ K
      .* expo (N-K) p * fact (N-K) * φ (N-K) (n0-k0) * Ψ (N-K)
      .* binomial n k
      = expo N p     * fact N     * φ N      n0     * Ψ N.

      hence, simplifying by expo N p  we get

        fact K * fact (N-K) * φ K k0 * Ψ K * φ (N-K) (n0-k0) * Ψ (N-K) * binomial n k = fact N * φ N n0 * Ψ N.

      then in Z/Zp we derive (modulo Wilson's theorem, unnecessary here〚fact (p-1)〛=〚-1〛)

       〚fact K〛⊗〚fact (N-K)〛⊗〚fact k0〛⊗〚-1〛^K⊗〚fact (n0-k0)〛⊗〚-1〛^(N-K)⊗〚binomial n k〛
      =〚fact N〛⊗〚fact n0〛⊗〚-1〛^N

        that we combine with 〚fact K〛⊗〚fact (N-K)〛⊗〚binomial N K〛=〚fact N〛
                        and  〚fact k0〛⊗〚fact (n0-k0)〛⊗〚binomial n0 k0〛=〚fact n0〛

        to derive the result:〚binomial n k 〛=〚binomial N K〛⊗〚binomial n0 k0〛

      with

      2) K < N & n0 < k0

      we have n-k = (N-(K+1))*p + (p-(k0-n0)) and

        expo K         p * fact K         * φ K          k0         * Ψ K
      .* expo (N-(K+1)) p * fact (N-(K+1)) * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1))
      .* binomial n k
      = expo N p     * fact N     * φ N      n0     * Ψ N.

      hence

         fact K * φ K k0 * Ψ K * fact (N-(K+1)) * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1)) * binomial n k
       = p * ....

      then in Z/Zp all the left factor are invertible except binomial n k which must thus be〚0〛 *)

  Section binomial_without_p_not_zero.

    Variable (n N n0 k K k0 : nat) (Hn : n = N*p+n0) (Hk : k = K*p+k0) (H1 : K <= N) (H2 : k0 <= n0).

    Let Hkn : k <= n.
    Proof.
      rewrite Hn, Hk.
      replace N with (K+(N-K)) by lia.
      rewrite Nat.mul_add_distr_r.
      generalize ((N-K)*p); intros; lia.
    Qed.

    Let Hnk : n - k = (N-K)*p+(n0-k0).
    Proof.
      rewrite Hn, Hk, Nat.mul_sub_distr_r.
      cut (K*p <= N*p).
      + generalize (K*p) (N*p); intros; lia.
      + apply Nat.mul_le_mono; auto.
    Qed.

    Fact binomial_wo_p : φ K k0 * Ψ K * φ (N-K) (n0-k0) * Ψ (N-K) * binomial n k
                       = binomial N K * φ N n0 * Ψ N.
    Proof using Hkn.
      apply (factorial_cancel (N-K)); repeat rewrite Nat.mul_assoc.
      rewrite (Nat.mul_comm (fact _) (binomial _ _)).
      apply (factorial_cancel K); repeat rewrite Nat.mul_assoc.
      rewrite (Nat.mul_comm (fact _) (binomial _ _)).
      rewrite <- binomial_thm; auto.
      apply expo_p_cancel with N.
      repeat rewrite Nat.mul_assoc.
      rewrite <- mprod_factorial_euclid, <- Hn.
      rewrite binomial_thm with (1 := Hkn).
      rewrite Hnk.
      rewrite Hk at 3.
      replace N with (K+(N-K)) at 1 by lia.
      rewrite power_plus.
      do 2 rewrite mprod_factorial_euclid.
      ring.
    Qed.

    Hypothesis (Hn0 : n0 < p).

    Hint Resolve Zp_mult_monoid : core.

    Fact binomial_Zp_prod :〚binomial n k〛=〚binomial N K〛⊗〚binomial n0 k0〛.
    Proof using Hkn Hn0 Hprime.
      generalize binomial_wo_p; intros G.
      apply f_equal with (f := nat2Zp Hp) in G.
      repeat rewrite nat2Zp_mult in G.
      repeat rewrite Psi_Zp_eq in G.
      repeat rewrite phi_Zp_eq in G.
      rewrite binomial_thm with (1 := H2) in G.
      repeat rewrite nat2Zp_mult in G.
      rewrite (Zp_mul_comm _ _〚 fact k0 〛) in G.
      repeat rewrite Zp_mul_assoc in G.
      rewrite (Zp_mul_comm _ _〚 fact k0 〛) in G.
      repeat rewrite <- Zp_mul_assoc in G.
      apply Zp_invertible_cancel_l in G.
      2: apply Zp_invertible_factorial; auto; lia.
      repeat rewrite Zp_mul_assoc in G.
      do 2 rewrite (Zp_mul_comm _ _〚 fact _ 〛) in G.
      repeat rewrite <- Zp_mul_assoc in G.
      apply Zp_invertible_cancel_l in G.
      2: apply Zp_invertible_factorial; auto; lia.
      repeat rewrite Zp_mul_assoc in G.
      rewrite <- mscal_plus in G; auto.
      replace (K+(N-K)) with N in G by lia.
      rewrite (Zp_mul_comm _ _ (expoZp _ _)) in G.
      apply Zp_invertible_cancel_l in G; trivial.
      apply Zp_expo_invertible, Zp_invertible_factorial; auto; lia.
    Qed.

  End binomial_without_p_not_zero.

  Section binomial_without_p_zero.

    Variable (n N n0 k K k0 : nat) (Hn : n = N*p+n0) (Hk : k = K*p+k0)
             (H1 : K < N) (H2 : n0 < k0) (Hk0 : k0 < p).

    Let H3 : p - (k0-n0) < p.    Proof. lia. Qed.
    Let H4 : S (N-1) = N.        Proof. lia. Qed.
    Let H5 : N-1 = K+(N-(K+1)).  Proof. lia. Qed.
    Let H6 : N = K+1+(N-(K+1)).  Proof. lia. Qed.
    Let HNK : N-K = S (N-(K+1)). Proof. lia. Qed.

    Let Hkn : k <= n.
    Proof.
      rewrite Hn, Hk, H6.
      do 2 rewrite Nat.mul_add_distr_r.
      generalize ((N-(K+1))*p); clear H3 H4 H5 H6 HNK; intros; lia.
    Qed.

    Let Hnk : n - k = (N-(K+1))*p+(p-(k0-n0)).
    Proof.
      rewrite Hn, Hk, Nat.mul_sub_distr_r.
      cut ((K+1)*p <= N*p).
      + rewrite Nat.mul_add_distr_r.
        generalize (K*p) (N*p); clear H3 H4 H5 H6 HNK Hkn; intros; lia.
      + apply Nat.mul_le_mono; auto; clear H3 H4 H5 H6 HNK Hkn; lia.
    Qed.

    Fact binomial_with_p : fact K * fact (N-(K+1)) * φ K k0 * Ψ K * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1)) * binomial n k
                         = p * fact N * φ N n0 * Ψ N.
    Proof using Hkn.
      apply expo_p_cancel with (N-1).
      repeat rewrite Nat.mul_assoc.
      rewrite (Nat.mul_comm (expo _ _) p).
      rewrite <- mscal_S.
      rewrite H4, <- mprod_factorial_euclid, <- Hn.
      rewrite binomial_thm with (1 := Hkn).
      rewrite Hnk.
      rewrite Hk at 3.
      do 2 rewrite mprod_factorial_euclid.
      rewrite H5 at 1.
      rewrite power_plus.
      ring.
    Qed.

    Fact binomial_with_p' : φ K k0 * Ψ K * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1)) * binomial n k
                          = p * binomial N K * (N-K) * φ N n0 * Ψ N.
    Proof using Hkn.
      apply (factorial_cancel (N-(K+1))); repeat rewrite Nat.mul_assoc.
      apply (factorial_cancel K); repeat rewrite Nat.mul_assoc.
      rewrite binomial_with_p.
      rewrite binomial_thm with (n := N) (p := K).
      2: { apply Nat.lt_le_incl; auto. }
      rewrite HNK at 1.
      rewrite fact_S.
      rewrite <- HNK.
      ring.
    Qed.

    Fact binomial_Zp_zero :〚binomial n k〛= Zp.
    Proof using Hkn Hprime.
      generalize binomial_with_p'; intros G.
      apply f_equal with (f := nat2Zp Hp) in G.
      repeat rewrite nat2Zp_mult in G.
      rewrite nat2Zp_p in G.
      repeat rewrite Zp_mult_zero in G.
      apply Zp_invertible_eq_zero in G; auto.
      repeat (apply Zp_mult_invertible; auto).
    Qed.

  End binomial_without_p_zero.

End fact.

Section lucas_lemma.

  (* https://math.stackexchange.com/questions/1463758/proof-of-lucas-theorem-without-the-polynomial-hint *)

  Variables (p : nat) (Hprime : prime p).

  Let Hp : p <> 0.
  Proof.
    generalize (prime_ge_2 Hprime); intro; lia.
  Qed.

  Variables (n N n0 k K k0 : nat)
            (G1 : n = N*p+n0)  (G2 : n0 < p)
            (G3 : k = K*p+k0)  (G4 : k0 < p).

  Let choice : (K <= N  /\ k0 <= n0)
            \/ (n0 < k0 /\ K < N)
            \/ ((n0 < k0 \/ N < K) /\ n < k).
  Proof.
    destruct (le_lt_dec k n) as [ H0 | H0 ];
    destruct (le_lt_dec k0 n0) as [ H1 | H1 ];
    destruct (le_lt_dec K N) as [ H2 | H2 ]; try lia.
    + do 2 right; split; auto.
      rewrite G1, G3.
      replace K with (N+1+(K-N-1)) by lia.
      do 2 rewrite Nat.mul_add_distr_r.
      generalize ((K-N-1)*p); intros; lia.
    + destruct (eq_nat_dec N K); try lia.
    + do 2 right; split; auto.
      rewrite G1, G3.
      replace K with (N+1+(K-N-1)) by lia.
      do 2 rewrite Nat.mul_add_distr_r.
      generalize ((K-N-1)*p); intros; lia.
  Qed.

  Theorem lucas_lemma : rem (binomial n k) p = rem (binomial N K * binomial n0 k0) p.
  Proof using choice.
    destruct choice as [ (H1 & H2)
                     | [ (H1 & H2)
                       | (H1 & H2) ] ]; clear choice.
    3: { rewrite binomial_gt with (1 := H2).
         f_equal.
         destruct H1 as [ H1 | H1 ];
           rewrite binomial_gt with (1 := H1); ring. }
    + apply nat2Zp_inj with (Hp := Hp).
      rewrite nat2Zp_mult.
      apply binomial_Zp_prod; auto.
    + rewrite binomial_gt with (1 := H1).
      rewrite Nat.mul_0_r.
      apply nat2Zp_inj with (Hp := Hp).
      rewrite nat2Zp_zero.
      apply binomial_Zp_zero with (2 := G1) (3 := G3); auto.
  Qed.

End lucas_lemma.

(* Eval compute in binomial 3 0. *)

Section lucas_theorem.

  Variable (p : nat) (Hp : prime p).

  Implicit Types (l m : list nat).

  (* base_p [x0;x1;x2;...] =  x0 + x1*p + x2*p² ...*)

  Notation base_p := (expand p).

  Fixpoint binomial_p l :=
    match l with
      | nil  => fix loop m := match m with
        | nil  => 1
        | y::m => binomial 0 y * loop m
      end
      | x::l => fun m => match m with
        | nil   => binomial x 0 * binomial_p l nil
        | y::m  => binomial x y * binomial_p l m
      end
    end.

  Fact binomial_p_fix00 : binomial_p nil nil = 1.
  Proof. auto. Qed.

  Fact binomial_p_fix01 y m : binomial_p nil (y::m) = binomial 0 y * binomial_p nil m.
  Proof. auto. Qed.

  Fact binomial_p_fix10 x l : binomial_p (x::l) nil = binomial x 0 * binomial_p l nil.
  Proof. auto. Qed.

  Fact binomial_p_fix11 x l y m : binomial_p (x::l) (y::m) = binomial x y * binomial_p l m.
  Proof. auto. Qed.

  (* This is Luca's thm as described eg on Wikipedia

      if p is prime
      and x = x0 + x1*p + x2*p² ...
      and y = y0 + y1*p + y2*p² ...

      then the identity

         binomial x y = binomial x0 y0 * binomial x1 y1 * binomial x2 y2 * ...

      holds modulo p

   *)

  Theorem lucas_theorem (l m : list nat) :
         Forall (fun i => i < p) l               (* digits must be less than p*)
      -> Forall (fun i => i < p) m               (* digits must be less than p*)
      -> rem (binomial (base_p l) (base_p m)) p
       = rem (binomial_p l m) p.
  Proof using Hp.
    intros H; revert H m.
    induction 1 as [ | x l H1 H2 IH2 ];
    induction 1 as [ | y m H3 H4 IH4 ].
    + simpl; auto.
    + rewrite binomial_p_fix01; simpl base_p.
      rewrite <- rem_mult_rem, <- IH4, rem_mult_rem,
              (Nat.mul_comm p), Nat.add_comm, (Nat.mul_comm (binomial _ _)).
      apply lucas_lemma; auto; simpl; lia.
    + rewrite binomial_p_fix10; simpl base_p.
      rewrite <- rem_mult_rem, <- IH2, rem_mult_rem; auto.
      rewrite (Nat.mul_comm p), Nat.add_comm, (Nat.mul_comm (binomial _ _)).
      apply lucas_lemma; auto; simpl; lia.
    + rewrite binomial_p_fix11; simpl base_p.
      rewrite <- rem_mult_rem, <- IH2, rem_mult_rem; auto.
      rewrite !(Nat.mul_comm p), !(Nat.add_comm _ (_ * _)), (Nat.mul_comm (binomial _ _)).
      apply lucas_lemma; auto; simpl; lia.
  Qed.

End lucas_theorem.

(* Check lucas_theorem. *)


Require Import Utf8.
Require Import Reals.
Require Import Lebesgue.
Require Import FunctionalExtensionality.

Set Implicit Arguments.

(** Entropy is the source of all randomness in an evaluation. The particular
representation we choose is the Hilbert cube #(ℕ → [0, 1])#. In particular,
the properties we use on it are that an entropy source can be split into two
entropy sources through the operations [πL] and [πR], which are defined here
and axiomatized to be IID in [integration_πL_πR]. When it actually comes to
using an entropy [t], it is also convenient to split it into arbitrarily many
indepent parts, as (π 0 t), (π 1 t), ... *)

Definition entropy := nat → { r : R | (0 ≤ r ≤ 1)%R }.

(** The projection functions don't muck with any real numbers, just shuffle
indices around. [πL_n] and the like are the exact index shuffling needed for
[πL] and the like. *)
Definition πL (t : entropy) : entropy := λ n, t (n + n)%nat.
Definition πR (t : entropy) : entropy := λ n, t (S (n + n))%nat.
Notation πU t := (proj1_sig (πL t 0%nat)).

(** [join] is the inverse of projections, that is [t = join (πL t) (πR t)].
This is later proved as [join_πL_πR]. This is finally automated in the tactic
[π_join]. *)
Definition join (tL tR : entropy) : entropy :=
fun n =>
  if Nat.even n
  then tL (Nat.div2 n)
  else tR (Nat.div2 n).

Lemma πL_join tL tR : πL (join tL tR) = tL.
Proof.
extensionality n.
unfold πL, join.
assert (Nat.even (n + n) = true). {
  induction n; simpl; auto.
  replace (n + S n)%nat with (S (n + n)); auto.
}
rewrite H.
f_equal.
fold (Nat.double n).
rewrite Nat.double_twice.
apply Nat.div2_double.
Qed.

Lemma πR_join tL tR : πR (join tL tR) = tR.
Proof.
extensionality n.
unfold πR, join.
assert (Nat.even (S (n + n)) = false). {
  induction n; simpl; auto.
  replace (n + S n)%nat with (S (n + n)); auto.
}
rewrite H.
f_equal.
fold (Nat.double n).
rewrite Nat.double_twice.
apply Nat.div2_succ_double.
Qed.

Lemma join_πL_πR t : join (πL t) (πR t) = t.
Proof.
extensionality n.
unfold join, πL, πR.
destruct (Nat.Even_or_Odd n). {
  rewrite (proj2 (Nat.even_spec n)); auto.

  f_equal.
  fold (Nat.double (Nat.div2 n)).
  rewrite <- Div2.even_double; auto.
  apply Even.even_equiv; auto.
} {
  pose proof (proj2 (Nat.odd_spec n) H).
  rewrite <- Nat.negb_even in H0.
  apply Bool.negb_true_iff in H0.
  rewrite H0.

  f_equal.
  change (S (Nat.double (Nat.div2 n)) = n).
  rewrite <- Div2.odd_double; auto.
  apply Even.odd_equiv; auto.
}
Qed.

Fixpoint π (n : nat) (t : entropy) : entropy :=
match n with
| O => πL t
| S n' => π n' (πR t)
end.
Arguments π _ _ _ : simpl never.

Fixpoint π_leftover (n : nat) (t : entropy) : entropy :=
match n with
| O => t
| S n' => π_leftover n' (πR t)
end.
Arguments π_leftover _ _ _ : simpl never.

Lemma π_O_join (tl tr : entropy) : π 0 (join tl tr) = tl.
Proof.
apply πL_join.
Qed.

Lemma π_S_join (n : nat) (tl tr : entropy) : π (S n) (join tl tr) = π n tr.
Proof.
unfold π.
fold π.
rewrite πR_join.
auto.
Qed.

Ltac π_join := repeat rewrite ?π_O_join, ?π_S_join in *.

(** Axiomatize the stock measure on traces. *)

(** Assume that [entropy] has a probability measure on it *)
Axiom μentropy : Meas entropy.
Axiom μentropy_is_a_probability_measure : μentropy full_event = 1.
Axiom μentropy_is_σ_finite : σ_finite μentropy.

(** This axiom states that entropy can be split into 2 IID entropies. *)
Axiom integration_πL_πR : ∀ (g : entropy → entropy → R⁺),
∫ (fun t => g (πL t) (πR t)) μentropy =
∫ (fun tL => ∫ (fun tR => g tL tR) μentropy) μentropy.

Axiom integration_πU_lebesgue : ∀ (f : R → R⁺),
∫ (λ (t : entropy), f (proj1_sig (t 0%nat))) μentropy =
∫ (λ r, f r * (if Rinterval_dec 0 1 r then 1 else 0)) lebesgue_measure.

(** Use the fact that [μentropy] is a probability measure to lift constant
functions out of integrals. *)
Lemma integration_const_entropy :
∀ (v : R⁺) (f : entropy → R⁺),
(∀ x, f x = v) → ∫ f μentropy = v.
Proof.
intros.
replace f with (fun x => f x * 1) by (extensionality x; ring).
setoid_rewrite H.
rewrite integration_of_const with (r := v).
1: {
  rewrite μentropy_is_a_probability_measure.
  ring.
}
intro; ring.
Qed.

(** A particular entropy value that is an infinite sequence of 0's. *)
Definition entropy0 : entropy.
Proof.
intro n.
refine (exist _ 0%R _).
split.
+ right; ring.
+ left; prove_sup.
Defined.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal49.

Set Printing Depth 1000.
Definition lfind_eval  y x:=
mem x y.

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil))) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ Zero) Nil))))) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* ** Matric computation *)

Require Import Arith ZArith.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd prime binomial sums.

Set Implicit Arguments.

Section rings.

  Variable (R : Type) (Rzero Rone : R) (Rplus Rmult Rminus : R -> R -> R) (Ropp : R -> R)
           (R_is_ring : ring_theory Rzero Rone Rplus Rmult Rminus Ropp eq).

  Infix "⊕" := Rplus (at level 50, left associativity).
  Infix "⊗" := Rmult (at level 40, left associativity).

  Notation z := Rzero.
  Notation o := Rone.
  Notation "∸" := Ropp.

  (* ⊕  ⊗  ∸ *)

  (* We use the magical parameterized ring tactic *)

  Add Ring Rring : R_is_ring.

  (* ⊕  ⊗  ∸ *)

  (*   ( a b )   <-> (a,b,c,d)
       ( c d )                    *)

  Definition M22 := (R * R * R * R)%type.
  Definition ID_22 : M22 := (o,z,z,o).
  Definition ZE_22 : M22 := (z,z,z,z).

  Definition PL22 : M22 -> M22 -> M22.
  Proof using Rplus.
    intros (((a,b),c),d) (((a',b'),c'),d').
    exact (a⊕a',b⊕b',
           c⊕c',d⊕d').
  Defined.

  Local Infix "⊞" := PL22 (at level 50, left associativity).

  Definition MI22 : M22 -> M22.
  Proof using Ropp.
    intros (((a,b),c),d).
    exact (∸a,∸b,
           ∸c,∸d).
  Defined.

  Local Notation "⊟" := MI22.

  Fact M22_equal (a b c d a' b' c' d' : R) : a = a' -> b = b' -> c = c' -> d = d' -> (a,b,c,d) = (a',b',c',d').
  Proof. intros; subst; trivial. Qed.

  Fact M22plus_zero : forall m, ZE_22 ⊞ m = m.
  Proof using R_is_ring.
    intros (((a,b),c),d); apply M22_equal; ring.
  Qed.

  Fact M22add_comm  : forall x y, x ⊞ y = y ⊞ x.
  Proof using R_is_ring.
    intros (((a,b),c),d) (((a',b'),c'),d'); apply M22_equal; ring.
  Qed.

  Fact M22add_assoc  : forall x y u, x ⊞ (y ⊞ u) = x ⊞ y ⊞ u.
  Proof using R_is_ring.
    intros (((a,b),c),d) (((a',b'),c'),d') (((a'',b''),c''),d''); simpl; apply M22_equal; ring.
  Qed.

  Fact M22minus : forall x, x ⊞ ⊟ x = ZE_22.
  Proof using R_is_ring.
    intros (((a,b),c),d); apply M22_equal; ring.
  Qed.

  Fact M22plus_cancel : forall x a b, x ⊞ a = x ⊞ b -> a = b.
  Proof using R_is_ring.
    intros x a b H.
    rewrite <- (M22plus_zero a), <- (M22minus x), (M22add_comm x),
            <- M22add_assoc, H, M22add_assoc,
            (M22add_comm _ x), M22minus, M22plus_zero.
    trivial.
  Qed.

  Theorem M22plus_monoid : monoid_theory PL22 ZE_22.
  Proof using R_is_ring.
    exists.
    + apply M22plus_zero.
    + intro; rewrite M22add_comm; apply M22plus_zero.
    + intros; apply M22add_assoc.
  Qed.

  Definition MU22 : M22 -> M22 -> M22.
  Proof using Rplus Rmult.
    intros (((a,b),c),d) (((a',b'),c'),d').
    exact (a⊗a' ⊕ b⊗c' , a⊗b' ⊕ b⊗d',
           c⊗a' ⊕ d⊗c' , c⊗b' ⊕ d⊗d' ).
  Defined.

  Local Infix "⊠" := MU22 (at level 40, left associativity).

  Tactic Notation "myauto" integer(n) := do n intros (((?&?)&?)&?); apply M22_equal; ring.

  Fact M22mult_one_l : forall x, ID_22 ⊠ x = x.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22mult_one_r : forall x, x ⊠ ID_22 = x.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22mul_assoc : forall x y u, x ⊠ (y ⊠ u) = x ⊠ y ⊠ u.
  Proof using R_is_ring. myauto 3. Qed.

  Fact M22_mult_distr_l : forall x y u, x ⊠ (y⊞u) = x⊠y ⊞ x⊠u.
  Proof using R_is_ring. myauto 3. Qed.

  Fact M22_mult_distr_r : forall x y u, (y⊞u) ⊠ x = y⊠x ⊞ u⊠x.
  Proof using R_is_ring. myauto 3. Qed.

  Theorem M22mult_monoid : monoid_theory MU22 ID_22.
  Proof using R_is_ring.
    exists.
    + apply M22mult_one_l.
    + apply M22mult_one_r.
    + apply M22mul_assoc.
  Qed.

  Fact M22_opp_mult_l : forall x y, (⊟ x) ⊠ y = ⊟ (x ⊠ y).
  Proof using R_is_ring. myauto 2. Qed.

  Fact M22_opp_mult_r : forall x y, x ⊠ (⊟y) = ⊟ (x ⊠ y).
  Proof using R_is_ring. myauto 2. Qed.

  Definition M22scal (k : R) : M22 -> M22.
  Proof using Rmult.
    intros (((u,v),w),z).
    exact (k⊗u,k⊗v,k⊗w,k⊗z).
  Defined.

  Fact M22scal_mult k1 k2 : forall x, M22scal k1 (M22scal k2 x) = M22scal (k1⊗k2) x.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22scal_PL22 k : forall x y, M22scal k (x ⊞ y) = M22scal k x ⊞ M22scal k y.
  Proof using R_is_ring. myauto 2. Qed.

  Fact M22scal_MI22 : forall x, M22scal (∸o) x = ⊟x.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22scal_zero : forall x, M22scal z x = ZE_22.
  Proof using R_is_ring. myauto 1. Qed.

  Fact M22scal_MU22_l k : forall x y, M22scal k (x ⊠ y) = M22scal k x ⊠ y.
  Proof using R_is_ring. myauto 2. Qed.

  Fact M22scal_MU22_r k : forall x y, M22scal k (x ⊠ y) = x ⊠ M22scal k y.
  Proof using R_is_ring. myauto 2. Qed.

  Fact mscal_M22scal n x : mscal PL22 ZE_22 n x = M22scal (mscal Rplus Rzero n Rone) x.
  Proof using R_is_ring.
    induction n as [ | n IHn ].
    + do 2 rewrite mscal_0; revert x; myauto 1.
    + do 2 rewrite mscal_S.
      rewrite IHn; clear IHn.
      revert x; myauto 1.
  Qed.

  (* M22 is NOT a ring because mult is not commutative *)

  (* ⊕  ⊗  ∸    ⊞ ⊠ ⊟ *)

  Definition Det22 : M22 -> R.
  Proof using Rplus Rmult Ropp.
    intros (((a,b),c),d).
    exact (a⊗d ⊕ ∸(b⊗c)).
  Defined.

  Fact Det22_scal k : forall x, Det22 (M22scal k x) = (k ⊗ k) ⊗ Det22 x.
  Proof using R_is_ring. intros (((?,?),?),?); simpl; ring. Qed.

  Fact Det22_mult : forall x y, Det22 (x⊠y) = Det22 x ⊗ Det22 y.
  Proof using R_is_ring. intros (((?,?),?),?) (((?,?),?),?); simpl; ring. Qed.

  Notation expo22 := (mscal MU22 ID_22).
  Notation expoR := (mscal Rmult o).

  Fact expo22_scal k n U : expo22 n (M22scal k U) = M22scal (expoR n k) (expo22 n U).
  Proof using R_is_ring.
    induction n as [ | n IHn ].
    + do 3 rewrite mscal_0; apply M22_equal; ring.
    + do 3 rewrite mscal_S.
      rewrite IHn.
      rewrite <- M22scal_MU22_l, <- M22scal_MU22_r.
      rewrite M22scal_mult; auto.
  Qed.

  Fact Det22_expo n x : Det22 (expo22 n x) = expoR n (Det22 x).
  Proof using R_is_ring.
    induction n as [ | n IHn ].
    + do 2 rewrite mscal_0; simpl; ring.
    + do 2 rewrite mscal_S.
      rewrite Det22_mult, IHn; ring.
  Qed.

  Fact Diag22_expo n x y : expo22 n (x,z,z,y) = (expoR n x,Rzero,Rzero,expoR n y).
  Proof using R_is_ring.
    induction n as [ | n IHn ]; try (simpl; auto; fail).
    do 3 rewrite mscal_S; rewrite IHn.
    apply M22_equal; ring.
  Qed.

  Fact MU22_Diag22 a b c d x y : (a,b,c,d) ⊠ (x,z,z,y) = (a⊗x,b⊗y,c⊗x,d⊗y).
  Proof using R_is_ring. apply M22_equal; ring. Qed.

  (* We also the to lift the Z -> Zp morphism to M22 matrices *)

  Fact M22_proj12 a1 b1 c1 d1 a2 b2 c2 d2 : (a1,b1,c1,d1) = (a2,b2,c2,d2) :> M22 -> c1 = c2.
  Proof. inversion 1; auto. Qed.

End rings.

Section ring_morphism.

  Variable (X : Type) (zX oX : X) (pX mX : X -> X -> X) (oppX : X -> X)
           (Y : Type) (zY oY : Y) (pY mY : Y -> Y -> Y) (oppY : Y -> Y).

  Variable phi : X -> Y.

  Local Notation "〚 x 〛" := (phi x).

  Record ring_morphism : Prop := mk_ring_morph {
    morph_z : 〚 zX 〛= zY;
    morph_o : 〚 oX 〛= oY;
    morph_plus : forall x y, 〚 pX x y 〛= pY 〚 x 〛〚 y 〛;
    morph_mult : forall x y, 〚 mX x y 〛= mY 〚 x 〛〚 y 〛;
    morph_opp : forall x, 〚 oppX x 〛= oppY 〚 x 〛;
  }.

  Hypothesis Hphi : ring_morphism.

  Definition morph22 : M22 X -> M22 Y.
  Proof using phi.
    intros (((a,b),c),d).
    exact (〚 a 〛, 〚 b 〛,
           〚 c 〛, 〚 d 〛).
  Defined.

  Tactic Notation "myauto" integer(n) := do n intros (((?&?)&?)&?); apply M22_equal; ring.

  Fact PL22_morph : forall x y, morph22 (PL22 pX x y) = PL22 pY (morph22 x) (morph22 y).
  Proof using Hphi.
    destruct Hphi.
    do 2 intros (((?&?)&?)&?); apply M22_equal; auto.
  Qed.

  Fact MU22_morph : forall x y, morph22 (MU22 pX mX x y) = MU22 pY mY (morph22 x) (morph22 y).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    do 2 intros (((?&?)&?)&?); apply M22_equal;
      repeat rewrite G3; repeat rewrite G4; auto.
  Qed.

  Fact MI22_morph : forall x, morph22 (MI22 oppX x) = MI22 oppY (morph22 x).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    do 1 intros (((?&?)&?)&?); apply M22_equal;
      repeat rewrite G3; repeat rewrite G4; auto.
  Qed.

  Fact M22scal_morph : forall k x, morph22 (M22scal mX k x) = M22scal mY 〚 k 〛 (morph22 x).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    intros k (((?&?)&?)&?); apply M22_equal; auto.
  Qed.

  Fact Det22_morph : forall x, 〚 Det22 pX mX oppX x 〛= Det22 pY mY oppY (morph22 x).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    intros (((?&?)&?)&?); simpl.
    rewrite G3, G6, G4, G4; auto.
  Qed.

  Fact expo22_morph n x : morph22 (mscal (MU22 pX mX) (ID_22 zX oX) n x)
                        = mscal (MU22 pY mY) (ID_22 zY oY) n (morph22 x).
  Proof using Hphi.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    induction n as [ | n IHn ].
    + do 2 rewrite mscal_0; apply M22_equal; auto.
    + do 2 rewrite mscal_S.
      rewrite MU22_morph, IHn; auto.
  Qed.

End ring_morphism.