From sflib Require Import sflib.
From Paco Require Import paco.
From Coq Require Export
  Relations.Relation_Operators.
From Coq Require Import
  RelationClasses
  Relations.Operators_Properties.
Set Implicit Arguments.

(* TODO: definitions copied from Ordinal library *)

Lemma well_founded_irrefl A (R : A -> A -> Prop) (WF : well_founded R) : forall x, ~ R x x.
Proof. ii. specialize (WF x). induction WF; eauto. Qed.

Variant succ_rel (n : nat) : nat -> Prop := succ_rel_intro : succ_rel n (S n).

Lemma succ_rel_well_founded : well_founded succ_rel.
Proof. ii. induction a; econs; i; inversion H. ss. Qed.

Lemma succ_clos_trans : forall m n, clos_trans_n1 nat succ_rel m n <-> m < n.
Proof.
  split.
  - revert m. induction n.
    + i. exfalso. inversion H; inversion H0.
    + i. inversion H.
      * inversion H0. ss.
      * inversion H0. subst. econs. eapply IHn, H1.
  - revert m. induction n.
    + i. inversion H.
    + i. inversion H.
      * econs 1. econs.
      * econs 2. econs. eapply IHn. ss.
Qed.

Variant double_rel A B (RA: A -> A -> Prop) (RB: B -> B -> Prop)
  : A * B -> A * B -> Prop :=
| double_rel_left a0 a1 b (LT: RA a0 a1): double_rel RA RB (a0, b) (a1, b)
| double_rel_right a b0 b1 (LT: RB b0 b1): double_rel RA RB (a, b0) (a, b1)
.

Lemma double_rel_well_founded A B (RA: A -> A -> Prop) (RB: B -> B -> Prop)
      (WFA: well_founded RA) (WFB: well_founded RB)
  :
  well_founded (double_rel RA RB).
Proof.
  cut (forall a b, Acc (double_rel RA RB) (a, b)).
  { ii. destruct a as [a b]. eapply H. }
  intros a0. pattern a0. revert a0.
  eapply (well_founded_induction WFA).
  intros a0 IHL. intros b0. pattern b0. revert b0.
  eapply (well_founded_induction WFB).
  intros b0 IHR. econs. intros [a1 b1]. i. inv H.
  { eapply IHL; eauto. }
  { eapply IHR; eauto. }
Qed.

Lemma double_well_founded_induction A B (RA: A -> A -> Prop) (RB: B -> B -> Prop)
      (WFA: well_founded RA) (WFB: well_founded RB)
      (P: A -> B -> Prop)
      (IND: forall a1 b1
                   (IHL: forall a0 (LT: RA a0 a1), P a0 b1)
                   (IHR: forall b0 (LT: RB b0 b1), P a1 b0),
          P a1 b1)
  :
  forall a b, P a b.
Proof.
  cut (forall ab, P (fst ab) (snd ab)).
  { i. apply (H (a, b)). }
  intros ab. pattern ab. revert ab.
  eapply (well_founded_induction (double_rel_well_founded WFA WFB)).
  intros [a b] ?. ss. eapply IND.
  { i. eapply (H (a0, b)). econstructor 1. auto. }
  { i. eapply (H (a, b0)). econstructor 2. auto. }
Qed.

Lemma clos_trans_well_founded
      A (R: A -> A -> Prop) (WF: well_founded R)
  :
    well_founded (clos_trans_n1 _ R).
Proof.
  ii. hexploit (well_founded_induction WF (fun a1 => forall a0 (LT: clos_trans_n1 A R a0 a1 \/ a0 = a1), Acc (clos_trans_n1 A R) a0)).
  { clear a. intros a1 IH. i. econs. i. des.
    - inv LT.
      + eapply IH; eauto.
      + eapply IH; eauto. left.
        eapply Operators_Properties.clos_trans_tn1. econs 2.
        * eapply Operators_Properties.clos_tn1_trans; eauto.
        * eapply Operators_Properties.clos_tn1_trans; eauto.
    - subst. inv H; eauto.
  }
  { right. reflexivity. }
  { eauto. }
Qed.

Lemma clos_trans_step A (R : A -> A -> Prop) x y : clos_trans_n1 _ R x y -> exists z, R z y /\ (x = z \/ clos_trans_n1 _ R x z).
Proof. i. destruct H; eauto. Qed.

Lemma clos_trans_n1_trans A (R : A -> A -> Prop) : Transitive (clos_trans_n1 _ R).
Proof.
  unfold Transitive. i.
  eapply clos_trans_tn1_iff.
  econs 2; eapply clos_trans_tn1_iff; eauto.
Qed.

Variant option_lt A (R: A -> A -> Prop): option A -> option A -> Prop :=
  | optoin_lt_top
      a
    :
    option_lt R (Some a) None
  | optoin_lt_normal
      a0 a1
      (LT: R a0 a1)
    :
    option_lt R (Some a0) (Some a1)
.

Lemma option_lt_well_founded A (R: A -> A -> Prop)
      (WF: well_founded R)
  :
  well_founded (option_lt R).
Proof.
  cut (forall a, Acc (option_lt R) (Some a)).
  { ii. destruct a; ss. econs. i. inv H0; ss. }
  i. induction (WF a). econs.
  i. inv H1. eauto.
Qed.

Variant sum_lt
        A B (RA: A -> A -> Prop) (RB: B -> B -> Prop):
  A + B -> A + B -> Prop :=
  | sum_lt_left
      a0 a1
      (LT: RA a0 a1)
    :
    sum_lt RA RB (inl a0) (inl a1)
  | sum_lt_right
      b0 b1
      (LT: RB b0 b1)
    :
    sum_lt RA RB (inr b0) (inr b1)
  | sum_lt_cross
      a b
    :
    sum_lt RA RB (inl a) (inr b)
.

Lemma sum_lt_well_founded
      A B (RA: A -> A -> Prop) (RB: B -> B -> Prop)
      (WFA: well_founded RA)
      (WFB: well_founded RB)
  :
  well_founded (sum_lt RA RB).
Proof.
  assert (ACCA: forall a, Acc (sum_lt RA RB) (inl a)).
  { i. induction (WFA a). econs.
    i. inv H1. eauto.
  }
  ii. destruct a as [a|b]; eauto.
  induction (WFB b). econs.
  i. inv H1; eauto.
Qed.

Variant prod_lt
        A B (RA: A -> A -> Prop) (RB: B -> B -> Prop):
  A * B -> A * B -> Prop :=
  | prod_lt_left
      a0 a1 b0 b1
      (ALT: RA a0 a1)
    :
    prod_lt RA RB (a0, b0) (a1, b1)
  | prod_lt_right
      a0 a1 b0 b1
      (ALE: a0 = a1 \/ RA a0 a1)
      (BLT: RB b0 b1)
    :
    prod_lt RA RB (a0, b0) (a1, b1)
.

Lemma prod_lt_well_founded
      A B (RA: A -> A -> Prop) (RB: B -> B -> Prop)
      (WFA: well_founded RA)
      (WFB: well_founded RB)
  :
  well_founded (prod_lt RA RB).
Proof.
  ii. destruct a as [a b]. revert b.
  induction (WFA a). rename x into a. clear H. rename H0 into IHA.
  intros b. induction (WFB b). rename x into b. clear H. rename H0 into IHB.
  econs. i. inv H; eauto. des; subst; eauto.
Qed.

Inductive ord_tree (A: Type): Type :=
| ord_tree_base
| ord_tree_cons (childs: A -> ord_tree A)
.

Variant ord_tree_lt A: ord_tree A -> ord_tree A -> Prop :=
  | ord_tree_lt_intro
      childs a
    :
    ord_tree_lt (childs a) (ord_tree_cons childs)
.

Lemma ord_tree_lt_well_founded A
  :
  well_founded (@ord_tree_lt A).
Proof.
  ii. induction a.
  { econs; i. inv H. }
  { econs; i. inv H0. eauto. }
Qed.

From Fairness Require Import Axioms.

Lemma ord_tree_join A (P: A -> Prop) (R: A -> ord_tree A -> Prop)
      (ORD: forall a (SAT: P a), exists o, R a o)
  :
  exists o1, forall (a: A) (SAT: P a),
  exists o0, R a o0 /\ ord_tree_lt o0 o1.
Proof.
  hexploit (choice (fun a o => P a -> R a o)).
  { i. destruct (classic (P x)).
    { hexploit ORD; eauto. i. des. eauto. }
    { eexists (ord_tree_base _). ss. }
  }
  i. des. exists (ord_tree_cons f). i.
  exists (f a). splits; eauto. econs; eauto.
Qed.

Variant option_bot_lt A (R: A -> A -> Prop): option A -> option A -> Prop :=
  | optoin_bot_lt_bot
      a
    :
    option_bot_lt R None (Some a)
  | optoin_bot_lt_normal
      a0 a1
      (LT: R a0 a1)
    :
    option_bot_lt R (Some a0) (Some a1)
.

Lemma option_bot_lt_well_founded A (R: A -> A -> Prop)
      (WF: well_founded R)
  :
  well_founded (option_bot_lt R).
Proof.
  cut (forall a, Acc (option_bot_lt R) (Some a)).
  { ii. destruct a; ss. econs. i. inv H0. }
  i. induction (WF a). econs.
  i. inv H1; eauto.
  econs. i. inv H1.
