Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** Fixed precision machine words *)

Require Import Coq.Arith.Arith
        Coq.Arith.Div2
        Coq.NArith.NArith
        Coq.Bool.Bool
        Coq.ZArith.ZArith.
Require Import Bedrock.Nomega.

Set Implicit Arguments.

(** * Basic definitions and conversion to and from [nat] *)

Inductive word : nat -> Set :=
| WO : word O
| WS : bool -> forall n, word n -> word (S n).

Fixpoint wordToNat sz (w : word sz) : nat :=
  match w with
    | WO => O
    | WS false w' => (wordToNat w') * 2
    | WS true w' => S (wordToNat w' * 2)
  end.

Fixpoint wordToNat' sz (w : word sz) : nat :=
  match w with
    | WO => O
    | WS false w' => 2 * wordToNat w'
    | WS true w' => S (2 * wordToNat w')
  end.

Theorem wordToNat_wordToNat' : forall sz (w : word sz),
  wordToNat w = wordToNat' w.
Proof.
  induction w. auto. simpl. rewrite mult_comm. reflexivity.
Qed.

Fixpoint mod2 (n : nat) : bool :=
  match n with
    | 0 => false
    | 1 => true
    | S (S n') => mod2 n'
  end.

Fixpoint natToWord (sz n : nat) : word sz :=
  match sz with
    | O => WO
    | S sz' => WS (mod2 n) (natToWord sz' (div2 n))
  end.

Fixpoint wordToN sz (w : word sz) : N :=
  match w with
    | WO => 0
    | WS false w' => 2 * wordToN w'
    | WS true w' => N.succ (2 * wordToN w')
  end%N.

Definition Nmod2 (n : N) : bool :=
  match n with
    | N0 => false
    | Npos (xO _) => false
    | _ => true
  end.

Definition wzero sz := natToWord sz 0.

Fixpoint wzero' (sz : nat) : word sz :=
  match sz with
    | O => WO
    | S sz' => WS false (wzero' sz')
  end.

Fixpoint posToWord (sz : nat) (p : positive) {struct p} : word sz :=
  match sz with
    | O => WO
    | S sz' =>
      match p with
        | xI p' => WS true (posToWord sz' p')
        | xO p' => WS false (posToWord sz' p')
        | xH => WS true (wzero' sz')
      end
  end.

Definition NToWord (sz : nat) (n : N) : word sz :=
  match n with
    | N0 => wzero' sz
    | Npos p => posToWord sz p
  end.

Fixpoint Npow2 (n : nat) : N :=
  match n with
    | O => 1
    | S n' => 2 * Npow2 n'
  end%N.

Ltac rethink :=
  match goal with
    | [ H : ?f ?n = _ |- ?f ?m = _ ] => replace m with n; simpl; auto
  end.

Theorem mod2_S_double : forall n, mod2 (S (2 * n)) = true.
  induction n; simpl; intuition; rethink.
Qed.

Theorem mod2_double : forall n, mod2 (2 * n) = false.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; rethink.
Qed.

Local Hint Resolve mod2_S_double mod2_double.

Theorem div2_double : forall n, div2 (2 * n) = n.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; f_equal; rethink.
Qed.

Theorem div2_S_double : forall n, div2 (S (2 * n)) = n.
  induction n; simpl; intuition; f_equal; rethink.
Qed.

Hint Rewrite div2_double div2_S_double : div2.

Theorem natToWord_wordToNat : forall sz w, natToWord sz (wordToNat w) = w.
  induction w; rewrite wordToNat_wordToNat'; intuition; f_equal; unfold natToWord, wordToNat'; fold natToWord; fold wordToNat';
    destruct b; f_equal; autorewrite with div2; intuition.
Qed.

Fixpoint pow2 (n : nat) : nat :=
  match n with
    | O => 1
    | S n' => 2 * pow2 n'
  end.

Theorem roundTrip_0 : forall sz, wordToNat (natToWord sz 0) = 0.
  induction sz; simpl; intuition.
Qed.

Hint Rewrite roundTrip_0 : wordToNat.

Local Hint Extern 1 (@eq nat _ _) => omega.

Theorem untimes2 : forall n, n + (n + 0) = 2 * n.
  auto.
Qed.

Section strong.
  Variable P : nat -> Prop.

  Hypothesis PH : forall n, (forall m, m < n -> P m) -> P n.

  Lemma strong' : forall n m, m <= n -> P m.
    induction n; simpl; intuition; apply PH; intuition.
    exfalso; omega.
  Qed.

  Theorem strong : forall n, P n.
    intros; eapply strong'; eauto.
  Qed.
End strong.

Theorem div2_odd : forall n,
  mod2 n = true
  -> n = S (2 * div2 n).
  induction n using strong; simpl; intuition.

  destruct n; simpl in *; intuition.
    try discriminate.
  destruct n; simpl in *; intuition.
  do 2 f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem div2_even : forall n,
  mod2 n = false
  -> n = 2 * div2 n.
  induction n using strong; simpl; intuition.

  destruct n; simpl in *; intuition.
  destruct n; simpl in *; intuition.
    try discriminate.
  f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Lemma wordToNat_natToWord' : forall sz w, exists k, wordToNat (natToWord sz w) + k * pow2 sz = w.
  induction sz; simpl; intuition; repeat rewrite untimes2.

  exists w; intuition.

  case_eq (mod2 w); intro Hmw.

  specialize (IHsz (div2 w)); firstorder.
  rewrite wordToNat_wordToNat' in *.
  exists x; intuition.
  rewrite mult_assoc.
  rewrite (mult_comm x 2).
  rewrite mult_comm. simpl mult at 1.
  rewrite (plus_Sn_m (2 * wordToNat' (natToWord sz (div2 w)))).
  rewrite <- mult_assoc.
  rewrite <- mult_plus_distr_l.
  rewrite H; clear H.
  symmetry; apply div2_odd; auto.

  specialize (IHsz (div2 w)); firstorder.
  exists x; intuition.
  rewrite mult_assoc.
  rewrite (mult_comm x 2).
  rewrite <- mult_assoc.
  rewrite mult_comm.
  rewrite <- mult_plus_distr_l.
  rewrite H; clear H.
  symmetry; apply div2_even; auto.
Qed.

Theorem wordToNat_natToWord : forall sz w, exists k, wordToNat (natToWord sz w) = w - k * pow2 sz /\ k * pow2 sz <= w.
  intros; destruct (wordToNat_natToWord' sz w) as [k]; exists k; intuition.
Qed.

Definition wone sz := natToWord sz 1.

Fixpoint wones (sz : nat) : word sz :=
  match sz with
    | O => WO
    | S sz' => WS true (wones sz')
  end.

(** Comparisons *)

Fixpoint wmsb sz (w : word sz) (a : bool) : bool :=
  match w with
    | WO => a
    | WS b x => wmsb x b
  end.

Definition whd sz (w : word (S sz)) : bool :=
  match w in word sz' return match sz' with
                               | O => unit
                               | S _ => bool
                             end with
    | WO => tt
    | WS b _ => b
  end.

Definition wtl sz (w : word (S sz)) : word sz :=
  match w in word sz' return match sz' with
                               | O => unit
                               | S sz'' => word sz''
                             end with
    | WO => tt
    | WS _ w' => w'
  end.

Theorem WS_neq : forall b1 b2 sz (w1 w2 : word sz),
  (b1 <> b2 \/ w1 <> w2)
  -> WS b1 w1 <> WS b2 w2.
  intuition.
  apply (f_equal (@whd _)) in H0; tauto.
  apply (f_equal (@wtl _)) in H0; tauto.
Qed.

(** Shattering **)

Lemma shatter_word : forall n (a : word n),
  match n return word n -> Prop with
    | O => fun a => a = WO
    | S _ => fun a => a = WS (whd a) (wtl a)
  end a.
  destruct a; eauto.
Qed.

Lemma shatter_word_S : forall n (a : word (S n)),
  exists b, exists c, a = WS b c.
Proof.
  intros; repeat eexists; apply (shatter_word a).
Qed.
Lemma shatter_word_0 : forall a : word 0,
  a = WO.
Proof.
  intros; apply (shatter_word a).
Qed.

Hint Resolve shatter_word_0.

Require Import Coq.Logic.Eqdep_dec.

Definition weq : forall sz (x y : word sz), {x = y} + {x <> y}.
  refine (fix weq sz (x : word sz) : forall y : word sz, {x = y} + {x <> y} :=
    match x in word sz return forall y : word sz, {x = y} + {x <> y} with
      | WO => fun _ => left _ _
      | WS b x' => fun y => if bool_dec b (whd y)
        then if weq _ x' (wtl y) then left _ _ else right _ _
        else right _ _
    end); clear weq.

  abstract (symmetry; apply shatter_word_0).

  abstract (subst; symmetry; apply (shatter_word y)).

  abstract (rewrite (shatter_word y); simpl; intro; injection H; intros;
    apply n0; apply inj_pair2_eq_dec in H0; [ auto | apply eq_nat_dec ]).

  abstract (rewrite (shatter_word y); simpl; intro; apply n0; injection H; auto).
Defined.

Fixpoint weqb sz (x : word sz) : word sz -> bool :=
  match x in word sz return word sz -> bool with
    | WO => fun _ => true
    | WS b x' => fun y =>
      if eqb b (whd y)
      then if @weqb _ x' (wtl y) then true else false
      else false
  end.

Theorem weqb_true_iff : forall sz x y,
  @weqb sz x y = true <-> x = y.
Proof.
  induction x; simpl; intros.
  { split; auto. }
  { rewrite (shatter_word y) in *. simpl in *.
    case_eq (eqb b (whd y)); intros.
    case_eq (weqb x (wtl y)); intros.
    split; auto; intros. rewrite eqb_true_iff in H. f_equal; eauto. eapply IHx; eauto.
    split; intros; try congruence. inversion H1; clear H1; subst.
    eapply inj_pair2_eq_dec in H4. eapply IHx in H4. congruence.
    eapply Peano_dec.eq_nat_dec.
    split; intros; try congruence.
    inversion H0. apply eqb_false_iff in H. congruence. }
Qed.

(** * Combining and splitting *)

Fixpoint combine (sz1 : nat) (w : word sz1) : forall sz2, word sz2 -> word (sz1 + sz2) :=
  match w in word sz1 return forall sz2, word sz2 -> word (sz1 + sz2) with
    | WO => fun _ w' => w'
    | WS b w' => fun _ w'' => WS b (combine w' w'')
  end.

Fixpoint split1 (sz1 sz2 : nat) : word (sz1 + sz2) -> word sz1 :=
  match sz1 with
    | O => fun _ => WO
    | S sz1' => fun w => WS (whd w) (split1 sz1' sz2 (wtl w))
  end.

Fixpoint split2 (sz1 sz2 : nat) : word (sz1 + sz2) -> word sz2 :=
  match sz1 with
    | O => fun w => w
    | S sz1' => fun w => split2 sz1' sz2 (wtl w)
  end.

Ltac shatterer := simpl; intuition;
  match goal with
    | [ w : _ |- _ ] => rewrite (shatter_word w); simpl
  end; f_equal; auto.

Theorem combine_split : forall sz1 sz2 (w : word (sz1 + sz2)),
  combine (split1 sz1 sz2 w) (split2 sz1 sz2 w) = w.
  induction sz1; shatterer.
Qed.

Theorem split1_combine : forall sz1 sz2 (w : word sz1) (z : word sz2),
  split1 sz1 sz2 (combine w z) = w.
  induction sz1; shatterer.
Qed.

Theorem split2_combine : forall sz1 sz2 (w : word sz1) (z : word sz2),
  split2 sz1 sz2 (combine w z) = z.
  induction sz1; shatterer.
Qed.

Require Import Coq.Logic.Eqdep_dec.

Theorem combine_assoc : forall n1 (w1 : word n1) n2 n3 (w2 : word n2) (w3 : word n3) Heq,
  combine (combine w1 w2) w3
  = match Heq in _ = N return word N with
      | refl_equal => combine w1 (combine w2 w3)
    end.
  induction w1; simpl; intuition.

  rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)); reflexivity.

  rewrite (IHw1 _ _ _ _ (plus_assoc _ _ _)); clear IHw1.
  repeat match goal with
           | [ |- context[match ?pf with refl_equal => _ end] ] => generalize pf
         end.
  generalize dependent (combine w1 (combine w2 w3)).
  rewrite plus_assoc; intros.
  rewrite (UIP_dec eq_nat_dec e (refl_equal _)).
  rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)).
  reflexivity.
Qed.

Theorem split2_iter : forall n1 n2 n3 Heq w,
  split2 n2 n3 (split2 n1 (n2 + n3) w)
  = split2 (n1 + n2) n3 (match Heq in _ = N return word N with
                           | refl_equal => w
                         end).
  induction n1; simpl; intuition.

  rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)); reflexivity.

  rewrite (IHn1 _ _ (plus_assoc _ _ _)).
  f_equal.
  repeat match goal with
           | [ |- context[match ?pf with refl_equal => _ end] ] => generalize pf
         end.
  generalize dependent w.
  simpl.
  fold plus.
  generalize (n1 + (n2 + n3)); clear.
  intros.
  generalize Heq e.
  subst.
  intros.
  rewrite (UIP_dec eq_nat_dec e (refl_equal _)).
  rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)).
  reflexivity.
Qed.

