(** * More Facts about Setoid Lists *)

Require Import common.CoqLib.
Require Import common.ListPlus.
Require Import common.FstSplit.

(** ** Facts about [InA] *)

Section InAFacts.

  (** If a couple (a, b) is in the list of couples l
      then a is in (fst (split l)). *)

  Lemma InA_fst_split {A B : Type} :
    forall {eqk : A -> A -> Prop} {eqv : B -> B -> Prop} {a l} (b : B),
      let eqkv := (fun x y => eqk (fst x) (fst y) /\ eqv (snd x) (snd y)) in
      InA eqkv (a, b) l -> InA eqk a (fst (split l)).
  Proof.
    induction l.
    - intros; inversion H.
    - elim a0; intros; rewrite fst_split_cons_app; simpl.
      inversion_clear H; apply InA_cons.
      + firstorder.
      + right; apply IHl with (b := b0); auto.
  Qed.

  Hint Resolve InA_fst_split : setoidl.
  Hint Extern 1 (InA _ _ (fs _)) => eapply InA_fst_split; eauto : setoidl.

  (* Version of [not_in_fst_split] for setoid lists. *)

  Lemma not_InA_fst_split {A B : Type} :
    forall {l : list (A * B)} {eqk : A -> A -> Prop} {eqv : B -> B -> Prop} {a : A},
      ~InA eqk a (fst (split l)) ->
      let eqkv := (fun x y => eqk (fst x) (fst y) /\ eqv (snd x) (snd y)) in
      (forall b : B, ~InA eqkv (a, b) l).
  Proof.
    induction l.
    - intros; intros Hin; inversion Hin.
    - elim a; intros; intros Hin.
      specialize (InA_fst_split b0 Hin) as Hnotin_a1.
      contradiction.
  Qed.

  Hint Resolve not_InA_fst_split : setoidl.

  Lemma InA_eqk :
    forall {A B : Type} {eqk : A -> A -> Prop} (eqv : B -> B -> Prop) {x y z l},
      eqk x y ->
      Equivalence eqk ->
      let eqkv := fun x y => eqk (fst x) (fst y) /\ eqv (snd x) (snd y) in
      InA eqkv (x, z) l ->
      InA eqkv (y, z) l.
  Proof.
    induction 3;
      [ destruct y0 as (a, b); apply InA_cons_hd; firstorder
      | apply InA_cons_tl; auto].
  Qed.

  Hint Resolve InA_eqk : setoidl.
  Hint Extern 1 (InA _ (_, _) _) => eapply InA_eqk; eauto : setoidl.

  Lemma InA_setv_inv_1 :
    forall {A B : Type} {x y : A} {z v : B} {eqk eqv l} {eqk_dec : forall x y, {eqk x y} + {~eqk x y}},
      let eqkv := (fun x y => eqk (fst x) (fst y) /\ eqv (snd x) (snd y)) in
      InA eqkv (x, z) l ->
      ~eqk x y ->
      Equivalence eqk ->
      InA eqkv (x, z) (setv eqk_dec y v l).
  Proof.
    induction 1.

    all: destruct y0; intros; simpl; destruct (eqk_dec y a); auto.
    destruct H as (Heqk, Heqv); simpl in Heqk.
    apply (Equivalence_Symmetric y a) in e.
    apply (Equivalence_Transitive x a y) in e; [contradiction | auto].
  Qed.

  Hint Resolve InA_setv_inv_1 : setoidl.
  Hint Extern 1 (InA _ (_, _) (setv _ _ _ _)) => eapply InA_setv_inv_1; eauto : setoidl.

  Lemma InA_setv_inv_2 :
    forall {A B : Type} {eqk eqv} {eqk_dec : forall x y, {eqk x y} + {~eqk x y}} {y v l} {x : A} {z : B},
      let eqkv := (fun x y => eqk (fst x) (fst y) /\ eqv (snd x) (snd y)) in
      InA eqkv (x, z) (setv eqk_dec y v l) ->
      ~eqk x y ->
      Equivalence eqk ->
      InA eqkv (x, z) l.
  Proof.
    intros until l.
    functional induction (setv eqk_dec y v l) using setv_ind;
      intros *; intros InA_setv neqk Equiv_eqk.
    (* CASE l = [] *)
    inversion_clear InA_setv as [ y0 a and_ | a l InA_nil ];
      [ destruct and_; contradiction | inversion InA_nil ].
    (* CASE fst hd = y *)
    inversion_clear InA_setv as [ y0 l and_ | y0 l InA_tl ]; auto.
    destruct and_; contradiction.
    (* CASE ind. call *)
    inversion_clear InA_setv as [ y0 l and_ | y0 l InA_tl ]; auto.
  Qed.

  Hint Resolve InA_setv_inv_2 : setoidl.
  Hint Extern 1 (InA _ (_, _) (setv _ _ _ _)) => eapply InA_setv_inv_2; eauto : setoidl.

  Lemma InA_setv :
    forall {A B : Type} {x : A} {z : B} {eqk eqv} {eqk_dec : forall x y, {eqk x y} + {~eqk x y}} {l},
      let eqkv := (fun x y => eqk (fst x) (fst y) /\ eqv (snd x) (snd y)) in
      Equivalence eqk ->
      Equivalence eqv ->
      InA eqkv (x, z) (setv eqk_dec x z l).
  Proof.
    intros until l.
    functional induction (setv eqk_dec x z l) using setv_ind; intros.
    1, 2: apply InA_cons_hd; firstorder.
    apply InA_cons_tl; apply IHl0; auto.
  Qed.

  Hint Resolve InA_setv : setoidl.

  Lemma InA_setv_fst_or_in_tl :
    forall {A B : Type} {y : A} {v2 : B} {eqk eqv} {eqk_dec : forall x y, {eqk x y} + {~eqk x y}} {l} {x v1},
      let eqkv := (fun x y => eqk (fst x) (fst y) /\ eqv (snd x) (snd y)) in
      InA eqkv (x, v1) (setv eqk_dec y v2 l) ->
      (eqk x y /\ eqv v1 v2) \/ InA eqkv (x, v1) l.
  Proof.
    intros until l; functional induction (setv eqk_dec y v2 l) using setv_ind.
    inversion_clear 1; [ left; auto | inversion H0 ].
    inversion_clear 1; [ left; auto | right; auto ].
    inversion_clear 1; [ right; auto | auto ].
    edestruct IHl0 as [and_ | InA_tl ]; eauto.
  Qed.

  Lemma InA_notin_fs_setv_inv {A B : Type} :
    forall {eqk : A -> A -> Prop} {eqk_dec : forall x y, {eqk x y} + {~eqk x y}}
           {y} (b : B) {l : list (A * B)} {x},
      Equivalence eqk ->
      ~InA eqk x (fs l) ->
      ~eqk y x ->
      ~InA eqk x (fs (setv eqk_dec y b l)).
  Proof.
    intros until l; functional induction (setv eqk_dec y b l) using setv_ind;
      rewrite fs_eq_cons_app ; simpl; intros; (rewrite fs_eq_cons_app; simpl; inversion_clear 1) || inversion_clear 1;
        [ apply Equivalence_Symmetric in H3; contradiction
        | apply H0; assumption
        | apply Equivalence_Symmetric in H3; contradiction
        | apply H0; auto
        | apply H0; auto
        | generalize H3; apply IHl0; auto
        ].
  Qed.

  Hint Resolve InA_notin_fs_setv_inv : setoidl.

  Lemma InA_neqA {A : Type} :
    forall {eqA : A -> A -> Prop} {x y} {l : list A},
      Equivalence eqA ->
      InA eqA x l ->
      ~InA eqA y l ->
      ~eqA x y.
  Proof. intros; intro; specialize (InA_eqA H H2 H0); contradiction. Qed.

  Hint Resolve InA_neqA : setoidl.

  Lemma nInA_eqA {A : Type} :
    forall {eqA : A -> A -> Prop} {x y} {l : list A},
      Equivalence eqA ->
      eqA x y ->
      ~InA eqA x l ->
      ~InA eqA y l.
  Proof.
    intros *; intros Equiv_eqA eqA_xy nInA InA_y.
    apply nInA; eauto; symmetry in eqA_xy; eauto.
    eapply InA_eqA; eauto.
  Qed.

  Hint Resolve nInA_eqA : setoidl.

  Lemma InA_fs_InA_fs_setv :
    forall {A B : Type} {eqk} {eqk_dec : forall x y : A, {eqk x y} + {~ eqk x y}} {y b}
           {l : list (A * B)} {x},
      Equivalence eqk ->
      InA eqk x (fs l) ->
      InA eqk x (fs (setv eqk_dec y b l)).
  Proof.
    intros until l; functional induction (setv eqk_dec y b l) using setv_ind.
    inversion 2.
    rewrite fs_eq_cons_app; cbn; intros x Equiv_eqk InA_.
    rewrite fs_eq_cons_app; cbn.
    inversion_clear InA_ as [z l eqk_xa | z l InA_tl]; [ | eauto].
    eapply InA_cons_hd; transitivity a; auto.
    symmetry; auto.
    rewrite fs_eq_cons_app; cbn; intros x Equiv_eqk InA_.
    rewrite fs_eq_cons_app; cbn.
    inversion InA_; auto.
  Qed.

  Hint Resolve nInA_eqA : setoidl.

  Lemma InA_setv_eqk :
    forall {A B : Type} {y : A} {z : B} {eqk : A -> A -> Prop} {eqv : B -> B -> Prop}
           {eqk_dec : forall x0 y0 : A, {eqk x0 y0} + {~ eqk x0 y0}} {l : list (A * B)} {x : A},
      let eqkv := fun x0 y : A * B => eqk (fst x0) (fst y) /\ eqv (snd x0) (snd y) in
      Equivalence eqk -> Equivalence eqv -> eqk x y -> InA eqkv (x, z) (setv eqk_dec y z l).
  Proof.
    intros until l; functional induction (setv eqk_dec y z l) using setv_ind.
    constructor 1; cbn; split; eauto with relations.
    constructor 1; cbn; split; eauto with relations.
    constructor 2; eauto.
  Qed.

  Hint Resolve InA_setv_eqk : setoidl.

  Lemma InA_eq_In :
    forall [A : Type] (l : list A) (x : A),
      InA eq x l -> List.In x l.
  Proof. induction 1; auto.
         rewrite H; auto with datatypes.
  Qed.

  Hint Resolve InA_eq_In : setoidl.

  Lemma InA_eq_pair_In :
    forall [A B : Type] (l : list (A * B)) (x : A) (y : B),
      InA (fun x1 y1 => fst x1 = fst y1 /\ snd x1 = snd y1) (x, y) l -> List.In (x, y) l.
  Proof. induction 1; auto.
         destruct y0 as (a, b).
         cbn in H; destruct H as (e1, e2); rewrite e1, e2.
         auto with datatypes.
  Qed.

  Hint Resolve InA_eq_pair_In : setoidl.

  Lemma length_neq_O :
    forall {A : Type} (eqA : A -> A -> Prop) (l : list A),
      (exists a, InA eqA a l) -> length l <> 0.
  Proof. induction l; [
           destruct 1 as (a, InA_); inversion InA_
         | cbn; lia ].
  Qed.

End InAFacts.

#[export] Hint Resolve InA_fst_split : setoidl.
#[export] Hint Extern 1 (InA _ _ (fs _)) => eapply InA_fst_split : setoidl.
#[export] Hint Resolve not_InA_fst_split : setoidl.
#[export] Hint Resolve InA_eqk : setoidl.
#[export] Hint Extern 1 (InA _ (_, _) _) => eapply InA_eqk : setoidl.
#[export] Hint Resolve InA_setv_inv_1 : setoidl.
#[export] Hint Resolve InA_setv_inv_2 : setoidl.
#[export] Hint Resolve InA_setv : setoidl.
#[export] Hint Extern 1 (InA _ (?x, ?z) (setv _ ?x ?z _)) => apply InA_setv : setoidl.
#[export] Hint Extern 1 (InA _ (?x, _) (setv _ ?y _ _)) => eapply InA_setv_inv_1; eauto : setoidl.
#[export] Hint Resolve InA_notin_fs_setv_inv : setoidl.
#[export] Hint Resolve InA_neqA : setoidl.
#[export] Hint Resolve nInA_eqA : setoidl.
#[export] Hint Resolve InA_fs_InA_fs_setv : setoidl.
#[export] Hint Resolve InA_setv_eqk : setoidl.
#[export] Hint Resolve InA_eq_In : setoidl.
#[export] Hint Resolve InA_eq_pair_In : setoidl.

(** ** Facts about [NoDupA] *)