Qed.

Section WFTYPE.
  Record WF: Type :=
    mk_wf {
        T: Type;
        lt: (T -> T -> Prop);
        wf: well_founded lt;
        le: (T -> T -> Prop) := eq \2/ lt;
      }.

  Global Program Instance le_Reflexive {wf: WF}: Reflexive wf.(le).
  Next Obligation.
    unfold le. auto.
  Qed.

  Lemma WF_le_Trans
        wf
        (WFTR: Transitive wf.(lt))
    :
    Transitive wf.(le).
  Proof.
    unfold le. ii. destruct wf; ss. des; clarify; eauto.
  Qed.

End WFTYPE.

Definition ord_tree_WF {A}: WF := mk_wf (@ord_tree_lt_well_founded A).
Definition option_WF (A: WF): WF := mk_wf (option_lt_well_founded A.(wf)).
Definition option_bot_WF (A: WF): WF := mk_wf (option_bot_lt_well_founded A.(wf)).
Definition sum_WF (A B: WF): WF := mk_wf (sum_lt_well_founded A.(wf) B.(wf)).
Definition prod_WF (A B: WF): WF := mk_wf (prod_lt_well_founded A.(wf) B.(wf)).
Definition clos_trans_WF (A: WF): WF := mk_wf (clos_trans_well_founded A.(wf)).
Definition double_rel_WF (A B: WF): WF := mk_wf (double_rel_well_founded A.(wf) B.(wf)).


(******************************************************************************)
(* This file provides a wrapper for functions of type S -> Prop which are     *)
(* interpreted as subsets of S. The wrapper is to allow nice notations that   *)
(* are only used in the appropriate places. The type is coerced into the      *)
(* sigma types.                                                               *)
(*                                                                            *)
(*       mf_subset.type S == The elements are functions S -> Prop.            *)
(*                          Coerced both into these functions and into        *)
(*                          the sigma types.                                  *)
(*          make_subset  == Notation for the constructor mf_subset.Pack       *)
(*           s \from A   == Elementhood relation. Notation for A s.           *)
(*            A === B    == equality of sets, i.e. notation for               *)
(*                          "s \from A <-> s \from B". The same as usual      *)
(*                          if propositional extensionality is assumed.       *)
(*             All       == constant function s => True where S is implicit.  *)
(*            empty      == constant function s => False where S is implicit. *)
(*          singleton s  == the singleton set containing only s, i.e.         *)
(*                          t \from S <-> t = s.                              *)
(*    A \is_subset_of B  == usual set inclusion, i.e.                         *)
(*                          "s \from A -> s \from B"                          *)
(*           A \n B      == set intersection                                  *)
(*           A \x B      == carthesian product of sets                        *)
(******************************************************************************)
From mathcomp Require Import ssreflect ssrfun.
Require Import Morphisms Setoid.

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

Structure subset S := {P :> S -> Prop}.

Delimit Scope mf_scope with mf.
Local Open Scope mf_scope.
Notation make_subset:= Build_subset (only parsing).
Definition from S (A: subset S) a:= A a.
Notation "a \from A" := (from A a) (at level 50).

Definition mf_sig S (P: subset S) := {s | P s}.
Coercion mf_sig: subset >-> Sortclass.

Section mf_subsets.
  Context (S: Type).

  Definition set_equiv (P Q: subset S) := forall s, s \from P <-> s \from Q.
  Local Notation "P === Q" := (set_equiv P Q) (at level 50).

  Global Instance sqv_equiv: Equivalence set_equiv.
  Proof.
    split => // [P Q eq s | P Q R eq eq' s]; first by split => [Ps | Qs]; apply (eq s).
    by split => [Ps | Rs]; [apply /eq' /eq | apply /eq /eq'].
  Qed.

  Global Instance from_prpr:
    Proper (set_equiv ==> (@eq S) ==> iff) (@from S).
  Proof. by move => P Q eq s _ <-; apply eq. Qed.

  Definition inclusion (P Q : subset S) := forall s, s \from P -> s \from Q.
  Local Notation "P '\is_subset_of' Q" := (inclusion P Q) (at level 50).

  Global Instance subs_prpr:
    Proper (set_equiv ==> set_equiv ==> iff) inclusion.
  Proof. by move => P Q PeQ P' Q' P'eQ'; split => subs s; intros; apply /P'eQ' /subs /PeQ. Qed.

  Global Instance subs_ref: Reflexive inclusion.
  Proof. by move => P P'. Qed.

  Global Instance subs_trans: Transitive inclusion.
  Proof. by move => P P' P'' PsP' P'sP'' s Ps; apply/P'sP''/PsP'. Qed.

  Lemma set_eq_subs P Q:
    P === Q <-> (P \is_subset_of Q /\ Q \is_subset_of P).
  Proof.
    split; first by move => eq; split => s Ps; apply eq.
    move => [subs subs'] s.
    split => Ps; try apply subs => //.
    by apply subs'.
  Qed.

  Lemma split_set_eq (P Q: subset S): P \is_subset_of Q -> Q \is_subset_of P -> P === Q.
  Proof. by move => subs subs' s; split; [apply subs | apply subs']. Qed.

  Definition All := make_subset (fun (_: S) => True).

  Lemma subs_all P: P \is_subset_of All.
  Proof. done. Qed.

  Definition empty := make_subset (fun (_: S) => False).

  Lemma subs_empty P : empty \is_subset_of P.
  Proof. done. Qed.

  Definition singleton (s: S) := make_subset (fun t => s = t).

  Definition intersects (P Q: subset S) := exists s, P s /\ Q s.
  Local Notation "P '\intersects' Q" := (intersects P Q) (at level 50).

  Lemma ntrsct_sym P Q: P \intersects Q <-> Q \intersects P.
  Proof. by split; move => [s []]; exists s. Qed.

  Definition intersection (P Q: subset S) := make_subset (fun s => P s /\ Q s).

  Definition union T P P':= make_subset (fun (q: T) => P q \/ P' q).
  Local Notation "P \n Q" := (intersection P Q) (at level 2).
End mf_subsets.
Notation "P === Q" := (set_equiv P Q) (at level 50): mf_scope.
Notation "P '\is_subset_of' Q" := (inclusion P Q) (at level 50): mf_scope.
Notation "P '\intersects' Q" := (intersects P Q) (at level 50): mf_scope.
Notation "P \n Q" := (intersection P Q) (at level 2): mf_scope.
Notation "P \u Q" := (union P Q) (at level 2): mf_scope.
Arguments All {S}.
Arguments empty {S}.

Section products.
  Definition set_prod S T (P: subset S) (Q: subset T) :=
	make_subset (fun st => P st.1 /\ Q st.2).
  Local Notation "P \x Q" := (set_prod P Q) (at level 40).

  Global Instance sprd_prpr S T:
    Proper (@set_equiv S ==> @set_equiv T ==> @set_equiv (S*T)) (@set_prod S T).
  Proof.
    move => P P' eq Q Q' eq' s /=.
    by rewrite eq eq'.
  Qed.

  Lemma sprd_All S T (P: subset S) (Q: subset T):
    P === All /\ Q === All -> P \x Q === All.
  Proof. by move => [eq eq'] s /=; rewrite eq eq'. Qed.

  Lemma sprd_All_inv S T (P: subset S) (Q: subset T) somes somet:
    P somes -> Q somet -> P \x Q === All -> P === All /\ Q === All.
  Proof.
    move => Ps Qt eq.
    split => [s | t]; first by have [/= _ []]//:= eq (s, somet).
    by have [/= _ []]//:= eq (somes, t).
  Qed.

  Lemma empty_prod S T : @empty (S * T) === empty \x empty.
  Proof. by move => [s t]; split => // [[]]. Qed.

  Lemma prod_eq S T (a c : subset S) (b d : subset T)
    : a === c -> b === d -> a \x b === c \x d.
  Proof. by move => eq eq'; rewrite eq eq'. Qed.

  Lemma prod_empty_l S T (A : subset S) (B : subset T)
    : A === empty -> (A \x B) === @empty (S * T).
  Proof. by move => -> s; split => [[] | ]. Qed.
End products.
Notation "P \x Q" := (set_prod P Q) (at level 40) : mf_scope.


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

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

Require Import basics.
Require Import preord.
Require Import categories.
Require Import 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'' [??]]; simpl; eauto.
        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.
    destruct H; split; simpl; auto.
    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).
        ** 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.


Require Import Coq.Arith.Arith.
Require Import Omega.
Require Import Unicode.Utf8.

Inductive div : nat -> nat -> Prop :=
  | zero_div : forall n, div 0 n
  | add_div : forall n m, div n m -> div (n + m) m.

Inductive coprime : nat -> nat -> Prop :=
  | div_co : forall n m, div n m -> coprime (n + 1) m
  | pred_co : forall n, coprime (n + 1) n
  | basic : coprime 1 1.