Theorem combine_end : forall n1 n2 n3 Heq w,
  combine (split1 n2 n3 (split2 n1 (n2 + n3) w))
  (split2 (n1 + n2) n3 (match Heq in _ = N return word N with
                          | refl_equal => w
                        end))
  = split2 n1 (n2 + n3) w.
  induction n1; simpl; intros.

  rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)).
  apply combine_split.

  rewrite (shatter_word w) in *.
  simpl.
  eapply trans_eq; [ | apply IHn1 with (Heq := plus_assoc _ _ _) ]; clear IHn1.
  repeat f_equal.
  repeat match goal with
           | [ |- context[match ?pf with refl_equal => _ end] ] => generalize pf
         end.
  simpl.
  generalize dependent w.
  rewrite plus_assoc.
  intros.
  rewrite (UIP_dec eq_nat_dec e (refl_equal _)).
  rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)).
  reflexivity.
Qed.

(** * Extension operators *)

Definition sext (sz : nat) (w : word sz) (sz' : nat) : word (sz + sz') :=
  if wmsb w false then
    combine w (wones sz')
  else
    combine w (wzero sz').

Definition zext (sz : nat) (w : word sz) (sz' : nat) : word (sz + sz') :=
  combine w (wzero sz').

(** * Arithmetic *)

Definition wneg sz (x : word sz) : word sz :=
  NToWord sz (Npow2 sz - wordToN x).

Definition wordBin (f : N -> N -> N) sz (x y : word sz) : word sz :=
  NToWord sz (f (wordToN x) (wordToN y)).

Definition wplus := wordBin Nplus.
Definition wmult := wordBin Nmult.
Definition wmult' sz (x y : word sz) : word sz :=
  split2 sz sz (NToWord (sz + sz) (Nmult (wordToN x) (wordToN y))).
Definition wminus sz (x y : word sz) : word sz := wplus x (wneg y).

Definition wnegN sz (x : word sz) : word sz :=
  natToWord sz (pow2 sz - wordToNat x).

Definition wordBinN (f : nat -> nat -> nat) sz (x y : word sz) : word sz :=
  natToWord sz (f (wordToNat x) (wordToNat y)).

Definition wplusN := wordBinN plus.

Definition wmultN := wordBinN mult.
Definition wmultN' sz (x y : word sz) : word sz :=
  split2 sz sz (natToWord (sz + sz) (mult (wordToNat x) (wordToNat y))).

Definition wminusN sz (x y : word sz) : word sz := wplusN x (wnegN y).

(** * Notations *)

Delimit Scope word_scope with word.
Bind Scope word_scope with word.

Notation "w ~ 1" := (WS true w)
 (at level 7, left associativity, format "w '~' '1'") : word_scope.
Notation "w ~ 0" := (WS false w)
 (at level 7, left associativity, format "w '~' '0'") : word_scope.

Notation "^~" := wneg.
Notation "l ^+ r" := (@wplus _ l%word r%word) (at level 50, left associativity).
Notation "l ^* r" := (@wmult _ l%word r%word) (at level 40, left associativity).
Notation "l ^- r" := (@wminus _ l%word r%word) (at level 50, left associativity).

Theorem wordToN_nat : forall sz (w : word sz), wordToN w = N_of_nat (wordToNat w).
  induction w; intuition.
  destruct b; unfold wordToN, wordToNat; fold wordToN; fold wordToNat.

  rewrite N_of_S.
  rewrite N_of_mult.
  rewrite <- IHw.
  rewrite Nmult_comm.
  reflexivity.

  rewrite N_of_mult.
  rewrite <- IHw.
  rewrite Nmult_comm.
  reflexivity.
Qed.

Theorem mod2_S : forall n k,
  2 * k = S n
  -> mod2 n = true.
  induction n using strong; intros.
  destruct n; simpl in *.
  exfalso; omega.
  destruct n; simpl in *; auto.
  destruct k; simpl in *.
  discriminate.
  apply H with k; auto.
Qed.

Theorem wzero'_def : forall sz, wzero' sz = wzero sz.
  unfold wzero; induction sz; simpl; intuition.
  congruence.
Qed.

Theorem posToWord_nat : forall p sz, posToWord sz p = natToWord sz (nat_of_P p).
  induction p; destruct sz; simpl; intuition; f_equal; try rewrite wzero'_def in *.

  rewrite ZL6.
  destruct (ZL4 p) as [? Heq]; rewrite Heq; simpl.
  replace (x + S x) with (S (2 * x)) by omega.
  symmetry; apply mod2_S_double.

  rewrite IHp.
  rewrite ZL6.
  destruct (nat_of_P p); simpl; intuition.
  replace (n + S n) with (S (2 * n)) by omega.
  rewrite div2_S_double; auto.

  unfold nat_of_P; simpl.
  rewrite ZL6.
  replace (nat_of_P p + nat_of_P p) with (2 * nat_of_P p) by omega.
  symmetry; apply mod2_double.

  rewrite IHp.
  unfold nat_of_P; simpl.
  rewrite ZL6.
  replace (nat_of_P p + nat_of_P p) with (2 * nat_of_P p) by omega.
  rewrite div2_double.
  auto.
  auto.
Qed.

Theorem NToWord_nat : forall sz n, NToWord sz n = natToWord sz (nat_of_N n).
  destruct n; simpl; intuition; try rewrite wzero'_def in *.
  auto.
  apply posToWord_nat.
Qed.

Theorem wplus_alt : forall sz (x y : word sz), wplus x y = wplusN x y.
  unfold wplusN, wplus, wordBinN, wordBin; intros.

  repeat rewrite wordToN_nat; repeat rewrite NToWord_nat.
  rewrite nat_of_Nplus.
  repeat rewrite nat_of_N_of_nat.
  reflexivity.
Qed.

Theorem wmult_alt : forall sz (x y : word sz), wmult x y = wmultN x y.
  unfold wmultN, wmult, wordBinN, wordBin; intros.

  repeat rewrite wordToN_nat; repeat rewrite NToWord_nat.
  rewrite nat_of_Nmult.
  repeat rewrite nat_of_N_of_nat.
  reflexivity.
Qed.

Theorem Npow2_nat : forall n, nat_of_N (Npow2 n) = pow2 n.
  induction n; simpl; intuition.
  rewrite <- IHn; clear IHn.
  case_eq (Npow2 n); intuition;
    rewrite untimes2; replace (Npos p~0) with (N.double (Npos p)) by reflexivity;
    apply nat_of_Ndouble.
Qed.

Theorem wneg_alt : forall sz (x : word sz), wneg x = wnegN x.
  unfold wnegN, wneg; intros.
  repeat rewrite wordToN_nat; repeat rewrite NToWord_nat.
  rewrite nat_of_Nminus.
  do 2 f_equal.
  apply Npow2_nat.
  apply nat_of_N_of_nat.
Qed.

Theorem wminus_Alt : forall sz (x y : word sz), wminus x y = wminusN x y.
  intros; unfold wminusN, wminus; rewrite wneg_alt; apply wplus_alt.
Qed.

Theorem wplus_unit : forall sz (x : word sz), natToWord sz 0 ^+ x = x.
  intros; rewrite wplus_alt; unfold wplusN, wordBinN; intros.
  rewrite roundTrip_0; apply natToWord_wordToNat.
Qed.

Theorem wplus_comm : forall sz (x y : word sz), x ^+ y = y ^+ x.
  intros; repeat rewrite wplus_alt; unfold wplusN, wordBinN; f_equal; auto.
Qed.

Theorem drop_mod2 : forall n k,
  2 * k <= n
  -> mod2 (n - 2 * k) = mod2 n.
  induction n using strong; intros.

  do 2 (destruct n; simpl in *; repeat rewrite untimes2 in *; intuition).

  destruct k; simpl in *; intuition.

  destruct k; simpl; intuition.
  rewrite <- plus_n_Sm.
  repeat rewrite untimes2 in *.
  simpl; auto.
  apply H; omega.
Qed.

Theorem div2_minus_2 : forall n k,
  2 * k <= n
  -> div2 (n - 2 * k) = div2 n - k.
  induction n using strong; intros.

  do 2 (destruct n; simpl in *; intuition; repeat rewrite untimes2 in *).
  destruct k; simpl in *; intuition.

  destruct k; simpl in *; intuition.
  rewrite <- plus_n_Sm.
  apply H; omega.
Qed.

Theorem div2_bound : forall k n,
  2 * k <= n
  -> k <= div2 n.
  intros; case_eq (mod2 n); intro Heq.

  rewrite (div2_odd _ Heq) in H.
  omega.

  rewrite (div2_even _ Heq) in H.
  omega.
Qed.

Theorem drop_sub : forall sz n k,
  k * pow2 sz <= n
  -> natToWord sz (n - k * pow2 sz) = natToWord sz n.
  induction sz; simpl; intuition; repeat rewrite untimes2 in *; f_equal.

  rewrite mult_assoc.
  rewrite (mult_comm k).
  rewrite <- mult_assoc.
  apply drop_mod2.
  rewrite mult_assoc.
  rewrite (mult_comm 2).
  rewrite <- mult_assoc.
  auto.

  rewrite <- (IHsz (div2 n) k).
  rewrite mult_assoc.
  rewrite (mult_comm k).
  rewrite <- mult_assoc.
  rewrite div2_minus_2.
  reflexivity.
  rewrite mult_assoc.
  rewrite (mult_comm 2).
  rewrite <- mult_assoc.
  auto.

  apply div2_bound.
  rewrite mult_assoc.
  rewrite (mult_comm 2).
  rewrite <- mult_assoc.
  auto.
Qed.

Local Hint Extern 1 (_ <= _) => omega.

Theorem wplus_assoc : forall sz (x y z : word sz), x ^+ (y ^+ z) = x ^+ y ^+ z.
  intros; repeat rewrite wplus_alt; unfold wplusN, wordBinN; intros.

  repeat match goal with
           | [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
             let Heq := fresh "Heq" in
               destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq
         end.

  replace (wordToNat x + wordToNat y - x1 * pow2 sz + wordToNat z)
    with (wordToNat x + wordToNat y + wordToNat z - x1 * pow2 sz) by auto.
  replace (wordToNat x + (wordToNat y + wordToNat z - x0 * pow2 sz))
    with (wordToNat x + wordToNat y + wordToNat z - x0 * pow2 sz) by auto.
  repeat rewrite drop_sub; auto.
Qed.

Theorem roundTrip_1 : forall sz, wordToNat (natToWord (S sz) 1) = 1.
  induction sz; simpl in *; intuition.
Qed.

Theorem mod2_WS : forall sz (x : word sz) b, mod2 (wordToNat (WS b x)) = b.
  intros. rewrite wordToNat_wordToNat'.
  destruct b; simpl.

  rewrite untimes2.
  case_eq (2 * wordToNat x); intuition.
  eapply mod2_S; eauto.
  rewrite <- (mod2_double (wordToNat x)); f_equal; omega.
Qed.

Theorem div2_WS : forall sz (x : word sz) b, div2 (wordToNat (WS b x)) = wordToNat x.
  destruct b; rewrite wordToNat_wordToNat'; unfold wordToNat'; fold wordToNat'.
  apply div2_S_double.
  apply div2_double.
Qed.

Theorem wmult_unit : forall sz (x : word sz), natToWord sz 1 ^* x = x.
  intros; rewrite wmult_alt; unfold wmultN, wordBinN; intros.
  destruct sz; simpl.
  rewrite (shatter_word x); reflexivity.
  rewrite roundTrip_0; simpl.
  rewrite plus_0_r.
  rewrite (shatter_word x).
  f_equal.

  apply mod2_WS.

  rewrite div2_WS.
  apply natToWord_wordToNat.
Qed.

Theorem wmult_comm : forall sz (x y : word sz), x ^* y = y ^* x.
  intros; repeat rewrite wmult_alt; unfold wmultN, wordBinN; auto with arith.
Qed.

Theorem wmult_assoc : forall sz (x y z : word sz), x ^* (y ^* z) = x ^* y ^* z.
  intros; repeat rewrite wmult_alt; unfold wmultN, wordBinN; intros.

  repeat match goal with
           | [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
             let Heq := fresh "Heq" in
               destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq
         end.

  rewrite mult_minus_distr_l.
  rewrite mult_minus_distr_r.
  rewrite (mult_assoc (wordToNat x) x0).
  rewrite <- (mult_assoc x1).
  rewrite (mult_comm (pow2 sz)).
  rewrite (mult_assoc x1).
  repeat rewrite drop_sub; auto with arith.
  rewrite (mult_comm x1).
  rewrite <- (mult_assoc (wordToNat x)).
  rewrite (mult_comm (wordToNat y)).
  rewrite mult_assoc.
  rewrite (mult_comm (wordToNat x)).
  repeat rewrite <- mult_assoc.
  auto with arith.
  repeat rewrite <- mult_assoc.
  auto with arith.
Qed.

Theorem wmult_plus_distr : forall sz (x y z : word sz), (x ^+ y) ^* z = (x ^* z) ^+ (y ^* z).
  intros; repeat rewrite wmult_alt; repeat rewrite wplus_alt; unfold wmultN, wplusN, wordBinN; intros.

  repeat match goal with
           | [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
             let Heq := fresh "Heq" in
               destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq
         end.

  rewrite mult_minus_distr_r.
  rewrite <- (mult_assoc x0).
  rewrite (mult_comm (pow2 sz)).
  rewrite (mult_assoc x0).

  replace (wordToNat x * wordToNat z - x1 * pow2 sz +
    (wordToNat y * wordToNat z - x2 * pow2 sz))
    with (wordToNat x * wordToNat z + wordToNat y * wordToNat z - x1 * pow2 sz - x2 * pow2 sz).
  repeat rewrite drop_sub; auto with arith.
  rewrite (mult_comm x0).
  rewrite (mult_comm (wordToNat x + wordToNat y)).
  rewrite <- (mult_assoc (wordToNat z)).
  auto with arith.
  generalize dependent (wordToNat x * wordToNat z).
  generalize dependent (wordToNat y * wordToNat z).
  intros.
  omega.
Qed.

Theorem wminus_def : forall sz (x y : word sz), x ^- y = x ^+ ^~ y.
  reflexivity.
Qed.

Theorem wordToNat_bound : forall sz (w : word sz), wordToNat w < pow2 sz.
  induction w; simpl; intuition.
  destruct b; simpl; omega.
Qed.

Theorem natToWord_pow2 : forall sz, natToWord sz (pow2 sz) = natToWord sz 0.
  induction sz; simpl; intuition.

  generalize (div2_double (pow2 sz)); simpl; intro Hr; rewrite Hr; clear Hr.
  f_equal.
  generalize (mod2_double (pow2 sz)); auto.
  auto.
Qed.

Theorem wminus_inv : forall sz (x : word sz), x ^+ ^~ x = wzero sz.
  intros; rewrite wneg_alt; rewrite wplus_alt; unfold wnegN, wplusN, wzero, wordBinN; intros.

  repeat match goal with
           | [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
             let Heq := fresh "Heq" in
               destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq
         end.

  replace (wordToNat x + (pow2 sz - wordToNat x - x0 * pow2 sz))
    with (pow2 sz - x0 * pow2 sz).
  rewrite drop_sub; auto with arith.
  apply natToWord_pow2.
  generalize (wordToNat_bound x).
  omega.
Qed.

Definition wring (sz : nat) : ring_theory (wzero sz) (wone sz) (@wplus sz) (@wmult sz) (@wminus sz) (@wneg sz) (@eq _) :=
  mk_rt _ _ _ _ _ _ _
  (@wplus_unit _) (@wplus_comm _) (@wplus_assoc _)
  (@wmult_unit _) (@wmult_comm _) (@wmult_assoc _)
  (@wmult_plus_distr _) (@wminus_def _) (@wminus_inv _).

Theorem weqb_sound : forall sz (x y : word sz), weqb x y = true -> x = y.
Proof.
  eapply weqb_true_iff.
Qed.

Ltac isWcst w :=
  match eval hnf in w with
    | WO => constr:(true)
    | WS ?b ?w' =>
      match eval hnf in b with
        | true => isWcst w'
        | false => isWcst w'
        | _ => constr:(false)
      end
    | _ => constr:(false)
  end.

Ltac wcst w :=
  let b := isWcst w in
    match b with
      | true => w
      | _ => constr:(NotConstant)
    end.

(* Here's how you can add a ring for a specific bit-width.
   There doesn't seem to be a polymorphic method, so this code really does need to be copied. *)

(*
Definition wring8 := wring 8.
Add Ring wring8 : wring8 (decidable (weqb_sound 8), constants [wcst]).
*)

(** * Bitwise operators *)

Fixpoint wnot sz (w : word sz) : word sz :=
  match w with
    | WO => WO
    | WS b w' => WS (negb b) (wnot w')
  end.

Fixpoint bitwp (f : bool -> bool -> bool) sz (w1 : word sz) : word sz -> word sz :=
  match w1 with
    | WO => fun _ => WO
    | WS b w1' => fun w2 => WS (f b (whd w2)) (bitwp f w1' (wtl w2))
  end.

Definition wor := bitwp orb.
Definition wand := bitwp andb.
Definition wxor := bitwp xorb.

Notation "l ^| r" := (@wor _ l%word r%word) (at level 50, left associativity).
Notation "l ^& r" := (@wand _ l%word r%word) (at level 40, left associativity).

Theorem wor_unit : forall sz (x : word sz), wzero sz ^| x = x.
  unfold wzero, wor; induction x; simpl; intuition congruence.
Qed.

Theorem wor_comm : forall sz (x y : word sz), x ^| y = y ^| x.
  unfold wor; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool.
Qed.

Theorem wor_assoc : forall sz (x y z : word sz), x ^| (y ^| z) = x ^| y ^| z.
  unfold wor; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool.
Qed.

Theorem wand_unit : forall sz (x : word sz), wones sz ^& x = x.
  unfold wand; induction x; simpl; intuition congruence.
Qed.

Theorem wand_kill : forall sz (x : word sz), wzero sz ^& x = wzero sz.
  unfold wzero, wand; induction x; simpl; intuition congruence.
Qed.

Theorem wand_comm : forall sz (x y : word sz), x ^& y = y ^& x.
  unfold wand; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool.
Qed.

Theorem wand_assoc : forall sz (x y z : word sz), x ^& (y ^& z) = x ^& y ^& z.
  unfold wand; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool.
Qed.

Theorem wand_or_distr : forall sz (x y z : word sz), (x ^| y) ^& z = (x ^& z) ^| (y ^& z).
  unfold wand, wor; induction x; intro y; rewrite (shatter_word y); intro z; rewrite (shatter_word z); simpl; intuition; f_equal; auto with bool.
  destruct (whd y); destruct (whd z); destruct b; reflexivity.
Qed.

Definition wbring (sz : nat) : semi_ring_theory (wzero sz) (wones sz) (@wor sz) (@wand sz) (@eq _) :=
  mk_srt _ _ _ _ _
  (@wor_unit _) (@wor_comm _) (@wor_assoc _)
  (@wand_unit _) (@wand_kill _) (@wand_comm _) (@wand_assoc _)
  (@wand_or_distr _).

(** * Inequality proofs *)

Ltac word_simpl := unfold sext, zext, wzero in *; simpl in *.

Ltac word_eq := ring.

Ltac word_eq1 := match goal with
                   | _ => ring
                   | [ H : _ = _ |- _ ] => ring [H]
                 end.

Theorem word_neq : forall sz (w1 w2 : word sz),
  w1 ^- w2 <> wzero sz
  -> w1 <> w2.
  intros; intro; subst.
  unfold wminus in H.
  rewrite wminus_inv in H.
  tauto.
Qed.

Ltac word_neq := apply word_neq; let H := fresh "H" in intro H; simpl in H; ring_simplify in H; try discriminate.

Ltac word_contra := match goal with
                      | [ H : _ <> _ |- False ] => apply H; ring
                    end.

Ltac word_contra1 := match goal with
                       | [ H : _ <> _ |- False ] => apply H;
                         match goal with
                           | _ => ring
                           | [ H' : _ = _ |- _ ] => ring [H']
                         end
                     end.

Open Scope word_scope.

(** * Signed Logic **)
Fixpoint wordToZ sz (w : word sz) : Z :=
  if wmsb w true then
    (** Negative **)
    match wordToN (wneg w) with
      | N0 => 0%Z
      | Npos x => Zneg x
    end
  else
    (** Positive **)
    match wordToN w with
      | N0 => 0%Z
      | Npos x => Zpos x
    end.

(** * Comparison Predicates and Deciders **)
Definition wlt sz (l r : word sz) : Prop :=
  N.lt (wordToN l) (wordToN r).
Definition wslt sz (l r : word sz) : Prop :=
  Z.lt (wordToZ l) (wordToZ r).

Notation "w1 > w2" := (@wlt _ w2%word w1%word) : word_scope.
Notation "w1 >= w2" := (~(@wlt _ w1%word w2%word)) : word_scope.
Notation "w1 < w2" := (@wlt _ w1%word w2%word) : word_scope.
Notation "w1 <= w2" := (~(@wlt _ w2%word w1%word)) : word_scope.

Notation "w1 '>s' w2" := (@wslt _ w2%word w1%word) (at level 70) : word_scope.
Notation "w1 '>s=' w2" := (~(@wslt _ w1%word w2%word)) (at level 70) : word_scope.
Notation "w1 '<s' w2" := (@wslt _ w1%word w2%word) (at level 70) : word_scope.
Notation "w1 '<s=' w2" := (~(@wslt _ w2%word w1%word)) (at level 70) : word_scope.

Definition wlt_dec : forall sz (l r : word sz), {l < r} + {l >= r}.
  refine (fun sz l r =>
    match N.compare (wordToN l) (wordToN r) as k return N.compare (wordToN l) (wordToN r) = k -> _ with
      | Lt => fun pf => left _ _
      | _ => fun pf => right _ _
    end (refl_equal _));
  abstract congruence.
Defined.

Definition wslt_dec : forall sz (l r : word sz), {l <s r} + {l >s= r}.
  refine (fun sz l r =>
    match Z.compare (wordToZ l) (wordToZ r) as c return Z.compare (wordToZ l) (wordToZ r) = c -> _ with
      | Lt => fun pf => left _ _
      | _ => fun pf => right _ _
    end (refl_equal _));
  abstract congruence.
Defined.

(* Ordering Lemmas **)
Lemma lt_le : forall sz (a b : word sz),
  a < b -> a <= b.
Proof.
  unfold wlt, N.lt. intros. intro. rewrite <- Ncompare_antisym in H0. rewrite H in H0. simpl in *. congruence.
Qed.
Lemma eq_le : forall sz (a b : word sz),
  a = b -> a <= b.
Proof.
  intros; subst. unfold wlt, N.lt. rewrite N.compare_refl. congruence.
Qed.
Lemma wordToN_inj : forall sz (a b : word sz),
  wordToN a = wordToN b -> a = b.
Proof.
  induction a; intro b0; rewrite (shatter_word b0); intuition.
  simpl in H.
  destruct b; destruct (whd b0); intros.
  f_equal. eapply IHa. eapply N.succ_inj in H.
  destruct (wordToN a); destruct (wordToN (wtl b0)); try congruence.
  destruct (wordToN (wtl b0)); destruct (wordToN a); inversion H.
  destruct (wordToN (wtl b0)); destruct (wordToN a); inversion H.
  f_equal. eapply IHa.
  destruct (wordToN a); destruct (wordToN (wtl b0)); try congruence.
Qed.
Lemma unique_inverse : forall sz (a b1 b2 : word sz),
  a ^+ b1 = wzero _ ->
  a ^+ b2 = wzero _ ->
  b1 = b2.
Proof.
  intros.
  transitivity (b1 ^+ wzero _).
  rewrite wplus_comm. rewrite wplus_unit. auto.
  transitivity (b1 ^+ (a ^+ b2)). congruence.
  rewrite wplus_assoc.
  rewrite (wplus_comm b1). rewrite H. rewrite wplus_unit. auto.
Qed.
Lemma sub_0_eq : forall sz (a b : word sz),
  a ^- b = wzero _ -> a = b.
Proof.
  intros. destruct (weq (wneg b) (wneg a)).
  transitivity (a ^+ (^~ b ^+ b)).
  rewrite (wplus_comm (^~ b)). rewrite wminus_inv.
  rewrite wplus_comm. rewrite wplus_unit. auto.
  rewrite e. rewrite wplus_assoc. rewrite wminus_inv. rewrite wplus_unit. auto.
  unfold wminus in H.
  generalize (unique_inverse a (wneg a) (^~ b)).
  intros. exfalso. apply n. symmetry; apply H0.
  apply wminus_inv.
  auto.
Qed.

Lemma le_neq_lt : forall sz (a b : word sz),
  b <= a -> a <> b -> b < a.
Proof.
  intros; destruct (wlt_dec b a); auto.
  exfalso. apply H0. unfold wlt, N.lt in *.
  eapply wordToN_inj. eapply Ncompare_eq_correct.
  case_eq ((wordToN a ?= wordToN b)%N); auto; try congruence.
  intros. rewrite <- Ncompare_antisym in n. rewrite H1 in n. simpl in *. congruence.
Qed.

Hint Resolve word_neq lt_le eq_le sub_0_eq le_neq_lt : worder.

Ltac shatter_word x :=
  match type of x with
    | word 0 => try rewrite (shatter_word_0 x) in *
    | word (S ?N) =>
      let x' := fresh in
      let H := fresh in
      destruct (@shatter_word_S N x) as [ ? [ x' H ] ];
      rewrite H in *; clear H; shatter_word x'
  end.

(** Uniqueness of equality proofs **)
Lemma rewrite_weq : forall sz (a b : word sz)
  (pf : a = b),
  weq a b = left _ pf.
Proof.
  intros; destruct (weq a b); try solve [ exfalso; auto ].
  f_equal.
  eapply UIP_dec. eapply weq.
Qed.

(** * Some more useful derived facts *)

Lemma natToWord_plus : forall sz n m, natToWord sz (n + m) = natToWord _ n ^+ natToWord _ m.
  destruct sz; intuition.
  rewrite wplus_alt.
  unfold wplusN, wordBinN.
  destruct (wordToNat_natToWord (S sz) n); intuition.
  destruct (wordToNat_natToWord (S sz) m); intuition.
  rewrite H0; rewrite H2; clear H0 H2.
  replace (n - x * pow2 (S sz) + (m - x0 * pow2 (S sz))) with (n + m - x * pow2 (S sz) - x0 * pow2 (S sz))
    by omega.
  repeat rewrite drop_sub; auto; omega.
Qed.

Lemma natToWord_S : forall sz n, natToWord sz (S n) = natToWord _ 1 ^+ natToWord _ n.
  intros; change (S n) with (1 + n); apply natToWord_plus.
Qed.

Theorem natToWord_inj : forall sz n m, natToWord sz n = natToWord sz m
  -> (n < pow2 sz)%nat
  -> (m < pow2 sz)%nat
  -> n = m.
  intros.
  apply (f_equal (@wordToNat _)) in H.
  destruct (wordToNat_natToWord sz n).
  destruct (wordToNat_natToWord sz m).
  intuition.
  rewrite H4 in H; rewrite H2 in H; clear H4 H2.
  assert (x = 0).
  destruct x; auto; simpl in *; generalize dependent (x * pow2 sz); intros; omega.
  assert (x0 = 0).
  destruct x0; auto; simpl in *; generalize dependent (x0 * pow2 sz); intros; omega.
  subst; simpl in *; omega.
Qed.

Lemma wordToNat_natToWord_idempotent : forall sz n,
  (N.of_nat n < Npow2 sz)%N
  -> wordToNat (natToWord sz n) = n.
  intros.
  destruct (wordToNat_natToWord sz n); intuition.
  destruct x.
  simpl in *; omega.
  simpl in *.
  apply Nlt_out in H.
  autorewrite with N in *.
  rewrite Npow2_nat in *.
  generalize dependent (x * pow2 sz).
  intros; omega.
Qed.

Lemma wplus_cancel : forall sz (a b c : word sz),
  a ^+ c = b ^+ c
  -> a = b.
  intros.
  apply (f_equal (fun x => x ^+ ^~ c)) in H.
  repeat rewrite <- wplus_assoc in H.
  rewrite wminus_inv in H.
  repeat rewrite (wplus_comm _ (wzero sz)) in H.
  repeat rewrite wplus_unit in H.
  assumption.
Qed.


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

Set Implicit Arguments.

Require Export Notations.

Notation "A -> B" := (forall (_ : A), B) : type_scope.

(** * Propositional connectives *)

(** [True] is the always true proposition *)

Inductive True : Prop :=
  I : True.

(** [False] is the always false proposition *)
Inductive False : Prop :=.

(** [not A], written [~A], is the negation of [A] *)
Definition not (A:Prop) := A -> False.

Notation "~ x" := (not x) : type_scope.

Hint Unfold not: core.

  (** [and A B], written [A /\ B], is the conjunction of [A] and [B]

      [conj p q] is a proof of [A /\ B] as soon as
      [p] is a proof of [A] and [q] a proof of [B]

      [proj1] and [proj2] are first and second projections of a conjunction *)

Inductive and (A B:Prop) : Prop :=
  conj : A -> B -> A /\ B

where "A /\ B" := (and A B) : type_scope.

Section Conjunction.

  Variables A B : Prop.

  Theorem proj1 : A /\ B -> A.
  Proof.
    destruct 1; trivial.
  Qed.

  Theorem proj2 : A /\ B -> B.
  Proof.
    destruct 1; trivial.
  Qed.

End Conjunction.

(** [or A B], written [A \/ B], is the disjunction of [A] and [B] *)

Inductive or (A B:Prop) : Prop :=
  | or_introl : A -> A \/ B
  | or_intror : B -> A \/ B

where "A \/ B" := (or A B) : type_scope.

Arguments or_introl [A B] _, [A] B _.
Arguments or_intror [A B] _, A [B] _.

(** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)

Definition iff (A B:Prop) := (A -> B) /\ (B -> A).

Notation "A <-> B" := (iff A B) : type_scope.

Section Equivalence.

Theorem iff_refl : forall A:Prop, A <-> A.
  Proof.
    split; auto.
  Qed.

Theorem iff_trans : forall A B C:Prop, (A <-> B) -> (B <-> C) -> (A <-> C).
  Proof.
    intros A B C [H1 H2] [H3 H4]; split; auto.
  Qed.

Theorem iff_sym : forall A B:Prop, (A <-> B) -> (B <-> A).
  Proof.
    intros A B [H1 H2]; split; auto.
  Qed.

End Equivalence.

Hint Unfold iff: extcore.

(** Backward direction of the equivalences above does not need assumptions *)

Theorem and_iff_compat_l : forall A B C : Prop,
  (B <-> C) -> (A /\ B <-> A /\ C).
Proof.
  intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ assumption | ]);
  [apply Hl | apply Hr]; assumption.
Qed.

Theorem and_iff_compat_r : forall A B C : Prop,
  (B <-> C) -> (B /\ A <-> C /\ A).
Proof.
  intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ | assumption ]);
  [apply Hl | apply Hr]; assumption.
Qed.

Theorem or_iff_compat_l : forall A B C : Prop,
  (B <-> C) -> (A \/ B <-> A \/ C).
Proof.
  intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left; assumption| right]);
  [apply Hl | apply Hr]; assumption.
Qed.

Theorem or_iff_compat_r : forall A B C : Prop,
  (B <-> C) -> (B \/ A <-> C \/ A).
Proof.
  intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left| right; assumption]);
  [apply Hl | apply Hr]; assumption.
