(* Copyright (c) 2014, Robert Dockins *)

Require Import Relations.
Require Import List.
Require Import Setoid.
Require Import Arith.

Require Import Domains.basics.
Require Import Domains.preord.
Require Import Domains.categories.
Require Import Domains.sets.

(** * The theory of finite sets.

      Here we define the theory of finite sets.  Concretely,
      finite sets are represetned by the standard list type,
      with list membership.  Singleton sets are given
      by one-element lists, union is defined by list
      concatination and image is the stadard list map function.
  *)

Definition concat (A:Type) (l:list (list A)) : list A :=
  List.fold_right (@app A) (@nil A) l.

Module finset.
Section finset.
  Definition fset (A:preord) := list A.
  Definition fsingle (A:preord) (a:A) := a::nil.
  Definition fmember (A:preord) (a:A) (P:fset A) := exists a', In a' P /\ a ≈ a'.
  Definition fimage (A B:preord) (f:A → B) (P:fset A) : fset B :=
    List.map (Preord.map A B f) P.
  Definition funion (A:preord) (XS:fset (set.set_preord fset fmember A)) : fset A :=
    fold_right (@app A) (@nil A) XS.

  Program Definition mixin : set.mixin_of fset fmember fsingle fimage funion :=
    set.Mixin fset fmember fsingle fimage funion _ _ _ _ _ _.
  Next Obligation.
    unfold fmember.
    intros. induction X; simpl in *; intuition.
    destruct H0 as [a' [??]]. elim H0.
    destruct H0 as [a' [??]]. destruct H0; subst.
    exists a'. split; eauto.
    destruct IHX as [q [??]]; eauto.
  Qed.
  Next Obligation.
    unfold fmember, fsingle; intros.
    firstorder; subst; auto.
  Qed.
  Next Obligation.
    unfold fmember. simpl; intros.
    induction XS; simpl; intuition.
    destruct H as [?[??]]. elim H.
    destruct H as [?[??]].
    destruct H as [?[??]]. elim H.

    destruct H1 as [a' [??]].
    apply in_app_or in H1.
    destruct H1.
    exists a0. split; eauto.
    destruct H as [X [??]]; eauto.
    exists X; split; eauto.
    destruct H as [q [??]].
    exists q; split; auto.
    destruct H1 as [X [??]].
    destruct H1 as [Y [??]].
    destruct H1; subst.
    destruct H2 as [a' [??]].
    destruct H3.
    destruct (H3 a') as [a'' [??]]; eauto.
    exists a'. split; auto.
    exists a''. split; auto.
    apply in_or_app. auto.
    eauto.
    destruct H0 as [q [??]]; eauto.
    destruct H2 as [a' [??]].
    exists q; split; auto.
    apply in_or_app; auto.
  Qed.
  Next Obligation.
    unfold fmember, fimage. simpl; intros.
    intuition.
    destruct H as [a' [??]].
    exists a'; split; auto.
    rewrite map_map. auto.
    destruct H as [a' [??]].
    exists a'; split; auto.
    rewrite map_map in H; auto.
  Qed.
  Next Obligation.
    unfold fmember, fimage; simpl; intros.
    destruct H as [a' [??]].
    induction P; simpl in *; intuition; subst.
    exists (Preord.map A B f a').
    split; auto.
    destruct H as [b [??]].
    exists b. split; auto.
  Qed.
  Next Obligation.
    unfold fmember, fimage; simpl; intros.
    destruct H as [a' [??]].
    induction P; simpl in *; intuition; subst.
    exists a. split; auto. exists a; split; auto.
    destruct H as [y [??]].
    exists y. split; auto.
    destruct H as [b [??]].
    exists b; split; auto.
  Qed.
End finset.
End finset.

Canonical Structure finset_theory : set.theory :=
  set.Theory
    finset.fset
    finset.fmember
    finset.fsingle
    finset.fimage
    finset.funion
    finset.mixin.

Notation finset := (set_preord finset_theory).

Definition cl_finset_theory (CL:color) : set.theory
  := cset_theory finset_theory CL.
Notation cl_finset CL := (set_preord (cl_finset_theory CL)).

Program Definition finset_dec (A:preord) (Adec : ord_dec A) : set_dec finset_theory A
  := Setdec finset_theory A _.
Next Obligation.
  intros A Adec x X.
  induction X. right. red; simpl; intros.
  destruct H as [x' [??]]. apply H.
  destruct IHX.
  left.
  destruct m as [x' [??]].
  exists x'. split; simpl; auto.
  destruct (PREORD_EQ_DEC A Adec x a).
  left.
  exists a. split; simpl; auto.
  right.
  intros [x' [??]].
  simpl in H; intuition; subst; auto.
  apply n.
  exists x'. split; auto.
Qed.

Canonical Structure finset_dec.

(**  Some useful lemmas relating list formation operations to
     finite set membership.
  *)
Lemma nil_elem : forall (A:preord) (x:A),
  x ∈ (nil : finset A) -> False.
Proof.
  intros. destruct H as [?[??]]. elim H.
Qed.

Lemma cons_elem : forall (A:preord) (a:A) (P:finset A) (x:A),
  x ∈ (a::P : finset A) <-> x ≈ a \/ x ∈ P.
Proof.
  intros; split; intros.
  destruct H as [q [??]].
  destruct H. subst. auto.
  right. exists q; split; auto.
  destruct H.
  exists a; split; simpl; auto.
  destruct H as [q [??]]. exists q; split; simpl; auto.
Qed.

Lemma app_elem :  forall (A:preord) (P Q:finset A) (x:A),
  x ∈ (P++Q : finset A) <-> x ∈ P \/ x ∈ Q.
Proof.
  intro A. induction P; split; intros; auto.
  destruct H; auto.
  apply nil_elem in H. elim H.
  simpl in H.
  apply cons_elem in H.
  destruct H.
  left. apply cons_elem; auto.
  apply IHP in H. destruct H.
  left. apply cons_elem; auto.
  auto.
  simpl. apply cons_elem.
  destruct H.
  apply cons_elem in H.
  destruct H; auto.
  right. apply IHP; auto.
  right. apply IHP; auto.
Qed.

Lemma nil_subset X (Q:finset X) :
  (nil : finset X) ⊆ Q.
Proof.
  repeat intro. apply nil_elem in H. elim H.
Qed.

Lemma ub_nil : forall (X:preord) (a:X),
  upper_bound a (nil : finset X).
Proof.
  repeat intro. apply nil_elem in H. elim H.
Qed.

Lemma ub_cons (X:preord) (x:X) (xs:finset X) (a:X) :
  x ≤ a ->
  upper_bound a xs ->
  upper_bound a (x::xs : finset X).
Proof.
  repeat intro.
  apply cons_elem in H1. destruct H1.
  rewrite H1. auto. apply H0; auto.
Qed.

Lemma cons_subset (X:preord) (x:X) (xs ys:finset X) :
  x ∈ ys -> xs ⊆ ys -> (x::xs : finset X) ⊆ ys.
Proof.
  repeat intro.
  apply cons_elem in H1. destruct H1.
  rewrite H1; auto. apply H0; auto.
Qed.

Lemma cons_morphism (X:preord) (x x':X) (xs xs':finset X) :
  x ≈ x' -> xs ≈ xs' -> (x :: xs:finset X) ≈ x' :: xs'.
Proof.
  intros.
  split.
  apply cons_subset. apply cons_elem. auto.
  red; intros. apply cons_elem; auto.
  right. rewrite <- H0; auto.
  apply cons_subset. apply cons_elem. auto.
  red; intros. apply cons_elem; auto.
  right. rewrite H0; auto.
Qed.

Lemma dec_conj (P Q : Prop) :
  {P}+{~P} -> {Q}+{~Q} -> {P/\Q}+{~(P/\Q)}.
Proof.
  intros. destruct H. destruct H0.
  left; auto.
  right; intros [??]; contradiction.
  right; intros [??]; contradiction.
Qed.

(**  The cartesian product of finite sets.
  *)
Fixpoint finprod {A B:preord} (P:finset A) (Q:finset B) : finset (A×B) :=
  match P with
  | nil => nil
  | x::P' => map (fun y => (x,y)) Q ++ finprod P' Q
  end.

Lemma finprod_elem : forall A B (P:finset A) (Q:finset B) a b,
  (a,b) ∈ finprod P Q <-> (a ∈ P /\ b ∈ Q).
Proof.
  intros A B. induction P; simpl; split; intros.
  apply nil_elem in H. elim H.
  destruct H. apply nil_elem in H. elim H.
  apply app_elem in H.
  destruct H.
  destruct H as [?[??]].
  apply in_map_iff in H.
  destruct H as [q [??]].
  subst x.
  split.
  apply cons_elem. left.
  destruct H0 as [[??][??]]; split; auto.
  exists q; split; auto.
  destruct H0 as [[??][??]]; split; auto.
  apply IHP in H.
  destruct H; split; auto.
  apply cons_elem; auto.
  destruct H.
  apply cons_elem in H.
  destruct H.
  apply app_elem.
  left.
  destruct H0 as [q [??]].
  exists (a,q).
  split.
  apply in_map_iff.
  exists q. split; auto.
  destruct H; destruct H1.
  split; split; auto.
  apply app_elem. right.
  apply IHP. split; auto.
Qed.

(**  Disjoint union of finite sets.
  *)

Fixpoint left_finset (A B:preord) (X:finset (sum_preord A B)) : finset A :=
  match X with
  | nil => nil
  | inl l :: X' => l :: left_finset A B X'
  | inr _ :: X' => left_finset A B X'
  end.

Fixpoint right_finset (A B:preord) (X:finset (sum_preord A B)) : finset B :=
  match X with
  | nil => nil
  | inl _ :: X' => right_finset A B X'
  | inr r :: X' => r :: right_finset A B X'
  end.

Lemma left_finset_elem A B X a :
  a ∈ left_finset A B X <-> inl a ∈ X.
Proof.
  induction X; simpl.
  split; intros.
  apply nil_elem in H. elim H.
  apply nil_elem in H. elim H.
  destruct a0; simpl.
  split; intros.
  apply cons_elem in H. destruct H.
  apply cons_elem. left. auto.
  rewrite IHX in H.
  apply cons_elem. right. auto.
  apply cons_elem in H. destruct H.
  apply cons_elem. left. auto.
  apply cons_elem. right. rewrite IHX. auto.
  split; intros.
  rewrite IHX in H.
  apply cons_elem. right. auto.
  apply cons_elem in H. destruct H.
  destruct H. elim H.
  rewrite IHX. auto.
Qed.

Lemma right_finset_elem A B X b :
  b ∈ right_finset A B X <-> inr b ∈ X.
Proof.
  induction X; simpl.
  split; intros.
  apply nil_elem in H. elim H.
  apply nil_elem in H. elim H.
  destruct a; simpl.
  split; intros.
  rewrite IHX in H.
  apply cons_elem. right. auto.
  apply cons_elem in H. destruct H.
  destruct H. elim H.
  rewrite IHX. auto.

  split; intros.
  apply cons_elem in H. destruct H.
  apply cons_elem. left. auto.
  rewrite IHX in H.
  apply cons_elem. right. auto.
  apply cons_elem in H. destruct H.
  apply cons_elem. left. auto.
  apply cons_elem. right. rewrite IHX. auto.
Qed.

Definition finsum {A B:preord} (P:finset A) (Q:finset B) : finset (sum_preord A B) :=
  map inl P ++ map inr Q.

Lemma finsum_left_elem : forall A B (P:finset A) (Q:finset B) a,
  inl a ∈ finsum P Q <-> a ∈ P.
Proof.
  split; intro.
  destruct H as [q [??]].
  unfold finsum in H.
  apply in_app_or in H.
  destruct H.
  apply in_map_iff in H.
  destruct H as [x [??]].
  subst q.
  exists x. split; auto.
  apply in_map_iff in H.
  destruct H as [x [??]].
  subst q.
  destruct H0. elim H.
  destruct H as [x [??]].
  exists (inl x).
  split; auto.
  unfold finsum.
  apply in_or_app.
  left.
  apply in_map. auto.
Qed.

Lemma finsum_right_elem : forall A B (P:finset A) (Q:finset B) b,
  inr b ∈ finsum P Q <-> b ∈ Q.
Proof.
  split; intro.
  destruct H as [q [??]].
  unfold finsum in H.
  apply in_app_or in H.
  destruct H.
  apply in_map_iff in H.
  destruct H as [x [??]].
  subst q.
  destruct H0. elim H.
  apply in_map_iff in H.
  destruct H as [x [??]].
  subst q.
  exists x; split; auto.
  destruct H as [x [??]].
  exists (inr x).
  split; auto.
  unfold finsum.
  apply in_or_app.
  right.
  apply in_map. auto.
Qed.

Lemma left_right_finset_finsum A B X :
  X ≈ finsum (left_finset A B X) (right_finset A B X).
Proof.
  split; hnf; intros.
  destruct a.
  apply finsum_left_elem.
  apply left_finset_elem. auto.
  apply finsum_right_elem.
  apply right_finset_elem. auto.
  destruct a.
  apply left_finset_elem.
  eapply finsum_left_elem; eauto.
  apply right_finset_elem.
  eapply finsum_right_elem; eauto.
Qed.

(**  We can take the subset of a finite set if the
     predicate we wish to use to take the subset is decidable.
  *)
Section finsubset.
  Variable A:preord.
  Variable P : A -> Prop.
  Variable HP : forall x y, x ≈ y -> P x -> P y.
  Variable Hdec : forall x, { P x } + { ~P x }.

  Fixpoint finsubset (l:finset A) : finset A :=
    match l with
    | nil => nil
    | x::xs => if Hdec x then x :: finsubset xs else finsubset xs
    end.

  Lemma finsubset_elem : forall X x,
    x ∈ finsubset X <-> (x ∈ X /\ P x).
  Proof.
    induction X; simpl; split; simpl; intros.
    destruct H as [?[??]]. elim H.
    destruct H.
    destruct H as [?[??]]. elim H.
    destruct (Hdec a).
    destruct H as [q [??]].
    simpl in H; destruct H; subst.
    split.
    exists q. split; simpl; auto.
    apply HP with q; auto.
    assert (x ∈ finsubset X).
    exists q; split; simpl; auto.
    apply IHX in H1.
    destruct H1.
    destruct H1 as [q' [??]].
    split; auto.
    exists q'; split; simpl; auto.
    apply IHX in H.
    destruct H.
    split; auto.
    destruct H as [q' [??]].
    exists q'; split; simpl; auto.

    destruct H.
    destruct H as [q [??]].
    simpl in H; destruct H; subst.
    destruct (Hdec q).
    exists q; split; simpl; auto.
    elim n.
    apply HP with x; auto.
    assert (x ∈ finsubset X).
    apply IHX. split; auto.
    exists q; split; auto.
    destruct (Hdec a); auto.
    destruct H2 as [q' [??]].
    exists q'; split; simpl; auto.
  Qed.
End finsubset.

(**  We can take the intersection of finite sets if the elements
     have decidable equality.
  *)
Definition fin_intersect (A:preord) (Hdec:ord_dec A) (X Y:finset A) : finset A
 := finsubset A (fun x => x ∈ X) (fun x => finset_dec A Hdec x X) Y.

Lemma fin_intersect_elem : forall A Hdec X Y x,
  x ∈ fin_intersect A Hdec X Y <-> (x ∈ X /\ x ∈ Y).
Proof.
  intros.
  split; intros.
  unfold fin_intersect in H.
  apply finsubset_elem in H.
  intuition.
  intros. rewrite <- H1; auto.
  unfold fin_intersect.
  apply finsubset_elem.
  intros. rewrite <- H0; auto.
  destruct H; split; auto.
Qed.

Definition fin_list_intersect
  A Hdec (l:finset (finset A)) (Z:finset A) : finset A :=
  List.fold_right (fin_intersect A Hdec) Z l.

Lemma fin_list_intersect_elem : forall A Hdec l Z x,
  x ∈ fin_list_intersect A Hdec l Z <-> (x ∈ Z /\ forall X, X ∈ l -> x ∈ X).
Proof.
  induction l; simpl; intros.
  intuition.
  destruct H0 as [?[??]]. elim H0.
  split; intros.
  apply fin_intersect_elem in H.
  destruct H.
  apply IHl in H0.
  intuition.
  destruct H0 as [q [??]].
  destruct H0. subst q.
  rewrite H3; auto.
  apply H2.
  exists q; split; simpl; auto.
  apply fin_intersect_elem.
  split.
  destruct H.
  apply H0.
  exists a; split; simpl; auto.
  destruct H.
  apply IHl. split; auto.
  intros. apply H0.
  destruct H1 as [q [??]]. exists q; split; simpl; auto.
Qed.

(**  We can remove an element from a finite set if the elements have
     decidable equality.
  *)
Fixpoint finset_remove {A:preord} (Hdec : ord_dec A) (X:finset A) (a:A) : finset A :=
  match X with
  | nil => nil
  | List.cons x xs => if PREORD_EQ_DEC A Hdec x a
                  then finset_remove Hdec xs a
                  else List.cons x (finset_remove Hdec xs a)
  end.

Lemma finset_remove_elem : forall A (Hdec:ord_dec A) X a x,
  x ∈ finset_remove Hdec X a <-> (x ∈ X /\ x ≉ a).
Proof.
  intros. induction X.
  split; intros.
  destruct H as [?[??]]. elim H.
  destruct H. auto.
  unfold finset_remove. fold (@finset_remove A).
  destruct (PREORD_EQ_DEC A Hdec a0 a).
  rewrite IHX.
  split; intros.
  destruct H.
  split; auto.
  destruct H as [q [??]]. exists q; split; simpl; auto.
  destruct H. split; auto.
  destruct H as [q [??]].
  simpl in H. destruct H; subst.
  elim H0. eauto.
  exists q; split; auto.
  split; intros.
  destruct H as [q[??]].
  simpl in H. destruct H; subst.
  split. 2: rewrite H0; auto.
  exists q. split; simpl; auto.
  assert (x ∈ (X:finset A) /\ x ≉ a).
  apply IHX.
  exists q; split; auto.
  destruct H1; split; auto.
  destruct H1 as [q' [??]].
  exists q'; split; simpl; auto.
  destruct H.
  destruct H as [q[??]].
  simpl in H. destruct H; subst.
  exists q. split; simpl; auto.
  assert (x ∈ finset_remove Hdec X a).
  apply IHX.
  split; auto.
  exists q; split; auto.
  destruct H2 as [q' [??]].
  exists q'; split; simpl; auto.
Qed.

Lemma finset_remove_length1 A Hdec (X:finset A) (a:A) :
  length (finset_remove Hdec X a) <= length X.
Proof.
  induction X; simpl; auto.
  destruct (Hdec a0 a).
  destruct (Hdec a a0).
  transitivity (length X); auto with arith.
  simpl. auto with arith.
  simpl. auto with arith.
Qed.

Lemma finset_remove_length2 A Hdec (X:finset A) (a:A) :
  a ∈ X -> length (finset_remove Hdec X a) < length X.
Proof.
  intros [q [??]].
  induction X; simpl; intros.
  destruct H.
  destruct H. subst a0.
  destruct (Hdec q a).
  destruct (Hdec a q).
  red.
  apply Le.le_n_S. apply finset_remove_length1.
  elim n; destruct H0; auto.
  elim n; destruct H0; auto.
  destruct (Hdec a0 a).
  destruct (Hdec a a0).
  transitivity (length X); auto.
  simpl. apply Lt.lt_n_S. apply IHX; auto.
  simpl. apply Lt.lt_n_S. apply IHX; auto.
Qed.

(**  We can take the powerset of a finite set; that is, all finite
     subsets of a finite set.
  *)
Fixpoint list_finsubsets {A:preord} (M:finset A) : finset (finset A) :=
  match M with
  | nil => List.cons nil nil
  | List.cons x xs =>
       let subs := list_finsubsets xs in
           List.app (subs) (List.map (List.cons x) subs)
  end.

Lemma list_finsubsets_correct A : forall (M X:finset A),
  X ∈ list_finsubsets M -> X ⊆ M.
Proof.
  induction M; simpl; intros.
  destruct H as [?[??]]. elim H.
  simpl in H. intuition subst.
  rewrite H0. red; auto.
  intros. elim H1.
  destruct H as [q [??]].
  apply List.in_app_or in H.
  destruct H.
  red. intros.
  apply (IHM X) in H1.
  destruct H1 as [q' [??]].
  exists q'; split; simpl; auto.
  exists q; split; auto.
  apply List.in_map_iff in H.
  destruct H as [x [??]].
  assert ((x:finset A) ⊆ (M:finset A)).
  apply IHM.
  exists x. split; auto.
  red; intros.
  rewrite H0 in H3.
  rewrite <- H in H3.
  destruct H3 as [q' [??]].
  simpl in H3; intuition subst.
  exists q'. split; simpl; auto.
  destruct (H2 a0) as [q'' [??]].
  exists q'. split; auto.
  exists q''. split; simpl; auto.
Qed.

Lemma list_finsubsets_complete A (Hdec : ord_dec A) : forall (M X:finset A),
  X ⊆ M -> X ∈ list_finsubsets M.
Proof.
  induction M; intros.
  simpl. exists nil. split; simpl; auto.
  split; auto.
  red; simpl; intros. destruct H0 as [?[??]]. elim H0.
  simpl.
  assert (finset_remove Hdec X a ⊆ (M:finset A)).
  red; intros.
  apply finset_remove_elem in H0.
  destruct H0.
  apply H in H0.
  destruct H0 as [q[??]].
  simpl in H0; destruct H0; subst.
  elim H1; auto.
  exists q; split; auto.
  destruct (finset_dec _ Hdec a X).
  generalize H0; intro.
  apply IHM in H0.
  destruct H0 as [Q[??]].
  exists (List.cons a Q).
  split.
  apply List.in_or_app. right.
  apply List.in_map. auto.
  split; red; simpl; intros.
  generalize H3; intros.
  apply H in H3.
  destruct H3 as [q [??]].
  simpl in H3; destruct H3; subst.
  exists q. split; simpl; auto.
  destruct (PREORD_EQ_DEC A Hdec a0 a).
  exists a. split; simpl; auto.
  assert (a0 ∈ finset_remove Hdec X a).
  apply finset_remove_elem. split; auto.
  rewrite H2 in H6.
  destruct H6 as [q' [??]].
  exists q'; split; simpl; auto.
  destruct H3 as [q [??]].
  simpl in H3. destruct H3; subst.
  rewrite H4. auto.
  assert (a0 ∈ Q).
  exists q; split; auto.
  rewrite <- H2 in H5.
  apply finset_remove_elem in H5.
  destruct H5; auto.

  assert (finset_remove Hdec X a ∈ list_finsubsets M).
  apply IHM. auto.
  destruct H1 as [Q [??]].
  exists Q. split; auto.
  apply List.in_or_app. auto.
  rewrite <- H2.
  split; red; simpl; intros.
  apply finset_remove_elem. split; auto.
  intro. apply n. rewrite <- H4; auto.
  apply finset_remove_elem in H3.
  destruct H3; auto.
Qed.

(**  Decidability facts of various kinds can be pushed into finite sets.
  *)
Lemma finset_find_dec (A:preord)
  (P:A -> Prop)
  (HP : forall x y:A, x ≈ y -> P x -> P y)
  (Hdec : forall x:A, {P x}+{~P x}) :
  forall M:finset A, { z | z ∈ M /\ P z } + { forall z, z ∈ M -> ~P z }.
Proof.
  induction M.
  right. intros. destruct H as [?[??]]. elim H.
  destruct IHM.
  destruct s as [z [??]].
  left. exists z. split; auto.
  destruct H as [q [??]]. exists q; split; simpl; auto.
  destruct (Hdec a).
  left. exists a. split; auto.
  exists a. split; simpl; auto.
  right.
  intros. destruct H as [q [??]].
  simpl in H; intuition subst.
  apply n0. apply HP with z; auto.
  apply (n z); auto.
  exists q; split; auto.
Qed.

Lemma finset_find_dec' (A:preord)
  (P:A -> Prop)
  (HP : forall x y:A, x ≈ y -> P x -> P y)
  (Hdec : forall x:A, {P x}+{~P x}) :
  forall M:finset A, { z | z ∈ M /\ ~P z } + { forall z, z ∈ M -> P z }.
Proof.
  induction M.
  right. intros. destruct H as [?[??]]. elim H.
  destruct IHM.
  destruct s as [z [??]].
  left. exists z. split; auto.
  destruct H as [q [??]]. exists q; split; simpl; auto.
  destruct (Hdec a).
  right. intros.
  destruct H as [q [??]].
  simpl in H; intuition subst.
  apply HP with q; auto.
  apply p. exists q; split; auto.
  left. exists a. split; auto.
  exists a; split; simpl; auto.
Qed.

Lemma finsubset_dec (A:preord)
  (HAdec : ord_dec A)
  (P:finset A -> Prop)
  (HP : forall x y:finset A, x ≈ y -> P x -> P y)
  (Hdec : forall x:finset A, {P x}+{~P x}) :
  forall (M:finset A),
    { exists X:finset A, X ⊆ M /\ P X } +
    { forall X:finset A, X ⊆ M -> ~P X }.
Proof.
  intro M.
  destruct (finset_find_dec (finset A) P) with  (list_finsubsets M); auto.
  destruct s as [?[??]].
  left. exists x.
  split; auto.
  apply list_finsubsets_correct. auto.
  right; intros. apply n.
  apply list_finsubsets_complete; auto.
Qed.

Lemma finsubset_dec' (A:preord)
  (HAdec : ord_dec A)
  (P:finset A -> Prop)
  (HP : forall x y:finset A, x ≈ y -> P x -> P y)
  (Hdec : forall x:finset A, {P x}+{~P x}) :
  forall (M:finset A),
    { forall X:finset A, X ⊆ M -> P X } +
    { exists X:finset A, X ⊆ M /\ ~P X }.
Proof.
  intro M.
  destruct (finset_find_dec' (finset A) P) with  (list_finsubsets M); auto.
  destruct s as [?[??]].
  right. exists x.
  split; auto.
  apply list_finsubsets_correct. auto.
  left; intros. apply p.
  apply list_finsubsets_complete; auto.
Qed.

Lemma finset_in_dec (A:preord) (Hdec : ord_dec A) : forall (M:finset A) (x:A),
  { x ∈ M } + { x ∉ M }.
Proof.
  induction M.
  right. intro. destruct H as [?[??]]. elim H.
  intro x.
  destruct (IHM x).
  left.
  destruct m as [q [??]].
  exists q. split; simpl; auto.
  destruct (Hdec x a).
  destruct (Hdec a x).
  left. exists a. split; simpl; auto.
  right.
  intro. destruct H as [q [??]].
  simpl in H; intuition subst.
  apply n0; destruct H0; auto.
  apply n.
  exists q. split; auto.
  right.
  intro. destruct H as [q [??]].
  simpl in H; intuition subst.
  apply n0; destruct H0; auto.
  apply n.
  exists q. split; auto.
Qed.

Lemma finset_cons_eq (A:preord) (x y:A) (l1 l2:finset A) :
  x ≈ y -> l1 ≈ l2 ->
  (x::l1 : finset A) ≈ (y::l2).
Proof.
  intros. split.
  hnf; intros.
  apply cons_elem in H1.
  destruct H1. rewrite H1.
  apply cons_elem; auto.
  apply cons_elem; right. rewrite <- H0; auto.
  hnf; intros.
  apply cons_elem in H1.
  destruct H1. rewrite H1.
  apply cons_elem; auto.
  apply cons_elem; right. rewrite H0; auto.
Qed.

(** ** Swelling

    This lemma is used to construct certain finite sets.
    It works by starting with some small set and adding new
    elements to it until it satisfies some completeness property
    of interest.  We know that the process must halt because
    every new element added is drawn from a finite set [M].

    Swelling is used to construct sets that are hard to get other
    ways, such as when the defining predicate is not decidable.

    The swelling techinque is essentially unique to constructive
    settings; in a classical setting one would simply use a set
    comprehension principle to define the desired finite subset.
  *)
Lemma swelling_lemma (A:preord) (HA:ord_dec A)
  (M:finset A)
  (INV : finset A -> Prop)
  (P : finset A -> Prop)

  (HP : forall z, z ⊆ M -> INV z ->
    P z \/ exists q, q ∈ M /\ q ∉ z /\ INV (q::z)) :

  (exists z0, z0 ⊆ M /\ INV z0) ->
  exists z, z ⊆ M /\ INV z /\ P z.
Proof.
  intros [z [??]].
  assert (exists M0:finset A,
    (forall q, q ∈ M0 <-> q ∈ M /\ q ∉ z)).
  assert (forall q, {q ∉ z}+{~q ∉ z}).
  intros.
  destruct (finset_in_dec A HA z q); auto.
  set (M0 := finsubset A (fun q => q ∉ z) X M).
  exists M0. intro q.
  unfold M0. rewrite finsubset_elem. split; auto.
  repeat intro. apply H2. rewrite H1; auto.
  destruct H1 as [M0 ?].
  revert z H H0 H1.

  induction M0 using
    (well_founded_induction (Wf_nat.well_founded_ltof _ (@length _))); intros.

  destruct (HP z); eauto.
  destruct H3 as [q [?[??]]].
  set (x' := @finset_remove A HA x q).
  apply (H x') with (q::z).
  red; simpl. unfold x'.
  apply finset_remove_length2.
  apply H2. split; auto.
  apply cons_subset; auto.
  auto.
  intros. split; intros.
  apply finset_remove_elem in H6.
  destruct H6.
  apply H2 in H6.
  destruct H6; split; auto.
  intro.
  apply cons_elem in H9. destruct H9.
  apply H7; auto.
  apply H8; auto.
  apply finset_remove_elem.
  destruct H6. split.
  apply H2.
  split; auto.
  intro. apply H7. apply cons_elem; auto.
  intro. apply H7. apply cons_elem; auto.
Qed.


(** * Priqueue: Priority Queues *)

(** A _priority queue_ is an abstract data type with the following operations:

  - [ empty: priqueue ]
  - [ insert: key -> priqueue -> priqueue ]
  - [ delete_max: priqueue -> option (key * priqueue) ]

  The idea is that you can find (and remove) the highest-priority element.
  Priority queues have applications in:
  - Discrete-event simulations: The highest-priority event is the
     one whose scheduled time is the earliest.  Simulating one event
     causes new events to be scheduled in the future.
  - Sorting: _heap sort_ puts all the elements in a priority queue,
     then removes them one at a time.
  - Computational geometry:  algorithms such as _convex hull_ use
     priority queues.
  - Graph algorithms: Dijkstra's algorithm for finding the shortest path
     uses a priority queue.

  We will be considering _mergeable_ priority queues, with one
   additional operator:

  - [ merge: priqueue -> priqueue -> priqueue ]

  The classic data structure for priority queues is the "heap", a balanced
  binary tree in which the the key at any node is _bigger_ than all the
  keys in nodes below it.  With heaps, [empty] is constant time,
  [insert] and [delete_max] are logN time.  But [merge] takes NlogN
  time, as one must take all the elements out of one queue and
  insert them into the other queue.

  Another way to do priority queues is by _balanced binary search trees_
  (such as red-black trees); again, [empty] is constant time,
  [insert] and [delete_max] are logN time, and [merge] takes NlogN
  time, as one must take all the elements out of one queue and
  insert them into the other queue.

  In the _Binom_ chapter we will examine an algorithm in which
  [empty] is constant time,  [insert], [delete_max], and [merge]
  are logN time.

  In _this_ chapter we will consider a much simpler (and slower)
  implementation, using unsorted lists, in which:
   - [empty] takes constant time
   - [insert] takes constant time
   - [delete_max] takes linear time
   - [merge] takes linear time

*)

(* ################################################################# *)
(** * Module Signature

    This is the "signature" of a correct implementation of priority queues
 where the keys are natural numbers.   Using [nat] for the key type is
 a bit silly, since the comparison function Nat.ltb takes linear time
 in the value of the numbers!  But you have already seen in the
 [Extract] chapter how to define these kinds of algorithms
 on key types that have efficient comparisons, so in this chapter
 (and the [Binom] chapter) we simply won't worry about the
 time per comparison. *)

From VFA Require Import Perm.

Module Type PRIQUEUE.
  Parameter priqueue: Type.
  Definition key := nat.

  Parameter empty: priqueue.
  Parameter insert: key -> priqueue -> priqueue.
  Parameter delete_max: priqueue -> option (key * priqueue).
  Parameter merge: priqueue -> priqueue -> priqueue.

  Parameter priq: priqueue -> Prop.
  Parameter Abs: priqueue -> list key -> Prop.
  Axiom can_relate:  forall p, priq p -> exists al, Abs p al.
  Axiom abs_perm: forall p al bl,
   priq p -> Abs p al -> Abs p bl -> Permutation al bl.
  Axiom  empty_priq: priq empty.
  Axiom empty_relate:  Abs empty nil.
  Axiom insert_priq: forall k p, priq p -> priq (insert k p).
  Axiom insert_relate:
        forall p al k, priq p -> Abs p al -> Abs (insert k p) (k::al).
  Axiom delete_max_None_relate:
        forall p, priq p -> (Abs p nil <-> delete_max p = None).
  Axiom delete_max_Some_priq:
      forall p q k, priq p -> delete_max p = Some(k,q) -> priq q.
  Axiom delete_max_Some_relate:
  forall (p q: priqueue) k (pl ql: list key), priq p ->
   Abs p pl ->
   delete_max p = Some (k,q) ->
   Abs q ql ->
   Permutation pl (k::ql) /\ Forall (ge k) ql.
  Axiom merge_priq: forall p q, priq p -> priq q -> priq (merge p q).
  Axiom merge_relate:
    forall p q pl ql al,
       priq p -> priq q ->
       Abs p pl -> Abs q ql -> Abs (merge p q) al ->
       Permutation al (pl++ql).
End PRIQUEUE.

(** Take some time to consider whether this is the right specification!
    As always, if we get the specification wrong, then proofs of
    "correctness" are not so useful.
*)

(* ################################################################# *)
(** * Implementation *)

Module List_Priqueue <: PRIQUEUE.

(** Now we are responsible for providing [Definitions] of all
  those [Parameters], and proving [Theorems] for all those [Axioms],
  so that the values in the [Module] match the types in
  the [Module Type].   If we try to [End List_Priqueue] before
  everything is provided, we'll get an error.  Uncomment the next
  line and try it!
*)

(* End List_Priqueue. *)

(* ================================================================= *)
(** ** Some Preliminaries *)

(** A copy of the [select] function from Selection.v, but
    getting the max element instead of the min element: *)

Fixpoint select (i: nat) (l: list nat) : nat * list nat :=
match l with
|  nil => (i, nil)
|  h::t => if i >=? h
               then let (j, l') := select i t in (j, h::l')
               else let (j,l') := select h t in (j, i::l')
end.

(** **** Exercise: 3 stars, standard (select_perm_and_friends) *)

Lemma select_perm: forall i l,
  let (j,r) := select i l in
   Permutation (i::l) (j::r).
Proof. (* Copy your proof from Selection.v, and change one character. *)
intros i l; revert i.
induction l; intros; simpl in *.
(* TODO: FILL IN HERE *) Admitted.

Lemma select_biggest_aux:
  forall i al j bl,
    Forall (fun x => j >= x) bl ->
    select i al = (j,bl) ->
    j >= i.
Proof. (* Copy your proof of [select_smallest_aux] from Selection.v, and edit. *)
(* TODO: FILL IN HERE *) Admitted.

Theorem select_biggest:
  forall i al j bl, select i al = (j,bl) ->
     Forall (fun x => j >= x) bl.
Proof. (* Copy your proof of [select_smallest] from Selection.v, and edit. *)
intros i al; revert i; induction al; intros; simpl in *.
(* TODO: FILL IN HERE *) admit.
bdestruct (i >=? a).
*
destruct (select i al) eqn:?H.
(* TODO: FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** The Program *)

Definition key := nat.

Definition priqueue := list key.

Definition empty : priqueue := nil.
Definition insert  (k: key)(p: priqueue) := k::p.
Definition delete_max (p: priqueue) :=
  match p with
  | i::p' => Some (select i p')
  | nil => None
  end.
Definition merge (p q: priqueue) : priqueue := p++q.

(* ################################################################# *)
(** * Predicates on Priority Queues *)

(* ================================================================= *)
(** ** The Representation Invariant *)

(** In this implementation of priority queues as unsorted lists,
    the representation invariant is trivial. *)

Definition priq (p: priqueue) := True.

(** The abstraction relation is trivial too. *)

Inductive Abs':  priqueue -> list key -> Prop :=
Abs_intro: forall p, Abs' p p.

Definition Abs := Abs'.

(* ================================================================= *)
(** ** Sanity Checks on the Abstraction Relation *)

Lemma can_relate : forall p, priq p -> exists al, Abs p al.
Proof.
  intros. exists p; constructor.
Qed.

(** When the [Abs] relation says, "priority queue [p] contains elements [al]",
   it is free to report the elements in any order.  It could even relate [p]
   to two different lists [al] and [bl], as long as one is a permutation of
   the other.  *)

Lemma abs_perm: forall p al bl,
   priq p -> Abs p al -> Abs p bl -> Permutation al bl.
Proof.
intros.
inv H0. inv H1. apply Permutation_refl.
Qed.

(* ================================================================= *)
(** ** Characterizations of the Operations on Queues *)

Lemma empty_priq: priq empty.
Proof. constructor. Qed.

Lemma empty_relate:  Abs empty nil.
Proof. constructor. Qed.

Lemma insert_priq: forall k p, priq p -> priq (insert k p).
Proof. intros; constructor. Qed.

Lemma insert_relate:
    forall p al k, priq p -> Abs p al -> Abs (insert k p) (k::al).
Proof. intros. unfold insert. inv H0. constructor. Qed.

Lemma delete_max_Some_priq:
      forall p q k, priq p -> delete_max p = Some(k,q) -> priq q.
Proof. constructor. Qed.

(** **** Exercise: 2 stars, standard (simple_priq_proofs) *)

Lemma delete_max_None_relate:
  forall p, priq p ->
      (Abs p nil <-> delete_max p = None).
Proof.
(* TODO: FILL IN HERE *) Admitted.

Lemma delete_max_Some_relate:
  forall (p q: priqueue) k (pl ql: list key), priq p ->
   Abs p pl ->
   delete_max p = Some (k,q) ->
   Abs q ql ->
   Permutation pl (k::ql) /\ Forall (ge k) ql.
Proof.
(* TODO: FILL IN HERE *) Admitted.

Lemma merge_priq:
  forall p q, priq p -> priq q -> priq (merge p q).
Proof. intros. constructor. Qed.

Lemma merge_relate:
    forall p q pl ql al,
       priq p -> priq q ->
       Abs p pl -> Abs q ql -> Abs (merge p q) al ->
       Permutation al (pl++ql).
Proof.
(* TODO: FILL IN HERE *) Admitted.
(** [] *)

End List_Priqueue.

(* 2022-08-08 17:36 *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Cprime : Universe, ((wd_ A B /\ (wd_ A Cprime /\ (wd_ A C /\ (col_ A B Cprime /\ col_ A B C)))) -> col_ A Cprime C)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Print Assumptions mul.


Module AssetTheory.
Require Export Coq.Lists.ListSet.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export maps_def.
Import Maps.

  Definition Asset : Type := T.
  Definition AssetName : Type := S.

  Variable a a1 a2 a3 : Asset.
  Variable aSet S1 S2 : set Asset.

  (* Decidibilidade *)
  Axiom ANdec_eq_axiom :
    forall x y: AssetName, {x = y} + {x <> y}.
  Axiom Asset_dec_axiom :
    forall x y: Asset, {x = y} + {x <> y}.

  (*Assumption <Assets refinement>*)
  Parameter inline assetRef_func :
    set Asset -> set Asset -> Prop.

  Inductive wfProduct_ind (aSet : set Asset) : Prop.

  (*Axiom <Asset refinement is pre-order>*)

  Axiom assetRefinement_axiom:
    forall x y z: set Asset, assetRef_func x x /\
      assetRef_func x y -> assetRef_func y z ->  assetRef_func x z.

   (*Axiom 5 <Asset refinement compositionality>*)
  Axiom asRefCompositional_axiom :
    forall (S1 : set Asset) (S2 : set Asset) (aSet : set Asset),
      (assetRef_func S1 S2) /\ wfProduct_ind (union_t_func  S1 aSet)
        -> (wfProduct_ind (union_t_func  S2 aSet))
          /\ assetRef_func (union_t_func  S1 aSet)
             (union_t_func S2 aSet).

End AssetTheory.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.NISTP256.AMD128.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Coq.micromega.Lia.
Require Import Crypto.Arithmetic.MontgomeryReduction.WordByWord.Definition.
Require Import Crypto.Arithmetic.MontgomeryReduction.WordByWord.Proofs.
Require Import Crypto.Arithmetic.Core. Import B.
Require Crypto.Arithmetic.Saturated.MontgomeryAPI.
Require Import Crypto.Arithmetic.Saturated.UniformWeight.
Require Import Crypto.Util.Sigma.Lift.
Require Import Coq.ZArith.BinInt.
Require Import Coq.PArith.BinPos.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ZUtil.ModInv.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Arithmetic.Saturated.UniformWeightInstances.
Require Import Crypto.Specific.Framework.ArithmeticSynthesis.HelperTactics.
Require Import Crypto.Util.Tactics.CacheTerm.

Local Open Scope Z_scope.
Local Infix "^" := Tuple.tuple : type_scope.

Local Definition sig_by_eq {A P} (x : { a : A | P a }) (a : A) (H : a = proj1_sig x)
  : { a : A | P a }.
Proof.
  exists a; subst; exact (proj2_sig x).
Defined.

Section with_args.
  Context (wt : nat -> Z)
          (r : positive)
          (sz : nat)
          (m : positive)
          (m_enc : Z^sz)
          (r' : Z)
          (r'_correct : ((Z.pos r * r') mod (Z.pos m) = 1)%Z)
          (m' : Z)
          (m'_correct : ((Z.pos m * m') mod (Z.pos r) = (-1) mod Z.pos r)%Z)
          (m_enc_correct_montgomery : Z.pos m = MontgomeryAPI.eval (n:=sz) (Z.pos r) m_enc)
          (r'_pow_correct : ((r' ^ Z.of_nat sz * Z.pos r ^ Z.of_nat sz) mod MontgomeryAPI.eval (n:=sz) (Z.pos r) m_enc = 1)%Z)
          (* computable *)
          (r_big : Z.pos r > 1)
          (m_big : 1 < Z.pos m)
          (m_enc_small : small (Z.pos r) m_enc)
          (map_m_enc : Tuple.map (Z.land (Z.pos r - 1)) m_enc = m_enc).

  Local Ltac t_fin :=
    repeat match goal with
           | _ => assumption
           | [ |- ?x = ?x ] => reflexivity
           | [ |- and _ _ ] => split
           | [ |- (0 <= MontgomeryAPI.eval (Z.pos r) _)%Z ] => apply MontgomeryAPI.eval_small
           | _ => rewrite <- !m_enc_correct_montgomery
           | _ => rewrite !r'_correct
           | _ => rewrite !Z.mod_1_l by assumption; reflexivity
           | _ => rewrite !(Z.mul_comm m' (Z.pos m))
           | _ => lia
           end.

  Local Definition mul'_gen
    : { f:Z^sz -> Z^sz -> Z^sz
      | forall (A B : Z^sz),
          small (Z.pos r) A -> small (Z.pos r) B ->
          let eval := MontgomeryAPI.eval (Z.pos r) in
          (small (Z.pos r) (f A B)
           /\ (eval B < eval m_enc -> 0 <= eval (f A B) < eval m_enc)
           /\ (eval (f A B) mod Z.pos m
               = (eval A * eval B * r'^(Z.of_nat sz)) mod Z.pos m))%Z
      }.
  Proof.
    exists (fun A B => redc (r:=r)(R_numlimbs:=sz) m_enc A B m').
    abstract (
        intros;
        split; [ | split ];
        [ apply small_redc with (ri:=r') | apply redc_bound_N with (ri:=r') | rewrite !m_enc_correct_montgomery; apply redc_mod_N ];
        t_fin
      ).
  Defined.

  Import ModularArithmetic.

  Definition montgomery_to_F_gen (v : Z) : F m
    := (F.of_Z m v * F.of_Z m (r'^Z.of_nat sz)%Z)%F.

  Local Definition mul_ext_gen
    : { f:Z^sz -> Z^sz -> Z^sz
      | let eval := MontgomeryAPI.eval (Z.pos r) in
        (forall (A : Z^sz) (_ : small (Z.pos r) A)
                (B : Z^sz) (_ : small (Z.pos r) B),
            montgomery_to_F_gen (eval (f A B))
            = (montgomery_to_F_gen (eval A) * montgomery_to_F_gen (eval B))%F)
        /\ (forall (A : Z^sz) (_ : small (Z.pos r) A)
                   (B : Z^sz) (_ : small (Z.pos r) B),
               (eval B < eval m_enc -> 0 <= eval (f A B) < eval m_enc)%Z) }.
  Proof.
    exists (proj1_sig mul'_gen).
    abstract (
        split; intros A Asm B Bsm;
        pose proof (proj2_sig mul'_gen A B Asm Bsm) as H;
        cbv zeta in *;
        try solve [ destruct_head'_and; assumption ];
        rewrite ModularArithmeticTheorems.F.eq_of_Z_iff in H;
        unfold montgomery_to_F_gen;
        destruct H as [H1 [H2 H3]];
        rewrite H3;
        rewrite <- !ModularArithmeticTheorems.F.of_Z_mul;
        f_equal; nia
      ).
  Defined.

  Local Definition add_ext_gen
    : { f:Z^sz -> Z^sz -> Z^sz
      | let eval := MontgomeryAPI.eval (Z.pos r) in
        ((forall (A : Z^sz) (_ : small (Z.pos r) A)
                 (B : Z^sz) (_ : small (Z.pos r) B),
             (eval A < eval m_enc
              -> eval B < eval m_enc
              -> montgomery_to_F_gen (eval (f A B))
                 = (montgomery_to_F_gen (eval A) + montgomery_to_F_gen (eval B))%F))
         /\ (forall (A : Z^sz) (_ : small (Z.pos r) A)
                    (B : Z^sz) (_ : small (Z.pos r) B),
                (eval A < eval m_enc
                 -> eval B < eval m_enc
                 -> 0 <= eval (f A B) < eval m_enc)))%Z }.
  Proof.
    exists (fun A B => add (r:=r)(R_numlimbs:=sz) m_enc A B).
    abstract (
        split; intros;
        unfold montgomery_to_F_gen; rewrite <- ?ModularArithmeticTheorems.F.of_Z_mul, <- ?ModularArithmeticTheorems.F.of_Z_add;
        rewrite <- ?Z.mul_add_distr_r;
        [ rewrite <- ModularArithmeticTheorems.F.eq_of_Z_iff, m_enc_correct_montgomery; push_Zmod; rewrite eval_add_mod_N; pull_Zmod
        | apply add_bound ];
        t_fin
      ).
  Defined.

  Local Definition sub_ext_gen
    : { f:Z^sz -> Z^sz -> Z^sz
      | let eval := MontgomeryAPI.eval (Z.pos r) in
        ((forall (A : Z^sz) (_ : small (Z.pos r) A)
                 (B : Z^sz) (_ : small (Z.pos r) B),
             (eval A < eval m_enc
              -> eval B < eval m_enc
              -> montgomery_to_F_gen (eval (f A B))
                 = (montgomery_to_F_gen (eval A) - montgomery_to_F_gen (eval B))%F))
         /\ (forall (A : Z^sz) (_ : small (Z.pos r) A)
                    (B : Z^sz) (_ : small (Z.pos r) B),
                (eval A < eval m_enc
                 -> eval B < eval m_enc
                 -> 0 <= eval (f A B) < eval m_enc)))%Z }.
  Proof.
    exists (fun A B => sub (r:=r) (R_numlimbs:=sz) m_enc A B).
    abstract (
        split; intros;
        unfold montgomery_to_F_gen; rewrite <- ?ModularArithmeticTheorems.F.of_Z_mul, <- ?ModularArithmeticTheorems.F.of_Z_sub;
        rewrite <- ?Z.mul_sub_distr_r;
        [ rewrite <- ModularArithmeticTheorems.F.eq_of_Z_iff, m_enc_correct_montgomery; push_Zmod; rewrite eval_sub_mod_N; pull_Zmod
        | apply sub_bound ];
        t_fin
      ).
  Defined.

  Local Definition opp_ext_gen
    : { f:Z^sz -> Z^sz
      | let eval := MontgomeryAPI.eval (Z.pos r) in
        ((forall (A : Z^sz) (_ : small (Z.pos r) A),
             (eval A < eval m_enc
              -> montgomery_to_F_gen (eval (f A))
                 = (F.opp (montgomery_to_F_gen (eval A)))%F))
         /\ (forall (A : Z^sz) (_ : small (Z.pos r) A),
                (eval A < eval m_enc
                 -> 0 <= eval (f A) < eval m_enc)))%Z }.
  Proof.
    exists (fun A => opp (r:=r) (R_numlimbs:=sz) m_enc A).
    abstract (
        split; intros;
        unfold montgomery_to_F_gen; rewrite <- ?ModularArithmeticTheorems.F.of_Z_mul, <- ?F_of_Z_opp;
        rewrite <- ?Z.mul_opp_l;
        [ rewrite <- ModularArithmeticTheorems.F.eq_of_Z_iff, m_enc_correct_montgomery; push_Zmod; rewrite eval_opp_mod_N; pull_Zmod
        | apply opp_bound ];
        t_fin
      ).
  Defined.

  (* This is kind-of stupid, but we add it for consistency *)
  Local Definition carry_ext_gen
    : { f:Z^sz -> Z^sz
      | let eval := MontgomeryAPI.eval (Z.pos r) in
        ((forall (A : Z^sz) (_ : small (Z.pos r) A),
             (eval A < eval m_enc
              -> montgomery_to_F_gen (eval (f A))
                 = montgomery_to_F_gen (eval A))))
         /\ (forall (A : Z^sz) (_ : small (Z.pos r) A),
                (eval A < eval m_enc
                 -> 0 <= eval (f A) < eval m_enc))%Z }.
  Proof.
    exists (fun A => A).
    abstract (
        split; eauto; split; auto;
        apply MontgomeryAPI.eval_small; auto; lia
      ).
  Defined.

  Local Definition nonzero_ext_gen
    : { f:Z^sz -> Z
      | let eval := MontgomeryAPI.eval (Z.pos r) in
        forall (A : Z^sz) (_ : small (Z.pos r) A),
          (eval A < eval m_enc
           -> f A = 0 <-> (montgomery_to_F_gen (eval A) = F.of_Z m 0))%Z }.
  Proof.
    exists (fun A => nonzero (R_numlimbs:=sz) A).
    abstract (
        intros eval A H **; rewrite (@eval_nonzero r) by (eassumption || reflexivity);
        subst eval;
        unfold montgomery_to_F_gen, uweight in *; rewrite <- ?ModularArithmeticTheorems.F.of_Z_mul;
        rewrite <- ModularArithmeticTheorems.F.eq_of_Z_iff, m_enc_correct_montgomery;
        let H := fresh in
        split; intro H;
        [ rewrite H; autorewrite with zsimplify_const; reflexivity
        | cut ((MontgomeryAPI.eval (Z.pos r) A * (r' ^ Z.of_nat sz * Z.pos r ^ Z.of_nat sz)) mod MontgomeryAPI.eval (n:=sz) (Z.pos r) m_enc = 0)%Z;
          [ rewrite Z.mul_mod, r'_pow_correct; autorewrite with zsimplify_const; pull_Zmod; [ | t_fin ];
            rewrite Z.mod_small; [ trivial | split; try assumption; apply MontgomeryAPI.eval_small; try assumption; lia ]
          | rewrite Z.mul_assoc, Z.mul_mod, H by t_fin; autorewrite with zsimplify_const; reflexivity ] ]
      ).
  Defined.
End with_args.

Local Definition for_assumptions
  := (mul_ext_gen, add_ext_gen, sub_ext_gen, opp_ext_gen, nonzero_ext_gen).

Print Assumptions for_assumptions.

Ltac pose_m' modinv_fuel m r m' := (* (-m)⁻¹ mod r *)
  pose_modinv modinv_fuel (-Z.pos m) (Z.pos r) m'.
Ltac pose_r' modinv_fuel m r r' := (* r⁻¹ mod m *)
  pose_modinv modinv_fuel (Z.pos r) (Z.pos m) r'.

Ltac pose_m'_correct m m' r m'_correct :=
  pose_correct_if_Z
    m'
    ltac:(fun _ => constr:((Z.pos m * m') mod (Z.pos r) = (-1) mod Z.pos r))
           m'_correct.
Ltac pose_r'_correct m r r' r'_correct :=
  pose_correct_if_Z
    r'
    ltac:(fun _ => constr:((Z.pos r * r') mod (Z.pos m) = 1))
           r'_correct.

Ltac pose_m_enc_correct_montgomery m sz r m_enc m_enc_correct_montgomery :=
  cache_proof_with_type_by
    (Z.pos m = MontgomeryAPI.eval (n:=sz) (Z.pos r) m_enc)
    ltac:(vm_compute; reflexivity)
           m_enc_correct_montgomery.

Ltac pose_r'_pow_correct r' sz r m_enc r'_pow_correct :=
  cache_proof_with_type_by
    ((r' ^ Z.of_nat sz * Z.pos r ^ Z.of_nat sz) mod MontgomeryAPI.eval (n:=sz) (Z.pos r) m_enc = 1)
    ltac:(vm_compute; reflexivity)
           r'_pow_correct.

Ltac pose_montgomery_to_F sz m r' montgomery_to_F :=
  let v := (eval cbv [montgomery_to_F_gen] in (montgomery_to_F_gen sz m r')) in
  cache_term v montgomery_to_F.

Ltac pose_r_big r r_big :=
  cache_proof_with_type_by
    (Z.pos r > 1)
    ltac:(vm_compute; reflexivity)
           r_big.

Ltac pose_m_big m m_big :=
  cache_proof_with_type_by
    (1 < Z.pos m)
    ltac:(vm_compute; reflexivity)
           m_big.

Ltac pose_m_enc_small sz r m_enc m_enc_small :=
  cache_proof_with_type_by
    (small (n:=sz) (Z.pos r) m_enc)
    ltac:(pose (small_Decidable (n:=sz) (bound:=Z.pos r)); vm_decide_no_check)
           m_enc_small.

Ltac pose_map_m_enc sz r m_enc map_m_enc :=
  cache_proof_with_type_by
    (Tuple.map (n:=sz) (Z.land (Z.pos r - 1)) m_enc = m_enc)
    ltac:(pose (@dec_eq_prod); pose dec_eq_Z; vm_decide_no_check)
           map_m_enc.

Ltac internal_pose_sig_by_eq ty sigl tac_eq id :=
  cache_term_with_type_by
    ty
    ltac:(eapply (@sig_by_eq _ _ sigl _); tac_eq ())
           id.

Import ModularArithmetic.

Local Ltac reduce_eq _ :=
  cbv -[Definitions.Z.add_with_get_carry Definitions.Z.add_with_carry Definitions.Z.sub_with_get_borrow Definitions.Z.sub_with_borrow Definitions.Z.mul_split_at_bitwidth Definitions.Z.zselect runtime_add runtime_mul runtime_and runtime_opp runtime_lor Let_In].

Ltac pose_mul_ext r sz m m_enc r' r'_correct m' m'_correct m_enc_correct_montgomery r_big m_big m_enc_small montgomery_to_F mul_ext :=
  internal_pose_sig_by_eq
    { f:Z^sz -> Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      (forall (A : Z^sz) (_ : small (Z.pos r) A)
              (B : Z^sz) (_ : small (Z.pos r) B),
          montgomery_to_F (eval (f A B))
          = (montgomery_to_F (eval A) * montgomery_to_F (eval B))%F)
      /\ (forall (A : Z^sz) (_ : small (Z.pos r) A)
                 (B : Z^sz) (_ : small (Z.pos r) B),
             (eval B < eval m_enc -> 0 <= eval (f A B) < eval m_enc)%Z) }
    (@mul_ext_gen r sz m m_enc r' r'_correct m' m'_correct m_enc_correct_montgomery r_big m_big m_enc_small)
    ltac:(fun _ => reduce_eq (); reflexivity)
           mul_ext.

Ltac pose_add_ext r sz m m_enc r' m_enc_correct_montgomery r_big m_big m_enc_small montgomery_to_F add_ext :=
  internal_pose_sig_by_eq
    { f:Z^sz -> Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      ((forall (A : Z^sz) (_ : small (Z.pos r) A)
               (B : Z^sz) (_ : small (Z.pos r) B),
           (eval A < eval m_enc
            -> eval B < eval m_enc
            -> montgomery_to_F (eval (f A B))
               = (montgomery_to_F (eval A) + montgomery_to_F (eval B))%F))
       /\ (forall (A : Z^sz) (_ : small (Z.pos r) A)
                  (B : Z^sz) (_ : small (Z.pos r) B),
              (eval A < eval m_enc
               -> eval B < eval m_enc
               -> 0 <= eval (f A B) < eval m_enc)))%Z }
    (@add_ext_gen r sz m m_enc r' m_enc_correct_montgomery r_big m_big m_enc_small)
    ltac:(fun _ => reduce_eq (); reflexivity)
           add_ext.

Ltac pose_sub_ext r sz m m_enc r' m_enc_correct_montgomery r_big m_enc_small map_m_enc montgomery_to_F sub_ext :=
  internal_pose_sig_by_eq
    { f:Z^sz -> Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      ((forall (A : Z^sz) (_ : small (Z.pos r) A)
               (B : Z^sz) (_ : small (Z.pos r) B),
           (eval A < eval m_enc
            -> eval B < eval m_enc
            -> montgomery_to_F (eval (f A B))
               = (montgomery_to_F (eval A) - montgomery_to_F (eval B))%F))
       /\ (forall (A : Z^sz) (_ : small (Z.pos r) A)
                  (B : Z^sz) (_ : small (Z.pos r) B),
              (eval A < eval m_enc
               -> eval B < eval m_enc
               -> 0 <= eval (f A B) < eval m_enc)))%Z }
    (@sub_ext_gen r sz m m_enc r' m_enc_correct_montgomery r_big m_enc_small map_m_enc)
    ltac:(fun _ => reduce_eq (); reflexivity)
           sub_ext.

Ltac pose_opp_ext r sz m m_enc r' m_enc_correct_montgomery r_big m_enc_small map_m_enc montgomery_to_F opp_ext :=
  internal_pose_sig_by_eq
    { f:Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      ((forall (A : Z^sz) (_ : small (Z.pos r) A),
           (eval A < eval m_enc
            -> montgomery_to_F (eval (f A))
               = (F.opp (montgomery_to_F (eval A)))%F))
       /\ (forall (A : Z^sz) (_ : small (Z.pos r) A),
              (eval A < eval m_enc
               -> 0 <= eval (f A) < eval m_enc)))%Z }
    (@opp_ext_gen r sz m m_enc r' m_enc_correct_montgomery r_big m_enc_small map_m_enc)
    ltac:(fun _ => reduce_eq (); reflexivity)
           opp_ext.

Ltac pose_carry_ext r sz m m_enc r' r_big montgomery_to_F carry_ext :=
  internal_pose_sig_by_eq
    { f:Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      ((forall (A : Z^sz) (_ : small (Z.pos r) A),
           (eval A < eval m_enc
            -> montgomery_to_F (eval (f A))
               = (montgomery_to_F (eval A))))
       /\ (forall (A : Z^sz) (_ : small (Z.pos r) A),
              (eval A < eval m_enc
               -> 0 <= eval (f A) < eval m_enc)))%Z }
    (@carry_ext_gen r sz m m_enc r' r_big)
    ltac:(fun _ => reduce_eq (); reflexivity)
           carry_ext.

Ltac pose_nonzero_ext r sz m m_enc r' m_enc_correct_montgomery r'_pow_correct r_big m_big montgomery_to_F nonzero_ext :=
  internal_pose_sig_by_eq
    { f:Z^sz -> Z
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      forall (A : Z^sz) (_ : small (Z.pos r) A),
        (eval A < eval m_enc
         -> f A = 0 <-> (montgomery_to_F (eval A) = F.of_Z m 0))%Z }
    (@nonzero_ext_gen r sz m m_enc r' m_enc_correct_montgomery r'_pow_correct r_big m_big)
    ltac:(fun _ => reduce_eq (); reflexivity)
           nonzero_ext.

Ltac pose_mul_sig r sz montgomery_to_F mul_ext mul_sig :=
  cache_term_with_type_by
    { f:Z^sz -> Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      forall (A : Z^sz) (_ : small (Z.pos r) A)
             (B : Z^sz) (_ : small (Z.pos r) B),
        montgomery_to_F (eval (f A B))
        = (montgomery_to_F (eval A) * montgomery_to_F (eval B))%F }
    ltac:(idtac;
          let v := (eval cbv [proj1_sig mul_ext_gen mul_ext sig_by_eq] in (proj1_sig mul_ext)) in
          (exists v);
          abstract apply (proj2_sig mul_ext))
           mul_sig.

Ltac pose_mul_bounded r sz m_enc montgomery_to_F mul_ext mul_sig mul_bounded :=
  cache_proof_with_type_by
    (let eval := MontgomeryAPI.eval (Z.pos r) in
     forall (A : Z^sz) (_ : small (Z.pos r) A)
            (B : Z^sz) (_ : small (Z.pos r) B),
       (eval B < eval m_enc
        -> 0 <= eval (proj1_sig mul_sig A B) < eval m_enc)%Z)
    ltac:(apply (proj2_sig mul_ext))
           mul_bounded.

Ltac pose_add_sig r sz m_enc montgomery_to_F add_ext add_sig :=
  cache_term_with_type_by
    { f:Z^sz -> Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      forall (A : Z^sz) (_ : small (Z.pos r) A)
             (B : Z^sz) (_ : small (Z.pos r) B),
        (eval A < eval m_enc
         -> eval B < eval m_enc
         -> montgomery_to_F (eval (f A B))
            = (montgomery_to_F (eval A) + montgomery_to_F (eval B))%F)%Z }
    ltac:(idtac;
          let v := (eval cbv [proj1_sig add_ext_gen add_ext sig_by_eq] in (proj1_sig add_ext)) in
          (exists v);
          abstract apply (proj2_sig add_ext))
           add_sig.

Ltac pose_add_bounded r sz m_enc montgomery_to_F add_ext add_sig add_bounded :=
  cache_proof_with_type_by
    (let eval := MontgomeryAPI.eval (Z.pos r) in
     (forall (A : Z^sz) (_ : small (Z.pos r) A)
             (B : Z^sz) (_ : small (Z.pos r) B),
         (eval A < eval m_enc
          -> eval B < eval m_enc
          -> 0 <= eval (proj1_sig add_sig A B) < eval m_enc))%Z)
    ltac:(apply (proj2_sig add_ext))
           add_bounded.

Ltac pose_sub_sig r sz m_enc montgomery_to_F sub_ext sub_sig :=
  cache_term_with_type_by
    { f:Z^sz -> Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      forall (A : Z^sz) (_ : small (Z.pos r) A)
             (B : Z^sz) (_ : small (Z.pos r) B),
        (eval A < eval m_enc
         -> eval B < eval m_enc
         -> montgomery_to_F (eval (f A B))
            = (montgomery_to_F (eval A) - montgomery_to_F (eval B))%F)%Z }
    ltac:(idtac;
          let v := (eval cbv [proj1_sig sub_ext_gen sub_ext sig_by_eq] in (proj1_sig sub_ext)) in
          (exists v);
          abstract apply (proj2_sig sub_ext))
           sub_sig.

Ltac pose_sub_bounded r sz m_enc montgomery_to_F sub_ext sub_sig sub_bounded :=
  cache_proof_with_type_by
    (let eval := MontgomeryAPI.eval (Z.pos r) in
     (forall (A : Z^sz) (_ : small (Z.pos r) A)
             (B : Z^sz) (_ : small (Z.pos r) B),
         (eval A < eval m_enc
          -> eval B < eval m_enc
          -> 0 <= eval (proj1_sig sub_sig A B) < eval m_enc))%Z)
    ltac:(apply (proj2_sig sub_ext))
           sub_bounded.

Ltac pose_opp_sig r sz m_enc montgomery_to_F opp_ext opp_sig :=
  cache_term_with_type_by
    { f:Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      forall (A : Z^sz) (_ : small (Z.pos r) A),
        (eval A < eval m_enc
         -> montgomery_to_F (eval (f A))
            = (F.opp (montgomery_to_F (eval A)))%F)%Z }
    ltac:(idtac;
          let v := (eval cbv [proj1_sig opp_ext_gen opp_ext sig_by_eq] in (proj1_sig opp_ext)) in
          (exists v);
          abstract apply (proj2_sig opp_ext))
           opp_sig.

Ltac pose_opp_bounded r sz m_enc montgomery_to_F opp_ext opp_sig opp_bounded :=
  cache_proof_with_type_by
    (let eval := MontgomeryAPI.eval (Z.pos r) in
     (forall (A : Z^sz) (_ : small (Z.pos r) A),
         (eval A < eval m_enc
          -> 0 <= eval (proj1_sig opp_sig A) < eval m_enc))%Z)
    ltac:(apply (proj2_sig opp_ext))
           opp_bounded.

Ltac pose_carry_sig r sz m_enc montgomery_to_F carry_ext carry_sig :=
  cache_term_with_type_by
    { f:Z^sz -> Z^sz
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      forall (A : Z^sz) (_ : small (Z.pos r) A),
        (eval A < eval m_enc
         -> montgomery_to_F (eval (f A))
            = (montgomery_to_F (eval A)))%Z }
    ltac:(idtac;
          let v := (eval cbv [proj1_sig carry_ext_gen carry_ext sig_by_eq] in (proj1_sig carry_ext)) in
          (exists v);
          abstract apply (proj2_sig carry_ext))
           carry_sig.

Ltac pose_carry_bounded r sz m_enc montgomery_to_F carry_ext carry_sig carry_bounded :=
  cache_proof_with_type_by
    (let eval := MontgomeryAPI.eval (Z.pos r) in
     (forall (A : Z^sz) (_ : small (Z.pos r) A),
         (eval A < eval m_enc
          -> 0 <= eval (proj1_sig carry_sig A) < eval m_enc))%Z)
    ltac:(apply (proj2_sig carry_ext))
           carry_bounded.

Ltac pose_nonzero_sig r sz m m_enc montgomery_to_F nonzero_ext nonzero_sig :=
  cache_term_with_type_by
    { f:Z^sz -> Z
    | let eval := MontgomeryAPI.eval (Z.pos r) in
      forall (A : Z^sz) (_ : small (Z.pos r) A),
        (eval A < eval m_enc
         -> f A = 0 <-> (montgomery_to_F (eval A) = F.of_Z m 0))%Z }
    ltac:(idtac;
          let v := (eval cbv [proj1_sig nonzero_ext_gen nonzero_ext sig_by_eq] in (proj1_sig nonzero_ext)) in
          (exists v);
          abstract apply (proj2_sig nonzero_ext))
           nonzero_sig.

Ltac pose_ring ring :=
  (* FIXME: TODO *)
  cache_term
    I
    ring.

(* disable default unused things *)
(*Ltac pose_carry_sig carry_sig :=
  cache_term tt carry_sig.*)
Ltac pose_freeze_sig freeze_sig :=
  cache_term tt freeze_sig.
Ltac pose_Mxzladderstep_sig Mxzladderstep_sig :=
  cache_term tt Mxzladderstep_sig.


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

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

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

Fixpoint rev2 (l : lst) (a : lst) : lst :=
  match l with
  | Nil => a
  | Cons x t => rev2 t (Cons x a)
  end.

Lemma rev2_append_aux : forall x a b : lst,
  append (rev2 x Nil) (append a b) = append (rev2 x a) b.
Proof.
  intro x.
  induction x.
  - reflexivity.
  - intros. simpl.
    rewrite <- (IHx (Cons n a)).
    rewrite <- IHx.
    reflexivity.
Qed.

Lemma append_single : forall (n : nat) (a : lst),
  append (Cons n Nil) a = Cons n a.
Proof.
  reflexivity.
Qed.

Theorem rev2_append : forall x a : lst, rev2 x a = append (rev2 x Nil) a.
Proof.
  intro x.
  induction x.
  - reflexivity.
  - intros. simpl.
    rewrite IHx.
    rewrite <- append_single.
 lfind. Admitted.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_bnd_con_reduce :
  forall T1 x1 L1, T1 = (t_sel_bnd x1 L1) ->
                  forall T2 T Ts, T2 = t_con T Ts ->
                             subtype T1 T2 = false.
Proof.
  intros; subst.

  unfold subtype, subtype_func;
    simpl;
    rewrite fix_sub_eq_ext;
    simpl;
    fold subtype_func;
    auto.
Qed.


From Equations Require Import Equations.
Import Sigma_Notations.

(** This noConfusion instance corresponds to the rule for simplifying injectivity with UIP. *)

Set Equations With UIP.

Section NoConfusionUIP.
  Context {A} (B : A -> Type) `(E : UIP A).

  Definition NoConfusion_UIP:  forall x, B x -> B x -> Prop := fun x y z => (x, y) = (x, z).

  Definition UIP_NoConfusionPackage : forall x, NoConfusionPackage (B x).
  Proof.
    intros.
    unshelve refine ({| NoConfusion := NoConfusion_UIP x |}).
    intros a b. simplify ?. simpl. trivial.
    intros a b. simplify *. constructor.
    intros a b. simpl. unfold NoConfusion_UIP. simplify *. simpl.
    rewrite DepElim.simplification_K_uip_refl. reflexivity.
    intros. simpl. destruct e. simpl.
    now rewrite DepElim.simplification_K_uip_refl.
  Defined.
End NoConfusionUIP.


Require Export Coq.Unicode.Utf8.
Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.

(******************************************************************************)
(* Representation of types.                                                   *)
(******************************************************************************)

Inductive Ty : Set :=
  | tvar (X : nat)
  | tarr (T1 T2 : Ty)
  | tall (T : Ty).

(******************************************************************************)
(* Representation of terms.                                                   *)
(******************************************************************************)

Inductive Tm : Set :=
  | var  (x  : nat)
  | abs  (T  : Ty) (t  : Tm)
  | app  (t1 : Tm) (t2 : Tm)
  | tabs (t  : Tm)
  | tapp (t  : Tm) (T  : Ty)
  | lett (ds : Decls) (t : Tm)
with Decls : Set :=
  | dnil
  | dcons (t : Tm) (ds : Decls).

Scheme tm_induction := Induction for Tm Sort Prop
with decls_induction := Induction for Decls Sort Prop.

Combined Scheme tm_decls_induction from tm_induction, decls_induction.

(* Calculates the number of cariables bound in a pattern. *)
Fixpoint bind (ds : Decls) : nat :=
  match ds with
   | dnil       => 0
   | dcons t ds => bind ds + 1
  end.

(******************************************************************************)
(* Representation of contexts, extensions.                                    *)
(******************************************************************************)

Inductive Env : Set :=
  | empty
  | etvar (Γ : Env)
  | evar  (Γ : Env) (T : Ty).


(**

  FP.v

  First Prize.

  Proof of 0-utility, rationality and, by counter-example, that FP is not truthful.

  Pierre Jouvelot (30/1/2022).

  Licence: CeCILL-B.

*)

From Coq Require Import Unicode.Utf8.
From mathcomp Require Import all_ssreflect.
From mathcomp.fingroup Require Import perm.

From mech.lib Require Import lib labelling mech.

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

Section FP.

Variable (n' : nat).
Definition n := n'.+1.

Definition A := agent.type n.

Notation agent_succ := (@agent.succ n').

Variable p' : nat.
Definition p := p'.+1.
Definition bid := 'I_p.
Definition bid0 : bid := Ordinal (ltn0Sn p').
Definition bids := n.-tuple bid.

Let geq_bid := @geq_bid p'.

Notation tsort := (tsort geq_bid).
Notation idxa := (idxa geq_bid).

Section Algorithm.

Variable (bs0 : bids) (i : A).

Let bs := tsort bs0.
Let i' := idxa bs0 i.

Definition is_winner := i' == ord0.

Notation "'[bid' j 'in' bs ']'" := (tnth bs j) (at level 10).

Definition price : nat := [bid i' in bs].

End Algorithm.

End FP.

Section Theorems.

Variable (a_n' : nat).

Notation A := (A a_n').
Notation n := (n a_n').

Variable (a_p' : nat).

Notation bid := 'I_(p a_p').
Notation bids := (bids a_n' a_p').

Notation is_winner := (@is_winner a_n' a_p').

Let m := mech.new (fun (bs : bids) => map_tuple (fun i => (is_winner bs i, bs)) (agent.agents n)).

Let a :=
  @auction.new _ _ m (fun o i =>
                        let: (w, bs) := tnth o i in
                        if w then Some (price bs i) else None).

Variable (vs : n.-tuple bid).

Definition ps := auction.prefs a (tnth vs).

Definition U := prefs.U ps.

(** FP has zero utility for the winner if s/he bids truthfully. *)

Lemma zero_utility (bs : bids) (i : A) (i_wins : is_winner bs i) :
  tnth bs i = tnth vs i -> U i (m bs) = 0.
Proof.
move=> tv.
rewrite /U /prefs.U /= /auction.U /auction.p /= tnth_map ifT -?tv;
  first by rewrite /price labelling_spec_idxa subnn.
by move: i_wins => /=; rewrite /is_winner tnth_ord_tuple.
Qed.

(** FP is rational if one bids truthfully. *)

Theorem rational (bs : bids) (i : A) :
  tnth bs i = tnth vs i -> price bs i <= tnth vs i.
Proof. by rewrite /price labelling_spec_idxa => ->. Qed.

(** FP is anonymous, if bids are always assumed unique. *)

Section Anonymous.

Theorem anonymous_XP (uniq_bids : forall bs : bids, uniq bs) :
  auction.anonymous a.
Proof.
have tot : total (geq_bid (n:=a_p')) by exact: total_geq_bid.
have anti : antisymmetric (geq_bid (n:=a_p')) by exact: anti_geq_bid.
have trans: transitive (geq_bid (n:=a_p')) by exact: transitive_geq_bid.
rewrite /= /auction.anonymous /= => bs i1 i2 w1.
rewrite /auction.is_winner /= !tnth_map tnth_ord_tuple /is_winner in w1 *.
rewrite /price !labelling_spec_idxa in w1 *.
rewrite tnth_map tnth_ord_tuple apermE tpermR idxa_tpermR ?uniq_bids //.
split=> [//|]; split=> [|i [nei1 nei2]].
- rewrite /auction.price /= /price !tnth_map !tnth_ord_tuple !labelling_spec_idxa.
  by rewrite !tnth_map !tnth_ord_tuple !apermE !tpermR idxa_tpermR // ?uniq_bids.
- rewrite !tnth_map !tnth_ord_tuple !labelling_spec_idxa idxa_tpermD // ?uniq_bids //.
  by rewrite tnth_map tnth_ord_tuple apermE tpermD 1?eq_sym // ?uniq_bids.
Qed.

End Anonymous.

End Theorems.

(** Non truthfulness. *)

Section NotTruthfulness.

(* 2 bidders *)
Definition a_n' := 1.

Notation A := (A a_n').
Notation agent_succ := (@agent.succ a_n').

Definition a0 : A := ord0.
Definition a1 : A := agent_succ a0.

(* Range of bids *)
Definition a_p' := 10.

Notation bid := (bid a_p').
Notation geq_bid := (@geq_bid a_p').
Notation tlabel := (tlabel geq_bid).
Notation idxa := (idxa geq_bid).

Notation bids := (bids a_n' a_p').

(* true values = 10, 8 *)
Definition vs : bids := map_tuple sub_ord [tuple 0; 2].

(* bs1: all ais bid their true value. *)
Definition bs1 : bids := vs.

(* bs2: a0 underbids = 9, 8 *)
Definition bs2 : bids := map_tuple sub_ord [tuple 1; 2].

Definition tlabel_bs2 := [tuple a0; a1].

Lemma idxaK_bs2 : idxa bs2 a0 = a0.
Proof.
rewrite /idxa /sval.
case: sorted_diff_agent_spec_ex => j.
have eqtlabel : tlabel bs2 = tlabel_bs2.
  apply: labelling_singleton; first by exact: tlabelP.
  by rewrite /is_labelling -(inj_eq val_inj).
rewrite [in RHS](_ : a0 = tnth tlabel_bs2 a0) // -eqtlabel.
apply: labelling_inj.
exact: tlabelP.
Qed.

Notation n := (n a_n').
Notation is_winner := (@is_winner a_n' a_p').

Let m := mech.new (fun (bs : bids) => map_tuple (fun i => (is_winner bs i, bs)) (agent.agents n)).

Let a :=
  @auction.new _ _ m (fun o i =>
                        let: (w, bs) := tnth o i in
                        if w then Some (price bs i) else None).

Definition prefs := auction.prefs a (tnth vs).

Lemma not_truthful_FP : not (truthful prefs).
Proof.
apply: not_truthful.
exists a0. exists bs1. exists bs2.
have diff: differ_on bs1 bs2 a0.
  move=> j.
  rewrite /action_on /bs2 /bs1 /vs /a0 /a_n'.
  have [] := boolP (0 < j) => [lt0j|]; last by rewrite lt0n negbK -(inj_eq val_inj) /= => /eqP ->.
  rewrite !(tnth_nth (sub_ord 0)) /= -lt0n => /prednK <-.
  by rewrite -nth_behead.
split => //.
split => //=.
rewrite /auction.U /auction.p //= !tnth_map !tnth_ord_tuple /is_winner /= /price.
rewrite idxaK //= ?idxaK_bs2 //=.
exact: transitive_geq_bid.
Qed.

End NotTruthfulness.

(* Check not_truthful_FP. *)
(* Print Assumptions not_truthful_FP. *)


Require Import Cdcl.Itauto.

Require Import Int63 Bool  ZArith Lia.

Import Formula.
Import HCons.

Open Scope Z_scope.
Lemma l1 : forall (x:Z), x >= 0 -> x <= 0 -> x <> 0 -> False.
Proof.
  intros.
  itauto lia.
Qed.

Lemma cc : forall (A:Type) (a b c:A) (d e:Z),
    d >= e ->
    a = b -> b = c -> a = c.
Proof.
  intros.
  itauto congruence.
Qed.

Lemma false_true :  Is_true (false) -> Is_true true.
Proof. itauto idtac. Qed.

Lemma true_andb_true : Is_true (true && true).
Proof.
  intros.
  itauto idtac.
Qed.

Lemma p_impl_p : forall (p:Prop), p /\ True -> p.
Proof.
  intros.
  itauto idtac.
Qed.

Lemma x_andb_true : forall x, Is_true (x && true) -> Is_true x.
Proof.
  intros.
  itauto idtac.
Qed.

#[local] Instance Zge_dec : DecP2 Z.ge.
Proof.
 unfold DecP2. intros. lia.
Qed.

#[local] Instance Zle_dec : DecP2 Z.le.
Proof.
 unfold DecP2. intros. lia.
Qed.

#[local] Instance Zeq_dec : DecP2 (@eq Z).
Proof.
 unfold DecP2. intros. lia.
Qed.

Lemma l2 : forall (x:Z), x >= 0 -> x <= 0 -> x <> 0 -> False.
Proof.
  intros.
  itauto lia.
Qed.

Lemma comb : forall (p: Prop) (x: Z),
    p ->
    (p -> x = 0) ->  x = 0.
Proof.
  intros.
  Fail lia.
Abort.

Lemma comb2 : forall (p: Prop) (x: Z),
    p ->
    (p -> x = 0) ->  x = 0.
Proof.
  intros.
  intuition lia.
Qed.

Lemma combt : forall (p: Prop) (x: Z),
    p ->
    (p -> x = 0) ->  x = 0.
Proof.
  intros.
  tauto.
Qed.

Lemma comb3 : forall (p: Prop) (x: Z),
    x >= 0 -> x <= 0 ->
    (x = 0 -> p) -> p.
Proof.
  intros.
  Fail intuition lia.
  itauto lia.
Qed.

Lemma comp_congr : forall (T:Type) (a b c:T) (p:Prop),
    a = b -> b = c -> (a = c -> p) -> p.
Proof.
  Fail intuition congruence.
  itauto congruence.
Qed.

(* From https://github.com/coq/coq/issues/10743#issuecomment-643391083 *)

Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.

Axiom word: Type.
Axiom stmt: Type.
Axiom stackalloc_size: stmt -> Z.
Axiom bytes_per_word: Z.
Axiom list_union: forall {A: Type}, (A -> A -> bool) -> list A -> list A -> list A.
Axiom modVars_as_list: (Z -> Z -> bool) -> stmt -> list Z.

Module word.
  Axiom of_Z: Z -> word.
End word.

Declare Scope word_scope.
Notation "! n" := (word.of_Z n) (at level 0, n at level 0, format "! n") : word_scope.
Notation "# n" := (Z.of_nat n) (at level 0, n at level 0, format "# n") : word_scope.
Delimit Scope word_scope with word.
Open Scope word_scope.

Open Scope Z_scope.

Goal forall (rem_framewords : Z) (program_base : word) (pos : Z) (pos0 : Z) (body: stmt)
            (unused_scratch old_argvals old_retvals : list word) (old_ra : word)
            (old_modvarvals ToSplit old_scratch : list word)
            (argnames retnames: list Z),
  0 <= rem_framewords ->
  rem_framewords +
  (stackalloc_size body / bytes_per_word +
   #(length argnames + length retnames + 1 +
     length (list_union Z.eqb (modVars_as_list Z.eqb body) argnames))) <=
  #(length
      ((((((ToSplit ++ old_scratch) ++ old_modvarvals) ++ [old_ra]) ++ old_retvals) ++ old_argvals) ++
       unused_scratch)) ->
  bytes_per_word = 4 \/ bytes_per_word = 8 ->
  0 <= stackalloc_size body / bytes_per_word ->
  length
    (((((ToSplit ++ old_scratch) ++ old_modvarvals) ++ [old_ra]) ++ old_retvals) ++ old_argvals) =
  (length
     ((((((ToSplit ++ old_scratch) ++ old_modvarvals) ++ [old_ra]) ++ old_retvals) ++ old_argvals) ++
      unused_scratch) - Z.to_nat rem_framewords)%nat ->
  length unused_scratch = Z.to_nat rem_framewords ->
  length ((((ToSplit ++ old_scratch) ++ old_modvarvals) ++ [old_ra]) ++ old_retvals) =
  (length
     (((((ToSplit ++ old_scratch) ++ old_modvarvals) ++ [old_ra]) ++ old_retvals) ++ old_argvals) -
   length argnames)%nat ->
  length old_argvals = length argnames ->
  length (((ToSplit ++ old_scratch) ++ old_modvarvals) ++ [old_ra]) =
  (length ((((ToSplit ++ old_scratch) ++ old_modvarvals) ++ [old_ra]) ++ old_retvals) -
   length retnames)%nat ->
  length old_retvals = length retnames ->
  length ((ToSplit ++ old_scratch) ++ old_modvarvals) =
  (length (((ToSplit ++ old_scratch) ++ old_modvarvals) ++ [old_ra]) - 1)%nat ->
  length [old_ra] = 1%nat ->
  length (ToSplit ++ old_scratch) =
  (length ((ToSplit ++ old_scratch) ++ old_modvarvals) -
   length (list_union Z.eqb (modVars_as_list Z.eqb body) argnames))%nat ->
  length old_modvarvals = length (list_union Z.eqb (modVars_as_list Z.eqb body) argnames) ->
  length ToSplit =
  (length (ToSplit ++ old_scratch) - Z.to_nat (stackalloc_size body / bytes_per_word))%nat ->
  length old_scratch = Z.to_nat (stackalloc_size body / bytes_per_word) ->
  length old_scratch = Z.to_nat (stackalloc_size body / bytes_per_word) /\
  length old_modvarvals = length (list_union Z.eqb (modVars_as_list Z.eqb body) argnames) /\
  length old_retvals = length retnames /\
  length old_argvals = length argnames /\
  length unused_scratch = Z.to_nat rem_framewords.
Proof.
  intros.
  (* zify. (* creates many disjunctions of the form "0 < z /\ z0 = z \/ z <= 0 /\ z0 = 0" *) *)
  (* Time repeat split; assumption. (* 0 secs *) *)
  Time itauto lia.
Qed.

Goal
  forall x y,
   (x = 0 -> y = 0) ->
   (x = 1 -> y = 0) ->
   (~ (x = 0 \/ x = 1) -> y = 0) ->
   y = 0.
Proof.
  intros.
  unfold not in *.
  itauto lia.
Qed.

Require Import Bool.

Open Scope bool_scope.
Require Import ZifyClasses.
#[local] Program Instance Op_eq_bool : BinRel (@eq bool) :=
  {TR := fun x y => Is_true (implb x y) /\ Is_true (implb y x) ; TRInj := _ }.
Next Obligation.
  destruct n,m; simpl; intuition congruence.
Qed.
Add Zify BinRel Op_eq_bool.

#[local] Program Instance Op_negb : UnOp negb :=
  {TUOp := fun x => implb x false ;  TUOpInj:= _ }.
Add Zify UnOp Op_negb.

Goal forall b, orb b true = true.
Proof.
  intros.
  zify;
  itauto idtac.
Qed.

Goal forall b, andb b b = b.
Proof.
  intros.
  zify.
  itauto idtac.
Qed.

Goal forall b b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14
            b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27
            b28 b29 b30 b31 : bool,
    (b && negb b0 || b1 && b2 || b3 && b4 || b5 && b6 ||
     b7 && b8 || b9 && b10 || b11 && b12
     || b13 && b14) && negb b15 =
    b16 && negb b17 || b18 && b19 || b20 && b21 || b22 && b23
    || b24 && b25 || b26 && b27
    || b28 && b29 || b30 && b31.
Proof.
  intros.
  zify.
  clear.
  Fail itauto idtac.
Abort.

Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Open Scope Z_scope.

Goal
  forall (r2 : Z) (L : nat),
  r2 = 8 * Z.of_nat L ->
  r2 <> 0 ->
  0 <= Z.of_nat L ->
  forall q r r1 : Z,
  (2 ^ r1 <> 0 -> r2 = 2 ^ r1 * q + r) ->
  (0 < 2 ^ r1 -> 0 <= r < 2 ^ r1) ->
  (2 ^ r1 < 0 -> 2 ^ r1 < r <= 0) ->
  (2 ^ r1 = 0 -> q = 0) ->
  (2 ^ r1 = 0 -> r = 0) ->
  forall q0 r0 M : Z,
  (M <> 0 -> 3 = M * q0 + r0) ->
  (0 < M -> 0 <= r0 < M) ->
  (M < 0 -> M < r0 <= 0) ->
  (M = 0 -> q0 = 0) ->
  (M = 0 -> r0 = 0) ->
  forall q1 : Z,
  (M <> 0 -> 4 = M * q1 + r1) ->
  (0 < M -> 0 <= r1 < M) ->
  (M < 0 -> M < r1 <= 0) ->
  (M = 0 -> q1 = 0) ->
  (M = 0 -> r1 = 0) ->
  forall q2 y1 y2 : Z,
  (M <> 0 -> y2 - y1 = M * q2 + r2) ->
  (0 < M -> 0 <= r2 < M) ->
  (M < 0 -> M < r2 <= 0) ->
  (M = 0 -> q2 = 0) -> (M = 0 -> r2 = 0) ->
  0 <= y2 - (y1 + q * 2 ^ r0 + 8) < M.
Proof.
  intros.
  Fail itauto lia.
Abort.

Require Import Classical.

Lemma discr : forall {A:Type} (a: A), a::nil = nil -> a::nil = a::nil -> False.
Proof.
  intros.
  itauto congruence.
Qed.

Lemma ifb : forall (P: bool -> Prop) (a b c:bool),
    P(if a then b else c) <-> ((a = true -> P b) /\ (a = false -> P c)).
Proof.
  intros.
  destruct a ; intuition try congruence.
Qed.

Lemma ifb_eq : forall (a b c: bool),
    (if a then b else c) = andb (implb a b) (implb (negb a) c).
Proof.
  intros.
  destruct a,b,c; simpl; auto.
Qed.

Lemma is_true_eq : forall b, is_true b <-> Is_true b.
Proof.
  unfold is_true.
  destruct b; simpl;
  intuition congruence.
Qed.

Lemma negb_eq : forall b, negb b = implb b false.
Proof.
  destruct b ; simpl; auto.
Qed.

Lemma test_orb a b : (if a || b then negb (negb b && negb a) else negb a && negb b) = true.
Proof.
  rewrite ifb_eq.
  match goal with
  | |- ?A = true => change (is_true A)
  end.
  rewrite is_true_eq.
  repeat rewrite negb_eq.
  itauto idtac.
Time Qed.

Lemma test_orb2 : forall a b,
  Is_true
    (implb (a || b) (implb (implb b false && implb a false) false) &&
     implb (implb (a || b) false) (implb a false && implb b false)).
Proof.
  itauto idtac.
Time Qed.


Require Export InitialTerminalCategory Category.Product Functor.Product.
Require Import Common Functor.Equality.

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

Local Open Scope category_scope.
Local Open Scope functor_scope.

Section swap.
  Definition SwapFunctor (C D : PreCategory)
  : Functor (C * D) (D * C)
    := Build_Functor (C * D) (D * C)
                     (fun cd => (snd cd, fst cd))
                     (fun _ _ m => (snd m, fst m))
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).

  Lemma ProductLawSwap `{Funext} (C D : PreCategory)
  : SwapFunctor C D ∘ SwapFunctor D C = 1.
  Proof.
    functor_eq.
    exists (path_forall _ _ (fun x => @eta_prod D C x)).
    repeat (apply path_forall; intro).
    rewrite !transport_forall_constant.
    destruct_head_hnf @prod.
    match goal with
      | [ |- appcontext[transport (fun x2 => (?K (fst (x2 ?x)) (fst (x2 ?x0))
                                              * ?K' (snd (x2 ?x)) (snd (x2 ?x0)))%type)
                                  (@path_forall ?H ?A ?B ?f ?g ?e)
                                  ?Px] ]
        => rewrite (@path_forall_2_beta H A B x x0 (fun x2x x2x0 => (K (fst x2x) (fst x2x0) * K' (snd x2x) (snd x2x0))%type) f g e Px)
    end.
    reflexivity.
  Qed.
End swap.

Section Law0.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Local Notation "0" := zero : category_scope.

  Variable C : PreCategory.

  Global Instance IsInitialCategory_Product
  : IsInitialCategory (C * 0)
    := fun P c => initial_category_rect P (snd c).

  Global Instance IsInitialCategory_Product'
  : IsInitialCategory (0 * C)
    := fun P c => initial_category_rect P (fst c).

  Definition ProductLaw0Functor : Functor (C * 0) 0 := FunctorFromInitial _.
  Definition ProductLaw0'Functor : Functor (0 * C) 0 := FunctorFromInitial _.
  Definition ProductLaw0Functor_Inverse : Functor 0 (C * 0) := FunctorFromInitial _.
  Definition ProductLaw0'Functor_Inverse : Functor 0 (0 * C) := FunctorFromInitial _.

  Definition ProductLaw0
  : ProductLaw0Functor ∘ ProductLaw0Functor_Inverse = 1
    /\ ProductLaw0Functor_Inverse ∘ ProductLaw0Functor = 1
    := center _.

  Definition ProductLaw0'
  : ProductLaw0'Functor ∘ ProductLaw0'Functor_Inverse = 1
    /\ ProductLaw0'Functor_Inverse ∘ ProductLaw0'Functor = 1
    := center _.
End Law0.

Section Law1.
  Context `{Funext}.
  Context `{IsTerminalCategory one}.
  Local Notation "1" := one : category_scope.
  Variable C : Category.

  Definition ProductLaw1Functor : Functor (C * 1) C
    := @fst_Functor C 1.

  Definition ProductLaw1'Functor : Functor (1 * C) C
    := @snd_Functor 1 C.

  Definition ProductLaw1Functor_Inverse : Functor C (C * 1)
    := IdentityFunctor C * FunctorToTerminal _.

  Definition ProductLaw1'Functor_Inverse : Functor C (1 * C)
    := FunctorToTerminal _ * IdentityFunctor C.

  (** We could throw this in a [repeat match goal with ... end], but
      we know the order, so we hard-code the order to speed it up by a
      factor of about 10. *)

  Local Ltac t_prod :=
    split;
    try first [ exact (FunctorProduct_Commutes_fst _ _)
              | exact (FunctorProduct_Commutes_snd _ _) ];
    [];
    apply path_prod_functor;
    rewrite <- !ComposeFunctorsAssociativity by assumption;
    (rewrite ?FunctorProduct_Commutes_fst, ?FunctorProduct_Commutes_snd,
     ?LeftIdentityFunctor, ?RightIdentityFunctor
      by assumption);
    try (reflexivity || exact (center _)).

  Lemma ProductLaw1
  : ProductLaw1Functor ∘ ProductLaw1Functor_Inverse = 1
    /\ ProductLaw1Functor_Inverse ∘ ProductLaw1Functor = 1.
  Proof.
    unfold ProductLaw1Functor, ProductLaw1Functor_Inverse.
    abstract t_prod.
  Qed.

  Lemma ProductLaw1'
  : ProductLaw1'Functor ∘ ProductLaw1'Functor_Inverse = 1
    /\ ProductLaw1'Functor_Inverse ∘ ProductLaw1'Functor = 1.
  Proof.
    unfold ProductLaw1'Functor, ProductLaw1'Functor_Inverse.
    abstract t_prod.
  Qed.
End Law1.


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

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

Require Import UniMath.CategoryTheory.limits.coproducts.

(** only for the last constructions that should be moved to [CategoryTheory.Chains.Omegacontfunctors] *)
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.Chains.All.

Local Open Scope cat.

Lemma CoproductOfArrowsIsos_aux (I : UU) (C : category) (a : I -> C) (CC : Coproduct I C a)
           (c : I -> C) (CC' : Coproduct I C c) (f : ∏ i : I, C⟦a i, c i⟧)
           (fi_iso :∏ i : I, is_z_isomorphism (f i)) :
  is_inverse_in_precat (CoproductOfArrows I C CC CC' f)
    (CoproductOfArrows I C CC' CC (λ i : I, pr1 (fi_iso i))).
Proof.
  split.
  + etrans. { apply precompWithCoproductArrow. }
    apply pathsinv0, CoproductArrowUnique.
    intro i.
    refine (id_right _ @ ! id_left _ @ _).
    refine (_ @ assoc' _ _ _).
    apply maponpaths_2.
    apply pathsinv0, (pr2 (fi_iso i)).
  + etrans. { apply precompWithCoproductArrow. }
    apply pathsinv0, CoproductArrowUnique.
    intro i.
    refine (id_right _ @ ! id_left _ @ _).
    refine (_ @ assoc' _ _ _).
    apply maponpaths_2.
    apply pathsinv0, (pr2 (fi_iso i)).
Qed.

Definition CoproductOfArrowsIsos
           (I : UU) (C : category) (a : I -> C) (CC : Coproduct I C a)
           (c : I -> C) (CC' : Coproduct I C c) (f : ∏ i : I, C⟦a i, c i⟧)
  : (∏ i : I, is_z_isomorphism (f i)) -> is_z_isomorphism (CoproductOfArrows I C CC CC' f).
Proof.
  intro fi_iso.
  use make_is_z_isomorphism.
  - use CoproductOfArrows.
    exact (λ i, pr1 (fi_iso i)).
  - apply CoproductOfArrowsIsos_aux.
Defined.

Lemma constant_functor_composition_nat_trans
      (A B C : category) (b : B) (F : functor B C)
  : nat_trans (functor_composite (constant_functor A B b) F)
              (constant_functor A C (F b)).
Proof.
  use make_nat_trans.
  + intro; apply identity.
  + abstract (intro; intros;
              apply maponpaths_2;
              exact (functor_id F b)).
Defined.

Lemma constant_functor_composition_nat_z_iso (A B C : category) (b : B) (F : functor B C)
  : nat_z_iso (functor_composite (constant_functor A B b) F)
              (constant_functor A C (F b)).
Proof.
  exists (constant_functor_composition_nat_trans A B C b F).
  intro; apply identity_is_z_iso.
Defined.

Lemma coproduct_of_functors_nat_trans_aux {I : UU} {C D : category} (CP : Coproducts I D)
  {F G : I → C ⟶ D} (α : ∏ i : I, nat_trans (F i) (G i))
  : is_nat_trans (coproduct_of_functors I C D CP F) (coproduct_of_functors I C D CP G)
      (λ c : C, CoproductOfArrows I D (CP (λ i : I, F i c)) (CP (λ i : I, G i c)) (λ i : I, α i c)).
Proof.
  intros c1 c2 f.
  etrans.
  1: apply precompWithCoproductArrow.
  etrans.
  2: apply pathsinv0, precompWithCoproductArrow.
  apply maponpaths.
  apply funextsec ; intro i.
  etrans.
  1: apply assoc.
  etrans.
  2: apply assoc'.
  apply maponpaths_2.
  exact (pr2 (α i) _ _ f).
Qed.

Lemma coproduct_of_functors_nat_trans
      {I : UU} {C D : category} (CP : Coproducts I D) {F G : I → C ⟶ D}
      (α : ∏ i : I, nat_trans (F i) (G i))
  : nat_trans (coproduct_of_functors I C D CP F) (coproduct_of_functors I C D CP G).
Proof.
  use make_nat_trans.
  - intro c.
    use CoproductOfArrows.
    exact (λ i, α i c).
  - apply coproduct_of_functors_nat_trans_aux.
Defined.

Lemma coproduct_of_functors_is_inverse {I : UU} {C D : category} (CP : Coproducts I D)
  {F G : I → C ⟶ D} (α : ∏ i : I, nat_z_iso (F i) (G i)) (c : C) :
  is_inverse_in_precat (coproduct_of_functors_nat_trans CP (λ i : I, α i) c)
    (CoproductOfArrows I D (CP (λ i : I, G i c)) (CP (λ i : I, F i c)) (λ i : I, pr1 (pr2 (α i) c))).
Proof.
  split.
  + etrans.
    1: apply precompWithCoproductArrow.
    apply pathsinv0, CoproductArrowUnique.
    intro i.
    etrans.
    2: apply assoc'.
    etrans.
    2: apply maponpaths_2, pathsinv0, (pr2 (pr2 (α i) c)).
    exact (id_right _ @ ! id_left _).
  + etrans.
    1: apply precompWithCoproductArrow.
    apply pathsinv0, CoproductArrowUnique.
    intro i.
    etrans.
    2: apply assoc'.
    etrans.
    2: apply maponpaths_2, pathsinv0, (pr2 (pr2 (α i) c)).
    exact (id_right _ @ ! id_left _).
Qed.

Lemma coproduct_of_functors_nat_z_iso
      {I : UU} {C D : category} (CP : Coproducts I D) {F G : I → C ⟶ D}
      (α : ∏ i : I, nat_z_iso (F i) (G i))
  : nat_z_iso (coproduct_of_functors I C D CP F) (coproduct_of_functors I C D CP G).
Proof.
  exists (coproduct_of_functors_nat_trans CP α).
  intro c.
  use tpair.
  - use CoproductOfArrows.
    exact (λ i, pr1 (pr2 (α i) c)).
  - apply coproduct_of_functors_is_inverse.
Defined.

(*
The following lemmas has to be moved accordingly,
e.g. in the file CategoryTheory.Chains.Omegacontfunctors
 *)
Lemma nat_trans_preserve_cone
      {A B : category}
      {F G : functor A B}
      (α : nat_trans F G)
      {coch : cochain A}
      {b : B} (b_con : cone (mapdiagram F coch) b)
  : cone (mapdiagram G coch) b.
Proof.
  exists (λ v, pr1 b_con v · α (dob coch v)).
  intros u v p.
  etrans.
  1: apply assoc'.
  cbn.
  etrans.
  1: apply maponpaths, pathsinv0, (pr2 α).
  etrans.
  1: apply assoc.
  apply maponpaths_2.
  exact (pr2 b_con u v p).
Defined.

Lemma nat_z_iso_preserve_ωlimits {A B : category}
      (F G : functor A B)
  : is_omega_cont F -> nat_z_iso F G -> is_omega_cont G.
Proof.
  (* This lemma should be split up in data and property and there is also a repeat of proof, need a more "general, but easy" lemma.
 *)
  intros Fc i.
  intros coch a a_con a_lim.
  intros b b_con.
  set (b'_con := nat_trans_preserve_cone (nat_z_iso_inv i) b_con).
  set (t := Fc coch a a_con a_lim b b'_con).
  use tpair.
  - exists (pr11 t · pr1 i a).
    intro v.
    etrans.
    1: apply assoc'.
    etrans.
    1: apply maponpaths, pathsinv0, (pr21 i).
    etrans.
    1: apply assoc.
    etrans.
    1: apply maponpaths_2, (pr21 t v).
    etrans.
    1: apply assoc'.
    etrans.
    1: apply maponpaths, (pr2 i (dob coch v)).
    apply id_right.
  - intro f.
    use total2_paths_f.
    + use (cancel_z_iso _ _ (_ ,, pr2 (nat_z_iso_inv i) a)).
      etrans.
      2: apply assoc.
      etrans.
      2: apply maponpaths, pathsinv0, (pr2 (pr2 i a)).
      etrans.
      2: apply pathsinv0, id_right.

      transparent assert (c' : (∑ x : B ⟦ b, F a ⟧, limits.is_cone_mor b'_con (limits.mapcone F coch a_con) x)).
      {
        exists (pr1 f · pr1 (pr2 i a)).
        intro v.
        cbn.
        etrans.
        1: apply assoc'.
        etrans.
        1: apply maponpaths, pathsinv0, (pr21 (nat_z_iso_inv i)).
        etrans.
        1: apply assoc.
        apply maponpaths_2, (pr2 f v).
      }

      exact (base_paths _ _ (pr2 t c')).
    + apply (impred_isaprop) ; intro ; apply homset_property.
Defined.