Lemma silly_114514 : forall n, div n 1.
Proof.
  induction n.
  - apply zero_div.
  - assert(H' : S n = n + 1).
    rewrite plus_comm. auto. rewrite H'.
    apply add_div. auto.
Qed.

Lemma coprime_1_n : forall n, coprime (S n) 1.
Proof.
  intros. assert(H' : S n = n + 1).
    rewrite plus_comm. auto.
    rewrite H'. apply div_co. apply silly_114514.
Qed.

Lemma coprime_ex : forall n m, coprime n m -> coprime m n.
Proof.
  intros.
  inversion H.
  - inversion H0.
    + simpl. destruct m.
  Abort.

Inductive Coprime : nat -> nat -> Prop :=
  | basic_co :                                  Coprime 1 1
  | addL_co  : forall n m, Coprime n m -> Coprime (n + m) m
  | addR_co  : forall n m, Coprime n m -> Coprime n (m + n).

Lemma coprime_ex : forall n m, Coprime n m -> Coprime m n.
Proof.
  intros. induction H;
  try (constructor;auto).
Qed.

Lemma Coprime_not_involutive : forall n, 1 <= n -> ~(Coprime n n).
Proof.
  intros. unfold not in *. induction n.
  - inversion H.
  - intros.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20synthconj2_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 lv1) (mult lv1 (Succ lv2))) ->  (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus (mult lv1 (plus (Succ lv2) Zero)) (plus (Succ lv2) Zero))).
Admitted.
QuickChick conj20synthconj2_hyp.


Require Import QArith QFacts Morphisms SetoidClass.

Record LReal :=
  { lbound :> Q -> Prop
  ; dclosed : forall q, lbound q -> forall q', q' <= q -> lbound q'
  ; uopen : forall q, lbound q -> exists q', (q < q') /\ lbound q'
  ; nonempty : exists q, lbound q
  }.

Definition LRle (x y : LReal) : Prop := forall q, x q -> y q.
Definition LReq (x y : LReal) : Prop := LRle x y /\ LRle y x.
Definition LRlt (x y : LReal) : Prop := exists q, ~ x q /\ y q.

Definition LRQ (x : Q) : LReal.
Proof.
refine ( {| lbound := fun q' => q' < x |}); intros.
- eapply Qle_lt_trans; eassumption.
- destruct (Qbetween q x H) as (mid & between).
  exists mid. apply between.
- exists (x - 1). apply Qlt_minus_iff.
  ring_simplify. reflexivity.
Defined.

Inductive LRplusT {x y : LReal} : Q -> Prop :=
  LRplusB : forall q q' sum, x q -> y q' -> sum <= q + q' -> LRplusT sum.

Arguments LRplusT : clear implicits.

Definition LRplus (x y : LReal) : LReal.
Proof.
refine ( {| lbound := LRplusT x y |}); intros.
- destruct H. econstructor; try eassumption.
  rewrite H0. apply H2.