Qed.

Theorem imp_iff_compat_l : forall A B C : Prop,
  (B <-> C) -> ((A -> B) <-> (A -> C)).
Proof.
  intros ? ? ? [Hl Hr]; split; intros H ?; [apply Hl | apply Hr]; apply H; assumption.
Qed.

Theorem imp_iff_compat_r : forall A B C : Prop,
  (B <-> C) -> ((B -> A) <-> (C -> A)).
Proof.
  intros ? ? ? [Hl Hr]; split; intros H ?; [apply H, Hr | apply H, Hl]; assumption.
Qed.

Theorem not_iff_compat : forall A B : Prop,
  (A <-> B) -> (~ A <-> ~B).
Proof.
  intros; apply imp_iff_compat_r; assumption.
Qed.

(** Some equivalences *)

Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False).
Proof.
  intro A; unfold not; split.
  - intro H; split; [exact H | intro H1; elim H1].
  - intros [H _]; exact H.
Qed.

Theorem and_cancel_l : forall A B C : Prop,
  (B -> A) -> (C -> A) -> ((A /\ B <-> A /\ C) <-> (B <-> C)).
Proof.
  intros A B C Hl Hr.
  split; [ | apply and_iff_compat_l]; intros [HypL HypR]; split; intros.
  + apply HypL; split; [apply Hl | ]; assumption.
  + apply HypR; split; [apply Hr | ]; assumption.