Section NoDupAFacts.

  Lemma NoDupA_tl (A : Type) :
    forall {eqA : A -> A -> Prop} {a : A} {l : list A},
      NoDupA eqA (a :: l) ->
      NoDupA eqA l.
  Proof. inversion 1; auto. Qed.

  Lemma NoDupA_fs_tl (A B : Type) :
    forall {eqA : A -> A -> Prop} {a : A} {b : B} {l : list (A * B)},
      NoDupA eqA (fs ((a, b) :: l)) ->
      NoDupA eqA (fs l).
  Proof.  intros *; rewrite fs_eq_cons_app; simpl; inversion 1; auto. Qed.

  Hint Resolve NoDupA_tl : setoidl.
  Hint Resolve NoDupA_fs_tl : setoidl.

  Lemma NoDupA_fs_eqk_eq (A : Type) {B : Type} :
    forall {eqk : A -> A -> Prop} {l : list (A * B)} {a b b'},
      Equivalence eqk ->
      NoDupA eqk (fs l) ->
      let eqkv := (fun x y => eqk (fst x) (fst y) /\ (snd x) = (snd y)) in
      InA eqkv (a, b) l ->
      InA eqkv (a, b') l ->
      b = b'.
  Proof.
    induction l.

    (* BASE CASE *)
    - inversion 3.

    (* IND. CASE *)
    - intros.
      lazymatch goal with
      | [ H: NoDupA _ _ |- _ ] =>
        rewrite fs_eq_cons_app in H; destruct a as (a1, b1);
          simpl in H; inversion_clear H
      end.

      lazymatch goal with
      | [ H: InA _ (a0, b) _, H': InA _ (a0, b') _ |- _ ] =>
        inversion_clear H; inversion_clear H'
      end.

      (* 4 subgoals *)

      (* [(a0, b) = (a1, b1)] and [(a0, b') = (a1, b1)] *)
      + firstorder; transitivity b1; auto.

      (* [(a0, b) = (a1, b1)] and [(a0, b') ∈ l].
       Then, [eqk a0 a1], then [(a1, b') ∈ l], then [a1 ∈ (fs l)].
       Contradicts [a1 ∉ (fs l)].  *)
      + elimtype False; lazymatch goal with
                        | [ H: ~InA _ _ _ |- _ ] =>
                          apply H
                        end.
        apply (@InA_fst_split A B eqk eq a1 l b').
        eapply InA_eqk; eauto; firstorder.

      + elimtype False; lazymatch goal with
                        | [ H: ~InA _ _ _ |- _ ] =>
                          apply H
                        end.
        apply (@InA_fst_split A B eqk eq a1 l b).
        eapply InA_eqk; eauto; firstorder.

      + eapply IHl; eauto.
  Qed.

  Hint Resolve NoDupA_fs_eqk_eq : setoidl.

  Lemma NoDupA_setv_cons (A : Type) {B : Type} :
    forall {eqk : A -> A -> Prop} {eqk_dec : forall x y, {eqk x y} + {~eqk x y}} {a b} {l : list (A * B)},
      Equivalence eqk ->
      NoDupA eqk (fs l) ->
      NoDupA eqk (fs (setv eqk_dec a b l)).
  Proof.
    intros until l; functional induction (setv eqk_dec a b l) using setv_ind.
    - intros; apply NoDupA_singleton.
    - intros Equiv_eqk NoDupA_; rewrite fs_eq_cons_app; cbn.
      apply NoDupA_cons; eauto with setoidl.
      rewrite fs_eq_cons_app in NoDupA_; cbn in NoDupA_.
      inversion_clear NoDupA_; eauto with setoidl.
      eapply nInA_eqA; eauto.
      symmetry; auto.
    - rewrite fs_eq_cons_app; cbn; intros Equiv_eqk NoDupA_.
      rewrite fs_eq_cons_app; cbn.
      eapply NoDupA_cons; inversion_clear NoDupA_; eauto with setoidl.
  Qed.

  Hint Resolve NoDupA_setv_cons : setoidl.

  Lemma NoDupA_app_comm :
    forall {A : Type} {eqA : A -> A -> Prop} {l m},
      Equivalence eqA ->
      NoDupA eqA (l ++ m) -> NoDupA eqA (m ++ l).
  Proof.
    induction m.
    rewrite app_nil_l, app_nil_r; auto.
    intros Equiv_eqA NoDupA_.
    rewrite <- app_comm_cons.
    constructor; eapply NoDupA_swap in NoDupA_; eauto; inversion_clear NoDupA_; eauto.
    intros InA_app1; apply H.
    rewrite InA_app_iff; rewrite InA_app_iff in InA_app1; firstorder.
  Qed.

  Hint Resolve NoDupA_app_comm : setoidl.

End NoDupAFacts.

#[export] Hint Resolve NoDupA_fs_eqk_eq : setoidl.
#[export] Hint Resolve NoDupA_setv_cons : setoidl.
#[export] Hint Resolve NoDupA_tl : setoidl.
#[export] Hint Resolve NoDupA_fs_tl : setoidl.
#[export] Hint Resolve NoDupA_app_comm : setoidl.

(** ** Facts about both [InA] and [NoDupA] *)

Section InAAnDNoDupAFacts.

  Lemma neqk_if_InA_NoDupA (A : Type) {B : Type} :
    forall {eqk : A -> A -> Prop} {eqv : B -> B -> Prop} {l : list (A * B)} {x y : A} {b1 b2 : B},
      Equivalence eqk ->
      let eqkv := (fun x y => eqk (fst x) (fst y) /\ eqv (snd x) (snd y)) in
      InA eqkv (x, b1) l ->
      NoDupA eqk (fs ((y, b2) :: l)) ->
      ~eqk x y.
  Proof.
    intros *; rewrite fs_eq_cons_app; cbn.
    inversion_clear 3.
    eapply @InA_neqA with (x := x) (l := fs l); eauto with setoidl typeclass_instances.
  Qed.

  Hint Resolve neqk_if_InA_NoDupA : setoidl.
  Hint Extern 1 False => eapply neqk_if_InA_NoDupA : setoidl.

  Lemma eqv_if_InA_NoDupA_setv :
    forall {A B : Type} {eqk : A -> A -> Prop} {eqk_dec : forall x0 y : A, {eqk x0 y} + {~ eqk x0 y}}
           {x : A} {z : B} {l : list (A * B)} {y},
      let eqkv := fun x0 y : A * B => eqk (fst x0) (fst y) /\ eq (snd x0) (snd y) in
      Equivalence eqk -> InA eqkv (x, y) (setv eqk_dec x z l) -> NoDupA eqk (fs l) -> y = z.
  Proof.
    intros until l.
    functional induction (setv eqk_dec x z l) using setv_ind.
    (* CASE l = [(x, z)] *)
    inversion_clear 2 as [ (a, b) l eqkv_ | (a, b) l InA_ ];
      [ simpl in eqkv_; firstorder | inversion InA_ ].
    (* CASE l = [(x, z) :: tl] *)
    inversion_clear 2 as [ (a1, b1) l eqkv_ | (a1, b1) l InA_ ];
      [ simpl in eqkv_; firstorder | intros; exfalso ].
    eauto with setoidl.
    (* CASE l = [(x, z) :: tl] *)
    inversion_clear 2 as [ (a1, b1) l eqkv_ | (a1, b1) l InA_ ];
      [ simpl in eqkv_; destruct eqkv_; contradiction |
        intros; eapply IHl0; eauto with setoidl ].
  Qed.

  Hint Resolve eqv_if_InA_NoDupA_setv : setoidl.

End InAAnDNoDupAFacts.

#[export] Hint Resolve neqk_if_InA_NoDupA : setoidl.
#[export] Hint Extern 1 False => eapply neqk_if_InA_NoDupA : setoidl.
#[export] Hint Resolve eqv_if_InA_NoDupA_setv : setoidl.


Require Import Coq.ZArith.ZArith Coq.micromega.Psatz.
Require Import Crypto.LegacyArithmetic.Interface.
Require Import Crypto.LegacyArithmetic.InterfaceProofs.
Require Import Crypto.LegacyArithmetic.Double.Core.
Require Import Crypto.LegacyArithmetic.Double.Proofs.Decode.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SimplifyProjections.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Prod.
Import Bug5107WorkAround.
Import BoundedRewriteNotations.

Local Coercion Z.of_nat : nat >-> Z.
Local Notation eta x := (fst x, snd x).

Local Open Scope Z_scope.
Local Opaque tuple_decoder.

Lemma ripple_carry_tuple_SS' {T} f k xss yss carry
  : @ripple_carry_tuple T f (S (S k)) xss yss carry
    = dlet xss := xss in
      dlet yss := yss in
      let '(xs, x) := eta xss in
      let '(ys, y) := eta yss in
      dlet addv := (@ripple_carry_tuple _ f (S k) xs ys carry) in
      let '(carry, zs) := eta addv in
      dlet fxy := (f x y carry) in
      let '(carry, z) := eta fxy in
      (carry, (zs, z)).
Proof. reflexivity. Qed.

Lemma ripple_carry_tuple_SS {T} f k xss yss carry
  : @ripple_carry_tuple T f (S (S k)) xss yss carry
    = let '(xs, x) := eta xss in
      let '(ys, y) := eta yss in
      let '(carry, zs) := eta (@ripple_carry_tuple _ f (S k) xs ys carry) in
      let '(carry, z) := eta (f x y carry) in
      (carry, (zs, z)).
Proof.
  rewrite ripple_carry_tuple_SS'.
  eta_expand.
  reflexivity.
Qed.

Lemma carry_is_good (n z0 z1 k : Z)
  : 0 <= n ->
    0 <= k ->
    (z1 + z0 >> k) >> n = (z0 + z1 << k) >> (k + n) /\
    (z0 mod 2 ^ k + ((z1 + z0 >> k) mod 2 ^ n) << k)%Z = (z0 + z1 << k) mod (2 ^ k * 2 ^ n).
Proof.
  intros.
  assert (0 < 2 ^ n) by auto with zarith.
  assert (0 < 2 ^ k) by auto with zarith.
  assert (0 < 2^n * 2^k) by nia.
  autorewrite with Zshift_to_pow push_Zpow.
  rewrite <- (Zmod_small ((z0 mod _) + _) (2^k * 2^n)) by (Z.div_mod_to_quot_rem; nia).
  rewrite <- !Z.mul_mod_distr_r by lia.
  rewrite !(Z.mul_comm (2^k)); pull_Zmod.
  split; [ | apply f_equal2 ];
    Z.div_mod_to_quot_rem; nia.
Qed.
Section carry_sub_is_good.
  Context (n k z0 z1 : Z)
          (Hn : 0 <= n)
          (Hk : 0 <= k)
          (Hz1 : -2^n < z1 < 2^n)
          (Hz0 : -2^k <= z0 < 2^k).

  Lemma carry_sub_is_good_carry
    : ((z1 - if z0 <? 0 then 1 else 0) <? 0) = ((z0 + z1 << k) <? 0).
  Proof using Hk Hz0.
    clear n Hn Hz1.
    assert (0 < 2 ^ k) by auto with zarith.
    autorewrite with Zshift_to_pow.
    repeat match goal with
           | _ => progress break_match
           | [ |- context[?x <? ?y] ] => destruct (x <? y) eqn:?
           | _ => reflexivity
           | _ => progress Z.ltb_to_lt
           | [ |- true = false ] => exfalso
           | [ |- false = true ] => exfalso
           | [ |- False ] => nia
           end.
  Qed.
  Lemma carry_sub_is_good_value
    : (z0 mod 2 ^ k + ((z1 - if z0 <? 0 then 1 else 0) mod 2 ^ n) << k)%Z
      = (z0 + z1 << k) mod (2 ^ k * 2 ^ n).
  Proof using Type*.
    assert (0 < 2 ^ n) by auto with zarith.
    assert (0 < 2 ^ k) by auto with zarith.
    assert (0 < 2^n * 2^k) by nia.
    autorewrite with Zshift_to_pow push_Zpow.
    rewrite <- (Zmod_small ((z0 mod _) + _) (2^k * 2^n)) by (Z.div_mod_to_quot_rem; nia).
    rewrite <- !Z.mul_mod_distr_r by lia.
    rewrite !(Z.mul_comm (2^k)); pull_Zmod.
    apply f_equal2; Z.div_mod_to_quot_rem; break_match; Z.ltb_to_lt; try reflexivity;
      match goal with
      | [ q : Z |- _ = _ :> Z ]
        => first [ cut (q = -1); [ intro; subst; ring | nia ]
                 | cut (q = 0); [ intro; subst; ring | nia ]
                 | cut (q = 1); [ intro; subst; ring | nia ] ]
      end.
  Qed.
End carry_sub_is_good.

Definition carry_is_good_carry n z0 z1 k H0 H1 := proj1 (@carry_is_good n z0 z1 k H0 H1).
Definition carry_is_good_value n z0 z1 k H0 H1 := proj2 (@carry_is_good n z0 z1 k H0 H1).

Section ripple_carry_adc.
  Context {n W} {decode : decoder n W} (adc : add_with_carry W).

  Lemma ripple_carry_adc_SS k xss yss carry
    : ripple_carry_adc (k := S (S k)) adc xss yss carry
      = let '(xs, x) := eta xss in
        let '(ys, y) := eta yss in
        let '(carry, zs) := eta (ripple_carry_adc (k := S k) adc xs ys carry) in
        let '(carry, z) := eta (adc x y carry) in
        (carry, (zs, z)).
  Proof using Type. apply ripple_carry_tuple_SS. Qed.

  Local Opaque Z.of_nat.
  Global Instance ripple_carry_is_add_with_carry
    : forall {k}
             {isdecode : is_decode decode}
             {is_adc : is_add_with_carry adc},
      is_add_with_carry (ripple_carry_adc (k := k) adc).
  Proof using Type.
    destruct k as [|k]; intros isdecode is_adc.
    { constructor; simpl; intros; autorewrite with zsimplify; reflexivity. }
    { induction k as [|k IHk].
      { cbv [ripple_carry_adc ripple_carry_tuple to_list].
        constructor; simpl @fst; simpl @snd; intros;
          simpl; pull_decode; reflexivity. }
      { apply Build_is_add_with_carry'; intros x y c.
        assert (0 <= n) by (destruct x; eauto using decode_exponent_nonnegative).
        assert (2^n <> 0) by auto with zarith.
        assert (0 <= S k * n) by nia.
        rewrite !tuple_decoder_S, !ripple_carry_adc_SS by assumption.
        simplify_projections; push_decode; generalize_decode.
        erewrite carry_is_good_carry, carry_is_good_value by lia.
        autorewrite with pull_Zpow push_Zof_nat zsimplify Zshift_to_pow.
        split; apply f_equal2; nia. } }
  Qed.

End ripple_carry_adc.

Hint Extern 2 (@is_add_with_carry _ (tuple ?W ?k) (@tuple_decoder ?n _ ?decode _) (@ripple_carry_adc _ ?adc _))
=> apply (@ripple_carry_is_add_with_carry n W decode adc k) : typeclass_instances.
Hint Resolve (fun n W decode adc isdecode isadc
              => @ripple_carry_is_add_with_carry n W decode adc 2 isdecode isadc
                 : @is_add_with_carry (Z.of_nat 2 * n) (W * W) (@tuple_decoder n W decode 2) (@ripple_carry_adc W adc 2))
  : typeclass_instances.

Section ripple_carry_subc.
  Context {n W} {decode : decoder n W} (subc : sub_with_carry W).

  Lemma ripple_carry_subc_SS k xss yss carry
    : ripple_carry_subc (k := S (S k)) subc xss yss carry
      = let '(xs, x) := eta xss in
        let '(ys, y) := eta yss in
        let '(carry, zs) := eta (ripple_carry_subc (k := S k) subc xs ys carry) in
        let '(carry, z) := eta (subc x y carry) in
        (carry, (zs, z)).
  Proof using Type. apply ripple_carry_tuple_SS. Qed.

  Local Opaque Z.of_nat.
  Global Instance ripple_carry_is_sub_with_carry
    : forall {k}
             {isdecode : is_decode decode}
             {is_subc : is_sub_with_carry subc},
      is_sub_with_carry (ripple_carry_subc (k := k) subc).
  Proof using Type.
    destruct k as [|k]; intros isdecode is_subc.
    { constructor; repeat (intros [] || intro); autorewrite with simpl_tuple_decoder zsimplify; reflexivity. }
    { induction k as [|k IHk].
      { cbv [ripple_carry_subc ripple_carry_tuple to_list].
        constructor; simpl @fst; simpl @snd; intros;
          simpl; push_decode; autorewrite with zsimplify; reflexivity. }
      { apply Build_is_sub_with_carry'; intros x y c.
        assert (0 <= n) by (destruct x; eauto using decode_exponent_nonnegative).
        assert (2^n <> 0) by auto with zarith.
        assert (0 <= S k * n) by nia.
        rewrite !tuple_decoder_S, !ripple_carry_subc_SS by assumption.
        simplify_projections; push_decode; generalize_decode.
        erewrite (carry_sub_is_good_carry (S k * n)), carry_sub_is_good_value by (break_match; lia).
        autorewrite with pull_Zpow push_Zof_nat zsimplify Zshift_to_pow.
        split; apply f_equal2; nia. } }
  Qed.

End ripple_carry_subc.

Hint Extern 2 (@is_sub_with_carry _ (tuple ?W ?k) (@tuple_decoder ?n _ ?decode _) (@ripple_carry_subc _ ?subc _))
=> apply (@ripple_carry_is_sub_with_carry n W decode subc k) : typeclass_instances.
Hint Resolve (fun n W decode subc isdecode issubc
              => @ripple_carry_is_sub_with_carry n W decode subc 2 isdecode issubc
                 : @is_sub_with_carry (Z.of_nat 2 * n) (W * W) (@tuple_decoder n W decode 2) (@ripple_carry_subc W subc 2))
  : typeclass_instances.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_differenceofparts.
Require Import ProofCheckingEuclid.lemma_doublereverse.
Require Import ProofCheckingEuclid.lemma_extensionunique.
Require Import ProofCheckingEuclid.lemma_interior5.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_ACD_ABD.
Require Import ProofCheckingEuclid.lemma_partnotequalwhole.
Require Import ProofCheckingEuclid.lemma_onray_orderofpoints_any.

Section Euclid.

Context `{Ax1:euclidean_neutral_ruler_compass}.

Lemma lemma_layoffunique :
	forall A B C D,
	OnRay A B C ->
	OnRay A B D ->
	Cong A C A D->
	eq C D.
Proof.
	intros A B C D.
	intros OnRay_AB_C.
	intros OnRay_AB_D.
	intros Cong_AC_AD.

	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AC_AD) as Cong_AD_AC.
	pose proof (cn_congruencereflexive A B) as Cong_AB_AB.
	pose proof (cn_congruencereflexive B C) as Cong_BC_BC.
	pose proof (cn_congruencereflexive A C) as Cong_AC_AC.

	pose proof (
		lemma_onray_orderofpoints_any _ _ _ OnRay_AB_C
	) as BetS_A_C_B_or_eq_B_C_or_BetS_A_B_C.
	pose proof (
		lemma_onray_orderofpoints_any _ _ _ OnRay_AB_D
	) as BetS_A_D_B_or_eq_B_D_or_BetS_A_B_D.

	destruct BetS_A_C_B_or_eq_B_C_or_BetS_A_B_C as [BetS_A_C_B | [eq_B_C | BetS_A_B_C]].
	{
		(* case BetS_A_C_B *)
		destruct BetS_A_D_B_or_eq_B_D_or_BetS_A_B_D as [BetS_A_D_B | [eq_B_D | BetS_A_B_D]].
		{
			(* case BetS_A_D_B *)
			pose proof (
				lemma_differenceofparts _ _ _ _ _ _ Cong_AC_AD Cong_AB_AB BetS_A_C_B BetS_A_D_B
			) as Cong_CB_DB.
			pose proof (lemma_congruenceflip _ _ _ _ Cong_CB_DB) as (Cong_BC_BD & _ & _).
			pose proof (
				lemma_interior5
				_ _ _ _
				_ _ _ _
				BetS_A_C_B
				BetS_A_D_B
				Cong_AC_AD
				Cong_CB_DB
				Cong_AC_AC
				Cong_BC_BC
			) as Cong_CC_DC.
			assert (~ neq C D) as n_neq_C_D.
			{
				intros neq_C_D.

				pose proof (lemma_doublereverse _ _ _ _ Cong_CC_DC) as (Cong_CD_CC & _).
				pose proof (axiom_nocollapse _ _ C C neq_C_D Cong_CD_CC) as neq_C_C.
				unfold neq in neq_C_C.
				assert (eq C C) as eq_C_C by (reflexivity).

				contradict eq_C_C.
				exact neq_C_C.
			}
			unfold neq in n_neq_C_D.
			apply Classical_Prop.NNPP in n_neq_C_D.
			exact n_neq_C_D.
		}
		{
			(* case eq_B_D *)
			assert (BetS A C D) as BetS_A_C_D by (rewrite <- eq_B_D; exact BetS_A_C_B).
			assert (~ neq C D) as n_neq_C_D.
			{
				intros neq_C_D.

				pose proof (lemma_partnotequalwhole _ _ _ BetS_A_C_D) as n_Cong_AC_AD.

				contradict n_Cong_AC_AD.
				exact Cong_AC_AD.
			}
			unfold neq in n_neq_C_D.
			apply Classical_Prop.NNPP in n_neq_C_D.
			exact n_neq_C_D.
		}
		{
			(* case BetS_A_B_D *)
			pose proof (
				lemma_orderofpoints_ABC_ACD_ABD _ _ _ _ BetS_A_C_B BetS_A_B_D
			) as BetS_A_C_D.
			assert (~ neq C D) as n_neq_C_D.
			{
				intros neq_C_D.

				pose proof (lemma_partnotequalwhole _ _ _ BetS_A_C_D) as n_Cong_AC_AD.

				contradict n_Cong_AC_AD.
				exact Cong_AC_AD.
			}
			unfold neq in n_neq_C_D.
			apply Classical_Prop.NNPP in n_neq_C_D.
			exact n_neq_C_D.
		}
	}
	{
		(* case eq_B_C *)
		assert (Cong A B A D) as Cong_AB_AD by (rewrite eq_B_C; exact Cong_AC_AD).
		pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AB_AD) as Cong_AD_AB.
		destruct BetS_A_D_B_or_eq_B_D_or_BetS_A_B_D as [BetS_A_D_B | [eq_B_D | BetS_A_B_D]].
		{
			(* case BetS_A_D_B *)
			pose proof (lemma_partnotequalwhole _ _ _ BetS_A_D_B) as n_Cong_AD_AB.

			contradict n_Cong_AD_AB.
			exact Cong_AD_AB.
		}
		{
			(* case eq_B_D *)
			assert (eq C D) as eq_C_D by (rewrite <- eq_B_C; exact eq_B_D).
			exact eq_C_D.
		}
		{
			(* case BetS_A_B_D *)
			assert (BetS A C D) as BetS_A_C_D by (rewrite <- eq_B_C; exact BetS_A_B_D).
			assert (~ neq C D) as n_neq_C_D.
			{
				intros neq_C_D.

				pose proof (lemma_partnotequalwhole _ _ _ BetS_A_C_D) as n_Cong_AC_AD.

				contradict n_Cong_AC_AD.
				exact Cong_AC_AD.
			}
			unfold neq in n_neq_C_D.
			apply Classical_Prop.NNPP in n_neq_C_D.
			exact n_neq_C_D.
		}
	}
	{
		(* case BetS_A_B_C *)
		destruct BetS_A_D_B_or_eq_B_D_or_BetS_A_B_D as [BetS_A_D_B | [eq_B_D | BetS_A_B_D]].
		{
			(* case BetS_A_D_B *)
			pose proof (
				lemma_orderofpoints_ABC_ACD_ABD _ _ _ _ BetS_A_D_B BetS_A_B_C
			) as BetS_A_D_C.
			assert (~ neq C D) as n_neq_C_D.
			{
				intros neq_C_D.

				pose proof (lemma_partnotequalwhole _ _ _ BetS_A_D_C) as n_Cong_AD_AC.

				contradict n_Cong_AD_AC.
				exact Cong_AD_AC.
			}
			unfold neq in n_neq_C_D.
			apply Classical_Prop.NNPP in n_neq_C_D.
			exact n_neq_C_D.
		}
		{
			(* case eq_B_D *)
			assert (BetS A D C) as BetS_A_D_C by (rewrite <- eq_B_D; exact BetS_A_B_C).
			assert (~ neq C D) as n_neq_C_D.
			{
				intros neq_C_D.

				pose proof (lemma_partnotequalwhole _ _ _ BetS_A_D_C) as n_Cong_AD_AC.

				contradict n_Cong_AD_AC.
				exact Cong_AD_AC.
			}
			unfold neq in n_neq_C_D.
			apply Classical_Prop.NNPP in n_neq_C_D.
			exact n_neq_C_D.
		}
		{
			(* case BetS_A_B_D *)
			pose proof (lemma_betweennotequal _ _ _ BetS_A_B_D) as (_ & neq_A_B & _).
			pose proof (
				lemma_differenceofparts _ _ _ _ _ _ Cong_AB_AB Cong_AC_AD BetS_A_B_C BetS_A_B_D
			) as Cong_BC_BD.
			pose proof (lemma_extensionunique _ _ _ _ BetS_A_B_C BetS_A_B_D Cong_BC_BD) as eq_C_D.
			exact eq_C_D.
		}
	}
Qed.

End Euclid.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2019, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Reals Psatz.
From Flocq Require Import Raux.
From Coq Require Import List.

Require Import Xreal.
Require Import Interval.
Require Import Tree.
Require Import Prog.

Inductive hyp : Set :=
  | Hle (b l : bool) (v : expr)
  | Hge (b l : bool) (u : expr)
  | Hlele (l1 l2 : bool) (u v : expr)
  | Habsle (b l : bool) (v : expr).

Definition eval_hyp (h : hyp) (var : R) :=
  match h with
  | Hle true true v => (var <= eval v nil)%R
  | Hle true false v => (var < eval v nil)%R
  | Hle false true v => (eval v nil >= var)%R
  | Hle false false v => (eval v nil > var)%R
  | Hge true true u => (eval u nil <= var)%R
  | Hge true false u => (eval u nil < var)%R
  | Hge false true u => (var >= eval u nil)%R
  | Hge false false u => (var > eval u nil)%R
  | Hlele true true u v => (eval u nil <= var <= eval v nil)%R
  | Hlele true false u v => (eval u nil <= var < eval v nil)%R
  | Hlele false true u v => (eval u nil < var <= eval v nil)%R
  | Hlele false false u v => (eval u nil < var < eval v nil)%R
  | Habsle true true v => (Rabs var <= eval v nil)%R
  | Habsle true false v => (Rabs var < eval v nil)%R
  | Habsle false true v => (eval v nil >= Rabs var)%R
  | Habsle false false v => (eval v nil > Rabs var)%R
  end.

Fixpoint eval_hyps_aux (hyps : list hyp) (var : R) (g : Prop) :=
  match hyps with
  | hh :: th => eval_hyp hh var -> eval_hyps_aux th var g
  | nil => g
  end.

Fixpoint eval_hyps (hyps : list (list hyp)) (vars : list R) (g : Prop) :=
  match hyps, vars with
  | hh :: th, hv :: tv =>
    eval_hyps_aux hh hv (eval_hyps th tv g)
  | nil, nil => g
  | _, _ => True
  end.

Inductive gol : Set :=
  | Gle (b : bool) (v : expr)
  | Gge (b : bool) (u : expr)
  | Glele (u v : expr)
  | Gabsle (b : bool) (v : expr)
  | Glt (v : expr)
  | Ggt (u : expr)
  | Gne (b : bool) (u : expr).

Definition eval_goal (g : gol) (x : R) :=
  match g with
  | Gle true v => (x <= eval v nil)%R
  | Gle false v => (eval v nil >= x)%R
  | Gge true u => (eval u nil <= x)%R
  | Gge false u => (x >= eval u nil)%R
  | Glele u v => (eval u nil <= x <= eval v nil)%R
  | Gabsle true v => (Rabs x <= eval v nil)%R
  | Gabsle false v => (eval v nil >= Rabs x)%R
  | Glt v => (x < eval v nil)%R
  | Ggt u => (eval u nil < x)%R
  | Gne true u => (x <> eval u nil)
  | Gne false u => (eval u nil <> x)
  end.

Ltac massage_goal :=
  let aux a x t :=
    let a := reify a (@nil R) in
    (change (eval_goal (t a) x)) in
  match goal with
  | |- (Rabs ?x <= ?v)%R => aux v x (Gabsle true)
  | |- (?u <= ?x)%R => aux u x (Gge true)
  | |- (?x <= ?v)%R => aux v x (Gle true)
  | |- (?x >= ?u)%R => aux u x (Gge false)
  | |- (?v >= ?x)%R => aux v x (Gle false)
  | |- (?u <= ?x <= ?v)%R =>
    let u := reify u (@nil R) in
    aux v x (Glele u)
  | |- (?u < ?x)%R => aux u x Ggt
  | |- (?x > ?u)%R => aux u x Ggt
  | |- (?x < ?v)%R => aux v x Glt
  | |- (?v > ?x)%R => aux v x Glt
  | |- (?x <> ?u :>R) => aux u x (Gne true)
  | |- (?u <> ?x :>R) => aux u x (Gne false)
  | _ => fail "Goal is not an inequality with constant bounds"
  end.

Ltac find_hyps_aux x known cont :=
  let aux H u t :=
    let u := reify u (@nil R) in
    let k := constr:(cons (t u) known) in
    revert H ;
    find_hyps_aux x k cont in
  match goal with
  | H : (?u <= x <= ?v)%R |- _ =>
    let u := reify u (@nil R) in
    aux H v (Hlele true true u)
  | H : (?u <= x < ?v)%R |- _ =>
    let u := reify u (@nil R) in
    aux H v (Hlele true false u)
  | H : (?u < x <= ?v)%R |- _ =>
    let u := reify u (@nil R) in
    aux H v (Hlele false true u)
  | H : (?u < x < ?v)%R |- _ =>
    let u := reify u (@nil R) in
    aux H v (Hlele false false u)
  | H : (?u <= x)%R |- _ => aux H u (Hge true true)
  | H : (x >= ?u)%R |- _ => aux H u (Hge false true)
  | H : (x <= ?v)%R |- _ => aux H v (Hle true true)
  | H : (?v >= x)%R |- _ => aux H v (Hle false true)
  | H : (Rabs x <= ?v)%R |- _ => aux H v (Habsle true true)
  | H : (?v >= Rabs x)%R |- _ => aux H v (Habsle false true)
  | H : (?u < x)%R |- _ => aux H u (Hge true false)
  | H : (x > ?u)%R |- _ => aux H u (Hge false false)
  | H : (x < ?v)%R |- _ => aux H v (Hle true false)
  | H : (?v > x)%R |- _ => aux H v (Hle false false)
  | H : (Rabs x < ?v)%R |- _ => aux H v (Habsle true false)
  | H : (?v > Rabs x)%R |- _ => aux H v (Habsle false false)
  | _ =>
    cont known
  end.

Ltac find_hyps_aux2 vars cont :=
  match vars with
  | ?h :: ?t =>
    let cont' k :=
      let cont'' k' :=
        let k'' := constr:(cons k' k) in
        cont k'' in
      let k' := constr:(@nil hyp) in
      find_hyps_aux h k' cont'' in
    find_hyps_aux2 t cont'
  | @nil R =>
    let k := constr:(@nil (list hyp)) in
    cont k
  end.

Ltac find_hyps vars :=
  match goal with
  | |- ?g =>
    let cont k :=
      change (eval_hyps k vars g) ;
      clear in
    find_hyps_aux2 vars cont
  end ;
  match goal with
  | |- eval_hyps ?hyps' _ _ =>
    let hyps := fresh "__hyps" in
    set (hyps := hyps')
  end.

Ltac reify_partial y vars :=
  let expr' := reify y vars in
  let expr := fresh "__expr" in
  set (expr := expr') ;
  change y with (eval expr vars) ;
  generalize (extract_correct expr vars) ;
  let decomp := eval lazy in (extract expr (length vars)) in
  change (extract expr (length vars)) with decomp ;
  cbv iota beta ;
  match decomp with
  | Eprog ?prog' ?consts' =>
    let prog := fresh "__prog" in
    set (prog := prog') ;
    let consts := fresh "__consts" in
    set (consts := consts')
  end.

Ltac reify_full vars0 :=
  match goal with
  | |- eval_goal ?g' ?y =>
    let vars := get_vars y vars0 in
    let g := fresh "__goal" in
    set (g := g') ;
    reify_partial y vars ;
    apply eq_ind ;
    find_hyps vars
  end.

Module Bnd (I : IntervalOps).

Module E := Tree.Bnd I.
Module J := IntervalExt I.

Definition eval_hyp_bnd (prec : I.precision) (h : hyp) :=
  match h with
  | Hlele _ _ u v => I.join (E.eval_bnd prec u) (E.eval_bnd prec v)
  | Hle _ _ v => I.lower_extent (E.eval_bnd prec v)
  | Hge _ _ u => I.upper_extent (E.eval_bnd prec u)
  | Habsle _ _ v => let vi := I.lower_extent (E.eval_bnd prec v) in I.meet (I.neg vi) vi
  end.

Theorem eval_hyp_bnd_correct :
  forall prec h var,
  eval_hyp h var ->
  contains (I.convert (eval_hyp_bnd prec h)) (Xreal var).
Proof.
intros prec h var.
destruct h as [b l v|b l u|l1 l2 u v|b l v] ; intros H.
- apply I.lower_extent_correct with (eval v nil).
  apply E.eval_bnd_correct.
  destruct l ; [|apply Rlt_le] ;
    destruct b ; [|apply Rge_le| |] ; apply H.
- apply I.upper_extent_correct with (eval u nil).
  apply E.eval_bnd_correct.
  destruct l ; [|apply Rlt_le] ;
    destruct b ; [|apply Rge_le| |] ; apply H.
- apply J.join_correct with (eval u nil) (eval v nil).
  apply E.eval_bnd_correct.
  apply E.eval_bnd_correct.
  destruct l1, l2 ; split ; try apply H ; apply Rlt_le, H.
- assert (H': (- eval v nil <= var <= eval v nil)%R).
    apply Rabs_le_inv.
    destruct l ; [|apply Rlt_le] ;
      destruct b ; [|apply Rge_le| |] ; apply H.
  apply I.meet_correct.
  rewrite <- (Ropp_involutive var).
  apply J.neg_correct.
  apply I.lower_extent_correct with (eval v nil).
  apply E.eval_bnd_correct.
  lra.
  apply I.lower_extent_correct with (eval v nil).
  apply E.eval_bnd_correct.
  apply H'.
Qed.

Fixpoint merge_hyps_aux (prec : I.precision) (hyps : list hyp) (acc : I.type) :=
  match hyps with
  | h :: t =>
    merge_hyps_aux prec t (I.meet (eval_hyp_bnd prec h) acc)
  | nil => acc
  end.

Fixpoint merge_hyps (prec : I.precision) (hyps : list (list hyp)) :=
  match hyps with
  | h :: t =>
    cons (merge_hyps_aux prec h I.whole) (merge_hyps prec t)
  | nil => nil
  end.

Fixpoint eval_hyps_bnd (hyps : list I.type) (vars : list R) :=
  match hyps, vars with
  | hh :: th, hv :: tv =>
    contains (I.convert hh) (Xreal hv) /\ eval_hyps_bnd th tv
  | nil, nil => True
  | _, _ => False
  end.

Theorem eval_hyps_bnd_correct :
  forall prec hyps vars (g : Prop),
  (eval_hyps_bnd (merge_hyps prec hyps) vars -> g) ->
  eval_hyps hyps vars g.
Proof.
intros prec.
induction hyps as [|h1 t1 IH1].
  intros [|x vars] g H.
  now apply H.
  exact I.
intros [|x vars].
easy.
simpl.
generalize I.whole (I.whole_correct x).
induction h1 as [|h2 t2 IH2] ; intros xi Ix g H.
  apply IH1.
  intros H'.
  now apply H.
simpl.
intros H'.
simpl in H.
apply (IH2 (I.meet (eval_hyp_bnd prec h2) xi)).
apply I.meet_correct with (2 := Ix).
now apply eval_hyp_bnd_correct.
intros H''.
now apply H.
Qed.

Definition eval_goal_bnd (prec : I.precision) (g : gol) : I.type -> bool :=
  match g with
  | Gle _ v =>
    let j := I.lower_complement (E.eval_bnd prec v) in
    fun i => I.subset i j
  | Gge _ u =>
    let j := I.upper_complement (E.eval_bnd prec u) in
    fun i => I.subset i j
  | Glele u v =>
    let u := I.upper_complement (E.eval_bnd prec u) in
    let v := I.lower_complement (E.eval_bnd prec v) in
    let j := I.meet u v in
    fun i => I.subset i j
  | Gabsle _ v =>
    let v := I.lower_complement (E.eval_bnd prec v) in
    let j := I.meet (I.neg v) v in
    fun i => I.subset i j
  | Glt v =>
    let j := E.eval_bnd prec v in
    fun i => match I.sign_strict (I.sub prec i j) with Xlt => true | _ => false end
  | Ggt u =>
    let j := E.eval_bnd prec u in
    fun i => match I.sign_strict (I.sub prec i j) with Xgt => true | _ => false end
  | Gne _ v =>
    let j := E.eval_bnd prec v in
    fun i => match I.sign_strict (I.sub prec i j) with Xlt => true | Xgt => true | _ => false end
  end.

Theorem eval_goal_bnd_correct :
  forall prec g xi x,
  contains (I.convert xi) (Xreal x) ->
  eval_goal_bnd prec g xi = true ->
  eval_goal g x.
Proof.
intros prec g xi x Ix.
destruct g as [b v|b u|u v|b v|v|u|b u] ; simpl ; intros H.
- cut (x <= eval v nil)%R.
    now destruct b ; [|apply Rle_ge].
  apply I.subset_correct, subset_contains in H.
  apply I.lower_complement_correct with (2 := H _ Ix).
  apply E.eval_bnd_correct.
- cut (eval u nil <= x)%R.
    now destruct b ; [|apply Rle_ge].
  apply I.subset_correct, subset_contains in H.
  apply I.upper_complement_correct with (2 := H _ Ix).
  apply E.eval_bnd_correct.
- apply I.subset_correct, subset_contains in H.
  specialize (H _ Ix).
  apply I.meet_correct' in H.
  split.
  apply I.upper_complement_correct with (2 := proj1 H).
  apply E.eval_bnd_correct.
  apply I.lower_complement_correct with (2 := proj2 H).
  apply E.eval_bnd_correct.
- cut (Rabs x <= eval v nil)%R.
    now destruct b ; [|apply Rle_ge].
  apply I.subset_correct, subset_contains in H.
  specialize (H _ Ix).
  apply I.meet_correct' in H.
  apply Rabs_le.
  destruct H as [H1 H2].
  split.
  rewrite <- (Ropp_involutive x) in H1 |- *.
  apply Ropp_le_contravar.
  apply (I.neg_correct' _ (Xreal (-x))) in H1.
  apply I.lower_complement_correct with (2 := H1).
  apply E.eval_bnd_correct.
  apply I.lower_complement_correct with (2 := H2).
  apply E.eval_bnd_correct.
- apply Rminus_lt.
  generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec v))).
  destruct I.sign_strict ; try easy.
  intros Hd.
  apply (Hd (Xreal (x - eval v nil))).
  apply J.sub_correct with (1 := Ix).
  apply E.eval_bnd_correct.
- apply Rminus_gt.
  generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec u))).
  destruct I.sign_strict ; try easy.
  intros Hd.
  apply (Hd (Xreal (x - eval u nil))).
  apply J.sub_correct with (1 := Ix).
  apply E.eval_bnd_correct.
- cut (x - eval u nil <> 0)%R.
    destruct b ; lra.
  generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec u))).
  destruct I.sign_strict ; try easy ; intros Hd.
  apply Rlt_not_eq.
  apply (Hd (Xreal (x - eval u nil))).
  apply J.sub_correct with (1 := Ix).
  apply E.eval_bnd_correct.
  apply Rgt_not_eq.
  apply (Hd (Xreal (x - eval u nil))).
  apply J.sub_correct with (1 := Ix).
  apply E.eval_bnd_correct.
Qed.

End Bnd.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** This file builds some machinery to deal with reflection and
   views.

   Through the development, we define several efficient comparison
   functions that produce results in [bool] or [comparison]. For
   example, [eq_nat_bool] efficiently computes the equality on [nat],
   but is not easy to manipulate.

   We provide some tools to deal with these kind of functions:

   - [*_analyse] tactics: using a "view" mechanism, we associate to
   boolean or comparison functions the relation they describe. The
   [*_analyse] tactics will perform case destructions.

   - [*_prop] tactics: Through the development, we declare several
   lemmas as hints for autorewrite libraries, in order to transform,
   e.g., [eq_nat_bool x y = true] into [x = y].

   - [bool_simpl] tactic: Through the development, we declare several
   simplification lemmas, in order to transform, e.g., [eq_nat_bool x x]
   into [true]

*)

Require Import Common.
Require Export Bool.
Require Import Equality Program Sumbool Peano.

                               (***********)
                               (* analyse *)
                               (***********)

Class Type_View {A} (f : A) := {
  type_view_ty : Type;
  type_view : type_view_ty
}.

(* TOTHINK: a-t'on vraiment besoin de passer par les instances, puisqu'on a toujours le lemme dans la main !? *)
Ltac type_view f :=
  Tactics.on_call f
   ltac:(fun c =>
           match c with
           | context args[f] =>
               let ind_app := context args [type_view (f:=f)] in
               let t := type of ind_app in
               destruct ind_app
           end).

Inductive compare_spec {A} eq lt (x y : A) : comparison -> Prop :=
| compare_spec_lt : lt x y -> compare_spec eq lt x y Lt
| compare_spec_eq : eq x y -> compare_spec eq lt x y Eq
| compare_spec_gt : lt y x -> compare_spec eq lt x y Gt.

(** computationally efficient equality and comparison of natural numbers *)
Fixpoint eq_nat_bool a b :=
  match (a,b) with
    | (S n, S p) => eq_nat_bool n p
    | (O , O) => true
    | _ => false
  end.

Fixpoint le_lt_bool a b :=
  match (a,b) with
    | (O , _) => true
    | (S n, S p) => le_lt_bool n p
    | _ => false
  end.

Lemma eq_nat_spec: forall a b, reflect (a=b) (eq_nat_bool a b).
Proof.
  induction a; intros [|b]; simpl; try constructor; auto.
  case (IHa ( b));  intros H; subst;  constructor; auto.
Qed.

Lemma le_nat_spec : forall a b, reflect (le a b) (le_lt_bool a b).
Proof.
  induction a; intros [|b]; simpl; try constructor; auto with arith.
  case (IHa ( b));  intros H; subst;  constructor; auto with arith.
Qed.

Instance eq_nat_view : Type_View eq_nat_bool := { type_view := eq_nat_spec }.
Instance le_nat_view : Type_View le_lt_bool := { type_view := le_nat_spec }.

Ltac nat_analyse :=
  repeat (
    try (type_view eq_nat_bool; try subst; try lia_false);
    try (type_view le_lt_bool; try subst; try lia_false)
  ).

(** same thing for positive numbers  *)
Fixpoint eq_pos_bool x y :=
  match x,y with
    | xH, xH => true
    | xO a, xO b => eq_pos_bool a b
    | xI a, xI b => eq_pos_bool a b
    | _, _ => false
  end.

Lemma eq_pos_spec : forall n m, reflect (n=m) (eq_pos_bool n m).
Proof.
  induction n; intros [m|m|]; simpl; try constructor; try congruence.
  case (IHn m); intro; subst; constructor; congruence.
  case (IHn m); intro; subst; constructor; congruence.
Qed.

Instance eq_pos_view : Type_View eq_pos_bool := { type_view := eq_pos_spec }.

Ltac pos_analyse := repeat type_view eq_pos_bool.

(** same thing for booleans  *)
Definition eq_bool_bool := Bool.eqb.

Lemma eq_bool_spec : forall a b, reflect (a=b) (eq_bool_bool a b).
Proof.
  intros [|] [|]; simpl; constructor; firstorder.
  congruence.
Qed.

Instance eq_bool_view : Type_View eq_bool_bool := { type_view := eq_bool_spec }.

Ltac bool_analyse := repeat type_view eq_bool_bool.

                            (************)
                            (* nat_prop *)
                            (************)

Lemma eq_nat_bool_true : forall x y, eq_nat_bool x y = true <-> x = y.
Proof. intros. nat_analyse; intuition discriminate. Qed.
Lemma eq_nat_bool_false : forall x y, eq_nat_bool x y = false <-> x <> y.
Proof. intros. nat_analyse; intuition discriminate. Qed.
Lemma le_lt_bool_true : forall x y, le_lt_bool x y = true <-> x <= y.
Proof. intros. nat_analyse; intuition. Qed.
Lemma le_lt_bool_false : forall x y, le_lt_bool x y = false <-> y < x.
Proof. intros. nat_analyse; intuition. lia. Qed.

Hint Rewrite eq_nat_bool_true eq_nat_bool_false le_lt_bool_true le_lt_bool_false : nat_prop.
Ltac nat_prop := autorewrite with nat_prop in *.

                           (**************)
                           (* bool_simpl *)
                           (**************)

(** * [bool_simpl] is a tactic that simplifies boolean operations in the context and in the goal
      The database bool_simpl should be enriched with lemmas such as [forall x, eqb x x = true],
      which is done in Numbers.v
*)
Hint Rewrite
  orb_false_r                    (** b || false -> b *)
  orb_false_l                    (** false || b -> b *)
  orb_true_r                     (** b || true  -> true *)
  orb_true_l                     (** true || b  -> true  *)
  andb_false_r                   (** b && false -> false *)
  andb_false_l                   (** false && b -> false *)
  andb_true_r                    (** b && true  -> b *)
  andb_true_l                    (** true && b  -> b  *)
  negb_orb                       (** negb (b || c) -> negb b && negb c *)
  negb_andb                      (** negb (b && c) -> negb b || negb c *)
  negb_involutive                (** negb (negb b) -> b *)
  : bool_simpl.

Hint Rewrite <- andb_lazy_alt : bool_simpl. (** a &&& b -> a && b *)
Hint Rewrite <- orb_lazy_alt : bool_simpl.  (** a ||| b -> a || b *)

Ltac bool_simpl := autorewrite with bool_simpl in *.

Lemma eq_nat_bool_refl: forall x, eq_nat_bool x x = true.
Proof. intro. nat_prop. reflexivity. Qed.
Lemma le_lt_bool_refl: forall x, le_lt_bool x x = true.
Proof. intro. nat_prop. auto with arith. Qed.

Hint Rewrite  eq_nat_bool_refl le_lt_bool_refl: bool_simpl.

                           (*******************)
                           (* bool_connectors *)
                           (*******************)

(** * [bool_connectors ] takes hypothesis like [((x && y) || negb z) = true] and transforms them into
      [? : (x = true /\ y = true) \/ (~ z = true)]. *)

Lemma andb_false_iff : forall b1 b2:bool, b1 && b2 = false <-> (b1 = false \/ b2 = false).
Proof. intros [|] [|]; firstorder. Qed.
Lemma andb_true_iff : forall b1 b2:bool, b1 && b2 = true <-> (b1 = true /\ b2 = true).
Proof. intros [|] [|]; firstorder. Qed.

Lemma orb_false_iff : forall b1 b2:bool, b1 || b2 = false <-> (b1 = false /\ b2 = false).
Proof. intros [|] [|]; firstorder. Qed.
Lemma orb_true_iff : forall b1 b2:bool, b1 || b2 = true <-> (b1 = true \/ b2 = true).
Proof. intros [|] [|]; firstorder. Qed.

Lemma negb_true  : forall b, negb b = true <-> b = false.
Proof. intros [|]; firstorder. Qed.
Lemma negb_false  : forall b, negb b = false <-> b = true.
Proof. intros [|]; firstorder. Qed.
Lemma eq_not_negb  : forall b c, b = c <-> ~ (b = negb c).
Proof. intros [|] [|]; firstorder; simpl; try congruence. Qed.

Hint Rewrite andb_false_iff andb_true_iff orb_false_iff orb_true_iff negb_true negb_false : bool_connectors.

Ltac bool_connectors := autorewrite with bool_connectors in *.

Lemma bool_prop_iff : forall b1 b2, b1 = b2 <-> (b1 = true <-> b2 = true).
Proof. intros [|] [|]; firstorder. Qed.

                           (*************)
                           (* decompose *)
                           (*************)

(** [completer tac] simplfies the layout of the hypothesis, and try to
   saturate the context with hypothesis. It is adapted from A. Chlipala
*)

Ltac notHyp P :=
  match goal with
    [ _ : P |- _ ] => fail 1
    | _ => match P with
             | ?P1 /\ ?P2 => first [notHyp P1 | notHyp P2 | fail 2]
             | _ => idtac
           end
  end.

Ltac extend pf :=
  let t := type of pf in notHyp t; generalize pf; intro.

Ltac completer tac:=
  repeat match goal with
    | H : False |- _ => apply False_ind; exact H
    | H : ?P \/ ?Q |- _ => destruct H as [?|?]
    | [ |- _ /\ _ ] => constructor
    | [ |- _ <-> _ ] => constructor
    | [ |- _ -> _] => intro
    | [H : _ /\ _ |- _] => destruct H
    | [H : ?P -> ?Q, H' : ?P |- _] => generalize (H H'); clear H; intro H
    | [ |- forall x, _] => intro
    | [H : forall x, ?P x -> _ , H' : ?P ?X |- _ ]=> extend (H X H')
    | [H : exists x, _ |- _ ] => destruct H
    | [H : ?x = ?y |- _ ]  => subst H
    | _ => tac
  end.


(*

MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Books.

Coq < Goal forall x y m:Prop, (~(x -> m) /\ ~(y -> ~m)) -> ~(x -> y).
1 subgoal

  ============================
   forall x y m : Prop, ~ (x -> m) /\ ~ (y -> ~ m) -> ~ (x -> y)

Unnamed_thm < intros.
1 subgoal

  x : Prop
  y : Prop
  m : Prop
  H : ~ (x -> m) /\ ~ (y -> ~ m)
  ============================
   ~ (x -> y)

Unnamed_thm < elim H.
1 subgoal

  x : Prop
  y : Prop
  m : Prop
  H : ~ (x -> m) /\ ~ (y -> ~ m)
  ============================
   ~ (x -> m) -> ~ (y -> ~ m) -> ~ (x -> y)

Unnamed_thm < info_auto.
(* info auto : *)
 intro.
 intro.
 unfold not.
  intro.
  apply H1.
   intro.
   unfold not.
    intro.
    apply H1.
     intro.
     unfold not.
     unfold not.
    apply H0.
     intro.
     assumption.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
info_auto.

Unnamed_thm is defined

Coq <

*)

Section Books.
Goal forall x y m:Prop, (~(x -> m) /\ ~(y -> ~m)) -> ~(x -> y).
intros.
elim H.
info_auto.
Qed.


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Isomorphism Theory.
  author    : ZhengPu Shi
  date      : 2022.07

  ref:
  1. https://blog.csdn.net/grb819/article/details/111745405
*)

Require Export BasicConfig.

(** Part I : reflexive, symmetric, transitive *)

(** Isomorphism mapping is reflexive *)
Theorem isomorphism_refl : forall {A B} (fa : A -> A -> A) (fb : B -> B -> B),
  isomorphism fa fb -> isomorphism fa fb.
Proof. intros. auto. Qed.

(** Isomorphism mapping is symmetric *)
Theorem isomorphism_sym : forall {A B} (fa : A -> A -> A) (fb : B -> B -> B),
  isomorphism fa fb -> isomorphism fb fa.
Proof.
  intros. destruct H as [phi [Hhomo Hbij]].
  pose (proj1_sig (inversefun_of_bij phi Hbij)).
  Admitted.

Theorem isomorphism_trans : forall {A B C} (fa : A -> A -> A)
  (fb : B -> B -> B) (fc : C -> C -> C),
  isomorphism fa fb -> isomorphism fb fc -> isomorphism fa fc.
Proof.
  Admitted.

(** Part II : inheritance of commutative, associative, cancel *)

(** Note that, here is iff, it is strong than the case in homomorphism *)
Theorem isomor_keep_comm : forall {A B} (fa : A -> A -> A)
  (fb : B -> B -> B) (H1 : isomorphism fa fb),
  commutative fa <-> commutative fb.
Proof.
  Admitted.

Theorem isomor_keep_assoc : forall {A B} (fa : A -> A -> A)
  (fb : B -> B -> B) (H1 : isomorphism fa fb),
  associative fa <-> associative fb.
Proof.
  Admitted.

Theorem isomor_keep_cancel_left : forall {A B} (fa : A -> A -> A)
  (fb : B -> B -> B) (H1 : isomorphism fa fb),
  cancel_left fa <-> cancel_left fb.
Proof.
  Admitted.

Theorem isomor_keep_cancel_right : forall {A B} (fa : A -> A -> A)
  (fb : B -> B -> B) (H1 : isomorphism fa fb),
  cancel_right fa <-> cancel_right fb.
Proof.
  Admitted.

(** Part III : distributive law *)

Theorem isomor_keep_distr_left : forall {A B} (fa ga : A -> A -> A)
  (fb gb : B -> B -> B) (H1 : isomorphism2 fa ga fb gb),
  distributive_left fa ga <-> distributive_left fb gb.
Proof.
  Admitted.

Theorem isomor_keep_distr_right : forall {A B} (fa ga : A -> A -> A)
  (fb gb : B -> B -> B) (H1 : isomorphism2 fa ga fb gb),
  distributive_right fa ga <-> distributive_right fb gb.
Proof.
  Admitted.


(*Modélisation des énigmes de Smullyan de la princesse et du tigre en logique des propositions.
(ici modélisé avec des formules Booléennes pour utiliser SMTCoq).
Utilisation du plugin SMTCoq et de la tactique zchaff. pour la résolution des énigmes.
*)

Require Import SMTCoq.SMTCoq.
Require Import Bool.

Parameters PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8 PC9: bool.
Parameters TC1 TC2 TC3 TC4 TC5 TC6 TC7 TC8 TC9: bool.
Parameters VC1 VC2 VC3 VC4 VC5 VC6 VC7 VC8 VC9: bool.

Definition A1 : bool := PC1 && TC2.
Definition A2 : bool := (PC1 && TC2) || (PC2 && TC1).
Definition HY1 : bool := (A1 && negb A2) || (A2 && negb A1).
Definition HN2 : bool := (PC1 || TC1) && negb (PC1 && TC1) && (PC2 || TC2) && negb (PC2 && TC2).

Lemma S1 : HY1 && HN2 --> negb PC1 && PC2.
Proof.
unfold HY1, HN2, A1, A2.
zchaff.
Qed.

Definition B1 : bool := PC1 || PC2.
Definition B2 : bool := TC2.
Definition HY2 : bool := (B1 && B2) || (negb B1 && negb B2).

Lemma S2 : HY2 && HN2 --> PC1 && negb PC2.
Proof.
unfold HY2, B1, B2, HN2.
zchaff.
Qed.

Definition C1 : bool := TC1 || PC2.
Definition C2 : bool := PC1.
Definition HY3 : bool := (C1 && C2) || (negb C1 && negb C2).

Lemma S3 : HY3 && HN2 --> PC1 && PC2.
Proof.
unfold HY3, C1, C2, HN2.
zchaff.
Qed.

Definition D1 : bool := PC1 && PC2.
Definition D2 : bool := PC1 && PC2.
Definition HY4 : bool := (PC1 --> D1) && (PC2 --> negb D2) && (TC1 --> negb D1) && (TC2 --> D2).

Lemma S4 : HY4 && HN2 --> negb PC1 && PC2.
Proof.
unfold HY4, D1, D2, HN2.
zchaff.
Qed.

Definition E1 : bool := PC1 || PC2.
Definition E2 : bool := PC1.
Definition HY5 : bool := (PC1 --> E1) && (PC2 --> negb E2) && (TC1 --> negb E1) && (TC2 --> E2).

Lemma S5 : HY5 && HN2 --> PC1 && negb PC2.
Proof.
unfold HY5, E1, E2, HN2.
zchaff.
Qed.

Definition F1 : bool := (PC1 && PC2) || (TC1 && TC2).
Definition F2 : bool := PC1.
Definition HY6 : bool := (PC1 --> F1) && (PC2 --> negb F2) && (TC1 --> negb F1) && (TC2 --> F2).

Lemma S6 : HY6 && HN2 --> negb PC1 && PC2.
Proof.
unfold HY6, F1, F2, HN2.
zchaff.
Qed.

Definition G1 : bool := (PC1 && TC2) || (TC1 && PC2).
Definition G2 : bool := PC1 && TC2.
Definition HY7 : bool := (PC1 --> G1) && (PC2 --> negb G2) && (TC1 --> negb G1) && (TC2 --> G2).

Lemma S7 : HY7 && HN2 --> PC1 && negb PC2.
Proof.
unfold HY7, G1, G2, HN2.
zchaff.
Qed.

Definition I1 : bool := TC1 && TC2.
Definition I2 : bool := TC2.
Definition J1 : bool := TC1.
Definition J2 : bool := TC1 && TC2.
Definition HY8 : bool := (PC1 --> I1) && (PC2 --> negb I2) && (TC1 --> negb I1) && (TC2 --> I2)
                         && (PC1 --> J1) && (PC2 --> negb J2) && (TC1 --> negb J1) && (TC2 --> J2).

Lemma S8 : HY8 && HN2 --> negb PC1 && PC2.
Proof.
unfold HY8, I1, I2, J1, J2, HN2.
zchaff.
Qed.

Definition K1 : bool := TC1.
Definition K2 : bool := PC2.
Definition K3 : bool := TC2.
Definition HD9 : bool := (PC1 && TC2 && TC3) || (PC2 && TC1 && TC3) || (PC3 && TC2 && TC1).
Definition HY9 : bool := (K1 && negb K2 && negb K3) || (negb K1 && K2 && negb K3) || (negb K1 && negb K2 && K3).
Definition HN3 : bool := (PC1 || TC1) && negb (PC1 && TC1) && (PC2 || TC2) && negb (PC2 && TC2) && (PC3 || TC3) && negb (PC3 && TC3).

Lemma S9 : HY9 && HN3 && HD9 --> PC1 && negb PC2 && negb PC3.
Proof.
unfold HY9, K1, K2, K3, HN3, HD9.
zchaff.
Qed.

Definition L1 : bool := TC2.
Definition L2 : bool := TC2.
Definition L3 : bool := TC1.
Definition HD10 : bool := (PC1 && TC2 && TC3) || (PC2 && TC1 && TC3) || (PC3 && TC2 && TC1).
Definition HY10 : bool := (PC1 --> (L1 && (negb L2 || negb L3)))
                       && (PC2 --> (L2 && (negb L1 || negb L3)))
                       && (PC3 --> (L3 && (negb L2 || negb L1))).

Lemma S10 : HY10 && HN3 && HD10 --> PC1 && negb PC2 && negb PC3.
Proof.
unfold HY10, L1, L2, L3, HN3, HD10.
zchaff.
Qed.

Definition M1 : bool := VC3.
Definition M2 : bool := TC1.
Definition M3 : bool := VC3.

Definition HD11 : bool := (PC1 && TC2 && VC3) || (PC1 && TC3 && VC2)
                       || (PC2 && TC1 && VC3) || (PC2 && TC1 && VC1)
                       || (PC3 && TC2 && VC1) || (PC3 && TC3 && VC2).

Definition HY11 : bool := (PC1 --> M1) && (TC1 --> negb M1) && (VC1 --> M1 || negb M1)
                       && (PC2 --> M2) && (TC2 --> negb M2) && (VC2 --> M2 || negb M2)
                       && (PC3 --> M3) && (TC3 --> negb M3) && (VC3 --> M3 || negb M3).

Definition HN3V : bool := ((PC1 && negb TC1 && negb VC1) || (negb PC1 && TC1 && negb VC1) || (negb PC1 && negb TC1 && VC1))
                       && ((PC2 && negb TC2 && negb VC2) || (negb PC2 && TC2 && negb VC2) || (negb PC2 && negb TC2 && VC2))
                       && ((PC3 && negb TC3 && negb VC3) || (negb PC3 && TC3 && negb VC3) || (negb PC3 && negb TC3 && VC3)).

Lemma S11 : HY11 && HD11 && HN3V --> PC1 && negb PC2 && negb PC3.
Proof.
unfold HY11, M1, M2, M3, HN3V, HD11.
zchaff.
Qed.

Definition N1 : bool := PC1 || PC3 || PC5 || PC7 || PC9.
Definition N2 : bool := VC2.
Definition N4 : bool := negb N1.
Definition N5 : bool := N2 || N4.
Definition N7 : bool := negb PC1.
Definition N3 : bool := N5 || negb N7.
Definition N6 : bool := negb N3.
Definition N8 : bool := TC8 && VC9.
Definition N9 : bool := TC9 && negb N6.

Definition HD12 : bool := (PC1 && negb PC2 && negb PC3 && negb PC4 && negb PC5 && negb PC6 && negb PC7 && negb PC8 && negb PC9)
                       || (negb PC1 && PC2 && negb PC3 && negb PC4 && negb PC5 && negb PC6 && negb PC7 && negb PC8 && negb PC9)
                       || (negb PC1 && negb PC2 && PC3 && negb PC4 && negb PC5 && negb PC6 && negb PC7 && negb PC8 && negb PC9)
                       || (negb PC1 && negb PC2 && negb PC3 && PC4 && negb PC5 && negb PC6 && negb PC7 && negb PC8 && negb PC9)
                       || (negb PC1 && negb PC2 && negb PC3 && negb PC4 && PC5 && negb PC6 && negb PC7 && negb PC8 && negb PC9)
                       || (negb PC1 && negb PC2 && negb PC3 && negb PC4 && negb PC5 && PC6 && negb PC7 && negb PC8 && negb PC9)
                       || (negb PC1 && negb PC2 && negb PC3 && negb PC4 && negb PC5 && negb PC6 && PC7 && negb PC8 && negb PC9)
                       || (negb PC1 && negb PC2 && negb PC3 && negb PC4 && negb PC5 && negb PC6 && negb PC7 && PC8 && negb PC9)
                       || (negb PC1 && negb PC2 && negb PC3 && negb PC4 && negb PC5 && negb PC6 && negb PC7 && negb PC8 && PC9).

Definition HY12 : bool := (PC1 --> N1) && (TC1 --> negb N1) && (VC1 --> N1 || negb N1)
                      &&  (PC2 --> N2) && (TC2 --> negb N2) && (VC2 --> N2 || negb N2)
                      &&  (PC3 --> N3) && (TC3 --> negb N3) && (VC3 --> N3 || negb N3)
                      &&  (PC4 --> N4) && (TC4 --> negb N4) && (VC4 --> N4 || negb N4)
                      &&  (PC5 --> N5) && (TC5 --> negb N5) && (VC5 --> N5 || negb N5)
                      &&  (PC6 --> N6) && (TC6 --> negb N6) && (VC6 --> N6 || negb N6)
                      &&  (PC7 --> N7) && (TC7 --> negb N7) && (VC7 --> N7 || negb N7)
                      &&  (PC8 --> N8) && (TC8 --> negb N8) && (VC8 --> N8 || negb N8)
                      &&  (PC9 --> N9) && (TC9 --> negb N9) && (VC9 --> N9 || negb N9).

Definition HN9 : bool := ((PC1 && negb TC1 && negb VC1) || (negb PC1 && TC1 && negb VC1) || (negb PC1 && negb TC1 && VC1))
                      && ((PC2 && negb TC2 && negb VC2) || (negb PC2 && TC2 && negb VC2) || (negb PC2 && negb TC2 && VC2))
                      && ((PC3 && negb TC3 && negb VC3) || (negb PC3 && TC3 && negb VC3) || (negb PC3 && negb TC3 && VC3))
                      && ((PC4 && negb TC4 && negb VC4) || (negb PC4 && TC4 && negb VC4) || (negb PC4 && negb TC4 && VC4))
                      && ((PC5 && negb TC5 && negb VC5) || (negb PC5 && TC5 && negb VC5) || (negb PC5 && negb TC5 && VC5))
                      && ((PC6 && negb TC6 && negb VC6) || (negb PC6 && TC6 && negb VC6) || (negb PC6 && negb TC6 && VC6))
                      && ((PC7 && negb TC7 && negb VC7) || (negb PC7 && TC7 && negb VC7) || (negb PC7 && negb TC7 && VC7))
                      && ((PC8 && negb TC8 && negb VC8) || (negb PC8 && TC8 && negb VC8) || (negb PC8 && negb TC8 && VC8))
                      && ((PC9 && negb TC9 && negb VC9) || (negb PC9 && TC9 && negb VC9) || (negb PC9 && negb TC9 && VC9)).

Lemma S12 : HY12 && HD12 && HN9 && negb VC8 --> negb PC1 && negb PC2 && negb PC3 && negb PC4 && negb PC5 && negb PC6 && PC7 && negb PC8 && negb PC9.
Proof.
unfold HY12, N9, N8, N6, N3, N7, N5, N4, N2, N1, HD12, HN9.
zchaff.
Qed.


(* =================================================================================== *)
(** * Modules over relative monads                                                     *)
(* =================================================================================== *)

(* ----------------------------------------------------------------------------------- *)
(** Contents:                                                                          *)
(**                                                                                *)
(**   - Definition of module over a relative monads [RelModule]                        *)
(**   - Functoriality for modules [mlift]                                              *)
(**   - Morphisms between relative modules (over the same monad).                      *)
(**                                                                                *)
(** Written by: Marco Maggesi (started March 2018)                                     *)
(* ----------------------------------------------------------------------------------- *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Require Import UniMath.CategoryTheory.Monads.RelativeMonads.

Local Open Scope cat.

(* ----------------------------------------------------------------------------------- *)
(** ** Miscellanea                                                                     *)
(* ----------------------------------------------------------------------------------- *)

Definition isaprop_RelMonad_axioms {C D : precategory_data} {J : C ⟶ D}
           (hs : has_homsets D) (R : RelMonad_data J)
  : isaprop (RelMonad_axioms R).
Proof.
  repeat apply isapropdirprod; repeat (apply impred; intros); apply hs.
Qed.

(* ----------------------------------------------------------------------------------- *)
(** ** Definition of module over a relative monad.                                     *)
(* ----------------------------------------------------------------------------------- *)

Section RelModule_Definition.

  Context {C D : precategory_data} {J : C ⟶ D}.

  Definition RelModule_data (R : RelMonad_data J) : UU
    := ∑ F : C → D, ∏ c d, D ⟦J c, R d⟧ → D ⟦F c, F d⟧.

  Definition make_relmodule_data (R : RelMonad_data J) (F : C → D)
             (mbind : ∏ c d, D ⟦J c, R d⟧ → D ⟦F c, F d⟧)
    : RelModule_data R
    := F,, mbind.

  Definition RelModule_ob {R : RelMonad_data J} (M : RelModule_data R)
    : C → D
    := pr1 M.
  Coercion RelModule_ob : RelModule_data >-> Funclass.

  Section Projections_and_Laws.

    Context {R : RelMonad_data J}.

    Definition mbind (M : RelModule_data R)
               {c d} (f : D⟦J c, R d⟧)
      : D ⟦M c, M d⟧
      := pr2 M _ _ f.

    Definition mlift (M : RelModule_data R) {a b} (f : C ⟦a, b⟧)
      : D ⟦pr1 M a, pr1 M b⟧
      := mbind M (#J f · r_eta R _).

    Definition relmodule_functor_data (M : RelModule_data R)
      : functor_data C D
      := make_functor_data M (λ a b (f : a -->b), mlift M f).

    Definition RelModule_laws (M : RelModule_data R) : UU
      := RelMonad_axioms R
       × (∏ c, mbind M (r_eta R c) = identity _ )
       × (∏ c d e (f : D ⟦J c, R d⟧) (g : D ⟦J d, R e⟧),
          mbind M f · mbind M g = mbind M (f · r_bind R g)).

    Coercion relmonad_axiom_from_relmodule {M : RelModule_data R} (X : RelModule_laws M)
      : RelMonad_axioms R
      := pr1 X.

    Definition mbind_r_eta {M : RelModule_data R} (X : RelModule_laws M)
      : ∏ c, mbind M (r_eta R c) = identity _ := pr1 (pr2 X).

    Definition mbind_mbind {M : RelModule_data R} (X : RelModule_laws M)
      : ∏ c d e (f : D ⟦J c, R d⟧) (g : D ⟦J d, R e⟧),
        mbind M f · mbind M g = mbind M (f · r_bind R g)
      := pr2 (pr2 X).

    Lemma isaprop_RelModule_laws (hs : has_homsets D) (M : RelModule_data R)
      : isaprop (RelModule_laws M).
    Proof.
      apply isapropdirprod.
      - apply isaprop_RelMonad_axioms, hs.
      - apply isapropdirprod; repeat (apply impred; intros); apply hs.
    Qed.

    Lemma mbind_mlift {M : RelModule_data R} (X : RelModule_laws M) {c d e : C} (f : J c --> R d) (g : d --> e)
      : mbind M f · mlift M g = mbind M (f · r_lift R g).
    Proof.
      apply (mbind_mbind X).
    Qed.

  End Projections_and_Laws.
End RelModule_Definition.

(* We make a separate section with stronger hypothesis [RelMonad] to state
   another fusion law involving [r_lift]. *)
Section Projections_and_Laws_2.

Context {C : precategory_data} {D : precategory}{J : C ⟶ D} {R : RelMonad J} {M : RelModule_data R} (X : RelModule_laws M).

Lemma mlift_mbind {c d e : C} (f : c --> d) (g : J d --> R e)
  : mlift M f · mbind M g = mbind M (#J f · g).
Proof.
  unfold mlift.
  etrans. { apply (mbind_mbind X). }
          apply maponpaths.
  etrans. { apply pathsinv0, assoc. }
          apply maponpaths.
  apply (r_eta_r_bind R).
Qed.

End Projections_and_Laws_2.

(* ----------------------------------------------------------------------------------- *)
(** ** Packing the full structure of Relative Module together.                         *)
(* ----------------------------------------------------------------------------------- *)

Definition RelModule {C D : precategory_data} {J : C ⟶ D} (R : RelMonad_data J) : UU
  := ∑ M : RelModule_data R, RelModule_laws M.

Definition make_RelModule {C D : precategory_data} {J : C ⟶ D} (R : RelMonad_data J)
           (M : RelModule_data R) (HM : RelModule_laws M)
  : RelModule R
  := (M,, HM).

Coercion RelModule_data_from_RelModule {C D : precategory_data} {J : C ⟶ D}
         {R : RelMonad_data J} (M : RelModule R)
  : RelModule_data R
  := pr1 M.

Coercion RelModule_laws_from_RelModule {C D : precategory_data} {J : C ⟶ D}
         {R : RelMonad_data J} (M : RelModule R)
  : RelModule_laws M
  := pr2 M.

(* ----------------------------------------------------------------------------------- *)
(** ** Functoriality of Modules                                                        *)
(* ----------------------------------------------------------------------------------- *)

Section Functor_from_RelModule.

  Context {C : precategory_data} {D : precategory} {J : C ⟶ D}.

  Lemma mlift_id {R : RelMonad_data J} {M : RelModule_data R} (X : RelModule_laws M) (c : C) :
    mlift M (identity c) = identity (M c).
  Proof.
    transitivity (mbind M (r_eta R c)).
    2: apply (mbind_r_eta X).
    unfold mlift. cbn. apply maponpaths.
    etrans.
    2: apply id_left.
    apply maponpaths_2.
    apply functor_id.
  Qed.

  Context {R : RelMonad J} {M : RelModule_data R} (X : RelModule_laws M).

  Lemma mlift_mlift {c d e : C} (f : c --> d) (g : d --> e) :
    mlift M f · mlift M g = mlift M (f · g).
  Proof.
    unfold mlift at 2.
    etrans. { apply (mlift_mbind X). }
    unfold mlift. apply maponpaths.
    etrans. { apply assoc. }
    apply maponpaths_2.
    apply pathsinv0, functor_comp.
  Qed.

  Definition functor_data_from_relmodule : functor_data C D
    := functor_data_constr C D
                           (RelModule_ob M : C → D)
                           (λ a b (f : a --> b), mlift M f).

  Definition is_functor_mlift : is_functor functor_data_from_relmodule.
  Proof.
    split.
    - red; intro a. apply (mlift_id X).
    - red. intros. cbn. apply pathsinv0. apply mlift_mlift.
  Defined.

  Definition functor_from_relmodule : C ⟶ D
    := make_functor functor_data_from_relmodule is_functor_mlift.

End Functor_from_RelModule.

(* ----------------------------------------------------------------------------------- *)
(** ** Morphisms of modules over a fixe relative monad.                                *)
(* ----------------------------------------------------------------------------------- *)

Section RelModule_Morphism_Definition.
Section Part1.
  Context {C D : precategory_data} {J : C ⟶ D} {R : RelMonad_data J}.

  Definition is_relmodule_mor (M N : RelModule_data R) (φ : ∏ a : C, M a --> N a) : UU
    := (∏ a b (f : J a --> R b), mbind M f · φ b = φ a · mbind N f).

  Lemma isaprop_RelModule_Mor_laws (hs : has_homsets D) (M N : RelModule_data R)
        (φ : ∏ a : C, M a --> N a)
    : isaprop (is_relmodule_mor M N φ).
  Proof.
    repeat (apply impred; intro); apply hs.
  Qed.

  Definition RelModule_Mor (M N : RelModule R) : UU :=
    ∑ (φ : ∏ a : C, M a --> N a), is_relmodule_mor M N φ.

  Definition relmodule_mor_map {M N : RelModule R} (φ : RelModule_Mor M N)
    : ∏ a : C, M a --> N a
    := pr1 φ.
  Coercion relmodule_mor_map : RelModule_Mor >-> Funclass.

  Coercion relmodule_mor_property {M N : RelModule R} (φ : RelModule_Mor M N)
    : is_relmodule_mor M N φ
    := pr2 φ.

End Part1.
(** now with [D : precategory, R : RelMonad J] *)
Section Part2.
  Context {C : precategory_data} {D : precategory} {J : C ⟶ D} {R : RelMonad J}.

  Definition is_nat_trans_relmodule_mor {M N : RelModule R} {φ : ∏ a : C, M a --> N a}
             (Hφ : is_relmodule_mor M N φ)
    : is_nat_trans (functor_from_relmodule M) (functor_from_relmodule N) φ.
  Proof.
    intros a b f. cbn. unfold mlift. apply Hφ.
  Defined.

  Definition RelModule_Mor_equiv (hs : has_homsets D)
  {M N : RelModule R} (φ ψ : RelModule_Mor M N)
  : φ = ψ ≃ (pr1 φ = pr1 ψ).
  Proof.
    apply subtypeInjectivity; intro a.
    apply isaprop_RelModule_Mor_laws, hs.
  Defined.

  Definition nat_trans_from_relmodule_mor {M N : RelModule R} (φ : RelModule_Mor M N)
    : functor_from_relmodule M ⟹ functor_from_relmodule N
    := make_nat_trans (functor_from_relmodule M) (functor_from_relmodule N)
                    φ
                    (is_nat_trans_relmodule_mor φ).

  Definition is_relmodule_mor_id (M : RelModule R)
    : is_relmodule_mor M M (λ a, identity (M a)).
  Proof.
    intros a b f. etrans.
    - apply id_right.
    - apply pathsinv0, id_left.
  Qed.

  Definition relmodule_mor_id (M : RelModule R) : RelModule_Mor M M :=
    ((λ a, identity (M a)),, is_relmodule_mor_id M).

  Definition is_relmodule_mor_comp {L M N : RelModule R}
             {φ} (φ_mor : is_relmodule_mor L M φ)
             {ψ} (ψ_mor : is_relmodule_mor M N ψ)
    : is_relmodule_mor L N (λ a, φ a · ψ a).
  Proof.
    intros a b f.
    etrans. { apply assoc. }
    etrans. { apply maponpaths_2, φ_mor. }
    etrans. { apply pathsinv0, assoc. }
    etrans. 2: apply assoc.
    apply maponpaths.
    apply ψ_mor.
  Qed.

  Definition relmodule_mor_comp {L M N : RelModule R}
             (φ : RelModule_Mor L M) (ψ : RelModule_Mor M N)
    : RelModule_Mor L N
    := ((λ a, φ a · ψ a),, is_relmodule_mor_comp φ ψ).

End Part2.

End RelModule_Morphism_Definition.

(* ----------------------------------------------------------------------------------- *)
(** ** Category of modules over a fixed relative monad.                                *)
(* ----------------------------------------------------------------------------------- *)

Section RelModule_Category.

  Context {C : precategory_data} {D : precategory} {J : C ⟶ D} (R : RelMonad J).

  Definition relmodule_precategory_ob_mor : precategory_ob_mor
    := make_precategory_ob_mor (RelModule R) RelModule_Mor.

  Definition relmodule_precategory_data : precategory_data
    := make_precategory_data
         relmodule_precategory_ob_mor
         relmodule_mor_id
         (λ M N P (φ : RelModule_Mor M N) (ψ : RelModule_Mor N P),
          relmodule_mor_comp φ ψ).

  Lemma is_precategory_relmodule (hs : has_homsets D)
    : is_precategory relmodule_precategory_data.
  Proof.
    apply is_precategory_one_assoc_to_two.
    repeat split.
    - intros x y f.
      apply (invmap (RelModule_Mor_equiv hs _ _ )).
      apply funextsec; intros a. apply id_left.
    - intros x y f.
      apply (invmap (RelModule_Mor_equiv hs _ _ )).
      apply funextsec; intros a. apply id_right.
    - intros x y z w f g h.
      apply (invmap (RelModule_Mor_equiv hs _ _ )).
      apply funextsec. intros a. apply assoc.
  Qed.

  Definition RelModule_Precategory (hs : has_homsets D)
    : precategory
    := make_precategory relmodule_precategory_data (is_precategory_relmodule hs).

  Definition has_homsets_RelModule_Precategory (hs : has_homsets D)
    : has_homsets (RelModule_Precategory hs).
  Proof.
    red. cbn. intros M N.
    apply isaset_total2.
    - apply impred_isaset. intros. apply hs.
    - intros P. apply isasetaprop.
      apply isaprop_RelModule_Mor_laws. apply hs.
  Defined.

End RelModule_Category.

(* ----------------------------------------------------------------------------------- *)
(** ** Tautological module                                                             *)
(*                                                                                *)
(** Any relative monad is a left module over itself.                                   *)
(* ----------------------------------------------------------------------------------- *)

Section Tautological_RelModule.

  Context {C D : precategory_data} {J : C ⟶ D} (R : RelMonad J).

  Definition tautological_RelModule_data : RelModule_data R
    := make_relmodule_data R R (λ a b (f : D⟦J a, R b⟧), r_bind R f).

  Lemma tautological_RelModule_law  : RelModule_laws tautological_RelModule_data.
  Proof.
    split.
    - exact R.
    - repeat split; cbn; intros.
      + apply (r_bind_r_eta R).
      + apply (r_bind_r_bind R).
  Qed.

  Definition tautological_RelModule : RelModule R
    := make_RelModule R tautological_RelModule_data tautological_RelModule_law.

End Tautological_RelModule.


(***************************************)
(***************************************)
(****                               ****)
(****   Equivalence of categories   ****)
(****                               ****)
(***************************************)
(***************************************)

Require Import Main.CategoryTheory.Arrow.
Require Import Main.CategoryTheory.Category.
Require Import Main.CategoryTheory.Functor.
Require Import Main.CategoryTheory.NaturalTransformation.
Require Import Main.Tactics.

#[local] Set Universe Polymorphism.

Definition equivalence C D
  (F : functor C D)
  (G : functor D C)
  (Eta : naturalTransformation (compFunctor F G) idFunctor)
  (Mu : naturalTransformation idFunctor (compFunctor G F)) :=
  naturalIsomorphism Eta /\ naturalIsomorphism Mu.

Definition equivalent C D :=
  exists
    (F : functor C D)
    (G : functor D C)
    (Eta : naturalTransformation (compFunctor F G) idFunctor)
    (Mu : naturalTransformation idFunctor (compFunctor G F)),
  equivalence C D F G Eta Mu.

Theorem equivalentRefl C : equivalent C C.
Proof.
  unfold equivalent.
  exists idFunctor.
  exists idFunctor.
  assert (idFunctor = @compFunctor C C C idFunctor idFunctor); [
    rewrite compFunctorIdentLeft; search |
    idtac
  ].
  exists (
    match H
    in (_ = rhs)
    return naturalTransformation rhs idFunctor
    with
    | eq_refl => idNaturalTransformation
    end
  ).
  exists (
    match H
    in (_ = rhs)
    return naturalTransformation idFunctor rhs
    with
    | eq_refl => idNaturalTransformation
    end
  ).
  unfold equivalence.
  destruct H.
  split;
    unfold naturalIsomorphism;
    clean;
    unfold isomorphism;
    exists id;
    unfold inverse;
    search.
Qed.

#[export] Hint Resolve equivalentRefl : main.


Require Import init.

Require Export category_base.

(* begin show *)
Set Universe Polymorphism.
(* end show *)

Definition initial `{C0 : Category} (I : cat_U C0)
    := ∀ A, Singleton (cat_morphism C0 I A).
Definition terminal `{C0 : Category} (T : cat_U C0)
    := ∀ A, Singleton (cat_morphism C0 A T).

(* begin hide *)
Section InitTerm1.

Context `{C0 : Category}.

(* end hide *)
Theorem initial_all_iso : ∀ I1 I2, initial I1 → initial I2 →
    ∀ f : cat_morphism C0 I1 I2, isomorphism f.
Proof.
    intros I1 I2 I1_init I2_init f.
    pose proof (I1_init I1) as I1_self.
    pose proof (I2_init I2) as I2_self.
    specialize (I2_init I1).
    destruct I2_init as [[g g_uni]].
    exists g.
    rewrite (singleton_unique2 (f ∘ g) 𝟙).
    rewrite (singleton_unique2 (g ∘ f) 𝟙).
    split; reflexivity.
Qed.

Theorem initial_unique : ∀ I1 I2, initial I1 → initial I2 → I1 ≅ I2.
Proof.
    intros I1 I2 I1_init I2_init.
    pose proof (I1_init I2) as I1_init'.
    destruct I1_init' as [[f f_uni]].
    exists f.
    apply initial_all_iso; assumption.
Qed.

Theorem initial_iso_unique : ∀ I1 I2, initial I1 → initial I2 →
    ∀ f g : cat_morphism C0 I1 I2, f = g.
Proof.
    intros I1 I2 I1_init I2_init f g.
    specialize (I1_init I2).
    apply singleton_unique2.
Qed.

Theorem initial_dual_terminal :
    ∀ I : cat_U C0, initial I → terminal (C0:=dual_category C0) I.
Proof.
    intros I I_init.
    exact I_init.
Qed.

Theorem terminal_dual_initial :
    ∀ I : cat_U C0, terminal I → initial (C0:=dual_category C0) I.
Proof.
    intros I I_term.
    exact I_term.
Qed.

(* begin hide *)
End InitTerm1.
Section InitTerm2.

Context `{C0 : Category}.

(* end hide *)
Theorem terminal_all_iso : ∀ T1 T2, terminal T1 → terminal T2 →
    ∀ f : cat_morphism C0 T1 T2, isomorphism f.
Proof.
    intros T1 T2 T1_term T2_term f.
    apply terminal_dual_initial in T1_term, T2_term.
    rewrite dual_isomorphism.
    exact (initial_all_iso _ _ T2_term T1_term f).
Qed.

Theorem terminal_unique : ∀ T1 T2, terminal T1 → terminal T2 → T1 ≅ T2.
Proof.
    intros T1 T2 T1_term T2_term.
    apply terminal_dual_initial in T1_term, T2_term.
    pose proof (initial_unique _ _ T2_term T1_term) as [f f_iso].
    exists f.
    rewrite dual_isomorphism.
    exact f_iso.
Qed.

Theorem terminal_iso_unique : ∀ T1 T2, terminal T1 → terminal T2 →
    ∀ f g : cat_morphism C0 T1 T2, f = g.
Proof.
    intros T1 T2 T1_term T2_term f g.
    specialize (T2_term T1).
    apply singleton_unique2.
Qed.

(* begin hide *)
End InitTerm2.

(* end hide *)
(* begin show *)
Unset Universe Polymorphism.
(* end show *)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e383m421_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import SpecCert.Equality.
Require Import SpecCert.Address.
Require Import SpecCert.Map.

Parameter Index: Set.
Parameter index_eq: Index -> Index -> Prop.
Parameter index_eq_refl: forall i:Index, index_eq i i.
Parameter index_eq_sym: forall i i':Index, index_eq i i' -> index_eq i' i.
Parameter index_eq_trans: forall i i' i'':Index, index_eq i i' -> index_eq i' i'' -> index_eq i i''.
Parameter index_dec: forall i i':Index, {index_eq i i'}+{~index_eq i i'}.
Parameter index_eq_eq: forall i i':Index, index_eq i i' -> i = i'.
Parameter eq_index_eq: forall i i':Index, i = i' -> index_eq i i'.

Parameter phys_to_index: PhysicalAddress -> Index.

Instance IndexEq: Eq Index :=
  { eq       := index_eq
  ; eq_sym   := index_eq_sym
  ; eq_refl  := index_eq_refl
  ; eq_trans := index_eq_trans
  ; eq_dec   := index_dec
  ; eq_equal := index_eq_eq
  ; equal_eq := eq_index_eq
  }.

Record CacheEntry
       (S: Type)
  := { dirty: bool
     ; content: S
     ; tag: PhysicalAddress }.

Arguments dirty   : default implicits.
Arguments content : default implicits.
Arguments tag     : default implicits.

Definition Cache (S: Type) := Map Index (CacheEntry S).


Require Import Verse.
Require Import Verse.CryptoLib.sha2.
Require Import Verse.CryptoLib.sha2.c.portable.

Module Config <: CONFIG.
  Definition WordSize   := 3 (*Word64*).
  Definition ROUNDS := 80.
  Definition KVec   := [ Ox "428a2f98d728ae22";
                         Ox "7137449123ef65cd";
                         Ox "b5c0fbcfec4d3b2f";
                         Ox "e9b5dba58189dbbc";
                         Ox "3956c25bf348b538";
                         Ox "59f111f1b605d019";
                         Ox "923f82a4af194f9b";
                         Ox "ab1c5ed5da6d8118";
                         Ox "d807aa98a3030242";
                         Ox "12835b0145706fbe";
                         Ox "243185be4ee4b28c";
                         Ox "550c7dc3d5ffb4e2";
                         Ox "72be5d74f27b896f";
                         Ox "80deb1fe3b1696b1";
                         Ox "9bdc06a725c71235";
                         Ox "c19bf174cf692694";
                         Ox "e49b69c19ef14ad2";
                         Ox "efbe4786384f25e3";
                         Ox "0fc19dc68b8cd5b5";
                         Ox "240ca1cc77ac9c65";
                         Ox "2de92c6f592b0275";
                         Ox "4a7484aa6ea6e483";
                         Ox "5cb0a9dcbd41fbd4";
                         Ox "76f988da831153b5";
                         Ox "983e5152ee66dfab";
                         Ox "a831c66d2db43210";
                         Ox "b00327c898fb213f";
                         Ox "bf597fc7beef0ee4";
                         Ox "c6e00bf33da88fc2";
                         Ox "d5a79147930aa725";
                         Ox "06ca6351e003826f";
                         Ox "142929670a0e6e70";
                         Ox "27b70a8546d22ffc";
                         Ox "2e1b21385c26c926";
                         Ox "4d2c6dfc5ac42aed";
                         Ox "53380d139d95b3df";
                         Ox "650a73548baf63de";
                         Ox "766a0abb3c77b2a8";
                         Ox "81c2c92e47edaee6";
                         Ox "92722c851482353b";
                         Ox "a2bfe8a14cf10364";
                         Ox "a81a664bbc423001";
                         Ox "c24b8b70d0f89791";
                         Ox "c76c51a30654be30";
                         Ox "d192e819d6ef5218";
                         Ox "d69906245565a910";
                         Ox "f40e35855771202a";
                         Ox "106aa07032bbd1b8";
                         Ox "19a4c116b8d2d0c8";
                         Ox "1e376c085141ab53";
                         Ox "2748774cdf8eeb99";
                         Ox "34b0bcb5e19b48a8";
                         Ox "391c0cb3c5c95a63";
                         Ox "4ed8aa4ae3418acb";
                         Ox "5b9cca4f7763e373";
                         Ox "682e6ff3d6b2b8a3";
                         Ox "748f82ee5defb2fc";
                         Ox "78a5636f43172f60";
                         Ox "84c87814a1f0ab72";
                         Ox "8cc702081a6439ec";
                         Ox "90befffa23631e28";
                         Ox "a4506cebde82bde9";
                         Ox "bef9a3f7b2c67915";
                         Ox "c67178f2e372532b";
                         Ox "ca273eceea26619c";
                         Ox "d186b8c721c0c207";
                         Ox "eada7dd6cde0eb1e";
                         Ox "f57d4f7fee6ed178";
                         Ox "06f067aa72176fba";
                         Ox "0a637dc5a2c898a6";
                         Ox "113f9804bef90dae";
                         Ox "1b710b35131c471b";
                         Ox "28db77f523047d84";
                         Ox "32caab7b40c72493";
                         Ox "3c9ebe0a15c9bebc";
                         Ox "431d67c49c100d4c";
                         Ox "4cc5d4becb3e42b6";
                         Ox "597f299cfc657e2a";
                         Ox "5fcb6fab3ad6faec";
                         Ox "6c44198c4a475817"
                       ]%vector.

  Definition R00 := 28. Definition R01 := 34. Definition R02 := 39.
  Definition R10 := 14. Definition R11 := 18. Definition R12 := 41.
  Definition r00 := 1.  Definition r01 := 8.  Definition s0  := 7.
  Definition r10 := 19. Definition r11 := 61. Definition s1  := 6.

  Lemma increasing_R's : R00 <= R01 <= R02 /\ R10 <= R11 <= R12.
  Proof.
    repeat (compute; constructor).
  Qed.

  Definition increasing_r's : r00 <= r01 /\ r10 <= r11.
  Proof.
    repeat (compute; constructor).
  Qed.

End Config.
Module SHA512 := SHA2 Config.

Require Import Verse.Target.C.

Inductive name := verse_sha512_c_portable.

Require Verse.CryptoLib.sha2.

Definition sha512iter : CodeGen.Config.programLine + {Error.TranslationError}.
  Iterator verse_sha512_c_portable
           SHA512.Block
           SHA512.Sha2.
Defined.

Require Import Verse.Error.
Definition iterator : Compile.programLine := recover (sha512iter).
Definition program := verseC [iterator].

Require Import Verse.FFI.Raaz.
Require Import Verse.FFI.Raaz.Target.C.

Definition raazFFI {Name} (name : Name)
  := mkProgram name [ iterator verse_sha512_c_portable
                               SHA512.Block
                               SHA512.Sha2
                    ].

(*

Require Import Verse.Print.
Require Import Verse.Target.C.Pretty.

Goal to_print program.
  print.
Abort.

*)


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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 := Cons : natural -> lst -> lst |  Nil : 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.

Theorem append_Nil: forall (l: lst), append l Nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  - simpl. rewrite <- IHl1. f_equal.
  - simpl. rewrite 2 append_Nil. reflexivity.
  - simpl. rewrite append_Nil.  reflexivity.
  - simpl. rewrite 2 append_Nil. reflexivity.
Qed.

Theorem append_rev_Cons:
  forall (l1 l2: lst) (x: natural),
    rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
  induction l1; induction l2; try (simpl; reflexivity).
  { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
    f_equal. }
  { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
  induction l1.
  { induction l2.
    { simpl. rewrite append_rev_Cons.
      rewrite <- 2 append_assoc.
      f_equal. }
    { simpl. lfind. Admitted.