- destruct H. destruct (uopen _ _ H).
  destruct H2.
  exists (x0 + q'). split. eapply Qle_lt_trans. eassumption.
  apply Qplus_lt_l. assumption.
  econstructor; try eassumption.
  reflexivity.
- destruct (nonempty x). destruct (nonempty y).
  exists (x0 + x1). econstructor; eauto.
  reflexivity.
Defined.

Require Import Coq.Sets.Ensembles ProofIrrelevance.

Infix "+" := LRplus : LR_scope.
Infix "<=" := LRle : LR_scope.
Infix "<" := LRlt : LR_scope.
Infix "==" := LReq : LR_scope.
Notation "0" := (LRQ 0) : LR_scope.
Delimit Scope LR_scope with LR.
Local Open Scope LR.

Theorem LRplus_comm_le : forall x y, x + y <= y + x.
Proof.
unfold LRle. simpl. intros. destruct H.
econstructor; eauto. rewrite Qplus_comm. assumption.
Qed.

Theorem LRplus_comm : forall x y, (x + y == y + x)%LR.
Proof.
intros. unfold LReq; split; apply LRplus_comm_le.
Qed.

Theorem LRplus_assoc : forall x y z, ((x + y) + z == x + (y + z))%LR.
Proof.
intros. unfold LReq; unfold LRle; split; simpl; intros;
repeat match goal with
| [ H : LRplusT _ _ _  |- _ ] => destruct H; simpl in *
| [  |- LRplusT _ _ _ ] => econstructor; simpl in *
| [  |- lbound _ _ ] => eassumption
end.
Focus 2. rewrite H1. rewrite H3. rewrite (Qplus_comm q (q'0 + q')).
  ring_simplify. reflexivity. reflexivity.
Focus 2.
  rewrite H1. rewrite H3. rewrite (Qplus_assoc q q0 q').
  reflexivity. reflexivity.
Qed.

Definition LReal_eq_compat (x y : LReal) :
  (x == y)%LR -> x = y.
Proof.
intros H. unfold LReq, LRle in H. destruct H.
destruct x, y; simpl in *.
assert (lbound0 = lbound1).
apply Extensionality_Ensembles. unfold Same_set, Included, In.
split; assumption.
induction H1. f_equal; apply proof_irrelevance.
Qed.

Theorem LRplus_comm_eq : forall x y, x + y = y + x.
Proof.
intros. apply LReal_eq_compat. apply LRplus_comm.
Qed.

Lemma LRle_refl : forall (x : LReal), x <= x.
Proof.
unfold LRle. auto.
Qed.

Instance LRle_Reflexive : Reflexive LRle.
Proof.
unfold Reflexive. apply LRle_refl.
Qed.

Lemma LRle_trans : forall x y z : LReal, x <= y -> y <= z -> x <= z.
Proof.
intros. unfold LRle in *. auto.
Qed.

Instance LRle_Transitive : Transitive LRle.
Proof.
unfold Transitive. apply LRle_trans.
Qed.

Lemma LReq_refl : forall (x : LReal), (x == x)%LR.
Proof.
intros; unfold LReq; split; apply LRle_refl.
Qed.

Lemma LReq_trans : forall x y z : LReal, (x == y)%LR -> (y == z)%LR -> (x == z)%LR.
Proof.
intros. destruct H, H0. split; eapply LRle_trans; eassumption.
Qed.

Lemma LReq_sym : forall x y : LReal, (x == y)%LR -> (y == x)%LR.
Proof.
intros. destruct H; split; auto.
Qed.

Instance LReq_Reflexive : Reflexive LReq.
Proof.
unfold Reflexive. apply LReq_refl.
Qed.

Instance LReq_Transitive : Transitive LReq.
Proof.
unfold Transitive. apply LReq_trans.
Qed.

Instance LReq_Symmetric : Symmetric LReq.
Proof.
unfold Symmetric. apply LReq_sym.
Qed.

Instance LReq_Equivalence : Equivalence LReq.
Proof.
constructor. apply LReq_Reflexive. apply LReq_Symmetric.
apply LReq_Transitive.
Qed.

Require Import Coq.Program.Basics.

Instance LReal_proper (x : LReal) : Proper (Qle --> impl) (lbound x).
Proof.
unfold Proper, respectful, impl, flip. intros.
eapply dclosed; eassumption.
Qed.

Instance LReal_proper2 (x : LReal) : Proper (Qeq ==> iff) (lbound x).
Proof.
unfold Proper, respectful. intros. split; intros;
  (eapply dclosed; [eassumption| rewrite H; apply Qle_refl]).
Qed.

Definition LRplus_le_compat : forall x x' y y'
  , x <= x' -> y <= y' -> x + y <= x' + y'.
Proof.
intros. unfold LRle in *; simpl. intros.
destruct H1. econstructor; eauto.
Qed.

Instance LRplus_le_Proper : Proper (LRle ==> LRle ==> LRle) LRplus.
Proof.
unfold Proper, respectful. intros.
apply LRplus_le_compat; assumption.
Qed.

Instance LRplus_Proper : Proper (LReq ==> LReq ==> LReq) LRplus.
Proof.
unfold Proper, respectful. intros.
destruct H, H0. split; apply LRplus_le_compat; assumption.
Qed.

Instance LRle_Proper : Proper (LReq ==> LReq ==> iff) LRle.
Proof.
unfold Proper, respectful. intros.
destruct H, H0. split; intros.
- rewrite H1, H3. assumption.
- rewrite <- H2, <- H3. assumption.
Qed.

Instance LRle_Proper_impl : Proper (LReq ==> LReq ==> flip impl) LRle.
Proof.
unfold Proper, respectful. intros.
destruct H, H0. unfold flip, impl. intros.
rewrite <- H2, <- H3. assumption.
Qed.

Definition LPRsup {A : Type} (inh : A) (f : A -> LReal) : LReal.
Proof.
refine ({| lbound := fun q => exists (idx : A), f idx q |}); intros.
- destruct H. exists x. rewrite H0. assumption.
- destruct H. destruct (uopen _ _ H) as (q' & qq' & fq').
  exists q'. split. assumption. exists x.  assumption.
- destruct (nonempty (f inh)). exists x. exists inh. assumption.
Defined.

Definition LRinfinity : LReal.
Proof.
refine ({| lbound := fun q => True |}); intros; auto.
- exists (q + 1)%Q. intuition. rewrite Qlt_minus_iff. ring_simplify.
  reflexivity.
- exists 0%Q. constructor.
Defined.

Theorem LRinfinity_max (r : LReal) : r <= LRinfinity.
Proof.
unfold LRle; simpl; auto.
Qed.

Definition LRmax (x y : LReal) : LReal.
Proof. refine (
  {| lbound := fun q => x q \/ y q |}
); intros.
- destruct H; [left | right]; eapply dclosed; eassumption.
- destruct H;
  pose proof (uopen _ _ H) as H';
  destruct H' as [q' [qq' pq']]; exists q'; intuition.
- destruct (nonempty x) as (q & qx). exists q. auto.
Defined.

Lemma LRmax_le_and : forall x y z : LReal
  , x <= z -> y <= z -> LRmax x y <= z.
Proof. intros.
unfold LRle; simpl in *; intros; intuition.
Qed.

Lemma LRmax_le_or : forall x y z : LReal
  , z <= x \/ z <= y -> z <= LRmax x y.
Proof. intros.
unfold LRle; simpl in *; intros; intuition.
Qed.

Lemma LRmax_le {x y x' y' : LReal}
  : x <= x' -> y <= y' -> LRmax x y <= LRmax x' y'.
Proof.
intros. unfold LRle. intros q Hmax. simpl in *.
destruct Hmax; [left | right].
- apply H. assumption.
- apply H0. assumption.
Qed.

Lemma LRmax_plus {x x' y y' : LReal}
  : LRmax (x + x') (y + y') <= LRmax x y + LRmax x' y'.
Proof.
apply LRmax_le_and; apply LRplus_le_compat; apply LRmax_le_or;
  (left; apply LRle_refl) || (right; apply LRle_refl).
Qed.

Require Import QArith.Qminmax.

Definition LRmin (x y : LReal) : LReal.
Proof. refine (
  {| lbound := fun q => x q /\ y q |}
).
- intros. destruct H; split; eapply dclosed; eassumption.
- intros. destruct H.
  destruct (uopen _ _ H) as [q'x [qq'x pq'x]].
  destruct (uopen _ _ H0) as [q'y [qq'y pq'y]].
  exists (Qmin q'x q'y). split. eapply Q.min_glb_lt; assumption.
  split; eapply dclosed; try eassumption. apply Q.le_min_l.
  apply Q.le_min_r.
- destruct (nonempty x) as (q & qx).
  destruct (nonempty y) as (q' & q'y).
  exists (Qmin q q'). split. rewrite Q.le_min_l. assumption.
  rewrite Q.le_min_r. assumption.
Defined.

Inductive UReal := | Negate : LReal -> UReal.

Definition ubound (x : UReal) (q : Q) : Prop := match x with
  Negate l => l (- q)%Q
  end.

Definition unegate (u : UReal) : LReal := match u with
  Negate l => l
  end.

Coercion ubound : UReal >-> Funclass.

Delimit Scope RNL_scope with RNL.

(** A non-located real number *)
Record RealNL :=
  { lower : LReal
  ; upper : LReal
  ; disjoint : lower + upper <= 0
  }.

Definition RNLopp (x : RealNL) : RealNL.
Proof.
refine (
  {| lower := upper x
   ; upper := lower x
  |}).
rewrite LRplus_comm. apply disjoint.
Defined.

Notation "- x" := (RNLopp x) : RNL_scope.

Definition RNLle (x y : RealNL) : Prop :=
  lower x <= lower y /\ upper y <= upper x.

Infix "<=" := RNLle : RNL_scope.

Theorem RNLle_refl : forall x : RealNL, (x <= x)%RNL.
Proof.
intros. unfold RNLle. split; reflexivity.
Qed.

Theorem RNLle_trans : forall x y z : RealNL, (x <= y -> y <= z -> x <= z)%RNL.
Proof.
intros. destruct H, H0.
split; eapply LRle_trans; eassumption.
Qed.

Instance RNLle_Reflexive : Reflexive RNLle := RNLle_refl.
Instance RNLle_Transitive : Transitive RNLle := RNLle_trans.

Definition RNLeq (x y : RealNL) : Prop := (x <= y /\ y <= x)%RNL.

Infix "==" := RNLeq : RNL_scope.

Theorem RNLeq_refl : forall x : RealNL, (x == x)%RNL.
Proof.
intros. unfold RNLeq; split; apply RNLle_refl.
Qed.

Theorem RNLeq_sym : forall x y : RealNL, (x == y)%RNL -> (y == x)%RNL.
Proof.
intros. destruct H. split; assumption.
Qed.

Theorem RNLeq_trans : forall x y z : RealNL,
  (x == y)%RNL -> (y == z)%RNL -> (x == z)%RNL.
Proof.
intros. destruct H, H0. split; eapply RNLle_trans; eassumption.
Qed.

Instance RNLeq_Reflexive : Reflexive RNLeq := RNLeq_refl.
Instance RNLeq_Symmetric : Symmetric RNLeq := RNLeq_sym.
Instance RNLeq_Transitive : Transitive RNLeq := RNLeq_trans.

Theorem LReal_reassoc : forall x y a b : LReal,
  ((x + y) + (a + b)  == (x + a) + (y + b))%LR.
Proof.
intros.
(** Eventually I'd like a commutative monoid tactic
    to handle this. *)
admit.
Qed.

Theorem LRzero_plus_id_l : forall x, (x + 0 == x)%LR.
Proof.
intros. unfold LReq, LRle; simpl; split; intros.
- destruct H. rewrite H1. simpl in H0.
  eapply dclosed. eassumption. rewrite H0.
  ring_simplify. reflexivity.
- destruct (uopen _ _ H) as (p & qp & xp).
  econstructor. eapply xp.
  rewrite Qlt_minus_iff in qp.
  apply Qopp_lt_compat in qp. ring_simplify in qp.
  apply qp. ring_simplify. reflexivity.
Qed.

Definition RNLplus (x y : RealNL) : RealNL.
Proof.
refine ({| lower := lower x + lower y
  ; upper := upper x + upper y |}); intros.
rewrite LReal_reassoc.
rewrite (disjoint y), (disjoint x).
rewrite LRzero_plus_id_l.
reflexivity.
Defined.

Lemma LRQ_plus : forall x y : Q,
  (LRQ x + LRQ y == LRQ (x + y)%Q)%LR.
Proof.
intros. unfold LReq, LRle; split; simpl; intros.
- destruct H; simpl in *.
  eapply Qle_lt_trans. eassumption.
  apply Qplus_lt_le_compat; auto.
  rewrite H0. reflexivity.
- pose proof (Qplus_open q x y H).
  destruct H0 as (x' & y' & x'x & y'y & qx'y').
  econstructor; simpl; eassumption.
Qed.

Inductive RmultT {xl xu yl yu : LReal} : Q -> Prop :=
  | RmultB : forall qxl qxu qyl qyu p
    , xl qxl -> xu qxu -> yl qyl -> yu qyu
    -> (p <= qxl * qyl
    -> p <= - qxl * qyu
    -> p <= - qxu * qyl
    -> p <= qxu * qyu
    -> RmultT p)%Q.

Arguments RmultT : clear implicits.

Definition RmultLbound (x y : RealNL) : LReal.
Proof.
refine ({| lbound := RmultT (lower x) (upper x) (lower y) (upper y) |}); intros.
- induction H. econstructor; try eassumption; rewrite H0; assumption.
- admit.
- admit.
Qed.

(** I just wrote this down quickly. It is probably wrong! *)
Definition RNLmult (x y : RealNL) : RealNL.
Proof.
refine (
  {| lower := RmultLbound x y
   ; upper := RmultLbound (RNLopp x) (RNLopp y)
  |}).
Abort.

Instance LRQ_Proper : Proper (Qeq ==> eq) LRQ.
Proof.
unfold Proper, respectful.
intros. apply LReal_eq_compat.
unfold LReq, LRle; split; simpl; intros.
rewrite <- H. assumption. rewrite H. assumption.
Qed.

Definition RNLQ (q : Q) : RealNL.
Proof.
refine ({| lower := LRQ q
        ; upper := LRQ (- q)
        |}).
rewrite LRQ_plus. rewrite Qplus_opp_r.
reflexivity.
Defined.

Record Real :=
  { L : LReal
  ; U : LReal
  ; cut : (L + U == 0)%LR
  }.

Definition Rzero : Real.
Proof.
refine (
  {| L := LRQ 0
   ; U := LRQ 0 |}); intros.
rewrite LRzero_plus_id_l. reflexivity.
Defined.

Definition Rplus (x y : Real) : Real.
Proof.
refine (
  {| L := L x + L y
   ; U := U x + U y
  |}).
rewrite LReal_reassoc.
rewrite (cut x), (cut y).
rewrite LRzero_plus_id_l. reflexivity.
Defined.

Definition Ropp (x : Real) : Real.
Proof.
refine (
  {| L := U x
   ; U := L x
  |}).
rewrite LRplus_comm_eq.
apply (cut x).
Defined.


(** * An implementation of # ωω *)

(** New implementation as a refinement of epsilon0 *)

Require Import T1 E0.
Require Import Arith  Coq.Logic.Eqdep_dec Coq.Arith.Peano_dec
  List Bool
  Recdef Lia  Coq.Wellfounded.Inverse_Image
  Coq.Wellfounded.Inclusion RelationClasses  Logic.Eqdep_dec.

Require Import Comparable.

(** * Representation by lists of pairs of integers *)

(* begin snippet LODef *)
Module LO.

  Definition t := list (nat*nat).

  Definition zero : t := nil.

  (** omega^ i * S n + alpha *)

  Notation cons i n alpha := ((i,n)::alpha).

  (** Finite ordinals *)

  Notation  FS n := (cons 0 n zero: t).

  Definition fin (n:nat): t := match n with 0 => zero | S p => FS p end.
  Coercion fin  : nat >-> t.

  (** [omega ^i ] *)

  Notation phi0 i := (cons i 0 nil).

  Notation omega := (phi0 1).

  (* end snippet LODef *)

  (** data refinement *)

  (* begin snippet refineDef  *)
  Fixpoint refine (a : t) : T1.T1 :=
    match a with
      nil => T1.zero
    | cons i n b => T1.cons (\F i)%t1 n (refine b)
    end.
  (* end snippet refineDef *)

  Inductive ap : t -> Prop :=
    ap_intro : forall a, ap (phi0 a).

  (** Successor and limits (syntactic definitions) *)

  Fixpoint succb (a : t) :=
    match a with
      nil => false
    | cons 0 _ _ => true
    | cons i n b => succb b
    end.

  Fixpoint limitb (a : t) :=
    match a with
      nil => false
    | cons 0 _ _ => false
    | cons i n nil => true
    | cons i n b => limitb b
    end.

  Lemma succb_ref (a:t): succb a -> T1is_succ (refine a).
  Proof.
    induction a as [| a l]; cbn.
    - trivial.
    - destruct a as [n n0]; now destruct n.
  Qed.

  Lemma limitb_ref (a:t): limitb a -> T1limit (refine a).
  Proof.
    induction a as [| a l]; cbn.
    - trivial.
    -  destruct a as [n n0].
       destruct n.
       + discriminate.
       + simpl T1limit; destruct l.
         * trivial.
         * intro H; rewrite IHl; case (refine (p::l)); auto.
  Qed.

  (* begin snippet compareDef:: no-out  *)
  #[ global ] Instance compare_t : Compare t :=
  fix cmp (a b : t) :=
    match a, b with
    | nil, nil => Eq
    | nil, cons a' n' b' => Datatypes.Lt
    | _   , nil => Gt
    | (cons a n b),(cons a' n' b') =>
      (match Nat.compare a a' with
       | Datatypes.Lt => Datatypes.Lt
       | Gt => Gt
       | Eq => (match Nat.compare n n' with
                | Eq => cmp b b'
                | comp => comp
                end)
       end)
    end.

  Lemma compare_ref (a b : t) :
    compare a b = compare (refine a) (refine b).
 (* end snippet compareDef  *)
  Proof.
    revert b; induction a.
    - destruct b.
      + easy.
      + cbn. now destruct p.
    - destruct a, b.
      + now cbn.
      + destruct  p; cbn.
        destruct (n ?= n1) eqn: cn_n1;
          destruct (n0 ?= n2) eqn: c_n0_n2;
          rewrite  compare_fin_rw; now rewrite cn_n1.
  Qed.

  (* begin snippet ltDef *)
  Definition lt (a b : t) : Prop :=
    compare a b = Datatypes.Lt.
  (* end snippet ltDef *)

  Lemma compare_rev :
    forall (a b : t),
      compare b a = CompOpp (compare a b).
  Proof.
    induction a, b.
    - easy.
    - cbn; destruct p; cbn; trivial.
    - cbn; destruct a; reflexivity.
    - cbn; rewrite IHa. destruct p, a;  rewrite Nat.compare_antisym.
      destruct (Nat.compare n1 n) eqn:? ; cbn; trivial.
      rewrite Nat.compare_antisym;
        destruct  (Nat.compare n2 n0) eqn:? ; now cbn.
  Qed.

  Lemma compare_reflect :
    forall a b,
      match compare a b with
      | Datatypes.Lt => lt a b
      | Eq => a = b
      | Gt => lt b a
      end.
  Proof.
    unfold lt; induction a  as [ | [p n]].
    - destruct b.
      + easy.
      + cbn; now destruct p.
    - destruct b as [ | [p0 n0] b].
      + cbn; trivial.
      + cbn; specialize (IHa b);
          rewrite compare_rev with a b;
          rewrite Nat.compare_antisym in * ;
          destruct (compare a b), (p0 ?= p) eqn:Heq; simpl in *;
            subst; try easy;
              apply Nat.compare_eq_iff in Heq as -> ;
              destruct (n ?= n0) eqn:Heqc; trivial.
        * destruct (compare _ _) eqn: H.
          apply Nat.compare_eq_iff in Heqc as ->.
          rewrite IHa.
          reflexivity.
          reflexivity.
          rewrite Nat.compare_antisym.
          rewrite Heqc.
          reflexivity.
        * destruct (n ?= n0) eqn:Heqn; trivial;
            now rewrite Nat.compare_antisym, Heqn.
        * destruct (compare _ _) eqn: H.
          apply Nat.compare_eq_iff in Heqc as ->.
          rewrite IHa.
          reflexivity.
          reflexivity.
          rewrite Nat.compare_antisym.
          rewrite Heqc.
          reflexivity.
        * destruct (n ?= n0) eqn:?; trivial; try discriminate.
          rewrite Nat.compare_antisym; now rewrite Heqc0.
        * destruct (compare _ _) eqn: H.
          apply Nat.compare_eq_iff in Heqc as ->.
          rewrite IHa.
          reflexivity.
          reflexivity.
          rewrite Nat.compare_antisym.
          rewrite Heqc.
          reflexivity.
        * rewrite Nat.compare_antisym.
          rewrite Heqc.
          reflexivity.
  Qed.

  Lemma compare_correct (a b: t):
    CompSpec eq lt a b (compare a b).
  Proof.
    unfold lt;  generalize (compare_reflect a b).
    destruct (compare a b); now constructor.
  Qed.

  (* begin snippet ltRef:: no-out *)
  Lemma lt_ref (a b : t) :
    lt a b <-> T1.lt (refine a) (refine b).
  (* end snippet ltRef *)

  Proof.
    unfold lt, T1.lt; rewrite compare_ref; now split.
  Qed.

  Lemma eq_ref  (a b : t) : a = b <-> refine a = refine b.
  Proof.
    destruct (compare_correct a b).
    - split.
      + intro; now subst.
      + trivial.
    - split.
      + intro; now subst.
      + rewrite lt_ref in H. intros H0; rewrite H0 in H.
        destruct (T1.lt_irrefl H).
    -  split.
       + intro; now subst.
       + rewrite lt_ref in H. intros H0; rewrite H0 in H.
         destruct (T1.lt_irrefl H).
  Qed.

  Lemma lt_irrefl (a : t): ~ lt a a.
  Proof.
    rewrite lt_ref; now apply T1.lt_irrefl.
  Qed.

  Lemma lt_trans (a b c : t): lt a b -> lt b c -> lt a c.
  Proof.
    rewrite !lt_ref; apply T1.lt_trans.
  Qed.

  #[global] Instance lo_strorder: StrictOrder lt.
  Proof.
    constructor.
    - intro a; apply lt_irrefl.
    - intros a b c; eapply lt_trans.
  Qed.

  #[global] Instance lo_comparable : Comparable lt compare.
  Proof.
    constructor.
    - exact lo_strorder.
    - apply compare_correct.
  Qed.

(* begin snippet nfDef *)
  Fixpoint nf_b (alpha : t) : bool :=
    match alpha with
    | nil => true
    | cons a n nil => true
    | cons a n ((cons a' n' b') as b) =>
      (nf_b b && Nat.ltb a' a)%bool
    end.

  Definition nf alpha :Prop := nf_b alpha.
(* end snippet nfDef *)
  (** refinements of T1's lemmas *)

  Lemma zero_nf : nf zero.
  Proof. reflexivity. Qed.

  Lemma fin_nf (i:nat) : nf (fin i).
  Proof.
    destruct i; red; now cbn.
  Qed.

  Lemma single_nf :
    forall i n, nf (cons i n zero).
  Proof. unfold nf; now cbn. Qed.

  Lemma cons_nf :
    forall i n j n' b,
      Nat.lt j i ->
      nf(cons j n' b)->
      nf(cons i n (cons j n' b)).
  Proof.
    unfold nf; simpl; intros i n j n' b' Hltji Ha.
    apply Nat.ltb_lt in Hltji as ->.
    destruct b'; auto with bool.
  Qed.

  #[local] Hint Resolve zero_nf  single_nf cons_nf : core.

  Lemma nf_inv2 :
    forall i n b, nf (cons i n b) -> nf b.
  Proof.
    unfold nf; cbn; destruct i, b;  auto.
    destruct p; cbn; destruct b.
    - auto with bool.
    - destruct p; auto with bool.
      rewrite andb_false_r; discriminate.
    - destruct p; intro H; apply andb_prop in H; now destruct H.
  Qed.

  Lemma nf_inv3 :
    forall i n  j n' b',
      nf (cons i n (cons j n' b')) -> Nat.lt j i.
  Proof.
    unfold nf; cbn;
      destruct  b'; try discriminate; auto with T1;
        intro H; red in H; repeat rewrite andb_true_iff in H.
    - destruct H as [_ H]; destruct i.
      + discriminate.
      + rewrite  Nat.leb_le in H; lia.
    - destruct p; destruct i.
      + destruct j; destruct H; discriminate.
      + destruct H; rewrite  Nat.leb_le in H0; lia.
  Qed.

  Lemma nf_ref: forall a, T1.nf (refine a) <-> nf a.
  Proof.
    induction a.
    - cbn; split; trivial.
    - destruct a as [i n];  split.
      + intro H;  destruct a0.
        * apply single_nf.
        * destruct p.
          apply cons_nf.
          -- cbn in H; apply T1.nf_inv3 in H; now apply T1.lt_fin_iff.
          -- cbn in H; apply IHa; apply T1.nf_inv2 in H; apply H.
      + intro H; destruct a0.
        * apply T1.single_nf, T1.nf_fin.
        * destruct p; cbn; apply T1.cons_nf.
          --  apply nf_inv3 in H; now apply T1.lt_fin_iff.
          -- apply T1.nf_fin.
          -- apply nf_inv2 in H; now rewrite IHa.
  Qed.

  Declare Scope lo_scope.
  Delimit Scope lo_scope with lo.
  Open Scope lo_scope.

  (* begin snippet succPlusMult *)

  Fixpoint succ (a : t) : t :=
    match a with
    | nil => fin 1
    | cons 0 n _  => cons 0 (S n) nil
    | cons a n b => cons a n (succ b)
    end.

  Fixpoint plus (a b : t) :t :=
    match a, b with
    |  nil, y  => y
    |  x, nil  => x
    |  cons a n b, cons a' n' b' =>
       (match Nat.compare a a' with
        | Datatypes.Lt => cons a' n' b'
        | Gt => (cons a n (plus b (cons a' n' b')))
        | Eq  => (cons a (S (n+n')) b')
        end)
    end
  where "a + b" := (plus a b) : lo_scope.

  Fixpoint mult (a b : t) : t :=
    match a, b with
    |  nil, _  => zero
    |  _, nil => zero
    |  cons 0 n _, cons 0 n' b' =>
       cons 0 (Peano.pred((S n) * (S n'))) b'
    |  cons a n b, cons 0 n' _ =>
       cons a (Peano.pred ((S n) * (S n'))) b
    |  cons a n b, cons a' n' b' =>
       cons (a + a')%nat n' ((cons a n b) * b')
    end
  where "a * b" := (mult a b) : lo_scope.

  Compute omega * omega.
  Compute fin 1 * omega.
  Compute fin 42 * omega.

  (* end snippet succPlusMult *)

  (* begin snippet phi0Ref:: no-out *)
  Lemma phi0_ref (i:nat) : refine (phi0 i) = T1.phi0 (\F i).
  Proof. reflexivity. Qed.
  (* end snippet phi0Ref *)

  Lemma phi0_nf  (i:nat) : nf (phi0 i).
  Proof. unfold nf;  now cbn. Qed.

  (* begin snippet succRef:: no-out  *)
  Lemma succ_ref (alpha : t) :
    refine (succ alpha) = T1.succ (refine alpha).
  (* end snippet succRef *)

  Proof.
    induction alpha.
    - now cbn.
    - destruct alpha.
      + destruct a;  cbn; destruct n; now cbn.
      + destruct a; destruct n.
        * now cbn.
        * destruct p; destruct n1.
          -- now cbn.
          -- cbn in *; now rewrite IHalpha.
  Qed.

  Lemma succ_nf alpha : nf alpha -> nf (succ alpha).
  Proof.
    intro H; rewrite <- nf_ref in *; rewrite succ_ref;
      now apply T1.succ_nf.
  Qed.

  (* begin snippet plusRef:: no-out  *)
  Lemma plus_ref : forall alpha beta: t,
      refine (alpha + beta) = T1.T1add (refine alpha) (refine beta).
  (* end snippet plusRef *)
  Proof.
    induction alpha, beta.
    - now cbn.
    - now cbn.
    - cbn; destruct a. now cbn.
    - destruct a, p; cbn;  destruct (n ?= n1) eqn:cn_n1.
      1,2:   rewrite T1.compare_fin_rw in *; rewrite cn_n1; now cbn.
      rewrite T1.compare_fin_rw in *; cbn;rewrite cn_n1, IHalpha;
        now cbn.
  Qed.

  Lemma plus_nf alpha beta : nf alpha -> nf beta -> nf (alpha + beta).
  Proof.
    intros Halpha Hbeta; rewrite <- nf_ref in *; rewrite plus_ref;
      now   apply T1.plus_nf.
  Qed.

  (* begin snippet multRef:: no-out   *)
  Lemma mult_ref : forall alpha beta: t,
      refine (alpha * beta) =
      T1.T1mul (refine alpha) (refine beta).
  (* end snippet multRef *)

  Proof.
    induction alpha.
    -  cbn; destruct beta.
       + now cbn.
       + cbn; destruct p; now cbn.
    - induction beta.
      +  destruct a; cbn. destruct n; now cbn.
      +  destruct a, a0; cbn. destruct n; cbn.
         destruct n1; cbn; trivial.
         * f_equal; rewrite IHbeta; f_equal.
         * cbn. destruct n1. cbn. reflexivity.
           cbn. f_equal. f_equal. lia.
           rewrite IHbeta; f_equal.
  Qed.

  Lemma mult_nf alpha beta : nf alpha -> nf beta -> nf (alpha * beta).
  Proof.
    intros Halpha Hbeta; rewrite <- nf_ref in *; rewrite mult_ref;
      now   apply T1.mult_nf.
  Qed.

  #[global] Instance plus_assoc: Assoc eq plus.
  Proof.
    red; intros *; apply eq_ref; now rewrite !plus_ref, T1.T1addA.
  Qed.

  Lemma mult_plus_distr_l (a b c: t) : nf a -> nf b -> nf c ->
                                       a * (b + c) = a * b + a * c.
  Proof.
    intros Ha Hb Hc; apply eq_ref;
      rewrite !mult_ref, !plus_ref, T1.mult_plus_distr_l, !mult_ref; trivial.
    all: now apply nf_ref.
  Qed.

End LO.

Declare Scope OO_scope.

Delimit Scope OO_scope with oo.
Open Scope OO_scope.
Import LO.

(** * well formed ordinal representation *)

Module OO.
  (* begin snippet OODef *)
  Class OO : Type := mkord {data: LO.t ; data_ok : LO.nf data}.

  Arguments data : clear implicits.
  #[local] Hint Resolve data_ok : core.

  Definition lt (alpha beta: OO) := LO.lt (data alpha) (data beta).
  Definition le := leq lt.
  #[ global ] Instance compare_OO : Compare OO :=
    fun (alpha beta: OO) => LO.compare_t (data alpha) (data beta).
  (*  end snippet OODef *)

  #[ global ] Instance Zero : OO := @mkord nil refl_equal.

  #[ global ] Instance _Omega : OO.
  Proof.
    now exists omega%lo.
  Defined.

  #[ global ] Instance Fin (i:nat) : OO.
  Proof.
    exists (LO.fin i); apply fin_nf.
  Defined.

  Notation omega  := _Omega.

  #[ global ] Instance Succ (alpha : OO) : OO.
  Proof.
    refine (@mkord (LO.succ (@data alpha)) _);
      apply succ_nf, data_ok.
  Defined.

  #[ global ] Instance plus (alpha beta : OO) : OO.
  Proof.
    refine (@mkord (LO.plus (@data alpha) (@data beta))_ );
      apply plus_nf; apply data_ok.
  Defined.

  Infix "+" := plus : OO_scope.

  #[ global ] Instance mult (alpha beta : OO) : OO.
  Proof.
    refine (@mkord (LO.mult (@data alpha) (@data beta))_ );
      apply mult_nf; apply data_ok.
  Defined.

  Infix "*" := mult : OO_scope.

  #[ global ] Instance phi0 (i : nat): OO.
  Proof.
    refine (@mkord (LO.phi0 i) _).
    apply phi0_nf; apply data_ok.
  Defined.

  Notation "'omega^'" := phi0 (only parsing) : OO_scope.

  Infix "*" := mult : OO_scope.

  (* begin snippet embedDef:: no-out *)
  #[ global ] Instance embed (alpha: OO) : E0.E0.
  Proof.
    destruct alpha as [data Hdata].
    refine (@E0.mkord (LO.refine data) _).
    now apply nf_ref.
  Defined.
  (* end snippet embedDef *)

  Lemma lt_embed (alpha beta : OO): lt alpha beta ->
                                    E0lt (embed alpha) (embed beta).
  Proof.
    destruct alpha, beta; unfold lt, E0lt, T1.LT; cbn; repeat split.
    - now apply nf_ref.
    - now apply lt_ref.
    - now apply nf_ref.
  Qed.

  #[ global ] Instance oo_str : StrictOrder lt.
  split.
  - intros x H; destruct x.
    unfold lt in H; cbn; destruct (LO.lt_irrefl _ H).
  - intros x y z; destruct x, y, z.
    unfold lt ; cbn; intros; eapply LO.lt_trans; eauto.
  Qed.

  Lemma nf_proof_unicity :
    forall (alpha:t) (H H': nf alpha), H = H'.
  Proof.
    intros; red in H, H'; apply eq_proofs_unicity_on; decide equality.
  Qed.

  Lemma OO_eq_intro : forall alpha beta : OO,
      data alpha = data beta -> alpha = beta.
  Proof.
    destruct alpha, beta; simpl; intros; subst; f_equal; auto;
      apply nf_proof_unicity.
  Qed.

  #[ global ] Instance OO_comp : Comparable lt compare.
  Proof.
    split.
    - apply oo_str.
    - destruct a, b; cbn.
      destruct (comparable_comp_spec data0 data1).
      + subst.
        assert (compare_t data1 data1 = compare data1 data1) by reflexivity.
        rewrite H.
        rewrite compare_refl.
        constructor.
        apply OO_eq_intro; now cbn.
      + apply compare_lt_iff in H.
        unfold compare in H.
        rewrite H.
        constructor; red; now cbn.
      + apply compare_gt_iff in H.
        unfold compare in H.
        rewrite H.
        constructor; red.
        apply compare_gt_iff.
        unfold compare.
        simpl.
        assumption.
  Qed.

  (* begin snippet ltWf:: no-out *)
  Lemma lt_wf : well_founded lt.
  (* end snippet ltWf *)
  Proof.
    specialize  (ON_Generic.wf_measure (B:= OO) embed); intro Hm;
      unfold ON_Generic.measure_lt in Hm; eapply wf_incl; [| eassumption].
    intros x y Hxy; red; now apply lt_embed.
  Qed.

  Import ON_Generic.

  (* begin snippet ONOO:: no-out *)
  #[ global ] Instance ON_OO : ON lt compare.
  (* end snippet ONOO *)
  Proof.
    split.
    - apply OO_comp.
    - apply lt_wf.
  Qed.

(* begin snippet OOz:: no-out *)
End OO.
(* end snippet OOz *)

(* begin snippet OODemo *)
Import OO.
#[local] Open Scope OO_scope.

Check phi0  7.

#[global] Coercion Fin : nat >-> OO.

Example Ex42: omega + 42 + omega^ 2 = omega^ 2. (* .no-out *)
rewrite <- Comparable.compare_eq_iff.
reflexivity.
Qed.

(* end snippet OODemo *)


Require Import List.
Require Import set.

(******************************************************************************)
(*                        elements : set -> list set                          *)
(******************************************************************************)

Fixpoint elements (a:set) : list set :=
  match a with
    | Empty         => nil
    | Singleton x   => x::nil
    | Union x y     => (elements x) ++ (elements y)
  end.


(* Additional lemmas about tuples *)
Require Import ssreflect ssrbool ssrnat eqtype seq fintype tuple.

Lemma mapCons {n A B} (f: A -> B) b (p: n.-tuple A) :
  map_tuple f [tuple of b :: p] = [tuple of f b :: map_tuple f p].
Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth (f b)). Qed.

Lemma mapNil {A B} (f:A -> B) :
  map_tuple f [tuple] = [tuple].
Proof. exact: val_inj. Qed.

Lemma theadCons : forall {n A} (a:A) (aa: n.-tuple A), thead [tuple of a::aa] = a.
Proof. done. Qed.

Lemma beheadCons {n A} a (aa: n.-tuple A) : behead_tuple [tuple of a::aa] = aa.
Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth a). Qed.

Lemma zipCons {n A B} a (aa: n.-tuple A) b (bb: n.-tuple B) :
  zip_tuple [tuple of a::aa] [tuple of b::bb] = [tuple of (a,b) :: zip_tuple aa bb].
Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth (a,b)). Qed.

Lemma nseqCons {n A} (a:A) : nseq_tuple (S n) a = [tuple of a::nseq_tuple n a].
Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth a). Qed.

Lemma catCons {n1 n2 A} (a:A) (aa:n1.-tuple A) (bb:n2.-tuple A) :
  cat_tuple [tuple of a::aa] bb = [tuple of a::cat_tuple aa bb].
Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth a). Qed.

Lemma catNil {n A} (aa:n.-tuple A) :
  cat_tuple [tuple] aa = aa.
Proof. exact: val_inj. Qed.

Lemma mapId T n (t: n.-tuple T) : map_tuple id t = t.
Proof.
  induction n.
  + by rewrite (tuple0 t) mapNil.
  + case : t / tupleP => h t.
    by rewrite mapCons IHn.
Qed.

Hint Rewrite @mapCons @mapNil @theadCons @ beheadCons @zipCons @nseqCons @catCons @catNil @mapId : tuple.

Lemma behead_nseq {n A} (a:A) : behead_tuple (nseq_tuple n.+1 a) = nseq_tuple n a.
Proof. by apply: eq_from_tnth=> i; rewrite !(tnth_nth a). Qed.

Lemma splitTuple {X n} {a b:X} {c d:n.-tuple X} : cons_tuple a c = cons_tuple b d -> a = b /\ c = d.
Proof. move => H. split. by inversion H. apply val_inj. by inversion H. Qed.

(* The last n elements *)
Fixpoint lastn {T} n {n2} : (n2+n).-tuple T -> n.-tuple T :=
  if n2 is _.+1 return (n2+n).-tuple T -> n.-tuple T
  then fun p => lastn _ (behead_tuple p) else fun p => p.

(* The first n elements *)
Fixpoint firstn {T} {n1} n : (n+n1).-tuple T -> n.-tuple T :=
  if n is _.+1 return (n+n1).-tuple T -> n.-tuple T
  then fun p => cons_tuple (thead p) (firstn _ (behead_tuple p)) else fun p => nil_tuple _.

Definition ordS {n} (k: 'I_n) : 'I_(n.+1) := lift ord0 k.

(*
Compute (ord0 : 'I_4).
Compute (val (ordS ord0 : 'I_4)).
Compute (val (ordS (ordS ord0) : 'I_4)).
*)

(* Induction over ordinals@ *)
Lemma ord_ind (P : forall n, 'I_n -> Prop) :
  (forall n, P n.+1 ord0) ->
  (forall n, forall k, P n k -> P n.+1 (ordS k)) ->
  forall n k,
  P n k.
Proof.
move=> bc ih.
elim=> [[m lemn]|n IHn [m lemn]];
  first by discriminate lemn.
case: m lemn=> [le0n|m lesmsn].
  (* P n.+1 ord0 *)
  have: Ordinal le0n = ord0 by exact: ord_inj.
  move=> ->; exact: bc.

  (* P n.+1 (ordS k) *)
  set k: 'I_n := @Ordinal n m lesmsn.
  have: Ordinal lesmsn = ordS k by exact: ord_inj.
  move=> ->.
  apply ih; apply IHn; by exact.
Qed.

(* A form of [eta] for non-empty enumerations *)
Lemma enum_eta {A} {n} (f: 'I_(n.+1) -> A) :
  val [tuple f s | s < n.+1 ] =
  (f ord0) :: [seq f (ordS s) | s <- enum 'I_n].
Proof.
  apply eq_trans with (y := [seq f s | s <- enum 'I_n.+1]);
    first by reflexivity.
  rewrite enum_ordS.
  rewrite map_cons.
  rewrite -map_comp.
  reflexivity.
Qed.


Add LoadPath "/home/blaine/lab/cpdtlib" as Cpdt.
Set Implicit Arguments. Set Asymmetric Patterns.
Require Import List Cpdt.CpdtTactics.
From stdpp Require Import base fin vector options.
Import ListNotations.

Ltac solve_crush := try solve [crush].
Ltac solve_assumption := try solve [assumption].
Ltac subst_injection H := injection H; intros; subst; clear H.

Notation impossible := (False_rect _ _).
Notation this item := (exist _ item _).
Notation use item := (proj1_sig item).

Require Import theory.list_assertions.

From Coq.Wellfounded Require Import Inclusion Inverse_Image.

Section wf_transfer.
	Variable A B: Type.
	Variable RA: A -> A -> Prop.
	Variable RB: B -> B -> Prop.
	Variable f: A -> B.

	Theorem wf_transfer:
		(forall a1 a2, (RA a1 a2) -> (RB (f a1) (f a2)))
		-> well_founded RB
		-> well_founded RA.
	Proof.
		intros H?;
		apply (wf_incl _ _ (fun a1 a2 => (RB (f a1) (f a2))) H);
		apply wf_inverse_image; assumption.
	Qed.

End wf_transfer.

Section VectorIndexAssertions.
	Context {T: Type}.
	Context {size: nat}.
	Notation IndexPair := (prod (fin size) T) (only parsing).

	Definition index_disjoint (index: fin size) :=
		fun (index_pair: IndexPair) => ((index_pair.1) <> index).

	Inductive UnionAssertion (vector: vec T size): list IndexPair -> Prop :=
		| union_nil: UnionAssertion vector []
		| union_cons: forall pairs index value,
			UnionAssertion vector pairs
			-> (vector !!! index) = value
			-> Forall (index_disjoint index) pairs
			-> UnionAssertion vector ((index, value) :: pairs)
	.

	(*Theorem UnionAssertion_no_duplicate_indices: forall vector index_pairs,
		UnionAssertion vector index_pairs
		-> NoDup (map (fun index_pair => index_pair.1) index_pairs).
	Proof. Qed.*)
	(*
		while this is fancy and everything, we almost certainly don't need it, since we really want a higher level opaque theorem stating that if two assertions point to the same location in the same vector then we can derive False
	*)

End VectorIndexAssertions.

Section convert_subset.
	Variable T: Type.
	Variable P Q: T -> Prop.
	Theorem convert_subset: {t | P t} -> (forall t: T, P t -> Q t) -> {t | Q t}.
	Proof. intros []; eauto. Qed.
End convert_subset.
Arguments convert_subset {T} {P} {Q} _ _.

Notation convert item := (convert_subset item _).

Notation Yes := (left _ _).
Notation No := (right _ _).
Notation Reduce x := (if x then Yes else No).

Theorem append_single_cons {T: Type}: forall (t: T) l, t :: l = [t] ++ l.
Proof. induction l; auto. Qed.

Theorem valid_index_not_None {T} (l: list T) index:
	index < (length l) -> (lookup index l) <> None.
Proof.
	intros ??%lookup_ge_None; lia.
Qed.
Theorem valid_index_Some {T} (l: list T) index:
	index < (length l) -> exists t, (lookup index l) = Some t.
Proof.
	intros ?%(lookup_lt_is_Some_2 l index);
	unfold is_Some in *; assumption.
Qed.
(*lookup_lt_Some*)
Definition safe_lookup {T} index (l: list T):
	index < (length l) -> {t | (lookup index l) = Some t}
.
	intros ?%valid_index_not_None;
	destruct (lookup index l) eqn:Hlook; try contradiction;
	rewrite <- Hlook; apply (exist _ t Hlook).
Defined.

Theorem safe_lookup_In {T} index (l: list T) (H: index < length l):
	In (use (safe_lookup l H)) l.
Proof.
	apply elem_of_list_In; destruct (safe_lookup l H); simpl;
	apply elem_of_list_lookup; exists index; assumption.
Qed.

Theorem Forall_safe_lookup {T} (P: T -> Prop) l:
	Forall P l <-> forall index (H: index < length l), P (use (safe_lookup l H)).
Proof.
	split.
	-
		intros; destruct (safe_lookup l _); simpl;
		apply (Forall_lookup_1 P l index); assumption.
	-
		intros ?Hfunc; apply Forall_lookup; intros index item Hlookup;
		specialize (lookup_lt_Some l index item Hlookup) as Hindex;
		specialize (Hfunc index Hindex);
		destruct (safe_lookup l _) as [item' Hitem'] in Hfunc; simpl in Hfunc;
		rewrite Hlookup in Hitem'; subst_injection Hitem'; assumption.
Qed.

Definition closer_to target: nat -> nat -> Prop :=
	fun next cur => (target - next) < (target - cur).
(*Hint Unfold closer_to: core.*)

Theorem closer_to_well_founded target: well_founded (closer_to target).
Proof.
	apply (well_founded_lt_compat nat (fun a => target - a)); intros; assumption.
Defined.

Theorem closer_to_reverse: forall target cur next,
	(target - next) < (target - cur) -> cur < next.
Proof. lia. Qed.

Theorem closer_to_bounded_reverse: forall target cur next,
	cur < next -> cur < target -> (target - next) < (target - cur).
Proof. lia. Qed.

Definition closer_to_end {T} (arr: list T) := closer_to (length arr).

Theorem closer_to_end_well_founded {T} (arr: list T): well_founded (closer_to_end arr).
Proof. apply closer_to_well_founded. Qed.

Theorem numeric_capped_incr_safe total begin cap index:
	total = begin + cap
	-> 0 < cap
	-> index < begin
	-> S index < total.
Proof. lia. Qed.

Theorem capped_incr_safe {T} (total begin cap: list T) index:
	total = begin ++ cap
	-> 0 < length cap
	-> index < length begin
	-> S index < length total.
Proof.
	intros Htotal Hcap Hindex;
	assert (Hlen: length total = (length begin) + (length cap))
		by solve [rewrite Htotal; apply app_length];
	apply (numeric_capped_incr_safe Hlen Hcap Hindex).
Qed.

Theorem index_pairs_lookup_forward {A B}:
	forall (items: list A) (f: nat -> A -> B) item index,
	lookup index items = Some item -> lookup index (imap f items) = Some (f index item).
Proof.
	induction items; intros ??[]?;
	try solve [apply (IHitems (compose f S)); assumption];
	naive_solver.
Qed.

Theorem index_pairs_lookup_back {A B}:
	forall (items: list A) (f: nat -> A -> B) item index,
	(forall index i1 i2, f index i1 = f index i2 -> i1 = i2)
	-> lookup index (imap f items) = Some (f index item)
	-> lookup index items = Some item.
Proof.
	induction items; intros ??[]Hf?;
	try solve [injection H; intros ?%Hf; naive_solver];
	try solve [apply (IHitems (compose f S)); eauto];
	naive_solver.
Qed.

Theorem index_pair_equality {A B} (a: A) (b1 b2: B): (a, b1) = (a, b2) -> b1 = b2.
Proof. naive_solver. Qed.

Inductive partial (P: Prop): Type :=
	| Proven: P -> partial P
	(*| Falsified: ~P -> partial P*)
	| Unknown: partial P
.
Notation proven := (Proven _).
Notation unknown := (Unknown _).
Notation provenif test := (if test then proven else unknown).

Section find_obligations.
	Context {T: Type}.
	Variable P: T -> Prop.

	Theorem forall_done_undone items done undone:
		Permutation items (done ++ undone)
		-> Forall P done -> Forall P undone
		-> Forall P items.
	Proof.
		intros Hpermutation??; assert (Happ: Forall P (done ++ undone))
			by solve [apply Forall_app_2; assumption];
		setoid_rewrite Hpermutation; assumption.
	Qed.

	Variable compute_partial: forall t: T, partial (P t).

	Definition split_by_maybe: forall items: list T, {
		pair | Permutation items (pair.1 ++ pair.2) /\ Forall P pair.1
	}.
		refine (fix split_by_maybe items :=
			match items with
			| [] => this ([], [])
			| item :: items' =>
				let (pair, H) := split_by_maybe items' in
				match (compute_partial item) with
				| Proven _ => this ((item :: pair.1), pair.2)
				| Unknown => this (pair.1, (item :: pair.2))
				end
			end
		);
		intros; split; simpl in *; try destruct H;
		try solve [setoid_rewrite H; apply Permutation_middle]; auto.
	Defined.

	Definition find_obligations_function: forall items, {
		obligations | Forall P obligations -> Forall P items
	}.
		refine (fun items =>
			let (pair, H) := split_by_maybe items in
			this pair.2
		);
		destruct H; apply (forall_done_undone H); assumption.
	Defined.

	Theorem verify__find_obligations_function:
		forall items found, found = find_obligations_function items
		-> Forall P (use found) -> Forall P items.
	Proof. intros ?[]; auto. Qed.

End find_obligations.

Ltac find_obligations__helper P compute_partial items :=
	let found := eval compute in (find_obligations_function P compute_partial items) in
	let pf := eval compute in (proj2_sig found) in
	apply pf; apply Forall_fold_right; simpl; repeat split
.

Ltac find_obligations P compute_partial items :=
	match goal with
	| |- Forall P items =>
		find_obligations__helper P compute_partial items

	| |- forall item, In item items -> P item =>
		apply Coq.Lists.List.Forall_forall;
		find_obligations__helper P compute_partial items

	| |- forall item, elem_of item items -> P item =>
		apply Forall_forall;
		find_obligations__helper P compute_partial items

	| |- forall index def, index < length items -> P (nth index items def) =>
		apply Coq.Lists.List.Forall_nth;
		find_obligations__helper P compute_partial items

	| |- forall index item, (lookup index items) = Some item -> P item =>
		apply Forall_lookup;
		find_obligations__helper P compute_partial items

	| |- forall index, index < length items -> P (items !!! index) =>
		apply Forall_lookup_total;
		find_obligations__helper P compute_partial items

	| |- forall index (H: index < length items), P (use (safe_lookup items H)) =>
		apply Forall_safe_lookup;
		find_obligations__helper P compute_partial items
	end
.

Module test__find_obligations.
	Definition P n := (n < 4 \/ n < 6).
	Definition compute_partial: forall n, partial (P n).
		refine (fun n => if (lt_dec n 4) then proven else unknown); unfold P; lia.
	Defined.

	Definition items := [0; 1; 2; 4; 3; 2; 5].
	Theorem find_obligations__Forall: Forall P items.
	Proof. find_obligations P compute_partial items; lia. Qed.
	Theorem find_obligations__forall_In: forall item, In item items -> P item.
	Proof. find_obligations P compute_partial items; lia. Qed.
	Theorem find_obligations__forall_elem_of: forall item, elem_of item items -> P item.
	Proof. find_obligations P compute_partial items; lia. Qed.
	Theorem find_obligations__forall_nth: forall index def, index < length items -> P (nth index items def).
	Proof. find_obligations P compute_partial items; lia. Qed.
	Theorem find_obligations__forall_lookup: forall index item, (lookup index items) = Some item -> P item.
	Proof. find_obligations P compute_partial items; lia. Qed.
	Theorem find_obligations__forall_lookup_total: forall index, index < length items -> P (items !!! index).
	Proof. find_obligations P compute_partial items; lia. Qed.
	Theorem find_obligations__forall_safe_lookup:
		forall index (H: index < length items), P (use (safe_lookup items H)).
	Proof. find_obligations P compute_partial items; lia. Qed.
End test__find_obligations.

(*
Inductive Result (T: Type) (E: Type): Type :=
	| Ok (value: T)
	| Err (error: E).

Arguments Ok {T} {E} _.
Arguments Err {T} {E} _.
*)