Qed.

Theorem and_cancel_r : forall A B C : Prop,
  (B -> A) -> (C -> A) -> ((B /\ A <-> C /\ A) <-> (B <-> C)).
Proof.
  intros A B C Hl Hr.
  split; [ | apply and_iff_compat_r]; intros [HypL HypR]; split; intros.
  + apply HypL; split; [ | apply Hl ]; assumption.
  + apply HypR; split; [ | apply Hr ]; assumption.
Qed.

Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A.
Proof.
  intros; split; intros [? ?]; split; assumption.
Qed.

Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C.
Proof.
  intros; split; [ intros [[? ?] ?]| intros [? [? ?]]]; repeat split; assumption.
Qed.

Theorem or_cancel_l : forall A B C : Prop,
  (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)).
Proof.
  intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_l]; intros [Hl Hr]; split; intros.
  { destruct Hl; [ right | destruct Fl | ]; assumption. }
  { destruct Hr; [ right | destruct Fr | ]; assumption. }
Qed.

Theorem or_cancel_r : forall A B C : Prop,
  (B -> ~ A) -> (C -> ~ A) -> ((B \/ A <-> C \/ A) <-> (B <-> C)).
Proof.
  intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_r]; intros [Hl Hr]; split; intros.
  { destruct Hl; [ left | | destruct Fl ]; assumption. }
  { destruct Hr; [ left | | destruct Fr ]; assumption. }
Qed.

Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A).
Proof.
  intros; split; (intros [? | ?]; [ right | left ]; assumption).
Qed.

Theorem or_assoc : forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C.
Proof.
  intros; split; [ intros [[?|?]|?]| intros [?|[?|?]]].
  + left; assumption.
  + right; left; assumption.
  + right; right; assumption.
  + left; left; assumption.
  + left; right; assumption.
  + right; assumption.
Qed.
Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A).
Proof.
  intros A B []; split; trivial.
Qed.

Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A).
Proof.
  intros; split; intros [Hl Hr]; (split; intros; [ apply Hl | apply Hr]); assumption.
Qed.

(** [(IF_then_else P Q R)], written [IF P then Q else R] denotes
    either [P] and [Q], or [~P] and [R] *)

Definition IF_then_else (P Q R:Prop) := P /\ Q \/ ~ P /\ R.

Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3)
  (at level 200, right associativity) : type_scope.

(** * First-order quantifiers *)

(** [ex P], or simply [exists x, P x], or also [exists x:A, P x],
    expresses the existence of an [x] of some type [A] in [Set] which
    satisfies the predicate [P].  This is existential quantification.

    [ex2 P Q], or simply [exists2 x, P x & Q x], or also
    [exists2 x:A, P x & Q x], expresses the existence of an [x] of
    type [A] which satisfies both predicates [P] and [Q].

    Universal quantification is primitively written [forall x:A, Q]. By
    symmetry with existential quantification, the construction [all P]
    is provided too.
*)

Inductive ex (A:Type) (P:A -> Prop) : Prop :=
  ex_intro : forall x:A, P x -> ex (A:=A) P.

Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop :=
  ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q.

Definition all (A:Type) (P:A -> Prop) := forall x:A, P x.

(* Rule order is important to give printing priority to fully typed exists *)

Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q))
  (at level 200, x ident, p at level 200, right associativity) : type_scope.
Notation "'exists2' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q))
  (at level 200, x ident, A at level 200, p at level 200, right associativity,
    format "'[' 'exists2'  '/  ' x  :  A ,  '/  ' '[' p  &  '/' q ']' ']'")
  : type_scope.

Notation "'exists2' ' x , p & q" := (ex2 (fun x => p) (fun x => q))
  (at level 200, x strict pattern, p at level 200, right associativity) : type_scope.
Notation "'exists2' ' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q))
  (at level 200, x strict pattern, A at level 200, p at level 200, right associativity,
    format "'[' 'exists2'  '/  ' ' x  :  A ,  '/  ' '[' p  &  '/' q ']' ']'")
  : type_scope.

(** Derived rules for universal quantification *)

Section universal_quantification.

  Variable A : Type.
  Variable P : A -> Prop.

  Theorem inst : forall x:A, all (fun x => P x) -> P x.
  Proof.
    unfold all; auto.
  Qed.

  Theorem gen : forall (B:Prop) (f:forall y:A, B -> P y), B -> all P.
  Proof.
    red; auto.
  Qed.

End universal_quantification.

(** * Equality *)

(** [eq x y], or simply [x=y] expresses the equality of [x] and
    [y]. Both [x] and [y] must belong to the same type [A].
    The definition is inductive and states the reflexivity of the equality.
    The others properties (symmetry, transitivity, replacement of
    equals by equals) are proved below. The type of [x] and [y] can be
    made explicit using the notation [x = y :> A]. This is Leibniz equality
    as it expresses that [x] and [y] are equal iff every property on
    [A] which is true of [x] is also true of [y] *)

Inductive eq (A:Type) (x:A) : A -> Prop :=
    eq_refl : x = x :>A

where "x = y :> A" := (@eq A x y) : type_scope.

Notation "x = y" := (x = y :>_) : type_scope.
Notation "x <> y  :> T" := (~ x = y :>T) : type_scope.
Notation "x <> y" := (x <> y :>_) : type_scope.

Arguments eq {A} x _.
Arguments eq_refl {A x} , [A] x.

Arguments eq_ind [A] x P _ y _.
Arguments eq_rec [A] x P _ y _.
Arguments eq_rect [A] x P _ y _.

Hint Resolve I conj or_introl or_intror : core.
Hint Resolve eq_refl: core.
Hint Resolve ex_intro ex_intro2: core.

Section Logic_lemmas.

  Theorem absurd : forall A C:Prop, A -> ~ A -> C.
  Proof.
    unfold not; intros A C h1 h2.
    destruct (h2 h1).
  Qed.

  Section equality.
    Variables A B : Type.
    Variable f : A -> B.
    Variables x y z : A.

    Theorem eq_sym : x = y -> y = x.
    Proof.
      destruct 1; trivial.
    Defined.

    Theorem eq_trans : x = y -> y = z -> x = z.
    Proof.
      destruct 2; trivial.
    Defined.

    Theorem f_equal : x = y -> f x = f y.
    Proof.
      destruct 1; trivial.
    Defined.

    Theorem not_eq_sym : x <> y -> y <> x.
    Proof.
      red; intros h1 h2; apply h1; destruct h2; trivial.
    Qed.

  End equality.

  Definition eq_ind_r :
    forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y.
    intros A x P H y H0. elim eq_sym with (1 := H0); assumption.
  Defined.

  Definition eq_rec_r :
    forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y.
    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
  Defined.

  Definition eq_rect_r :
    forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y.
    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
  Defined.
End Logic_lemmas.

Module EqNotations.
  Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H)
    (at level 10, H' at level 10,
     format "'[' 'rew'  H  in  '/' H' ']'").
  Notation "'rew' [ P ] H 'in' H'" := (eq_rect _ P H' _ H)
    (at level 10, H' at level 10,
     format "'[' 'rew'  [ P ]  '/    ' H  in  '/' H' ']'").
  Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H)
    (at level 10, H' at level 10,
     format "'[' 'rew'  <-  H  in  '/' H' ']'").
  Notation "'rew' <- [ P ] H 'in' H'" := (eq_rect_r P H' H)
    (at level 10, H' at level 10,
     format "'[' 'rew'  <-  [ P ]  '/    ' H  in  '/' H' ']'").
  Notation "'rew' -> H 'in' H'" := (eq_rect _ _ H' _ H)
    (at level 10, H' at level 10, only parsing).
  Notation "'rew' -> [ P ] H 'in' H'" := (eq_rect _ P H' _ H)
    (at level 10, H' at level 10, only parsing).

End EqNotations.

Import EqNotations.

Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a.
Proof.
intros.
destruct H.
reflexivity.
Defined.

Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a.
Proof.
intros.
destruct H.
reflexivity.
Defined.

Theorem f_equal2 :
  forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1)
    (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
Proof.
  destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal3 :
  forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1)
    (x2 y2:A2) (x3 y3:A3),
    x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3.
Proof.
  destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal4 :
  forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B)
    (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
    x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4.
Proof.
  destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal5 :
  forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B)
    (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5),
    x1 = y1 ->
    x2 = y2 ->
    x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5.
Proof.
  destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b),
  f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e.
Proof.
  destruct e. reflexivity.
Defined.

(** The goupoid structure of equality *)

Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e.
Proof.
  destruct e. reflexivity.
Defined.

Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e.
Proof.
  destruct e. reflexivity.
Defined.

Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e.
Proof.
  destruct e; reflexivity.
Defined.

Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl.
Proof.
  destruct e; reflexivity.
Defined.

Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl.
Proof.
  destruct e; reflexivity.
Defined.

Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t),
  eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''.
Proof.
  destruct e''; reflexivity.
Defined.

(** Extra properties of equality *)

Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a).
Proof.
  intros.
  unfold f_equal.
  rewrite <- (eq_trans_sym_inv_l (Hf a)).
  destruct (Hf a) at 1 2.
  destruct (Hf a).
  reflexivity.
Defined.

Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a).
Proof.
  intros.
  unfold f_equal.
  rewrite <- (eq_trans_sym_inv_l (Hf (f (f a)))).
  set (Hfsymf := fun a => eq_sym (Hf a)).
  change (eq_sym (Hf (f (f a)))) with (Hfsymf (f (f a))).
  pattern (Hfsymf (f (f a))).
  destruct (eq_id_comm_l f Hfsymf (f a)).
  destruct (eq_id_comm_l f Hfsymf a).
  unfold Hfsymf.
  destruct (Hf a). simpl.
  rewrite eq_trans_refl_l.
  reflexivity.
Defined.

Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x).
Proof.
  reflexivity.
Qed.

Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e').
Proof.
destruct e'.
reflexivity.
Defined.

Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e).
Proof.
destruct e.
reflexivity.
Defined.

Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e).
Proof.
destruct e, e'.
reflexivity.
Defined.

Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x),
    rew (eq_trans e e') in k = rew e' in rew e in k.
Proof.
  destruct e, e'; reflexivity.
Qed.

Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P),
    rew [fun _ => P] e in k = k.
Proof.
  destruct e; reflexivity.
Qed.

(* Aliases *)

Notation sym_eq := eq_sym (only parsing).
Notation trans_eq := eq_trans (only parsing).
Notation sym_not_eq := not_eq_sym (only parsing).

Notation refl_equal := eq_refl (only parsing).
Notation sym_equal := eq_sym (only parsing).
Notation trans_equal := eq_trans (only parsing).
Notation sym_not_equal := not_eq_sym (only parsing).

Hint Immediate eq_sym not_eq_sym: core.

(** Basic definitions about relations and properties *)

Definition subrelation (A B : Type) (R R' : A->B->Prop) :=
  forall x y, R x y -> R' x y.

Definition unique (A : Type) (P : A->Prop) (x:A) :=
  P x /\ forall (x':A), P x' -> x=x'.

Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y.

(** Unique existence *)

Notation "'exists' ! x .. y , p" :=
  (ex (unique (fun x => .. (ex (unique (fun y => p))) ..)))
  (at level 200, x binder, right associativity,
   format "'[' 'exists'  !  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Lemma unique_existence : forall (A:Type) (P:A->Prop),
  ((exists x, P x) /\ uniqueness P) <-> (exists! x, P x).
Proof.
  intros A P; split.
  - intros ((x,Hx),Huni); exists x; red; auto.
  - intros (x,(Hx,Huni)); split.
    + exists x; assumption.
    + intros x' x'' Hx' Hx''; transitivity x.
      symmetry; auto.
      auto.
Qed.

Lemma forall_exists_unique_domain_coincide :
  forall A (P:A->Prop), (exists! x, P x) ->
  forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x).
Proof.
  intros A P (x & Hp & Huniq); split.
  - intro; exists x; auto.
  - intros (x0 & HPx0 & HQx0) x1 HPx1.
    assert (H : x0 = x1) by (transitivity x; [symmetry|]; auto).
    destruct H.
    assumption.
Qed.

Lemma forall_exists_coincide_unique_domain :
  forall A (P:A->Prop),
  (forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x))
  -> (exists! x, P x).
Proof.
  intros A P H.
  destruct H with (Q:=P) as ((x & Hx & _),_); [trivial|].
  exists x. split; [trivial|].
  destruct H with (Q:=fun x'=>x=x') as (_,Huniq).
  apply Huniq. exists x; auto.
Qed.

(** * Being inhabited *)

(** The predicate [inhabited] can be used in different contexts. If [A] is
    thought as a type, [inhabited A] states that [A] is inhabited. If [A] is
    thought as a computationally relevant proposition, then
    [inhabited A] weakens [A] so as to hide its computational meaning.
    The so-weakened proof remains computationally relevant but only in
    a propositional context.
*)

Inductive inhabited (A:Type) : Prop := inhabits : A -> inhabited A.

Hint Resolve inhabits: core.

Lemma exists_inhabited : forall (A:Type) (P:A->Prop),
  (exists x, P x) -> inhabited A.
Proof.
  destruct 1; auto.
Qed.

Lemma inhabited_covariant (A B : Type) : (A -> B) -> inhabited A -> inhabited B.
Proof.
  intros f [x];exact (inhabits (f x)).
Qed.

(** Declaration of stepl and stepr for eq and iff *)

Lemma eq_stepl : forall (A : Type) (x y z : A), x = y -> x = z -> z = y.
Proof.
  intros A x y z H1 H2. rewrite <- H2; exact H1.
Qed.

Declare Left Step eq_stepl.
Declare Right Step eq_trans.

Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B).
Proof.
  intros ? ? ? [? ?] [? ?]; split; intros; auto.
Qed.

Declare Left Step iff_stepl.
Declare Right Step iff_trans.

Local Notation "'rew' 'dependent' H 'in' H'"
  := (match H with
      | eq_refl => H'
      end)
       (at level 10, H' at level 10,
        format "'[' 'rew'  'dependent'  '/    ' H  in  '/' H' ']'").

(** Equality for [ex] *)
Section ex.
  Local Unset Implicit Arguments.
  Definition eq_ex_uncurried {A : Type} (P : A -> Prop) {u1 v1 : A} {u2 : P u1} {v2 : P v1}
             (pq : exists p : u1 = v1, rew p in u2 = v2)
  : ex_intro P u1 u2 = ex_intro P v1 v2.
  Proof.
    destruct pq as [p q].
    destruct q; simpl in *.
    destruct p; reflexivity.
  Qed.

  Definition eq_ex {A : Type} {P : A -> Prop} (u1 v1 : A) (u2 : P u1) (v2 : P v1)
             (p : u1 = v1) (q : rew p in u2 = v2)
  : ex_intro P u1 u2 = ex_intro P v1 v2
    := eq_ex_uncurried P (ex_intro _ p q).

  Definition eq_ex_hprop {A} {P : A -> Prop} (P_hprop : forall (x : A) (p q : P x), p = q)
             (u1 v1 : A) (u2 : P u1) (v2 : P v1)
             (p : u1 = v1)
    : ex_intro P u1 u2 = ex_intro P v1 v2
    := eq_ex u1 v1 u2 v2 p (P_hprop _ _ _).

  Lemma rew_ex {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : exists p, Q x p) {y} (H : x = y)
  : rew [fun a => exists p, Q a p] H in u
    = match u with
        | ex_intro _ u1 u2
          => ex_intro
               (Q y)
               (rew H in u1)
               (rew dependent H in u2)
      end.
  Proof.
    destruct H, u; reflexivity.
  Qed.
End ex.

(** Equality for [ex2] *)
Section ex2.
  Local Unset Implicit Arguments.

  Definition eq_ex2_uncurried {A : Type} (P Q : A -> Prop) {u1 v1 : A}
             {u2 : P u1} {v2 : P v1}
             {u3 : Q u1} {v3 : Q v1}
             (pq : exists2 p : u1 = v1, rew p in u2 = v2 & rew p in u3 = v3)
  : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3.
  Proof.
    destruct pq as [p q r].
    destruct r, q, p; simpl in *.
    reflexivity.
  Qed.

  Definition eq_ex2 {A : Type} {P Q : A -> Prop}
             (u1 v1 : A)
             (u2 : P u1) (v2 : P v1)
             (u3 : Q u1) (v3 : Q v1)
             (p : u1 = v1) (q : rew p in u2 = v2) (r : rew p in u3 = v3)
  : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3
    := eq_ex2_uncurried P Q (ex_intro2 _ _ p q r).

  Definition eq_ex2_hprop {A} {P Q : A -> Prop}
             (P_hprop : forall (x : A) (p q : P x), p = q)
             (Q_hprop : forall (x : A) (p q : Q x), p = q)
             (u1 v1 : A) (u2 : P u1) (v2 : P v1) (u3 : Q u1) (v3 : Q v1)
             (p : u1 = v1)
    : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3
    := eq_ex2 u1 v1 u2 v2 u3 v3 p (P_hprop _ _ _) (Q_hprop _ _ _).

  Lemma rew_ex2 {A x} {P : A -> Type}
        (Q : forall a, P a -> Prop)
        (R : forall a, P a -> Prop)
        (u : exists2 p, Q x p & R x p) {y} (H : x = y)
  : rew [fun a => exists2 p, Q a p & R a p] H in u
    = match u with
        | ex_intro2 _ _ u1 u2 u3
          => ex_intro2
               (Q y)
               (R y)
               (rew H in u1)
               (rew dependent H in u2)
               (rew dependent H in u3)
      end.
  Proof.
    destruct H, u; reflexivity.
  Qed.
End ex2.


Require Import
  Coq.Classes.RelationClasses Coq.Classes.Morphisms Coq.Program.Program
  MathClasses.interfaces.universal_algebra MathClasses.interfaces.canonical_names MathClasses.theory.ua_subalgebra.

(* In theory/ua_subalgebra.v we defined closed proper subsets and showed that
they yield subalgebras. We now expand on this result and show that they
also yield subvarieties (by showing that the laws still hold in the subalgebra). *)

Section contents.
  Context `{InVariety et A} `{@ClosedSubset et A _ _ P}. (* todo: why so ugly? *)

  Definition Pvars (vars: Vars et (carrier P) nat): Vars et A nat
    := λ s n, ` (vars s n).

  (* To prove that the laws still hold in the subalgebra, we first prove that evaluation in it
   is the same as evaluation in the original: *)

  Program Fixpoint heq {o}: op_type (carrier P) o → op_type A o → Prop :=
    match o with
    | ne_list.one _ => λ a b, `a = b
    | ne_list.cons _ _ => λ a b, ∀ u, heq (a u) (b u)
    end.

  Instance heq_proper {o}: Proper ((=) ==> (=) ==> iff) (@heq o).
  Proof with intuition.
   intros x y U x0 y0 K.
   induction o; simpl in *.
    destruct x, y.
    change (x = x1) in U.
    simpl in *.
    split; intro.
     transitivity x...
     transitivity x0...
    transitivity x1...
    transitivity y0...
   assert (∀ u, x u = y u). intros. apply U...
   split; repeat intro.
    apply -> (IHo (x u) (y u) (H1 u) (x0 (proj1_sig u)))...
    apply K...
   apply <- (IHo (x u) (y u) (H1 u) (x0 (proj1_sig u)))...
   apply K...
  Qed.

  Lemma heq_eval vars {o} (t: T et o): heq (eval et vars t) (eval et (Pvars vars) t).
  Proof with intuition.
   induction t; simpl...
     unfold Pvars...
    simpl in IHt1.
    generalize (IHt1 (eval et vars t3)). clear IHt1.
    apply heq_proper.
     pose proof (@eval_proper et (carrier P) _ _ _ nat (ne_list.cons y t1)).
     apply H1; try intro...
    pose proof (@eval_proper et A _ _ _ nat (ne_list.cons y t1)).
    apply H1...
    unfold heq in IHt2. (* todo: this wasn't needed in a previous Coq version *)
    rewrite IHt2.
    apply (@eval_proper et A _ _ _ nat (ne_list.one y))...
   unfold impl, algebra_op.
   generalize (subset_closed P o).
   unfold algebra_op.
   generalize (AlgebraOps0 o).
   intros.
   induction (et o); simpl in *...
  Qed.

  Lemma heq_eval_const vars {o} (t: T et (ne_list.one o)): ` (eval et vars t) = eval et (Pvars vars) t.
  Proof. apply (heq_eval vars t). Qed.
    (* todo: this specialization wasn't needed in a previous Coq version *)

  Lemma laws s: et_laws et s → ∀ vars: ∀ a, nat → carrier P a, eval_stmt et vars s.
  Proof with intuition.
   intros.
   generalize (@variety_laws et A _ _ _ s H1 (Pvars vars)). clear H1.
   destruct s as [x [? [t t0]]].
   induction x as [| [x1 [t1 t2]]]; simpl in *; intros.
    unfold equiv, sig_equiv.
    rewrite (heq_eval_const vars t).
    rewrite (heq_eval_const vars t0)...
   apply IHx, H1.
   rewrite <- (heq_eval_const vars t1).
   rewrite <- (heq_eval_const vars t2)...
  Qed.

  (* Which gives us our variety: *)

  Global Instance: InVariety et (carrier P) := { variety_laws := laws }.

End contents.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_ss :
	forall P Q A B X U V,
	Col A B U ->
	Col A B V ->
	BetS P U X ->
	BetS Q V X ->
	nCol A B P ->
	nCol A B Q ->
	SS P Q A B.
Proof.
	intros P Q A B X U V.
	intros Col_A_B_U.
	intros Col_A_B_V.
	intros BetS_P_U_X.
	intros BetS_Q_V_X.
	intros nCol_A_B_P.
	intros nCol_A_B_Q.

	exists X, U, V.
	split.
	exact Col_A_B_U.
	split.
	exact Col_A_B_V.
	split.
	exact BetS_P_U_X.
	split.
	exact BetS_Q_V_X.
	split.
	exact nCol_A_B_P.
	exact nCol_A_B_Q.
Qed.

End Euclid.


(* http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt2.html *)
Goal forall (P Q : Prop), (forall P :Prop, (P -> Q) -> Q) -> ((P -> Q) -> P) -> P.
intros.apply H0.intro.apply (H (P -> Q)).intros.apply H2.apply H1.Qed.

Goal forall (P Q R : Prop), (P -> Q) -> (Q -> R) -> P -> R.
intros.apply H0.apply H.apply H1.Qed.

Inductive False : Prop :=.
Definition not (A: Prop) := A -> False.
Goal forall P : Prop, P -> not (not P).
intro.intros.intro.apply H0.apply H.Qed.

Inductive or (A B : Prop) : Prop :=
| or_introl : A -> or A B
| or_intror : B -> or A B.
Goal forall (P Q : Prop), (or P Q) -> (or Q P).
intros.destruct H.apply or_intror.apply H.apply or_introl.apply H.Qed.

Inductive and (A B : Prop) : Prop :=
  conj : A -> B -> and A B.
Goal forall (P Q : Prop), (and P Q) -> (and Q P).
intros.apply conj.destruct H.apply H0.destruct H.apply H.Qed.

Goal forall (P : Prop), not (and P (not P)).
  intros.intro.destruct H.destruct H0.apply H.Qed.

Goal forall (P Q : Prop), (or (not P) (not Q)) -> (not (and P Q)).
intros.intro.destruct H0.destruct H.apply H.apply H0.apply H.apply H1.Qed.

Goal forall (P : Prop), (forall (P : Prop), (not (not P)) -> P) -> (or P (not P)).
intros.apply H.intro.apply H0.right.intro.apply H0.left.apply H1.


Require Import Indices.
Require Import SetoidList.
(* Require Import SetoidListEquiv. *)

Module mkFacts (I:IndexType).

  (* perhaps I should use PairOrderedType and build a ListOrderedType ? *)

  Definition ci_eq  (ci ci': I.t * I.t) := I.eq (fst ci) (fst ci') /\ I.eq (snd ci) (snd ci').

  Theorem ci_eq_refl: forall ci, ci_eq ci ci.
  Proof.
    intros; destruct ci; unfold ci_eq; simpl;  split; apply I.eq_refl.
  Qed.

  Theorem ci_eq_sym: forall ci ci', ci_eq ci ci' -> ci_eq ci' ci.
  Proof.
    intros.
    destruct ci; destruct ci'.
    unfold ci_eq in *; simpl in *; destruct H; split;
      apply I.eq_sym; assumption.
  Qed.

  Theorem ci_eq_trans: forall ci1 ci2 ci3,
    ci_eq ci1 ci2 -> ci_eq ci2 ci3 -> ci_eq ci1 ci3.
  Proof.
    intros.
    destruct ci1; destruct ci2; destruct ci3.
    unfold ci_eq in *; simpl in *; destruct H; destruct H0; split;
      [apply I.eq_trans with t1 |apply I.eq_trans with t2]; auto.
  Qed.

  Theorem ci_eq_Equiv : Equivalence ci_eq.
    apply Build_Equivalence.
    unfold Reflexive; apply ci_eq_refl.
    unfold Symmetric; apply ci_eq_sym.
    unfold Transitive; apply ci_eq_trans.
  Qed.

  Definition cil_eq := eqlistA ci_eq.

  Definition cil_Equiv : Equivalence cil_eq.
  eapply eqlistA_equiv.
  exact ci_eq_Equiv.
  Defined.

End mkFacts.


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

Require Import Arith List Wellfounded.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import php.

From Undecidability.Shared.Libs.DLW.Wf
  Require Import acc_irr measure_ind wf_chains.

Set Implicit Arguments.

(* Results about the well-foundedness of strict (reverse)
    inclusion between lists

    These proofs avoid the need of decidable equality
    and use the finitary Pigeon Hole Principle (PHP)
    instead
*)

Section sincl.

  (* Strict inclusion between lists is a well founded relation *)

  Variable (X : Type).

  Implicit Type (l m : list X).

  (* sincl l m if incl l m and there is a witness in m \ l *)

  Definition sincl l m := incl l m /\ exists x, ~ In x l /\ In x m.

  (* Any n-chain m ~~> l contains a
     duplication-free subset of l of size n
     which does not intersect m  *)

  Lemma sincl_chain n m l :
       chain sincl n m l -> incl m l
                         /\ exists ll, ~ list_has_dup ll
                                      /\ length ll = n
                                      /\ incl ll l
                                      /\ forall x, In x m -> In x ll -> False.
  Proof.
    induction 1 as [ m | n m l k H1 H2 (H7 & ll & H3 & H4 & H5 & H6) ].
    + split.
      * intros ?; auto.
      * exists nil; simpl; repeat split; auto.
        - inversion 1.
        - intros _ [].
    + split.
      * intros ? ?; apply H7, H1; auto.
      * destruct H1 as (G1 & x & G2 & G3).
        exists (x::ll); simpl; repeat split; auto.
        - contradict H3.
          apply list_has_dup_cons_inv in H3.
          destruct H3 as [ H3 | ]; auto.
          destruct (H6 x); auto.
        - apply incl_cons; auto.
        - intros y F1 [ F2 | F2 ]; subst.
          ** tauto.
          ** apply (H6 y); auto.
  Qed.

  (* Hence, by the PHP, if there is a n-chain to l then n must be less than length l *)

  Corollary sincl_chain_bounded l m n : chain sincl n m l -> n <= length l.
  Proof.
    intros H.
    apply sincl_chain in H.
    destruct H as (_ & ll & H1 & H2 & H3 & _).
    destruct (le_lt_dec n (length l)) as [ | C ]; auto.
    subst; destruct H1.
    apply finite_php_dup with l; auto.
  Qed.

  (* Hence sincl is well-founded because n-chains to l have length bounded by length l *)

  Theorem wf_sincl : well_founded sincl.
  Proof.
    apply wf_chains.
    intros l; exists (length l).
    intros ? ?; apply sincl_chain_bounded.
  Qed.

End sincl.

Arguments wf_sincl {X}.

Section rincl_fin.

  (* Strict reverse inclusion between lists is well founded over a finite domain *)

  (* M the upper-bound/finiteness of the domain *)

  Variable (X : Type) (M : list X).

  (* l cap M strictly contains in m cap M *)

  Definition rincl_fin l m := (forall x, In x m -> In x M -> In x l)
                            /\ exists x, ~ In x m /\ In x l /\ In x M.

  (* Any n-chain m ~~> l contains a duplication-free subset of M of size n *)

  Lemma rincl_fin_chains n m l :   chain rincl_fin n m l
                   -> exists ll, ~ list_has_dup ll
                                /\ incl ll M
                                /\ length ll = n
                                /\ incl ll m.
  Proof.
    induction 1 as [ x | n m k l H1 H2 (ll & H3 & H4 & H5 & H6) ].
    + exists nil.
      repeat split; simpl; auto; inversion 1.
    + destruct H1 as (H1 & a & G1 & G2 & G3).
      exists (a::ll).
      repeat split.
      * contradict H3.
        apply list_has_dup_cons_inv in H3.
        destruct H3 as [ H3 | ]; auto.
        destruct G1; apply H6; auto.
      * apply incl_cons; auto.
      * simpl; f_equal; auto.
      * apply incl_cons; auto.
        intros ? ?; auto.
  Qed.

  (* Hence, by the PHP, if there is a n-chain to l then n is less than length M *)

  Corollary rincl_fin_chain_bounded l m n : chain rincl_fin n m l -> n <= length M.
  Proof.
    intros H.
    apply rincl_fin_chains in H.
    destruct H as (ll & H1 & H2 & H3 & _).
    destruct (le_lt_dec n (length M)) as [ | C ]; auto.
    subst n; destruct H1.
    apply finite_php_dup with M; auto.
  Qed.

  Theorem wf_rincl_fin : well_founded rincl_fin.
  Proof.
    apply wf_chains.
    intros l; exists (length M).
    intros ? ?; apply rincl_fin_chain_bounded.
  Qed.

End rincl_fin.

Arguments wf_rincl_fin {X}.


From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (qreva x (rev y))) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite rev_rev. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite (eq_refl : Cons n (rev y) = append (rev (Cons n Nil)) (rev y)). rewrite <- rev_append. rewrite IHx. rewrite append_assoc. simpl. reflexivity.
Qed.


(*Here we show that for any countable type (which injects into
  the natural numbers), we can generate a list of distinct
  elements of the type not present in some input list.
  This is useful for generating new free variables and
  unique names.*)
Require Import Coq.Lists.List.
Require Import Coq.Logic.FinFun.
Require Import Coq.Arith.PeanoNat.
Require Import Common.
Section NoDupsList.

Context {A: Type}.
Variable (f: nat -> A).
(*We have an injection nat -> A*)
Variable (Hinj: forall n1 n2, f n1 = f n2 -> n1 = n2).

(*Generate list with n distinct elements*)
Definition gen_dist (n: nat) : list A :=
  map f (seq 0 n).

Lemma gen_dist_length (n: nat): length (gen_dist n) = n.
Proof.
  unfold gen_dist. rewrite map_length, seq_length. reflexivity.
Qed.

Lemma gen_dist_correct (n: nat): NoDup (gen_dist n).
Proof.
  unfold gen_dist. apply Injective_map_NoDup.
  unfold Injective. apply Hinj.
  apply seq_NoDup.
Qed.

(*Generate list of n distinct elements, all of which are not
  in l*)
Variable eq_dec: forall (x y: A), {x=y} +{x<>y}.
Definition gen_notin (n: nat) (l: list A): list A :=
  firstn n
    (filter (fun x => negb(in_dec eq_dec x l)) (gen_dist (n + length l))).

(*Proving that this is correct is not trivial*)
(*A version of the pigeonhole principle: given two lists l1 and l2,
  if l2 is larger and has no duplicates, it has at least
    (length l2) - (length l1) elements that are not in l1*)
Lemma php (l1 l2: list A):
  NoDup l2 ->
  length l1 <= length l2 ->
  length l2 - length l1 <=
    length (filter (fun x => negb(in_dec eq_dec x l1)) l2).
Proof.
  (*Try alternate, then go back*)
  revert l2. induction l1; intros; auto.
  - simpl. rewrite Nat.sub_0_r.
    assert ((filter (fun _ : A => true) l2) = l2). {
      apply all_filter. apply forallb_forall. auto.
    }
    rewrite H1. auto.
  - destruct (in_dec eq_dec a l2).
    2: {
      rewrite filter_in_notin; auto; simpl.
      specialize (IHl1 _ H). lia.
    }
    (*For this one, we have to split l2 depending on
      where a appears*)
    apply in_split in i.
    destruct i as [p1 [p2 Hl2]].
    rewrite Hl2, filter_app, filter_cons.
    assert (Hnodup:=H).
    rewrite Hl2 in H.
    rewrite NoDup_app_iff in H. destruct H as [Hn1 [Hn2 [Hnotin1 Hnotin2]]].
    inversion Hn2. subst x l.
    assert (~ In a p1). {
      apply Hnotin2. left; auto.
    }
    rewrite !filter_in_notin; auto.
    simpl. destruct (eq_dec a a); auto; try contradiction.
    simpl. rewrite <- filter_app.
    assert (Hn3: NoDup (p1 ++ p2)). {
      rewrite NoDup_app_iff. repeat split; auto.
      - intros; intro C. apply (Hnotin1 x H1). right; auto.
      - intros; apply Hnotin2. right; auto.
    }
    specialize (IHl1 _ Hn3).
    rewrite !app_length; simpl. simpl in H0.
    rewrite !app_length in IHl1. lia.
Qed.

(*Now we can prove our function correct*)
Lemma gen_notin_length (n: nat) (l: list A):
  length (gen_notin n l) = n.
Proof.
  unfold gen_notin.
  rewrite firstn_length_le; auto.
  pose proof (php l (gen_dist (n + length l))).
  rewrite gen_dist_length in H.
  specialize (H (gen_dist_correct _)). lia.
Qed.

Lemma gen_notin_nodup (n: nat) (l: list A):
  NoDup (gen_notin n l).
Proof.
  unfold gen_notin.
  apply NoDup_firstn.
  apply NoDup_filter.
  apply gen_dist_correct.
Qed.

Lemma gen_notin_notin (n: nat) (l: list A):
  forall y, In y (gen_notin n l) -> ~ In y l.
Proof.
  intros. unfold gen_notin in H.
  apply In_firstn in H.
  rewrite in_filter in H. destruct H.
  destruct (in_dec eq_dec y l); auto. inversion H.
Qed.

Lemma add_notin_nodup (l1: list A) n:
  NoDup l1 ->
  NoDup (l1 ++ gen_notin n l1).
Proof.
  intros.
  rewrite NoDup_app_iff; split_all; auto.
  + apply gen_notin_nodup; apply nth_vs_inj.
  + intros. intro C. apply gen_notin_notin in C. contradiction.
  + intros. apply gen_notin_notin in H0. auto.
Qed.

End NoDupsList.

(*We want to apply this to strings and vsymbols.
  To do this, we want to give decent names (at least
  x0, x1, etc) and not just 0, 00, 000 or something
  easy to define and prove injective. Converting
  nats to strings is surprisingly difficult*)

(*Apply this to vsymbols*)
Require Import Types.
Require Import Syntax.
Require Import Coq.Strings.String.
Require Import FunInd.
Require Import Recdef.
From mathcomp Require Import all_ssreflect ssrnat div.

Set Bullet Behavior "Strict Subproofs".

Section NatToStr.

Local Open Scope string_scope.

Definition nat_to_digit (n : nat) : string :=
  match n with
    | 0 => "0"%string
    | 1 => "1"%string
    | 2 => "2"%string
    | 3 => "3"%string
    | 4 => "4"%string
    | 5 => "5"%string
    | 6 => "6"%string
    | 7 => "7"%string
    | 8 => "8"%string
    | _ => "9"%string
  end.

(*Gives list of digits in reverse order*)
Function nat_to_digits (n : nat) {measure (fun x => x) n} : list string :=
  if n < 10 then [nat_to_digit (n %% 10)] else
  nat_to_digit (n %% 10) :: nat_to_digits (n %/ 10).
Proof.
  move=> n Hn10. apply /ltP.
  apply ltn_Pdiv=>//.
  move: Hn10. by case: n.
Defined.

Lemma nat_to_digits_simpl n :
  nat_to_digits n = nat_to_digit (n %% 10) :: if n < 10 then nil else
    nat_to_digits (n %/ 10).
Proof.
  rewrite nat_to_digits_equation.
  by case: (n < 10).
Qed.

(*Injectivity*)

Ltac solve_or :=
  match goal with
  | |- ?P \/ ?Q => solve[left; solve_or] + solve[right; solve_or]
  | |- _ => auto
  end.

(*Makes things easier*)
Lemma nat_lt10 (n: nat):
  n < 10 ->
  n = 0 \/ n = 1 \/ n = 2 \/ n = 3 \/ n =4 \/
  n = 5 \/ n = 6 \/ n = 7 \/ n = 8 \/ n= 9.
Proof.
  move=> Hn.
  do 10 (destruct n as [| n]; solve_or). inversion Hn.
Qed.

Ltac case_or :=
  repeat match goal with
  | H: ?P \/ ?Q |- _ => destruct H
  end.

(*Just do all 100 cases*)
Lemma nat_to_digit_inj (n1 n2: nat):
  n1 < 10 ->
  n2 < 10 ->
  nat_to_digit n1 = nat_to_digit n2 ->
  n1 = n2.
Proof.
  move=>Hn1 Hn2.
  apply nat_lt10 in Hn1; apply nat_lt10 in Hn2.
  case_or; subst; simpl; auto; intros H; inversion H.
Qed.

Lemma nat_to_digits_nil n:
  ~ (nat_to_digits n = nil).
Proof.
  by rewrite nat_to_digits_simpl.
Qed.

Lemma modn_inj (m n d: nat):
  m < d ->
  n < d ->
  m = n %[mod d] ->
  m = n.
Proof.
  move=> Hm Hn Hmod.
  by rewrite (divn_eq m d) (divn_eq n d) !divn_small.
Qed.

Lemma nat_to_digits_inj n1 n2:
  nat_to_digits n1 = nat_to_digits n2 ->
  n1 = n2.
Proof.
  move: n2.
  apply nat_to_digits_ind with
    (P:=fun m1 m2 => forall n2, m2 = nat_to_digits n2 -> m1 = n2).
  - move=> n Hn n2.
    rewrite nat_to_digits_simpl => [[]].
    case Hn2: (n2 < 10).
    + move=> Hdig _.
      apply nat_to_digit_inj in Hdig; try by
      apply ltn_pmod.
      by apply (modn_inj _ _ _ Hn).
    + by rewrite nat_to_digits_simpl.
  - move=> n2 [//| Hn2 _ Hdigits n3].
    rewrite (nat_to_digits_simpl n3).
    case Hn3: (n3 < 10).
    + move=> []. by rewrite nat_to_digits_simpl.
    + move=> [Heq1 Heq2].
      apply Hdigits in Heq2.
      apply nat_to_digit_inj in Heq1; try by
      apply ltn_pmod.
      by rewrite (divn_eq n2 10) (divn_eq n3 10) Heq1 Heq2.
Qed.

(*Convert digits to string*)
Definition digits_to_string (l: list string) : string :=
  concat "" l.

(*How is this not in the stdlib?*)
Lemma append_length s1 s2:
  length (s1 ++ s2) = length s1 + length s2.
Proof.
  elim: s1 =>//=a s IH. by rewrite IH.
Qed.

(*Intermediate cases for injectivity - concat is annoying*)

Lemma concat_nil l:
  (forall x, In x l -> length x = 1) ->
  concat "" l = "" -> l = nil.
Proof.
  case: l => //= x l Hallin Heq.
  have //: 1 <= length "".
  rewrite -Heq {Heq}. move: Hallin.
  by case: l =>//=[Hallin | y l Hallin];
  [|rewrite append_length]; rewrite Hallin; auto.
Qed.

Lemma concat_cons_case x1 x2 y1 l1:
  length x1 = 1 ->
  length x2 = 1 ->
  length y1 = 1 ->
  x1 ++ concat "" (y1 :: l1) <> x2.
Proof.
  move=> Hlen1 Hlen2 Hlen3.
  rewrite /=. case: l1=>[| z1 l1].
  - move=> Heq.
    have: length x1 + length y1 = length x2 by
      rewrite -Heq append_length.
    by rewrite Hlen1 Hlen2 Hlen3.
  - move=> Heq.
    have: length x1 + length y1 + length (concat "" (z1 :: l1)) =
      length x2 by rewrite -Heq !append_length addnA.
    rewrite Hlen1 Hlen2 Hlen3 => Heq2.
    by have: 1 + 1 <= 1 by rewrite -{3}Heq2.
Qed.

Lemma append_inj s1 s2 s3 s4:
  length s1 = length s2 ->
  s1 ++ s3 = s2 ++ s4 ->
  s1 = s2 /\ s3 = s4.
Proof.
  revert s2.
  elim: s1 => [[| a2 s2]//=| a1 s1/= IH [| a2 s2]//= [Hlen] [Hstr] Heq].
  apply IH in Heq=>//. case: Heq => [Hseq Hseq2].
  by subst.
Qed.

Lemma concat_cons x1 x2 l1 l2:
  (forall x, In x (x1 :: l1) -> length x = 1) ->
  (forall x, In x (x2 :: l2) -> length x = 1) ->
  concat "" (x1 :: l1) = concat "" (x2 :: l2) ->
  x1 = x2 /\ concat "" l1 = concat "" l2.
Proof.
  rewrite /=. case: l1 =>[| y1 l1]; case: l2 =>[| y2 l2] //.
  - move=>/= Hall1 Hall2 Heq. symmetry in Heq.
    by apply concat_cons_case in Heq; auto.
  - move=>/= Hall1 Hall2 Heq.
    by apply concat_cons_case in Heq; auto.
  - move=> Hall1 Hall2 Heq.
    by apply append_inj in Heq; last by
      rewrite Hall1; auto; rewrite Hall2; auto.
Qed.

Lemma digits_to_string_inj (l1 l2: list string):
  (forall x, In x l1 -> length x = 1) ->
  (forall x, In x l2 -> length x = 1) ->
  digits_to_string l1 = digits_to_string l2 ->
  l1 = l2.
Proof.
  revert l2. rewrite /digits_to_string.
  elim: l1=>[/=| x1 l1 IHl [|x2 l2]].
  - move=>l2 _ Hallin Heq.
    symmetry in Heq. by apply concat_nil in Heq.
  - move=> Hallin _ Heq. by apply concat_nil in Heq.
  - move=> Hall1 Hall2 Heq.
    apply concat_cons in Heq=>//.
    case: Heq => [Hxeq Hceq].
    rewrite Hxeq. f_equal. by apply IHl=>//;
    [intros; apply Hall1 | intros; apply Hall2]=>/=; auto.
Qed.

Lemma rev_inj {A: Type} (l1 l2: list A):
  rev l1 = rev l2 ->
  l1 = l2.
Proof.
  move=> Hrev.
  by rewrite -(revK l1) Hrev revK.
Qed.

(*All things in digit list have length 1*)
Lemma nat_to_digit_len n:
  length (nat_to_digit n) = 1.
Proof.
  repeat (destruct n; auto).
Qed.

Lemma nat_to_digits_len n:
  forall x, In x (nat_to_digits n) -> length x = 1.
Proof.
  apply nat_to_digits_ind with (P:=fun m1 m2 => forall x, In x m2 -> length x = 1).
  - move=> n1 Hn1 x/= [Hx | []]. by rewrite -Hx nat_to_digit_len.
  - move=> n1 [//| Hn1 _] IH x/= [Hh | Htl].
    + by rewrite -Hh nat_to_digit_len.
    + by apply IH.
Qed.

Lemma in_rev {A: Type} x (l: list A):
  In x l <-> In x (rev l).
Proof.
  elim: l=>//= y l IH.
  by rewrite IH rev_cons -cats1 in_app_iff /= or_false_r or_comm.
Qed.

(*Finally, the full function and theorem*)
Definition nat_to_string (n: nat) : string :=
  digits_to_string (rev (nat_to_digits n)).

(*Some tests*)
Eval compute in (nat_to_string 654).
Eval compute in (nat_to_string 0).
Eval compute in (nat_to_string 1000).

Lemma nat_to_string_inj n1 n2:
  nat_to_string n1 = nat_to_string n2 ->
  n1 = n2.
Proof.
  rewrite /nat_to_string.
  move=> Hn.
  apply digits_to_string_inj in Hn;
  try (move=> x; rewrite -in_rev; apply nat_to_digits_len).
  apply rev_inj in Hn.
  by apply nat_to_digits_inj in Hn.
Qed.

End NatToStr.

(*Get the string xn*)
Definition nth_str (n: nat) : string :=
  "x" ++ nat_to_string n.

Lemma nth_str_inj: forall n1 n2,
  nth_str n1 = nth_str n2 ->
  n1 = n2.
Proof.
  intros n1 n2. unfold nth_str.
  intros. inversion H.
  apply nat_to_string_inj in H1; auto.
Qed.

Definition nth_vs (n: nat) : vsymbol :=
  (nth_str n, vty_int).

Lemma nth_vs_inj: forall n1 n2,
  nth_vs n1 = nth_vs n2 ->
  n1 = n2.
Proof.
  intros. unfold nth_vs in H. inversion H; subst.
  apply nat_to_string_inj in H1; auto.
Qed.

(*We give a specific function for generating n distinct
  vsymbols not in list l*)
Definition gen_vars (n: nat) (l: list vsymbol) :=
  gen_notin nth_vs vsymbol_eq_dec n l.

Lemma gen_vars_length (n: nat) (l: list vsymbol):
  List.length (gen_vars n l) = n.
Proof.
  apply gen_notin_length. apply nth_vs_inj.
Qed.

Lemma gen_vars_nodup (n: nat) (l: list vsymbol):
  NoDup (gen_vars n l).
Proof.
  apply gen_notin_nodup. apply nth_vs_inj.
Qed.

Lemma gen_vars_notin (n: nat) (l: list vsymbol):
  forall x, In x (gen_vars n l) -> ~ In x l.
Proof.
  apply gen_notin_notin.
Qed.

(*And one to generate new variable names*)
Definition gen_strs (n: nat) (l: list vsymbol) : list string :=
  gen_notin nth_str string_dec n (map fst l).

Lemma gen_strs_length n l:
  List.length (gen_strs n l) = n.
Proof.
  apply gen_notin_length. apply nth_str_inj.
Qed.

Lemma gen_strs_nodup n l:
  NoDup (gen_strs n l).
Proof.
  apply gen_notin_nodup. apply nth_str_inj.
Qed.

Lemma gen_strs_notin (n: nat) (l: list vsymbol):
  forall (x: vsymbol), In (fst x) (gen_strs n l) -> ~ In x l.
Proof.
  intros. apply gen_notin_notin in H.
  rewrite in_map_iff in H. intro Hin.
  apply H. exists x. split; auto.
Qed.


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rtotal_order.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rdichotomy : forall r1 r2, r1 <> r2 -> r1 < r2 \/ r2 < r1.
Proof.
  intros x y.
  unfold not.
  intro hneq.
  destruct (Rtotal_order x y) as [ hxy | [ heq | hxy ] ].
  { left. exact hxy. }
  {
    specialize (hneq heq).
    contradiction.
  }
  { right. exact hxy. }
Qed.


Require Export Families.
Require Export Image.
Require Import ImageImplicit.
Require Import FiniteTypes.
Require Export EnsemblesTactics.

Set Implicit Arguments.

Section IndexedFamilies.

Variable A T:Type.
Definition IndexedFamily := A -> Ensemble T.
Variable F:IndexedFamily.

Inductive IndexedUnion : Ensemble T :=
  | indexed_union_intro: forall (a:A) (x:T),
    In (F a) x -> In IndexedUnion x.

Inductive IndexedIntersection : Ensemble T :=
  | indexed_intersection_intro: forall (x:T),
    (forall a:A, In (F a) x) -> In IndexedIntersection x.

End IndexedFamilies.

Section IndexedFamilyFacts.

(* unions and intersections over subsets of the index set *)
Lemma sub_indexed_union: forall {A B T:Type} (f:A->B)
  (F:IndexedFamily B T),
  let subF := (fun a:A => F (f a)) in
    Included (IndexedUnion subF) (IndexedUnion F).
Proof.
unfold Included.
intros.
destruct H.
apply indexed_union_intro with (f a).
assumption.
Qed.

Lemma sub_indexed_intersection: forall {A B T:Type} (f:A->B)
  (F:IndexedFamily B T),
  let subF := (fun a:A => F (f a)) in
    Included (IndexedIntersection F) (IndexedIntersection subF).
Proof.
unfold Included.
intros.
constructor.
destruct H.
intro.
apply H.
Qed.

Lemma empty_indexed_intersection: forall {T:Type}
  (F:IndexedFamily False T),
  IndexedIntersection F = Full_set.
Proof.
intros.
apply Extensionality_Ensembles; red; split; red; intros;
  auto with sets.
constructor.
constructor.
destruct a.
Qed.

Lemma empty_indexed_union: forall {T:Type}
  (F:IndexedFamily False T),
  IndexedUnion F = Empty_set.
Proof.
intros.
apply Extensionality_Ensembles; red; split; red; intros.
destruct H.
destruct a.
destruct H.
Qed.

Lemma finite_indexed_union {A T : Type} {F : IndexedFamily A T} :
  FiniteT A ->
  (forall a, Finite _ (F a)) ->
  Finite _ (IndexedUnion F).
Proof.
intro H.
induction H;
  intros.
- replace (IndexedUnion F) with (@Empty_set T).
  + constructor.
  + extensionality_ensembles.
    destruct a.
- replace (IndexedUnion F) with (Union (IndexedUnion (fun t => In (F (Some t)))) (F None)).
  apply Union_preserves_Finite.
  + apply IHFiniteT.
    intro.
    apply H0.
  + apply H0.
  + extensionality_ensembles.
    * econstructor.
      eassumption.
    * econstructor.
      eassumption.
    * destruct a.
      ** left.
         econstructor.
         eassumption.
      ** now right.
- replace (IndexedUnion F) with (IndexedUnion (fun x => F (f x))).
  + apply IHFiniteT.
    intro.
    apply H1.
  + extensionality_ensembles.
    * econstructor.
      eassumption.
    * destruct H0.
      rewrite <- (H3 a) in H2.
      econstructor.
      eassumption.
Qed.

End IndexedFamilyFacts.

Section IndexedFamilyToFamily.

(* relation to families of subsets of T *)
Variable T:Type.
Variable A:Type.
Variable F:IndexedFamily A T.

Definition ImageFamily : Family T :=
  Im Full_set F.

Lemma indexed_to_family_union: IndexedUnion F = FamilyUnion ImageFamily.
Proof.
apply Extensionality_Ensembles.
unfold Same_set.
unfold Included.
intuition.
destruct H.
apply family_union_intro with (F a).
apply Im_intro with a.
constructor.
reflexivity.
assumption.

destruct H.
destruct H.
apply indexed_union_intro with x0.
rewrite <- H1.
assumption.
Qed.

Lemma indexed_to_family_intersection:
  IndexedIntersection F = FamilyIntersection ImageFamily.
Proof.
apply Extensionality_Ensembles.
unfold Same_set.
unfold Included.
intuition.
constructor.
intros.
destruct H.
destruct H0.
rewrite H1.
apply H.

constructor.
intro.
destruct H.
apply H.
apply Im_intro with a.
constructor.
reflexivity.
Qed.

End IndexedFamilyToFamily.


(** * Uniform die program. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import Streams Basics QArith String Lia Lra.
Local Open Scope program_scope.
Local Open Scope string_scope.

From ITree Require Import
  ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From zar Require Import
  compile cotree cocwp cpGCL cpo cwp equidistribution eR misc itree order tactics tree.
Local Open Scope cpGCL_scope.

Require Import prelude.

Definition die (out : string) (n : nat) : cpGCL :=
  CUniform (const n) (fun m => out <-- m).

Lemma wf_die (out : string) (n : nat) :
  (0 < n)%nat ->
  wf_cpGCL (die out n).
Proof. intro Hlt; repeat constructor; auto. Qed.

(** The probability of assigning any m < n to the output variable is
    equal to 1/n. *)
Theorem die_correct (out : string) (n m : nat) :
  (m < n)%nat ->
  cwp (die out n) (fun s => if Nat.eqb (as_nat (s out)) m then 1 else 0) empty =
    1 / INeR n.
Proof.
  intro Hn.
  unfold cwp, die, wp, wlp, const; simpl; eRauto.
  unfold upd; simpl.
  rewrite String.eqb_refl; simpl.
  assert (H: sum (List.map (fun _ : nat => 1 / INeR n) (range n)) = 1).
  { rewrite sum_map_const with (c := 1 / INeR n).
    - rewrite range_length.
      unfold eRdiv.
      eRauto.
      rewrite eRinv_r; eRauto.
      destruct n.
      + inv Hn.
      + apply not_0_INeR; lia.
    - apply List.Forall_impl with (P := const True); auto.
      apply Forall_const_true. }
  rewrite H; clear H.
  eRauto.
  unfold eRdiv.
  rewrite sum_map_scalar_r.
  f_equal.
  induction n; simpl.
  { inv Hn. }
  rewrite List.map_app; simpl.
  rewrite sum_app; simpl; eRauto.
  destruct (Nat.eqb_spec n m); subst.
  - rewrite sum_map_count.
    rewrite Forall_not_in_countb_list_0.
    + rewrite INeR_0; eRauto.
    + unfold compose.
      eapply List.Forall_impl.
      2: { apply List_forall_neq_range. }
      simpl; intros a Ha HC; apply Ha.
      rewrite Nat.eqb_sym; auto.
  - rewrite IHn; eRauto; lia.
Qed.

Section die_equidistribution.
  Context (env : SamplingEnvironment) (P : St -> bool) (samples : nat -> St).
  Context (out : string) (n : nat) (Hn : (0 < n)%nat).
  Hypothesis bitstreams_samples :
    forall i, iproduces (eq (samples i)) (env.(bitstreams) i)
           (cpGCL_to_itree (die out n) empty).

  Theorem die_samples_equidistributed :
    converges (freq (is_true ∘ P) ∘ prefix samples)
      (cwp (die out n) (fun s => if P s then 1 else 0) empty).
  Proof.
    eapply cpGCL_samples_equidistributed; eauto; apply wf_die; auto.
  Qed.
End die_equidistribution.

(** Extracting the sampler. *)
From Coq Require Import ExtrOcamlBasic ExtrOcamlString.
Definition sampler (n : nat) : itree boolE nat :=
  ITree.map (fun s => as_nat (s "n")) (cpGCL_to_itree (die "n" n) empty).
Extraction "extract/die/die.ml" sampler.

(* From Coq Require Import ExtrHaskellBasic. *)
(* Extraction Language Haskell. *)
(* Definition sampler (n : nat) : itree boolE (unit + nat) := *)
(*   ITree.map (fun lr => match lr with *)
(*                     | inl tt => inl tt *)
(*                     | inr s => inr (as_nat (s "n")) *)
(*                     end) (cpGCL_to_itree_open (die "n" n) empty). *)
(* Extraction "extract/die/Sampler.hs" sampler. *)


Require Import Lia.
Require Import Bool.
Require Import List.
Import PeanoNat.Nat.
Import ListNotations.
Require Extraction.
Require Import Program.Wf.
Require Import Arith.Wf_nat.

Require Import Definitions.

Fixpoint decode_nat (x : message) : nat := match x with
  | [] => 0
  | x :: xs => (if x then 1 else 0) + 2 * decode_nat xs
  end.

Fixpoint div2 (n acc : nat) : nat * bool := match n with
  | 0       => (acc,false)
  | 1       => (acc,true)
  | S (S n) => div2 n (S acc)
  end.

Lemma div2_nk : forall n k,
   fst (div2 n (S k)) <= S (fst (div2 n k)) /\
   fst (div2 (S n) (S k)) <= S (fst (div2 (S n) k)).
Proof.
  induction n; intros.
  simpl. lia.
  split. destruct (IHn k). auto.
  simpl. destruct (IHn (S k)). lia.
Qed.

Lemma div2_le : forall n k, n <> 0 ->
  fst (div2 n k) < n + k /\
  fst (div2 (S n) k) < S n + k.
Proof.
  intros.
  generalize dependent k.
  induction n; intros. exfalso; apply H; auto.
  destruct n. simpl. lia.
  simpl. specialize IHn with k. destruct IHn as [IH1 IH2]. auto.
  split. change (div2 n (S k)) with (div2 (S (S n)) k). lia.
  destruct n. simpl. lia.
  simpl. change (div2 n (S (S k))) with (div2 (S (S n)) (S k)).
  pose proof (div2_nk (S (S n)) k). lia.
Qed.

Lemma div2_le_0 : forall n, n <> 0 ->
  fst (div2 n 0) < n.
Proof. intros. destruct (div2_le n 0); auto. lia.
Qed.

Theorem nat_two_induction (P : nat -> Prop) :
  P 0 ->
  P 1 ->
  (forall n, P n -> P (S n) -> P (S (S n))) ->
  (forall n, P n).
Proof.
  intros H0 H1 IH n.
  enough (P n /\ P (S n)) by easy.
  induction n; intuition.
Qed.

Lemma div2_eq : forall n k q b,
  div2 n k = (q, b) ->
  match b with
  | true  => 2 * q + 1 = n + 2 * k
  | false => 2 * q     = n + 2 * k
  end.
Proof.
  induction n using nat_two_induction; intros.
  - simpl in *. inversion H; subst. auto.
  - simpl in *. inversion H; subst. lia.
  - simpl in H.
    specialize IHn with (S k) q b.
    assert (S (S n) + 2 * k = n + 2 * S k). lia. rewrite H0.
    apply IHn; auto.
Qed.

Fixpoint encode_nat' (n n_meas : nat) :message := match n with
  | 0 => []
  | 1 => [B1]
  | S (S _) => (match n_meas with
    | 0 => [] (* Unreachable from encode_nat *)
    | S n_meas' => (match div2 n 0 with
      | (q,true)  => B1 :: encode_nat' q n_meas'
      | (q,false) => B0 :: encode_nat' q n_meas'
      end)
    end)
  end.
Definition encode_nat (n : nat) := encode_nat' n n.

Lemma encode_nat'_reduce : forall n X,
  n <= X ->
  encode_nat' n X = encode_nat' n n.
Proof.
  induction n using lt_wf_ind; intros.
  destruct n. destruct X; simpl; auto.
  destruct n. destruct X; simpl; auto.
  destruct X. inversion H0.
  destruct X. lia.
  destruct (div2 n 1) eqn:?.
  remember (encode_nat' (S (S n)) (S (S X))) as E.
  assert (E = match div2 (S (S n)) 0 with | (q,true) => B1 :: encode_nat' q (S X) | (q,false) => B0 :: encode_nat' q (S X) end).
  simpl. subst. auto.
  rewrite H1.
  remember (encode_nat' (S (S n)) (S (S n))) as F.
  assert (F= match div2 (S (S n)) 0 with | (q,true) => B1 :: encode_nat' q (S n) | (q,false) => B0 :: encode_nat' q (S n) end).
  simpl; subst; auto.
  rewrite H2.
  destruct (div2 (S (S n)) 0) as [q b'] eqn:?.
  clear H1. clear H2. clear HeqF. clear HeqE. clear E. clear F.
  assert (fst (div2 (S (S n)) 0) = q). rewrite Heqp0. auto.
  assert (q < S (S n)). rewrite <- H1. apply div2_le_0. auto.
  destruct b'.
  - rewrite H; try lia. assert (encode_nat' q (S n) = encode_nat' q q). rewrite H; try lia; auto. rewrite H3. auto.
  - rewrite H; try lia. assert (encode_nat' q (S n) = encode_nat' q q). rewrite H; try lia; auto. rewrite H3. auto.
Qed.

(** The main theorem relating encoding and decoding: encode_nat and decode_nat are inverses. This is the lemma that is needed for the final proof. *)
Lemma encode_inv : forall X,
  X = decode_nat (encode_nat X).
Proof.
  intros.
  induction X using lt_wf_ind.
  destruct (div2 X 0) eqn:?. destruct X. auto.
  assert (n < S X). { assert (n = fst (div2 (S X) 0)). rewrite Heqp. auto. rewrite H0. apply div2_le_0; auto. }
  specialize H with n.
  unfold encode_nat, encode_nat'; simpl; fold encode_nat'.
  destruct X; auto.
  simpl in Heqp. rewrite Heqp.
  destruct b.
  - assert (encode_nat' n (S X) = encode_nat n). { rewrite encode_nat'_reduce; auto; lia. } rewrite H1. simpl. rewrite <- H; auto.
    pose proof (div2_eq X 1 n true Heqp). simpl in H2. lia.
  - assert (encode_nat' n (S X) = encode_nat n). apply encode_nat'_reduce; try lia. rewrite H1. simpl. rewrite <- H; auto.
    pose proof (div2_eq X 1 n false Heqp). simpl in H2. lia.
Qed.