Require Import List.
Require Import FunctionalExtensionality.
Import ListNotations.
Import Coq.Program.Basics.
Require Import Coq.QArith.Qcanon.

Set Implicit Arguments.

Section Pair.

  Definition mapFirst A B C (f : A -> B) (p : A * C) :=
    pair (f (fst p)) (snd p).

  Definition mapSecond A B C (f : A -> B) (p : C * A) :=
    pair (fst p) (f (snd p)).

End Pair.

Section BDD.

  Inductive BDD :=
  | Zero : BDD
  | One : BDD
  | Node : nat -> nat -> BDD -> BDD -> BDD
  | Ref : nat -> BDD.

  Fixpoint foldBDD (A : Type) (zero one : A) (ref : nat -> A)
           (node : nat -> A -> nat -> A -> A) (bdd : BDD) : A :=
    match bdd with
    | Zero => zero
    | One  => one
    | Ref i => ref i
    | Node id var thenB elseB =>
      node id (foldBDD zero one ref node thenB)
           var (foldBDD zero one ref node elseB)
    end.

  Section Dict.

    Variable K V : Type.
    Definition Dict := K -> V.
    Definition insertDict (eqK : K -> K -> bool)
               (key : K) (val : V) (dict : Dict) : Dict :=
      fun k' => if eqK key k'
             then val
             else dict k'.

    Axiom ERROR : V.
    Definition emptyDict : Dict := fun k => ERROR.

  End Dict.

  Definition foldBDDShareDict (A : Type) (zero one : A)
           (node : A -> nat -> A -> A)
    : BDD -> Dict nat A -> Dict nat A * A :=
    let zeroS := fun dict => (dict, zero) in
    let oneS  := fun dict => (dict, one) in
    let refS  := fun i dict => (dict, dict i) in
    let nodeS := fun id thenF var elseF dict =>
        let '(dict1, res1) := thenF dict in
        let '(dict2, res2) := elseF dict1 in
        let res           := node res1 var res2
        in (insertDict Nat.eqb id res dict2, res)
    in foldBDD zeroS oneS refS nodeS.

  Definition foldBDDShare (A : Type) (zero one : A) (node : A -> nat -> A -> A)
             (bdd : BDD) : A :=
    snd (foldBDDShareDict zero one node bdd (@emptyDict nat A)).

  Definition all (bdd : BDD) : list (list nat * list nat) :=
    let nodeAll pt v pe :=
        map (mapFirst (fun xs => v :: xs)) pt
            ++ map (mapSecond (fun xs => v :: xs)) pe
    in foldBDDShare [] [([],[])] nodeAll bdd.

End BDD.

Section CommutativeSemiring.

  Class CommutativeSemiring (A : Type) :=
    { one : A;
      zero : A;
      plus : A -> A -> A;
      mult : A -> A -> A;
      plus_0_r : forall x, plus x zero = x;
      plus_0_l : forall x, plus zero x = x;
      plus_assoc : forall z1 z2 z3, plus z1 (plus z2 z3) = plus (plus z1 z2) z3;
      mult_1_r : forall x, mult x one = x;
      mult_1_l : forall x, mult one x = x;
      mult_0_l : forall x, mult zero x = zero;
      mult_0_r : forall x, mult x zero = zero;
      mult_assoc : forall z1 z2 z3, mult z1 (mult z2 z3) = mult (mult z1 z2) z3;
      mult_comm : forall x y, mult x y = mult y x;
      mult_plus_distr_r : forall x y z, mult x (plus y z) = plus (mult x y) (mult x z);
      mult_plus_distr_l : forall x y z, mult (plus x y) z = plus (mult x z) (mult y z)
    }.

  Variable A : Type.
  Context {CA : CommutativeSemiring A}.

  Definition sum : list A -> A := fold_right plus zero.

  Definition prod : list A -> A := fold_right mult one.

  Lemma mult_prod_map :
    forall B C (z : B) (h1 : B -> A) (zsc : list B * C),
      mult (h1 z) (prod (map h1 (fst zsc))) = prod (map h1 (z :: fst zsc)).
  Proof.
      reflexivity.
  Qed.

End CommutativeSemiring.

Section HenningIndex.

  Definition sumProdSpec (A : Type) `{CommutativeSemiring A}
             (f g : nat -> A) (bdd : BDD) : A :=
    let prods := fun '(win,comp) =>
        mult (prod (map f win)) (prod (map g comp))
    in sum (map prods (all bdd)).

  Definition sumProd (A : Type) {CA : CommutativeSemiring A}
             (f g : nat -> A) (bdd : BDD) : A :=
    let nodeSumProd t v e := plus (mult (f v) t) (mult (g v) e)
    in foldBDDShare zero one nodeSumProd bdd.

  Instance Qc_CSR : CommutativeSemiring Qc :=
    { one := 1;
      zero := 0;
      plus := Qcplus;
      mult := Qcmult;
      plus_0_r := Qcplus_0_r;
      plus_0_l := Qcplus_0_l;
      plus_assoc := Qcplus_assoc;
      mult_1_r := Qcmult_1_r;
      mult_1_l := Qcmult_1_l;
      mult_0_l := Qcmult_0_l;
      mult_0_r := Qcmult_0_r;
      mult_assoc := Qcmult_assoc;
      mult_comm := Qcmult_comm;
      mult_plus_distr_r := Qcmult_plus_distr_r;
      mult_plus_distr_l := Qcmult_plus_distr_l
    }.

  Definition henningIndex (p : nat -> Qc) (bdd : BDD) : Qc :=
    sumProd p (fun i => 1 - p i) bdd.

  Definition henningIndexSpec (p : nat -> Qc) (bdd : BDD) : Qc :=
    sumProdSpec p (fun i => 1 - p i) bdd.

End HenningIndex.

Section Lemma1.

  Variable A B : Type.
  Variable h : A -> B.
  Variable p : A -> nat -> A -> A.
  Variable q : B -> nat -> B -> B.

  Axiom free_theorem_foldBDDShare :
    (forall (v : A) (n : nat) (w : A),
        h (p v n w) = q (h v) n (h w)) ->
    forall (x y : A) (bdd : BDD),
      h (foldBDDShare x y p bdd) = foldBDDShare (h x) (h y) q bdd.

End Lemma1.

Section Lemma2.

  Variable A : Type.
  Context {CA : CommutativeSemiring A}.

  Lemma sum_homomorphism :
    forall (xs ys : list A),
      sum (xs ++ ys) = plus (sum xs) (sum ys).
  Proof.
    induction xs; intro ys.
    - unfold "++".
      rewrite <- plus_0_l with (x := (sum ys)) at 1.
      simpl.
      reflexivity.
    - simpl sum.
      rewrite IHxs.
      rewrite plus_assoc.
      reflexivity.
  Qed.

End Lemma2.

Section Lemma3.

  Variable A : Type.
  Context {CA : CommutativeSemiring A}.

  Lemma mult_sum :
    forall c l, mult c (sum l) = sum (map (mult c) l).
  Proof.
    intros c l.
      induction l.
    - simpl sum.
      apply mult_0_r.
    - simpl sum.
      rewrite mult_plus_distr_r.
      rewrite IHl.
      reflexivity.
  Qed.

End Lemma3.

Section prods.

  Variable A : Type.
  Context {CA : CommutativeSemiring A}.

  Variable f : nat -> A.
  Variable g : nat -> A.

  Definition prods : list nat * list nat -> A :=
    fun '(win,comp) => mult (prod (map f win)) (prod (map g comp)).

End prods.

Section Lemma4.

  Variable A : Type.
  Context {CA : CommutativeSemiring A}.

  Variable f : nat -> A.
  Variable g : nat -> A.

  Lemma prods_cons1 :
    forall l z,
      prods f g (mapFirst (fun zs => z :: zs) l) = mult (f z) (prods f g l).
  Proof.
    intros l z.
    unfold prods.
    simpl.
    destruct l.
    rewrite mult_assoc.
    reflexivity.
  Qed.

End Lemma4.

Section Lemma5.

  Variable A : Type.
  Context {CA : CommutativeSemiring A}.

  Variable f : nat -> A.
  Variable g : nat -> A.

  Lemma prods_cons2 :
    forall l z,
      prods f g (mapSecond (fun zs => z :: zs) l) = mult (g z) (prods f g l).
  Proof.
    intros l z.
    unfold prods.
    destruct l.
    simpl.
    rewrite mult_assoc, mult_comm with (x := prod (map f l)), <- mult_assoc.
    reflexivity.
  Qed.

End Lemma5.

Section Theorem1.

  Variable A : Type.
  Context {CA : CommutativeSemiring A}.

  Variable f : nat -> A.
  Variable g : nat -> A.

  Definition prods' := prods f g.

  Definition h (xs : list (list nat * list nat)) : A := sum (map prods' xs).

  Definition p (v : list (list nat * list nat))
             (z : nat) (w : list (list nat * list nat)) :=
    map (mapFirst (fun zs => z :: zs)) v
        ++ map (mapSecond (fun zs => z :: zs)) w.

  Definition q (pt : A) (v : nat) (pe : A) :=
    plus (mult (f v) pt) (mult (g v) pe).

  Definition x : list (list nat * list nat) := [].
  Definition y : list (list nat * list nat) := [([],[])].

  Section Proof_Obligations.

    Lemma h_x_zero :
      h x = zero.
    Proof.
      unfold h, x.
      reflexivity.
    Qed.

    Lemma h_y_one :
      h y = one.
    Proof.
      unfold h, y; simpl.
      unfold prods', prods; simpl.
      rewrite mult_1_r.
      apply plus_0_r.
    Qed.

    Lemma h_p_q_paper_version :
      forall v n w,
        h (p v n w) = q (h v) n (h w).
    Proof.
      intros v n w.
      unfold h at 1.
      unfold p.
      rewrite map_app.
      do 2 rewrite map_map.
      rewrite sum_homomorphism.

      replace (fun x0 : list nat * list nat => prods' (mapFirst (fun zs => n :: zs) x0))
      with (fun x0 : list nat * list nat => mult (f n) (prods' x0));
        try (extensionality xys; unfold prods'; rewrite prods_cons1; reflexivity).

      replace (fun x0 : list nat * list nat => prods' (mapSecond (fun zs => n :: zs) x0))
      with (fun x0 : list nat * list nat => mult (g n) (prods' x0));
        try (extensionality xys; unfold prods'; rewrite prods_cons2; reflexivity).

      rewrite <- map_map.
      rewrite <- mult_sum.
      rewrite <- map_map with (l := w).
      rewrite <- mult_sum.

      unfold q.
      unfold h.
      reflexivity.
    Qed.

    Lemma h_p_q :
      forall v n w,
        h (p v n w) = q (h v) n (h w).
    Proof.
      intros v n w.
      unfold h at 1.
      unfold p.
      rewrite map_app.
      do 2 rewrite map_map.
      rewrite sum_homomorphism.

      unfold q.
      unfold h.
      do 2 rewrite mult_sum.
      do 2 rewrite map_map.
      unfold prods', prods.
      simpl fst; simpl snd; simpl prod.

      do 3 f_equal.
      - extensionality pair.
        simpl.
        destruct pair.
        rewrite <- mult_assoc.
        reflexivity.
      - extensionality pair.
        simpl.
        destruct pair.
        rewrite mult_assoc.
        rewrite mult_comm with (x := prod (map f l)).
        rewrite <- mult_assoc.
        reflexivity.
    Qed.

  End Proof_Obligations.

  Theorem sumProd_sumProdSpec :
    forall bdd,
      sumProd f g bdd = sumProdSpec f g bdd.
  Proof.
    intro bdd.
    pose proof (free_theorem_foldBDDShare h p q h_p_q x y).
    rewrite h_x_zero in H.
    rewrite h_y_one in H.
    unfold sumProd.
    rewrite <- H.
    reflexivity.
  Qed.

End Theorem1.

Section Corollary1.

  Corollary henningIndex_henningIndexSpec :
    forall (p : nat -> Qc) bdd, henningIndex p bdd = henningIndexSpec p bdd.
  Proof.
    intros p bdd.
    unfold henningIndex, henningIndexSpec.
    apply sumProd_sumProdSpec.
  Qed.

End Corollary1.


Require Import MyTactics.
Require Import LCSyntax.
Require Import LCValues.
Require Import LCReduction.
Require Import STLCDefinition.
Require Import STLCLemmas.

(*|

This is a failed attempt to prove the lemma `jt_te_substitution_0` in
a direct way, without introducing the auxiliary judgement `js`. See
STLCLemmas for a valid proof.

|*)

(*|
The subject reduction theorem, also known as type preservation:
the typing judgement is preserved by one step of reduction.

This is proved here for `cbv`, but could be proved for other notions
of reduction, such as `cbn`, or strong reduction.

|*)

Lemma jt_preservation:
  forall Gamma t T,
  jt Gamma t T ->
  forall t',
  cbv t t' ->
  jt Gamma t' T.
Proof.
  (* By induction on the type derivation,
     then by cases on `cbv t t'`. *)
  induction 1; intros; subst; invert_cbv; try eauto with jt.
  (* Case: JApp/RedBetaV. *)
  { pick_jt (Lam t) invert.
    eauto using jt_te_substitution_0. }
  { pick_jt (VariantSome vc) invert.
    eauto using jt_te_substitution_0.
  }
Qed.

(*|

An inversion lemma: if a closed value admits a function type `TyFun T1 T2`,
then it must be a lambda-abstraction.

|*)

Lemma invert_jt_TyFun:
  forall Gamma t T1 T2,
  jt Gamma t (TyFun T1 T2) ->
  closed t ->
  is_value t ->
  exists t', t = Lam t'.
Proof.
  (* By cases. The type system is so simple that an induction is not
     even required here. An induction would be required if the type
     system had non-syntax-directed rules, such as a subtyping rule, or
     type abstraction and type instantiation rules, as in System F. *)
  inversion 1; intros; subst.
  (* Case: JVar. A variable is not closed. Contradiction. *)
  { false. eauto with closed. }
  (* Case: JLam. Immediate. *)
  { obvious. }
  (* Case: JApp. An application is not a value. Contradiction. *)
  { false. }
  (* Case: Ite. An Ite is not a value. Contradiction. *)
  { false. }
Qed.

Lemma invert_jt_TyOption:
  forall Gamma t T,
  jt Gamma t (TyOption T) ->
  is_value t ->
  closed t ->
  (
    t = VariantNone \/
    exists t',
      is_value t'
      /\ closed t'
      /\ jt Gamma t' T
      /\ t = VariantSome t'
  ).
Proof.
  inversion 1; intros; subst.
  { false. eauto with closed. }
  { false. }
  { obvious. }
  { right. exists t0; repeat split; eauto with closed. }
  { false. }
Qed.

(*|

The progress theorem: a closed, well-typed term
must either be able to make one step of reduction
or be a value.

|*)

Lemma jt_progress:
  forall Gamma t T,
  jt Gamma t T ->
  closed t ->
  (exists t', cbv t t') \/ is_value t.
Ltac use_ih ih :=
  destruct ih; [ eauto with closed | unpack; eauto with red |  ].
Proof.
  (* By induction on the type derivation. *)
  induction 1; intros; subst.
  (* Case: JVar. *)
  { (* A variable does not reduce, so we must find a contradiction among
       our hypotheses. Here, the hypothesis that `t` is closed provides
       such a contradiction. (We could also exploit the fact that,
       according to our definition of `is_value`, a variable is a value,
       but it is preferable not to do so if we can avoid it.) *)
    false. eauto with closed. }
  (* Case: JLam. *)
  { (* A lambda-abstraction is a value. *)
    compute; eauto. }
  (* Case: JApp. *)
  { (* Apply the induction hypothesis to `t1`. If `t1` reduces, then
       obviously `App t1 t2` reduces as well, so we are finished. There
       remains to consider the case where `t1` is a value. *)
    use_ih IHjt1.
    (* Reason in the same way about `t2`. *)
    use_ih IHjt2.
    (* We wish to prove that `App t1 t2` is a beta-redex. *)
    left.
    (* Because `t1` is a closed value and has a function type,
       it must be a lambda-abstraction. *)
    forward invert_jt_TyFun. { eauto with closed. }
    (* Therefore, we have a beta-redex. *)
    subst; eexists; eapply RedBetaV; eauto. }

  { (* A Constant is a value. *)
    right; now compute. }
  { use_ih IHjt.
    edestruct (invert_jt_TyOption).
    - eapply JtSome; eassumption.
    - eauto.
    - eauto.
    - discriminate.
    - right. unpack; injections; subst.
      eauto.
  }
  {
    left.
    use_ih IHjt1.
    forward invert_jt_TyOption. { eauto with closed. }
    destruct H4; unpack; eauto with red.
  }
Qed.


(** * Exploring equality via homotopy and proof assistants - Day 2 - Equality in Coq *)
(** Note: You may use either the lab computers, or your laptop.  Coq may not be installed on the Windows computers, you should use the Macs.  If the Macs do not have CoqIDE installed, you can go to https://coq.inria.fr/coq-85, download CoqIDE_8.5beta2.dmg, open it, and run CoqIDE directly, without installing it.

  This file contains the exercises for Day 2.  Some are explicitly marked as "Homework"; the rest can be done either in class or for homework.

  When doing exercises on your own, feel free to skip around; there are some interesting puzzles near the bottom (around [J_implies_UIP]).

  If you feel like you know exactly how a proof will go, but find it painful and tedious to write out the proof terms explicitly, come find me.  Coq has a lot of support for automation and taking care of things that are easy and verbose, so you don't have to. Proving should feel like a game.  If it doesn't, I can probably help you with that.

  N.B. There are many theorem provers out there, e.g., Agda, Idris, NuPRL, Otter, Twelf, Isabelle/HOL, Mizar, Metamath *)

(** The following are placeholders; [admit] indicates that something should be filled in later. *)
Axiom admit : forall {T}, T.
Axiom admit1 : forall {T}, T.
Axiom admit2 : forall {T}, T.
Axiom admit3 : forall {T}, T.

(** ** Tautologies *)

(** We'll fill in these first few together.  Any ideas for how to to prove something like this? *)

Definition id : forall A, A -> A
  := admit.

(** We can also write the colon on a line of its own; I set up this file in this way so that I can use a large font in my presentation. *)

Definition modus_ponens
: forall P Q, (P -> Q) -> P -> Q
  := admit.

(** N.B. [A -> (B -> C)] and [A -> B -> C] are the same; [->] associates to the right. *)

Definition first_argument
: forall A B, A -> (B -> A)
  := admit.

Definition compose
: forall A B C,
    (A -> B) -> (B -> C) -> (A -> C)
  := admit.

(** We can also fill in the functions bit by bit, as follows: *)

Definition compose'
: forall A B C,
    (A -> B) -> (B -> C) -> (A -> C).
Proof.
  refine _.
  refine admit.
Defined.

(** These two are exercises to do individually or with the people sitting next to you. *)

Definition introduce_intermediate
: forall A B C,
    (A -> (B -> C))
    -> ((A -> B) -> (A -> C))
  := admit.

Definition swap_args
: forall A B C,
    (A -> B -> C) -> (B -> A -> C)
  := admit.

(** Optional Homework Problems for More Practice *)

Definition second_argument
: forall A B, A -> B -> B
  := admit.

Definition id_either
: forall A, A -> A -> A
  := admit.

Definition third_argument
: forall A B C, A -> B -> C -> C
  := admit.

(** This one is a bit different; one of the arguments has a [forall] *)
Definition explode
: forall A B F,
    (forall C, F -> C)
    -> (A -> F)
    -> (A -> B)
  := admit.

(** Challenge Homework Problems *)

(** Come ask me about disjunction and negation during TAU if you are interested in playing with these. *)

(** Prove that the Law of Excluded Middle implies Double Negation Elimination *)

Definition LEM_implies_DNE
: (forall P, P \/ ~P)
  -> (forall P, ~~P -> P)
  := admit.

(** Prove that Double Negation Elimination implies Peirce's Law *)

Definition DNE_implies_Peirce
: (forall P, ~~P -> P)
  -> (forall P Q : Prop,
        ((P -> Q) -> P) -> P)
  := admit.

(** Prove that Peirce's Law implies the Law of Excluded Middle *)

Definition Peirce_implies_LEM
: (forall P Q : Prop,
     ((P -> Q) -> P) -> P)
  -> (forall P, P \/ ~P)
  := admit.

(** ** Judgmental equality. *)

About eq_refl.
About eq.
Print eq.

(** We allow writing [refl] for [eq_refl]. *)

Notation refl := eq_refl.

(** Interesting question: Are all proofs of equality themselves equal? Keep this in the back of your mind as we define what equality is. To do this we need to define two notions of equality: judgmental, and propositional.  *)

(** Coq knows some things about equality.  If Coq judges that two things are equal (and equally trivially), then you can prove them (propositionally) equal by reflexivity, with [refl].  In this case, we say that they are also judgmentally equal.  For example: *)

(** Propositional equality is denoted as [x = y]. *)

(** Definition of judgmental equality, version 1: intuitively, [x] and [y] are judgmentally equal if there is a really stupid, trivial proof that [x = y]. *)

(** Definition of judgmental equality, version 2: [x] and [y] are judgmentally equal if (Coq says that) [refl] proves [x = y]. *)

Definition one_plus_one_equals_two
: 1 + 1 = 2
  := refl.

Definition two_plus_two_equals_four
: 2 + 2 = 4
  := refl.

Definition two_times_three_equals_six
: 2 * 3 = 6
  := refl.

(** Just so that you don't think Coq believes everything is equal: *)

Fail Definition one_does_not_equal_zero
: 1 = 0
  := refl.

(** This gives
<<
The command has indeed failed with message:
=> Error: The term "refl" has type "?30 = ?30"
    while it is expected to have type "1 = 0".
>> *)

Fail Definition addition_is_not_judgmentally_commutative
: forall x y, x + y = y + x
  := fun x y => refl.

(** You can see the "normal form" of something with [Compute]: *)

Compute 1 + 1.

Compute 2 + 2.

Compute 2 * 3.

(** Definition of judgmental equality, version 3: [x] and [y] are judgmentally equal if [Compute] gives you the same normal form for [x] and [y].  N.B.  This is equivalent to what Coq is doing internally. *)

(** Note that equality is homogeneous; the things you're comparing for equality need to already have the same type.  You can ask if a statement is valid using [Check]: *)

Check 1. (* [1] is a number (a [nat]) *)

Check 1 = 1. (* [1 = 1] is a proposition (a [Prop]) *)

Check true. (* [true] is a boolean *)

Fail Check 1 = true. (* [1] is a [nat], and so isn't comparable to [true], which is a [bool] *)

(** A note on syntax *)
Definition id'
: forall A, A -> A
  := admit.

Definition id''
: forall (A : Type), A -> A
  := admit.

Definition id'''
: forall (A : Type) (pf : A), A
  := admit.

(** Pattern matching is case analysis, on things that are defined by cases (like, [bool], [nat]).  This is a technical meaning for "pattern matching" or "case analysis", namely, "using a [match ... with ... end] statement in Coq". *)

Definition is_positive : nat -> bool
  := admit.

Definition is_zero : nat -> bool
  := admit.

Definition If_Then_Else
: forall (A : Type)
         (b : bool)
         (true_case : A)
         (false_case : A),
    A
  := admit.

(** [unit] is a type with one element. *)
Print unit.
(** But [refl] does not prove that all units are equal. *)
Fail Definition all_units_equal
: forall x y : unit, x = y
  := fun x y => refl.
(** But we can pattern match *)
Definition all_units_equal : forall x y : unit, x = y
  := admit.

(** Optional Homework for More Practice *)

(** This should send [true] to [false], and [false] to [true]. *)
Definition boolean_negation : bool -> bool
  := admit.

(** This should implement the truth table for "and":
<<
  A B │ A ∧ B
  ────┼──────
  T T │   T
  T F │   F
  F T │   F
  F F │   F
>> *)

Definition boolean_conjunction
: bool -> bool -> bool
  := admit.

(** This should implement the truth table for "or":
<<
  A B │ A ∨ B
  ────┼──────
  T T │   T
  T F │   T
  F T │   T
  F F │   F
>> *)

Definition boolean_disjunction
: bool -> bool -> bool
  := admit.

(** This should implement the truth table for "xor":
<<
  A B │ A ⊕ B
  ────┼──────
  T T │   F
  T F │   T
  F T │   T
  F F │   F
>> *)

Definition boolean_exclusive_or
: bool -> bool -> bool
  := admit.

(** This should implement the truth table for "implication":
<<
  A B │ A → B
  ────┼──────
  T T │   T
  T F │   F
  F T │   T
  F F │   T
>> *)

Definition boolean_implication
: bool -> bool -> bool
  := admit.

(** This should implement the truth table for "biconditional":
<<
  A B │ A ↔ B
  ────┼──────
  T T │   T
  T F │   F
  F T │   F
  F F │   T
>> *)

Definition boolean_biconditional
: bool -> bool -> bool
  := admit.

(** Recall: Are all proofs of equality themselves equal?  Here we define what equality is, i.e., how to use it. *)

(** We can prove the J-rule by pattern matching.  *)

(** We start off with the simpler version, called the "non-dependent" version. *)

Definition J_nondep
: forall (A : Type) (x : A) (y : A)
         (H : x = y)
         (P : A -> Type),
    P x -> P y
  := admit.

(** If you want to not always have to pass all of the arguments to [J] explicitly, you can uncomment the following lines, removing the << and >>, to make [A], [x], and [y] be inferred automatically. *)
(**
<<
Arguments J_nondep {A} {x} {y} H P _.
>> *)

(** Recall the blackboard proof of symmetry, that [x = y -> y = x]. Someone remind me how it goes. *)

(** First prove this by passing arguments to [J_nondep]. *)

Definition sym_J
: forall A (x y : A), x = y -> y = x
  := admit.

Arguments sym_J {A x y} p, A x y p.

(** Now prove this by pattern matching. *)

Definition sym
: forall A (x y : A), x = y -> y = x
  := admit.

(** We allow writing [sym p] to mean [sym _ _ _ p] *)

Arguments sym {A x y} p, A x y p.

(** First prove this by passing arguments to [J_nondep]. *)

Definition trans_J
: forall A (x y z : A),
    x = y -> y = z -> x = z
  := admit.

Arguments trans_J {A x y z} p q, A x y z p q.

(** Now prove this by pattern matching. *)

Definition trans
: forall A (x y z : A),
    x = y -> y = z -> x = z
  := admit.

Arguments trans {A x y z} p q, A x y z p q.

(** First prove this by passing arguments to [J_nondep]. *)

Definition ap_J
: forall A B (f : A -> B) (x y : A),
    x = y -> f x = f y
  := admit.

Arguments ap_J {A B} f {x y} p, {A B} f x y p, A B f x y p.

(** First prove this by pattern matching. *)

Definition ap
: forall A B (f : A -> B) (x y : A),
    x = y -> f x = f y
  := admit.

Arguments ap {A B} f {x y} p, {A B} f x y p, A B f x y p.

(** Now the version with more bells and whistles, again provable by pattern matching. *)

Definition J
: forall
    (A : Type) (x : A) (y : A)
    (H : x = y)
    (P : forall (y' : A)
                (H' : x = y'),
           Type),
    P x refl -> P y H
  := admit.

(** [J] also has a computation rule, which holds judgmentally.  We start with the rule for [J_nondep]. *)

Definition J_nondep_computes
: forall (A : Type) (x : A)
         (P : A -> Type)
         (k : P x),
    J_nondep A x x refl P k = k
  := admit.

Definition J_computes
: forall (A : Type) (x : A)
         (P : forall (y' : A) (H' : x = y'), Type)
         (k : P x refl),
    J A x x refl P k = k
  := admit.

(** If you want to not always have to pass all of the arguments to [J] explicitly, you can uncomment the following lines, removing the << and >>, to make [A], [x], and [y] be inferred automatically. *)
(**
<<
Arguments J {A} {x} {y} H P _.
Arguments J_computes {A x} P k.
Arguments J_non_computes {A x} P k.
>> *)

(** First prove this by passing arguments to [J]. *)

Definition trans_pV_J
: forall A (x y : A) (H : x = y),
    trans_J H (sym_J H) = refl
  := admit.

(** Now prove this by pattern matching. *)

Definition trans_pV : forall A (x y : A) (p : x = y),
                        trans p (sym p) = refl
  := admit.

(** Exercises to do individually, or with the people next to you. *)

(** First prove this by filling in arguments to [J] explicitly. *)

Definition sym_sym_J
: forall A (x y : A) (H : x = y),
    sym_J (sym_J H) = H
  := admit.

Arguments sym_sym_J {A x y} H, A x y H.

(** Now prove this by pattern matching. *)

Definition sym_sym
: forall A (x y : A) (H : x = y),
    sym (sym H) = H
  := admit.

Arguments sym_sym {A x y} H, A x y H.

Definition trans_1p_J
: forall A (x y : A) (H : x = y),
    trans_J refl H = H
  := admit.

Definition trans_1p
: forall A (x y : A) (H : x = y),
    trans refl H = H
  := admit.

Definition trans_p1_J
: forall A (x y : A) (H : x = y),
    trans_J H refl = H
  := admit.

Definition trans_p1
: forall A (x y : A) (H : x = y),
    trans H refl = H
  := admit.

Definition sym_refl_J
: forall A (x : A),
    sym_J (refl x) = refl x
  := admit.

Definition sym_refl
: forall A (x : A),
    sym (refl x) = refl x
  := admit.

(** Recall the informal proof from yesterday's homework, which "proved" that all proofs of [x = y] are themselves equal:

  The [J] rule says informally that if you have a proof [p] of [x = y], it suffices to assume that [y] _is_ [x] (to substitute [x] for [y] in what you are trying to prove), and to assume that [p] is [refl x] (to substitute [refl x] for [p] in what you are trying to prove).  Suppose we have a type [A], two inhabitants [x] and [y] of type [A], and two proofs [p] and [q] that [x = y].  By [J], it suffices to assume that [y] is [x], that [p] is [refl x], and hence it suffices to prove that [refl x = q], where [q] now has type [x = x].  To prove this, again by [J], it suffices to assume that [x] is [x] (it already is) and that [q] is [refl x], and hence it suffices to prove [refl x = refl x].  We can prove this by [refl (refl x)].  Thus for any proofs [p] and [q] that [x = y], we have [p = q].  Qed.

  Try to formalize this proof in Coq, and see what goes wrong.  It may help to use [refine] so that you can construct the proof sentence by sentence.  If you are having trouble figuring out how to instantiate [J] for a proof of equality [H : x = y], you can ask Coq to figure it out for you by running [destruct H.].  You can see what it did by typing [Show Proof.] afterwards. *)

Definition J_implies_UIP
: forall A (x y : A) (H0 H1 : x = y), H0 = H1.
Proof.
  refine _.
  refine admit.
Abort.

(** The rest of these are explicitly Homework; feel free to take a break now, or to keep going. *)

(** Recall from yesterday's homework that the [K] rule says: *)

Definition K_rule_type
  := forall A (x : A) (H : x = x) (P : x = x -> Type), P refl -> P H.

(** Prove that [K] implies uniqueness of identity proofs.  If you do this interactively with [refine], you may find it useful to [unfold K_rule_type in *] to see the definition of [K] in your goals window. *)

Definition K_implies_UIP
: forall (K : K_rule_type) A (x y : A) (H0 H1 : x = y), H0 = H1
  := admit.

(** Note that it's impossible to prove [K] from [J].  See if you can get any insight into this by attempting to construct a proof.

  Hint: Think about what these things (and UIP) mean in the paths interpretation of equality, and remember that _all_ of our functions are continuous. *)

Definition J_implies_K : K_rule_type
  := admit.

(** Can you write down three "different" proofs of transitivity (they should all be judgmentally different; [refl] should not prove any two of them the same. *)

Definition trans1
: forall A (x y z : A),
    x = y -> y = z -> x = z
  := admit1.
Definition trans2
: forall A (x y z : A),
    x = y -> y = z -> x = z
  := admit2.
Definition trans3
: forall A (x y z : A),
    x = y -> y = z -> x = z
  := admit3.

(** Now we have Coq check that they are not the same; these lines should compile unmodified. *)

Fail Check refl : trans1 = trans2.

Fail Check refl : trans2 = trans3.

Fail Check refl : trans1 = trans3.

(** Now prove that these are all equal (propositionally, but not judgmentally. *)

Definition trans_12
: forall A (x y z : A) (H0 : x = y) (H1 : y = z),
    trans1 A x y z H0 H1 = trans2 A x y z H0 H1
  := admit.
Definition trans_23
: forall A (x y z : A) (H0 : x = y) (H1 : y = z),
    trans2 A x y z H0 H1 = trans3 A x y z H0 H1
  := admit.

(** We can also prove associativity. *)

Definition trans_assoc
: forall A (x y z w : A) (H0 : x = y) (H1 : y = z) (H2 : z = w),
    trans H0 (trans H1 H2) = trans (trans H0 H1) H2
  := admit.

Definition trans_Vp
: forall A (x y : A) (H : x = y),
    trans (sym H) H = refl
  := admit.

Definition trans_sym
: forall A (x y z : A) (H0 : x = y) (H1 : y = z),
    sym (trans H0 H1) = trans (sym H1) (sym H0)
  := admit.

(** *** Category theory *)

(** Those of you familiar with category theory might find the following properties interesting. *)

(** All exercises in this section are optional homework. *)

(** We can look at [ap] as describing the action on morphisms (equality proofs) of any function; the type of morphisms from [x : A] to [y : A] is the type [x = y]; the action of [f : A -> B] on a morphism [m : x = y] is [ap f m : f x = f y].  We can prove the relevant functoriality properties. *)

(** Action on identity: *)

Definition ap_refl
: forall {A B} (f : A -> B) x,
    ap f (refl x) = refl (f x)
  := admit.

(** Action on composition: *)

Definition ap_trans
: forall {A B} (f : A -> B) {x y z : A}
         (H0 : x = y) (H1 : y = z),
    ap f (trans H0 H1) = trans (ap f H0) (ap f H1)
  := admit.

(** Action on inverses (additional rule for groupoids): *)

Definition ap_sym
: forall {A B} (f : A -> B) {x y : A}
         (H : x = y),
    ap f (sym H) = sym (ap f H)
  := admit.

(** Furthermore, every function that specifies the action of a natural transformation on objects is automatically natural: *)

Definition concat_Ap
: forall {A B} (f g : A -> B)
         (T : forall x, f x = g x),
    forall {x y : A} (m : x = y),
      trans (ap f m) (T y) = trans (T x) (ap g m)
  := admit.

(** *** Further exploration:

    These are completely optional, and moderately challenging.  If you are interested, here are some problems that draw interesting connections between this material and category theory.

1. Can you find and prove a statement relating [sym_sym] to [sym_trans]?

2. Can you find and prove a statement relating [sym] to [trans_assoc] and [sym_trans] via [ap]?

3. The equality relation on a type forms a weak ω-groupoid (sometimes written as a weak ∞-groupoid).  This means that there is structure at every level.  The first few levels are given by [refl], [sym], and [trans] (level 1); [sym_sym], [sym_trans], [trans_assoc], [sym_refl], [trans_1p], [trans_p1], [trans_pV], and [trans_Vp] (level 2).  The theorem statements in general are known as the Stasheff polyhedra or Stasheff associahedra.  Can you discover more of these rules? *)


Require Import
  MathClasses.interfaces.canonical_names.

(*
  The following class is nice to parametrize instances by additional properties, for example:
  [∀ z, PropHolds (z ≠ 0) → LeftCancellation op z]
  This tool is very powerful as we can combine it with instances as:
  [∀ x y, PropHolds (x ≠ 0) → PropHolds (y ≠ 0) → PropHolds (x * y ≠ 0)]
  Of course, one should be very careful not to make too many instances as that could
  easily lead to a blow-up of the search space (or worse, cycles).
*)
Class PropHolds (P : Prop) := prop_holds: P.

#[global]
Hint Extern 0 (PropHolds _) => assumption : typeclass_instances.

#[global]
Instance: Proper (iff ==> iff) PropHolds.
Proof. now repeat intro. Qed.

Ltac solve_propholds :=
  match goal with
  | [ |- PropHolds (?P) ] => apply _
  | [ |- ?P ] => change (PropHolds P); apply _
  end.


Require Export ProjectiveGeometry.Dev.rank_space_or_higher_properties.

(*****************************************************************************)
(** Proof of projective space geometry to matroid' **)

Section s_rkEquivToPsoh.

Context `{RPSOH : RankProjectiveSpaceOrHigher}.
Context `{EP : EqDecidability Point}.

(*** Definition LineInd ***)
Inductive LineInd : Type :=
| Cline : forall (A B : Point) (H: ~ A [==] B), LineInd.

Definition Line := LineInd.

(*** Definition fstP ***)
Definition fstP : Line -> Point.
intros.
elim H0.
intros.
exact A.
Defined.

(*** Definition sndP ***)
Definition sndP : Line -> Point.
intros.
elim H0.
intros.
exact B.
Defined.

(*** Definition Incid ***)
Definition Incid (A : Point)(l : Line) := rk (triple (fstP l) (sndP l) A) = 2.

Lemma incid_dec :  forall (A : Point)(l : Line), {Incid A l} + {~Incid A l}.
Proof.
intros.
unfold Incid.
exact (eq_nat_dec (rk (triple (fstP l) (sndP l) A)) 2).
Qed.

Lemma second_point : forall A : Point, exists B, ~ A [==] B.
Proof.
intro.
assert (T:= rk_lower_dim).
case_eq(eq_dec P0 A);intros.
case_eq(eq_dec P1 P0);intros.
rewrite e0 in *.
case_eq(eq_dec P2 P0);intros.
rewrite e1 in *.
case_eq(eq_dec P3 P0);intros.
rewrite e2 in *.
setoid_replace (quadruple P0 P0 P0 P0) with (singleton P0) in T by (clear_all;fsetdecide).
rewrite rk_singleton in T.
cut False.
intuition.
omega.
exists P3;rewrite <-e;intuition.
exists P2;rewrite <-e;intuition.
exists P1;rewrite <-e;intuition.
exists P0;intuition.
Qed.

Definition line_eq l m := rk (quadruple (fstP l) (sndP l) (fstP m) (sndP m)) = 2.

Lemma line_eq_refl : forall l, line_eq l l.
Proof.
intro.
induction l.
unfold line_eq, Incid.
simpl.
setoid_replace (quadruple A B A B) with (couple A B) by (clear_all;fsetdecide).
apply rk_couple1.
auto.
Qed.

Lemma line_eq_sym : forall l m, line_eq l m -> line_eq m l.
Proof.
intros.
induction l.
induction m.
unfold line_eq, Incid in *.
simpl in *.
setoid_replace (quadruple A0 B0 A B) with (quadruple A B A0 B0).
auto.
clear_all;fsetdecide.
Qed.

Lemma line_eq_trans : forall l m n, line_eq l m -> line_eq m n -> line_eq l n.
Proof.
intros.
induction l.
induction m.
induction n.
unfold line_eq, Incid in *.
simpl in *.
assert (rk (union (quadruple A B A0 B0) (quadruple A0 B0 A1 B1)) +
           rk (couple A0 B0) <=
           rk (quadruple A B A0 B0) + rk (quadruple A0 B0 A1 B1)).
apply matroid3_useful.
clear_all;fsetdecide.
assert (rk (couple A0 B0) = 2).
apply rk_couple1;auto.
assert (rk (union (quadruple A B A0 B0) (quadruple A0 B0 A1 B1)) <= 2).
omega.
apply le_antisym.
cut (rk (quadruple A B A1 B1) <= rk (union (quadruple A B A0 B0) (quadruple A0 B0 A1 B1)) ).
omega.
apply matroid2;clear H0 H1 H5 H6 H7; fsetdecide.
assert (rk (couple A1 B1) = 2).
apply rk_couple1;auto.
rewrite <- H8.
apply matroid2.
clear_all;fsetdecide.
Qed.

Lemma a1_exists : forall (A B :Point) , exists l, Incid A l /\ Incid B l.
Proof.
intros.
case_eq(eq_dec A B);intros.
elim (second_point B).
intros C H1.
exists (Cline B C H1).
unfold Incid.
simpl.
rewrite e.
setoid_replace (triple B C B) with (couple C B) by (clear_all;fsetdecide).
split.
apply rk_couple1.
solve[intuition].
apply rk_couple1.
solve[intuition].
exists (Cline A B n).
unfold Incid.
simpl.
setoid_replace (triple A B A) with (couple A B) by (clear_all;fsetdecide).
setoid_replace (triple A B B) with (couple A B) by (clear_all;fsetdecide).
split.
apply rk_couple1.
solve[intuition].
apply rk_couple1.
solve[intuition].
Qed.

Lemma uniqueness : forall (A B : Point)(l1 l2 : Line),
   Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> A [==] B \/ line_eq l1 l2.
Proof.
intros A B l1 l2.
case_eq(eq_dec A B);intros.
solve[intuition].
induction l1.
induction l2.
intros.
right.
unfold Incid, line_eq in *.
simpl in *.
assert (rk (couple A0 B0) = 2).
apply rk_couple1;assumption.
assert (rk (couple A1 B1) = 2).
apply rk_couple1;assumption.
assert (rk (couple A B) = 2).
apply rk_couple1;assumption.

assert (rk (quadruple A0 B0 A B) = 2).
apply le_antisym.
assert (rk (union (triple A0 B0 A) (triple A0 B0 B)) + rk (couple A0 B0) <=
           rk (triple A0 B0 A) + rk (triple A0 B0 B)).
apply (matroid3_useful (triple A0 B0 A) (triple A0 B0 B) (couple A0 B0)).
clear_all;fsetdecide.
setoid_replace (union (triple A0 B0 A) (triple A0 B0 B)) with (quadruple A0 B0 A B) in H10.
omega.
clear_all;fsetdecide.
rewrite <- H1.
apply matroid2.
clear_all;fsetdecide.

assert (rk (quadruple A1 B1 A B) = 2).
apply le_antisym.
assert (rk (union (triple A1 B1 A) (triple A1 B1 B)) + rk (couple A1 B1) <=
           rk (triple A1 B1 A) + rk (triple A1 B1 B)).
apply (matroid3_useful (triple A1 B1 A) (triple A1 B1 B) (couple A1 B1)).
clear_all;fsetdecide.
setoid_replace (union (triple A1 B1 A) (triple A1 B1 B)) with (quadruple A1 B1 A B) in H11.
omega.
clear_all;fsetdecide.
rewrite <- H3.
apply matroid2.
clear_all;fsetdecide.

assert (rk (union (quadruple A0 B0 A B) (quadruple A1 B1 A B)) +
           rk (couple A B) <=
           rk (quadruple A0 B0 A B) + rk (quadruple A1 B1 A B)).
apply (matroid3_useful (quadruple A0 B0 A B) (quadruple A1 B1 A B) (couple A B)).
clear_all;fsetdecide.
assert (rk (union (quadruple A0 B0 A B) (quadruple A1 B1 A B)) <= 2).
omega.
apply le_antisym.
assert (rk (quadruple A0 B0 A1 B1) <= rk (union (quadruple A0 B0 A B) (quadruple A1 B1 A B))).
apply matroid2.
clear_all;fsetdecide.
omega.
rewrite <- H7.
apply matroid2.
clear_all;fsetdecide.
Qed.

(* A2 Pasch *)

Lemma a2 : forall A B C D : Point, forall lAB lCD lAC lBD : Line,
~ A [==] B /\ ~ A [==] C /\ ~ A [==] D /\
~ B [==] C /\ ~ B [==] D /\ ~ C [==] D ->
Incid A lAB /\ Incid B lAB ->
Incid C lCD /\ Incid D lCD ->
Incid A lAC /\ Incid C lAC ->
Incid B lBD /\ Incid D lBD ->
(exists I : Point, (Incid I lAB /\ Incid I lCD)) -> exists J : Point, (Incid J lAC /\ Incid J lBD).
Proof.
intros.
induction lAB.
induction lCD.
induction lAC.
induction lBD.
unfold Incid in *.
simpl in *.
decompose [and] H1; clear H1.
decompose [and] H2; clear H2.
decompose [and] H3; clear H3.
decompose [and] H4; clear H4.
elim H5;clear H5.
intro P.
intros.
decompose [and] H4;clear H4.
assert (HC:rk (quadruple A B C D) >= 3 \/ rk (quadruple A B C D) < 3).
omega.
elim HC;intro HABCD;clear HC.

apply (rk_pasch A2 B2 A3 B3).

assert(rk (union (singleton P) (quadruple A0 B0 A1 B1)) <= 3).
apply (intersecting_lines_rank_3 A0 B0 A1 B1 P);omega.
assert (rk (quadruple A0 B0 A1 B1) <= 3).
cut (rk (quadruple A0 B0 A1 B1) <=  rk (union (singleton P) (quadruple A0 B0 A1 B1))).
omega.
apply matroid2; (clear_all; fsetdecide).

assert (rk (couple A0 B0) = 2).
apply rk_couple1;auto.
assert (rk (couple A1 B1) = 2).
apply rk_couple1;auto.
assert (rk (couple A2 B2) = 2).
apply rk_couple1;auto.
assert (rk (couple A3 B3) = 2).
apply rk_couple1;auto.

assert (rk (union (quadruple A0 B0 A1 B1) (triple A0 B0 A)) + rk (couple A0 B0) <=
           rk (quadruple A0 B0 A1 B1) + rk (triple A0 B0 A)).
apply (matroid3_useful (quadruple A0 B0 A1 B1) (triple A0 B0 A) (couple A0 B0)).
(clear_all; fsetdecide).

assert (rk (union (quadruple A0 B0 A1 B1) (triple A0 B0 A))  <= 3).
omega.
assert (rk
         (union (union (quadruple A0 B0 A1 B1) (triple A0 B0 A))
            (triple A1 B1 C)) + rk (couple A1 B1) <=
       rk (union (quadruple A0 B0 A1 B1) (triple A0 B0 A)) +
       rk (triple A1 B1 C)).
apply (matroid3_useful (union (quadruple A0 B0 A1 B1) (triple A0 B0 A))
 (triple A1 B1 C) (couple A1 B1)).
(clear_all; fsetdecide).
assert (rk
        (union (union (quadruple A0 B0 A1 B1) (triple A0 B0 A))
           (triple A1 B1 C)) <= 3).
omega.
setoid_replace (union (union (quadruple A0 B0 A1 B1) (triple A0 B0 A))
           (triple A1 B1 C)) with (union (quadruple A0 B0 A1 B1) (couple A C)) in H24 by (clear_all; fsetdecide).
assert (rk
         (union (union (quadruple A0 B0 A1 B1) (couple A C)) (triple A0 B0 B)) +
       rk (couple A0 B0) <=
       rk (union (quadruple A0 B0 A1 B1) (couple A C)) +
       rk (triple A0 B0 B)).
apply (matroid3_useful (union (quadruple A0 B0 A1 B1) (couple A C))
(triple A0 B0 B) (couple A0 B0)).
(clear_all; fsetdecide).
assert ( rk
        (union (union (quadruple A0 B0 A1 B1) (couple A C)) (triple A0 B0 B)) <= 3).
omega.
assert (rk
         (union
            (union (union (quadruple A0 B0 A1 B1) (couple A C))
               (triple A0 B0 B)) (triple A1 B1 D)) + rk (couple A1 B1) <=
       rk
         (union (union (quadruple A0 B0 A1 B1) (couple A C)) (triple A0 B0 B)) +
       rk (triple A1 B1 D)).
apply (matroid3_useful  (union (union (quadruple A0 B0 A1 B1) (couple A C)) (triple A0 B0 B))
(triple A1 B1 D) (couple A1 B1)).
(clear_all; fsetdecide).
assert ( rk
        (union
           (union (union (quadruple A0 B0 A1 B1) (couple A C))
              (triple A0 B0 B)) (triple A1 B1 D)) <= 3).
omega.
assert (rk (quadruple A B C D) <= 3).
cut (rk (quadruple A B C D) <= rk
        (union
           (union (union (quadruple A0 B0 A1 B1) (couple A C))
              (triple A0 B0 B)) (triple A1 B1 D)) ).
omega.
apply matroid2.
(clear_all; fsetdecide).
assert (rk (quadruple A B C D) = 3).
omega.

assert (rk (quadruple A2 B2 A C) = 2).
apply rk_lemma_1;auto.
assert (rk (quadruple A3 B3 B D) = 2).
apply rk_lemma_1;auto.

decompose [and] H0.
assert (rk (couple A C) =2).
apply rk_couple1;auto.
assert (rk (couple A D) =2).
apply rk_couple1;auto.
assert (rk (couple B C) =2).
apply rk_couple1;auto.
assert (rk (couple B D) =2).
apply rk_couple1;auto.

assert (rk (union (quadruple A2 B2 A C) (quadruple A B C D)) +
            rk (couple A C) <=
           rk (quadruple A2 B2 A C) + rk (quadruple A B C D)).
apply (matroid3_useful (quadruple A2 B2 A C) (quadruple A B C D) (couple A C)).
(clear_all; fsetdecide).
assert (rk (union (quadruple A2 B2 A C) (quadruple A B C D)) <= 3).
omega.
assert (rk (union (quadruple A3 B3 B D) (quadruple A B C D)) +
            rk (couple B D) <=
           rk (quadruple A3 B3 B D) + rk (quadruple A B C D)).
apply (matroid3_useful (quadruple A3 B3 B D) (quadruple A B C D) (couple B D)).
(clear_all; fsetdecide).
assert ( rk (union (quadruple A3 B3 B D) (quadruple A B C D))  <= 3).
omega.
assert (rk
         (union (union (quadruple A2 B2 A C) (quadruple A B C D))
            (union (quadruple A3 B3 B D) (quadruple A B C D))) +
       rk (quadruple A B C D) <=
       rk (union (quadruple A2 B2 A C) (quadruple A B C D)) +
       rk (union (quadruple A3 B3 B D) (quadruple A B C D))).
apply (matroid3_useful (union (quadruple A2 B2 A C) (quadruple A B C D))).
(clear_all; fsetdecide).
assert (rk
        (union (union (quadruple A2 B2 A C) (quadruple A B C D))
           (union (quadruple A3 B3 B D) (quadruple A B C D))) <= 3).
omega.
cut (rk (quadruple A2 B2 A3 B3) <=  rk
        (union (union (quadruple A2 B2 A C) (quadruple A B C D))
           (union (quadruple A3 B3 B D) (quadruple A B C D)))).
omega.
apply matroid2.
(clear_all; fsetdecide).

exists A2.
split.
setoid_replace (triple A2  B2 A2) with (couple A2 B2) by (clear_all; fsetdecide).
apply rk_couple1;auto.
assert (rk (quadruple A B C D) = 2).
apply le_antisym.
omega.
decompose [and] H0.
assert (rk (couple A B) =2).
apply rk_couple1;intuition.
rewrite <- H20.
apply matroid2.
(clear_all; fsetdecide).

assert (rk (couple A0 B0) = 2).
apply rk_couple1;auto.
assert (rk (couple A1 B1) = 2).
apply rk_couple1;auto.
assert (rk (couple A2 B2) = 2).
apply rk_couple1;auto.
assert (rk (couple A3 B3) = 2).
apply rk_couple1;auto.

assert (rk (quadruple A2 B2 A C) = 2).
apply rk_lemma_1;auto.
assert (rk (quadruple A3 B3 B D) = 2).
apply rk_lemma_1;auto.

decompose [and] H0.
assert (rk (couple A C) =2).
apply rk_couple1;auto.
assert (rk (couple A D) =2).
apply rk_couple1;auto.
assert (rk (couple B C) =2).
apply rk_couple1;auto.
assert (rk (couple B D) =2).
apply rk_couple1;auto.

assert (rk (union (quadruple A3 B3 B D) (quadruple A B C D)) +
       rk (couple B D) <=
       rk (quadruple A3 B3 B D) + rk (quadruple A B C D)).
apply (matroid3_useful (quadruple A3 B3 B D) (quadruple A B C D) (couple B D)).
(clear_all; fsetdecide).
assert ( rk (union (quadruple A3 B3 B D) (quadruple A B C D)) <= 2).
omega.

assert (rk
         (union (union (quadruple A3 B3 B D) (quadruple A B C D))
            (quadruple A2 B2 A C)) + rk (couple A C) <=
       rk (union (quadruple A3 B3 B D) (quadruple A B C D)) +
       rk (quadruple A2 B2 A C)).
apply matroid3_useful.
(clear_all; fsetdecide).
assert ( rk
        (union (union (quadruple A3 B3 B D) (quadruple A B C D))
           (quadruple A2 B2 A C)) <= 2).
omega.
apply le_antisym.
cut (rk (triple A3 B3 A2)  <=  rk
        (union (union (quadruple A3 B3 B D) (quadruple A B C D))
           (quadruple A2 B2 A C))).
omega.
apply matroid2.
(clear_all; fsetdecide).
rewrite <- H19.
apply matroid2.
(clear_all; fsetdecide).
Qed.

(* A3 : dimension-related axioms *)

Lemma a3_1 :
forall l : Line, exists A : Point, exists B : Point, exists C : Point,
~ A [==] B /\ ~ A [==] C /\ ~ B [==] C /\ Incid A l /\ Incid B l /\ Incid C l.
Proof.
intros.
induction l.
exists A.
exists B.
elim (rk_three_points A B).
intro C.
intros.
exists C.
unfold Incid.
simpl.
setoid_replace (triple A B A) with (couple A B).
setoid_replace (triple A B B) with (couple A B).
assert (rk (couple A B) = 2).
apply rk_couple1;auto.
intuition.
rewrite H3 in H5.
apply couple_rk1 in H5;intuition.
rewrite H3 in H4.
apply couple_rk1 in H4;intuition.
apply triple_couple_1.
assumption.
apply triple_couple_4.
assumption.
Qed.

Lemma a3_2 (* dim >= 3 *) : exists l1, exists l2, forall p, ~(Incid p l1 /\ Incid p l2).
Proof.
exists (Cline P0 P1 base_points_distinct_1).
exists (Cline P2 P3 base_points_distinct_2).
intros.
unfold Incid.
simpl.
unfold not;intro.
destruct H0.
assert (rk (union (triple P0 P1 p) (triple P2 P3 p)) + rk (singleton p) <=
           rk (triple P0 P1 p) + rk (triple P2 P3 p)).
apply matroid3_useful.
(clear_all; fsetdecide).
rewrite rk_singleton in H2.
assert (rk (union (triple P0 P1 p) (triple P2 P3 p)) <= 3).
omega.
clear H0.
assert (rk (quadruple P0 P1 P2 P3) <= 3).
cut (rk (quadruple P0 P1 P2 P3) <= rk (union (triple P0 P1 p) (triple P2 P3 p)) ).
omega.
apply matroid2.
(clear_all; fsetdecide).
assert (T:= rk_lower_dim).
omega.
Qed.

End s_rkEquivToPsoh.


Require Import rt.util.all.
Require Import rt.model.basic.task rt.model.basic.job rt.model.basic.schedule
               rt.model.basic.priority rt.model.basic.workload.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module Interference.

  Import Schedule ScheduleOfSporadicTask Priority Workload.

  Section PossibleInterferingTasks.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Section FP.

      (* Assume an FP policy. *)
      Variable higher_eq_priority: FP_policy sporadic_task.

      (* Under constrained deadlines, tsk_other can only interfere with tsk
         if it's a different task with higher or equal priority. *)
      Definition fp_can_interfere_with (tsk tsk_other: sporadic_task) :=
        higher_eq_priority tsk_other tsk && (tsk_other != tsk).

    End FP.

    Section JLFP.

      (* Under JLFP/JLDP policies, any two different tasks can interfere with
         each other. *)
      Definition jldp_can_interfere_with (tsk tsk_other: sporadic_task) :=
        tsk_other != tsk.

    End JLFP.

  End PossibleInterferingTasks.

  Section InterferenceDefs.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Assume any job arrival sequence...*)
    Context {arr_seq: arrival_sequence Job}.

    (* ... and any schedule. *)
    Context {num_cpus: nat}.
    Variable sched: schedule num_cpus arr_seq.

    (* Consider any job j that incurs interference. *)
    Variable j: JobIn arr_seq.

    (* Recall the definition of backlogged (pending and not scheduled). *)
    Let job_is_backlogged (t: time) :=
      backlogged job_cost sched j t.

    Section TotalInterference.

      (* First, we define the total interference incurred by job j during [t1, t2)
         as the cumulative time in which j is backlogged in this interval. *)
      Definition total_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2) job_is_backlogged t.

    End TotalInterference.

    Section JobInterference.

      (* Let job_other be a job that interferes with j. *)
      Variable job_other: JobIn arr_seq.

      (* We define the total interference caused by job_other during [t1, t2) as the
         cumulative service received by job_other while j is backlogged. *)
      Definition job_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t && scheduled_on sched job_other cpu t).

    End JobInterference.

    Section TaskInterference.

      (* In order to define task interference, consider any interfering task tsk_other. *)
      Variable tsk_other: sporadic_task.

      (* We define the total interference caused by tsk during [t1, t2) as
         the cumulative service received by tsk while j is backlogged. *)
      Definition task_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t &&
            task_scheduled_on job_task sched tsk_other cpu t).

    End TaskInterference.

    Section TaskInterferenceJobList.

      Variable tsk_other: sporadic_task.

      Definition task_interference_joblist (t1 t2: time) :=
        \sum_(j <- jobs_scheduled_between sched t1 t2 | job_task j == tsk_other)
         job_interference j t1 t2.

    End TaskInterferenceJobList.

    Section BasicLemmas.

      (* Interference cannot be larger than the considered time window. *)
      Lemma total_interference_le_delta :
        forall t1 t2,
          total_interference t1 t2 <= t2 - t1.
      Proof.
        unfold total_interference; intros t1 t2.
        apply leq_trans with (n := \sum_(t1 <= t < t2) 1);
          first by apply leq_sum; ins; apply leq_b1.
        by rewrite big_const_nat iter_addn mul1n addn0 leqnn.
      Qed.

      Lemma job_interference_le_service :
        forall j_other t1 t2,
          job_interference j_other t1 t2 <= service_during sched j_other t1 t2.
      Proof.
        intros j_other t1 t2; unfold job_interference, service_during.
        apply leq_sum; intros t _.
        unfold service_at; rewrite [\sum_(_ < _ | scheduled_on _ _ _  _)_]big_mkcond.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        by destruct (scheduled_on sched j_other cpu t).
      Qed.

      Lemma task_interference_le_workload :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= workload job_task sched tsk t1 t2.
      Proof.
        unfold task_interference, workload; intros tsk t1 t2.
        apply leq_sum; intros t _.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        unfold task_scheduled_on, service_of_task.
        by destruct (sched cpu t).
      Qed.

    End BasicLemmas.

    Section InterferenceSequentialJobs.

      (* If jobs are sequential, ... *)
      Hypothesis H_sequential_jobs: sequential_jobs sched.

      (* ... then the interference incurred by a job in an interval
         of length delta is at most delta. *)
      Lemma job_interference_le_delta :
        forall j_other t1 delta,
          job_interference j_other t1 (t1 + delta) <= delta.
      Proof.
        rename H_sequential_jobs into SEQ.
        unfold job_interference, sequential_jobs in *.
        intros j_other t1 delta.
        apply leq_trans with (n := \sum_(t1 <= t < t1 + delta) 1);
          last by rewrite big_const_nat iter_addn mul1n addn0 addKn leqnn.
        apply leq_sum; intros t _.
        destruct ([exists cpu, scheduled_on sched j_other cpu t]) eqn:EX.
        {
          move: EX => /existsP [cpu SCHED].
          rewrite (bigD1 cpu) // /=.
          rewrite big_mkcond (eq_bigr (fun x => 0)) /=;
            first by simpl_sum_const; rewrite leq_b1.
          intros cpu' _; des_if_goal; last by done.
          destruct (scheduled_on sched j_other cpu' t) eqn:SCHED'; last by rewrite andbF.
          move: SCHED SCHED' => /eqP SCHED /eqP SCHED'.
          by specialize (SEQ j_other t cpu cpu' SCHED SCHED'); rewrite SEQ in Heq.
        }
        {
          apply negbT in EX; rewrite negb_exists in EX.
          move: EX => /forallP EX.
          rewrite (eq_bigr (fun x => 0)); first by simpl_sum_const.
          by intros cpu _; specialize (EX cpu); apply negbTE in EX; rewrite EX andbF.
        }
      Qed.

    End InterferenceSequentialJobs.

    (* The sequential per-job interference bounds the actual interference. *)
    Section BoundUsingPerJobInterference.

      Lemma interference_le_interference_joblist :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= task_interference_joblist tsk t1 t2.
      Proof.
        intros tsk t1 t2.
        unfold task_interference, task_interference_joblist, job_interference, job_is_backlogged.
        rewrite [\sum_(_ <- _ sched _ _ | _) _]exchange_big /=.
        rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
        apply leq_sum; move => t /andP [LEt _].
        rewrite exchange_big /=.
        apply leq_sum; intros cpu _.
        destruct (backlogged job_cost sched j t) eqn:BACK;
          last by rewrite andFb (eq_bigr (fun x => 0));
            first by rewrite big_const_seq iter_addn mul0n addn0.
        rewrite andTb.
        destruct (task_scheduled_on job_task sched tsk cpu t) eqn:SCHED; last by done.
        unfold scheduled_on, task_scheduled_on in *.
        destruct (sched cpu t) as [j' |] eqn:SOME; last by done.
        rewrite big_mkcond /= (bigD1_seq j') /=; last by apply undup_uniq.
        {
          by rewrite SCHED eq_refl.
        }
        {
          unfold jobs_scheduled_between.
          rewrite mem_undup; apply mem_bigcat_nat with (j := t);
            first by done.
          apply mem_bigcat_ord with (j := cpu); first by apply ltn_ord.
          by unfold make_sequence; rewrite SOME mem_seq1 eq_refl.
        }
      Qed.

    End BoundUsingPerJobInterference.

  End InterferenceDefs.

End Interference.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e256m88x2e240m1_4limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.abstract_algebra MathClasses.theory.rings.

Class RingCongruence A (R : relation A) `{Ring A} :=
  { ring_congr_equivalence : Equivalence R
  ; ring_congr_subrelation : subrelation (=) R
  ; ring_congr_plus : Proper (R ==> R ==> R) (+)
  ; ring_congr_mult : Proper (R ==> R ==> R) (.*.)
  ; ring_congr_negate : Proper (R ==> R) (-)}.

(*
As far as I see, there are three ways to represent the quotient ring:
- Define the congruence as a new Equiv instance. This leads to ambiguity.
- Wrap it into a definition and define a ring structure on top of it.
     Definition Quotient A (R : relation A) := A.
   However, in order to avoid ambiguity we have to make it Opaque for
   type class resolution.
- Wrap it into an inductive and define a ring structure on top of it.
The latter makes the clearest distinction between the original structure
and the quotient. Unfortunately, it is sometimes a bit verbose.
*)
Inductive Quotient A (R : relation A) := quotient_inject : Cast A (Quotient A R).
Existing Instance quotient_inject.
Arguments quotient_inject {A R} _.

Instance quotient_rep {A R} : Cast (Quotient A R) A := λ x,
  match x with quotient_inject r => r end.

Section quotient_ring.
  Context `{cong : RingCongruence A R}.
  Add Ring A : (rings.stdlib_ring_theory A).

  Existing Instance ring_congr_equivalence.

  Global Instance quotient_equiv: Equiv (Quotient A R) := λ x y, R ('x) ('y).
  Global Instance quotient_0: Zero (Quotient A R) := cast A (Quotient A R) 0.
  Global Instance quotient_1: One (Quotient A R) := cast A (Quotient A R) 1.
  Global Instance quotient_plus: Plus (Quotient A R) := λ x y, cast A (Quotient A R) ('x + 'y).
  Global Instance quotient_mult: Mult (Quotient A R) := λ x y, cast A (Quotient A R) ('x * 'y).
  Global Instance quotient_negate: Negate (Quotient A R) := λ x, cast A (Quotient A R) (-'x).

  Instance: Setoid (Quotient A R).
  Proof.
    constructor; unfold equiv, quotient_equiv.
      intros [x]. reflexivity.
     intros [x] [y] E. now symmetry.
    intros [x] [y] [z] E1 E2. now transitivity y.
  Qed.

  Instance: Proper ((=) ==> (=) ==> (=)) quotient_plus.
  Proof. intros [?] [?] E1 [?] [?] E2. now rapply ring_congr_plus. Qed.

  Instance: Proper ((=) ==> (=) ==> (=)) quotient_mult.
  Proof. intros [?] [?] E1 [?] [?] E2. now rapply ring_congr_mult. Qed.

  Instance: Proper ((=) ==> (=)) quotient_negate.
  Proof. intros [?] [?] E. now rapply ring_congr_negate. Qed.

  Global Instance: Setoid_Morphism quotient_inject.
  Proof. split; try apply _. intros ?? E. now rapply ring_congr_subrelation. Qed.

  Global Instance: Ring (Quotient A R).
  Proof.
    repeat (constructor; try apply _); repeat intros [?];
      unfold mult, plus, sg_op, mon_unit, one_is_mon_unit, zero_is_mon_unit, plus_is_sg_op, mult_is_sg_op,
      quotient_0, negate, quotient_negate, quotient_1, quotient_plus, quotient_mult, cast in *; simpl; apply sm_proper; ring.
  Qed.
End quotient_ring.


Require Import Relations.
Load LTS.

Section Bisimulations.
Variable T : LTS.
Variable R : relation T.
(* Usual definition of strong bisimulation *)
Definition sbsim_rel : Prop := forall (m : wlabel), sym_diagram R (trans m) (trans m) R.

(* Usual definition of weak bisimulation *)
Definition bsim_rel : Prop := forall (m : wlabel), sym_diagram R (trans m) (whtrans m) R.

End Bisimulations.

Arguments sbsim_rel [_] _.
Arguments bsim_rel [_] _.

Section Bisimilarities.
Variable T : LTS.

(* Strong bisimilarity as the largest strong bisimulation relation *)
Definition sbsim (x y : T) := exists (R : relation T), R x y /\ sbsim_rel R.
(* Weak bisimilarity as the largest weak bisimulation relation *)
Definition bsim (x y : T)  := exists (R : relation T), R x y /\ bsim_rel R.

(* Some very basic properties of weak bisimilarity*)
Lemma bsim_diag : forall x y, bsim x y -> forall (m : wlabel) x', (x [m] x' -> exists y', (y [* m *] y' /\ bsim x' y')).
intros x y b m x' h.
destruct b as [R b].
destruct b as [r b].
destruct (b m) as [d d'].
destruct (d x y x' r h) as [y' h'].
exists y'. split; [apply h'|].
exists R; split; [apply h'|assumption].
Qed.

Lemma bsim_diag2 : forall x y, bsim x y -> forall (m : wlabel) y', (y [m] y' -> exists x', (x [* m *] x' /\ bsim x' y')).
intros x y b m y' h.
destruct b as [R b].
destruct b as [r b].
destruct (b m) as [d d'].
destruct (d' y x y' r h) as [x' h'].
exists x'. split; [apply h'|].
exists R; split; [apply h'|assumption].
Qed.

Lemma bsim_bsim: bsim_rel bsim.
intro m; split; intros x y z b t; [eapply bsim_diag|eapply bsim_diag2]; eassumption.
Qed.

End Bisimilarities.

Arguments bsim [_] _ _.
Arguments sbsim [_] _ _.

Infix "~~" := bsim (at level 10).

(* More properties of weak bisimilarity (reflexivity, symmetry, transitivity) *)
Section bsim_prop.
Variable T:LTS.

Lemma sym_rel : forall (R : relation T), bsim_rel R <-> bsim_rel (transp T R).
intro R. split; intros h m; destruct h with m as [h' h'']; split; assumption.
Qed.

Lemma sym_bsim : forall (x y : T), x ~~ y <-> y ~~ x.
intros x y. split; intros h; destruct h as [R h]; destruct h as [h h']; exists (transp T R);
  split; try (apply sym_rel); unfold transp; assumption.
Qed.

Lemma refl_bsim : forall x : T, x ~~ x.
assert (bsim_rel (fun (x y : T) => x = y)).
+ intros m. split; intros x y z eq tr; exists z; split; try trivial; induction m; simpl; subst.
- apply rt_step. trivial.
- exists y; split; [apply rt_refl|exists z; split; [|apply rt_refl] ]; trivial.
- apply rt_step. unfold transp in eq. subst;  trivial.
- exists y. unfold transp in eq; subst. split; [apply rt_refl| exists z; split; [|apply rt_refl] ]; trivial.
- unfold transp; trivial.
- unfold transp; trivial.
+ intro x. exists (fun x y : T => x = y). auto.
Qed.

Lemma bsim_diag_wttransl : forall (R : relation T), bsim_rel R -> diagram R (fun (x y :T) => wttrans x y) (fun (x y :T) => wttrans x y) R.
intros R br.
destruct (br t) as [diag rdiag]; simpl in *. unfold wttrans in *.
eapply equiv_diag. apply rel_eq_eq. apply rel_eq_eq. apply rel_eq_fun.  apply trans_refl_trans_refl_eq2.
apply rel_eq_eq. apply (diag_comp_rt T R (trans t) (clos_refl_trans T (trans t)) diag).
Qed.

Lemma bsim_diag_wttransr : forall (R : relation T), bsim_rel R -> rev_diagram R (fun (x y :T) => wttrans x y) (fun (x y :T) => wttrans x y) R.
intros R br.
destruct (br t) as [diag rdiag]; simpl in *. unfold wttrans in *.
unfold rev_diagram. apply bsim_diag_wttransl. apply (sym_rel R). apply br.
Qed.

Lemma comp_tau_weak : forall m, rel_eq T (wtrans m) (rel_comp T (wtrans m) (fun x y:T => x >*y)).
intros m. intros x y . split; intros tr.
+ exists y. split; [apply tr|apply rt_refl].
+ destruct tr as [x'' s]; destruct s as [tr ttr'].
  destruct tr as [x' s]. destruct s as [ttr s].
  destruct s as [z s]. destruct s as [tr' ttr''].
  exists x'. split; [apply ttr|].
  exists z. split; [apply tr'|].
  apply trans_trans_refl_eq2.
  apply t_trans with x''; apply t_step; assumption.
Qed.

Lemma comp_tau_weak2 : forall m, rel_eq T (rel_comp T (fun x y:T => x >*y) (wtrans m)) (wtrans m).
intros m. intros x y . split; intros tr.
+ destruct tr as [x'' s]; destruct s as [ttr' tr].
  destruct tr as [x' s]. destruct s as [ttr s].
  destruct s as [z s]. destruct s as [tr' ttr''].
  exists x'. split; [|].
  -   apply trans_trans_refl_eq2.   apply t_trans with x''; apply t_step; assumption.
  - exists z. split; [apply tr'|]. assumption.
+ exists x. split; [apply rt_refl|assumption].
Qed.

Lemma bsim_diag_weakl : forall (R : relation T) a, bsim_rel R -> diagram R (wtrans (l a)) (wtrans (l a)) R.
intros R a br.
eapply equiv_diag with R _ (rel_comp T (fun x y:T=> x>*y) (wtrans (l a))) R; try apply rel_eq_eq.
  - apply comp_tau_weak2.
  - apply diag_compose with R.
    * apply bsim_diag_wttransl. apply br.
    * eapply equiv_diag with R _ (rel_comp T (wtrans (l a)) (fun x y:T => x>*y)) R; try apply rel_eq_eq.
      + apply rel_eq_sym. apply comp_tau_weak.
      + apply diag_compose with R. apply br. apply bsim_diag_wttransl. apply br.
Qed.

Lemma bsim_diag_hweakl : forall (R : relation T) m, bsim_rel R -> diagram R (whtrans m) (whtrans m) R.
intros R m br. induction m.
+ simpl. apply bsim_diag_wttransl. apply br.
+ simpl. apply bsim_diag_weakl. apply br.
Qed.

Lemma bsim_diag_weak : forall (x y : T) x' m, x ~~ y -> x [*m*] x' -> exists y', y [*m*] y' /\ x' ~~ y'.
intros x y x' m b tr.
+ edestruct bsim_diag_hweakl.
  - apply bsim_bsim.
  - apply b.
  - apply tr.
  - exists x0. assumption.
Qed.

Lemma bsim_rel_trans : forall R R': relation T, bsim_rel R -> bsim_rel R' -> bsim_rel (rel_comp T R R').
intros R R' br br' m. split.
+ intros x y z rc tr.
  destruct rc as [w s]; destruct s as [r r'].
  destruct br with m as [d _]. destruct d with x w z as [w' s]; try assumption.
  destruct s as [trw rw].
  destruct bsim_diag_hweakl with R' m w y w' as [y' s]; try assumption.
  destruct s as [try r'y'].
  exists y'. split; [assumption| exists w'] ; split; assumption.
+ intros x y z rc tr.
  unfold transp in rc.
  destruct rc as [w s]; destruct s as [r r'].
  destruct br' with m as [_ d]. destruct d with x w z as [w' s]; try assumption.
  destruct s as [trw rw].
  destruct bsim_diag_hweakl with (transp T R) m w y w' as [y' s]; try assumption; try apply sym_rel; try assumption.
  destruct s as [try r'y'].
  exists y'. split; [assumption| exists w'] ; split; assumption.
Qed.

Lemma bsim_trans: forall (x y z : T), x ~~ y -> y ~~ z -> x ~~ z.
intros x y z h h'.
destruct h as [R s]; destruct h' as [R' s'].
exists (rel_comp T R R').
split; [|apply bsim_rel_trans; [apply s|apply s'] ].
exists y. split; [apply s| apply s'].
Qed.

End bsim_prop.

(* transitive closures of relations and relations over functions (for autonomous transitions and operators) *)

Lemma rel_fall : forall (A : Type) (R: relation A) (f g : A -> A),
clos_refl_trans (A -> A) (fun h h' => forall (x : A), R (h x) (h' x)) f g -> forall x, (clos_refl_trans A R) (f x) (g x).
intros.
induction H.
constructor. apply H.
apply rt_refl.
eapply rt_trans;
eassumption.
Qed.

Arguments sym_rel [_] _.
Arguments sym_bsim [_] _ _.

Lemma clos_refl_trans_one_or : forall (A : Type) (R : relation A) (x y : A), clos_refl_trans A R x y
-> (x = y) \/ (exists z, R x z /\ clos_refl_trans A R z y).
intros A R x y h.
induction h as [ x y r| | ].
+ right. exists y. split; [assumption|apply rt_refl].
+ left; trivial.
+ destruct IHh1; subst; [destruct IHh2; subst|].
  - left; trivial.
  - right. apply H.
  - destruct H as [z' h].
    right. exists z'. split; [apply h|].
    eapply rt_trans. apply h. apply h2.
Qed.


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

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1.
Proof.
  intros x y.
  unfold not.
  unfold "<=".
  intro h.
  destruct (Rtotal_order x y) as [ hxy | [ heq | hyx ] ].
  {
    exfalso.
    apply h.
    left.
    exact hxy.
  }
  {
    exfalso.
    apply h.
    right.
    exact heq.
  }
  { exact hyx. }
Qed.


(** This file implements finite as unordered lists without duplicates.
Although this implementation is slow, it is very useful as decidable equality
is the only constraint on the carrier set. *)
From stdpp Require Export sets list.
From stdpp Require Import options.

Record listset_nodup A := ListsetNoDup {
  listset_nodup_car : list A; listset_nodup_prf : NoDup listset_nodup_car
}.
Arguments ListsetNoDup {_} _ _ : assert.
Arguments listset_nodup_car {_} _ : assert.
Arguments listset_nodup_prf {_} _ : assert.

Section list_set.
Context `{EqDecision A}.
Notation C := (listset_nodup A).

Global Instance listset_nodup_elem_of: ElemOf A C := λ x l, x ∈ listset_nodup_car l.
Global Instance listset_nodup_empty: Empty C := ListsetNoDup [] (@NoDup_nil_2 _).
Global Instance listset_nodup_singleton: Singleton A C := λ x,
  ListsetNoDup [x] (NoDup_singleton x).
Global Instance listset_nodup_union: Union C :=
  λ '(ListsetNoDup l Hl) '(ListsetNoDup k Hk),
    ListsetNoDup _ (NoDup_list_union _ _ Hl Hk).
Global Instance listset_nodup_intersection: Intersection C :=
  λ '(ListsetNoDup l Hl) '(ListsetNoDup k Hk),
    ListsetNoDup _ (NoDup_list_intersection _ k Hl).
Global Instance listset_nodup_difference: Difference C :=
  λ '(ListsetNoDup l Hl) '(ListsetNoDup k Hk),
    ListsetNoDup _ (NoDup_list_difference _ k Hl).

Instance listset_nodup_set: Set_ A C.
Proof.
  split; [split | | ].
  - by apply not_elem_of_nil.
  - by apply elem_of_list_singleton.
  - intros [??] [??] ?. apply elem_of_list_union.
  - intros [??] [??] ?. apply elem_of_list_intersection.
  - intros [??] [??] ?. apply elem_of_list_difference.
Qed.

Global Instance listset_nodup_elems: Elements A C := listset_nodup_car.
Global Instance listset_nodup_fin_set: FinSet A C.
Proof. split; [apply _|done|]. by intros [??]. Qed.
End list_set.


(* Based on "\u03b1\u03b2-Relations and the Actual Meaning of \u03b1-Renaming" by Michele Basaldella (2021) *)

Require Import Coq.Program.Equality.

Parameter Name : Type.

Parameter Name_eq_dec : forall (a b : Name), {a = b} + {a <> b}.

Inductive Expr : Type :=
| Var : Name -> Expr
| App : Expr -> Expr -> Expr
| Lam : Name -> Expr -> Expr.

Lemma Expr_eq_dec : forall (a b : Expr), {a = b} + {a <> b}.
Proof. decide equality; apply Name_eq_dec. Defined.

(* Inductive Cofinite : Type := *)

Inductive Beta : Expr -> Expr -> Type :=
| Beta_refl : forall e, Beta e e
| Beta_sym  : forall e1 e2, Beta e1 e2 -> Beta e2 e1
| Beta_trans : forall e1 e2 e3, Beta e1 e2 -> Beta e2 e3 -> Beta e1 e3
| Beta_Lam : forall x a b, Beta (Lam x a) (Lam x b)
| Beta_App : forall a b c d, Beta a b -> Beta c d -> Beta (App a c) (App b d)

| Beta_id : forall x d, Beta (App (Lam x (Var x)) d) d
| Beta_const : forall x y d, x <> y -> Beta (App (Lam x (Var y)) d) (Var y)
| Beta_App_distr : forall x a b d,
    Beta (App (Lam x (App a b)) d)
         (App (App (Lam x a) d) (App (Lam x b) d))
| Beta_dup : forall x a d, Beta (App (Lam x (Lam x a)) d) (Lam x a)
| Beta_Lam_swap : forall x y a d,
    x <> y ->
    Beta (App (Lam y d) (Var x)) d ->
    Beta (App (Lam x (Lam y a)) d)
         (Lam y (App (Lam x a) d)).

Definition Beta_rel (R : Expr -> Expr -> Type) :=
  forall a b,
    Beta a b -> R a b.

Definition Inconsistent_Beta : Expr -> Expr -> Type := fun _ _ => True.

Lemma Inconsistent_Beta_rel : Beta_rel Inconsistent_Beta.
Proof. easy. Defined.

Inductive Subst : Expr -> Name -> Expr -> Expr -> Type :=
| Subst_id : forall d x, Subst d x (Var x) d
| Subst_const : forall d x y, x <> y -> Subst d x (Var y) (Var y)
| Subst_App : forall d x a b rA rB,
    Subst d x a rA ->
    Subst d x b rB ->
    Subst d x (App a b) (App rA rB)
| Subst_Lam1 : forall d x a, Subst d x (Lam x a) (Lam x a)
| Subst_Lam2 : forall d x y a r,
    x <> y ->
    Subst (Var x) y d d ->
    Subst d x a r ->
    Subst d x (Lam y a) r.

Lemma Subst_unique : forall {e d x e' e''},
  Subst d x e e' ->
  Subst d x e e'' ->
  e' = e''.
Proof.
  intro e.
  induction e; intros.
  - case_eq (Name_eq_dec x n); intros.
    + subst.
      inversion X0; inversion X; subst; easy.
    + inversion X0; inversion X; subst; easy.
  - inversion X0; inversion X; subst.
    pose (P := IHe1 d x rA0 rA X3 X1).
    pose (Q := IHe2 d x rB0 rB X4 X2).
    rewrite P. rewrite Q. reflexivity.
  - inversion X0; inversion X; subst; try easy.
    apply (IHe _ _ _ _ X4). assumption.
Defined.

Lemma Subst_dec : forall d x e e',
  ( Subst d x e e' ) + ( notT (Subst d x e e') ).
Proof.
  intros.

  assert (A1 : forall q r, App q r <> q).
    induction q; intros; try easy.
    intro. injection H; intros. subst.
    pose (Q1 := IHq1 q2). easy.

  assert (A2 : forall q r, App r q <> q).
    induction q; intros; try easy.
    intro. injection H; intros. subst.
    pose (Q1 := IHq2 q1). easy.

  induction e.
  - case_eq (Name_eq_dec x n); intros.

    + subst.
      case_eq (Expr_eq_dec e' d); intros.
      * subst. left. constructor.
      * right. intro X. inversion X; subst; easy.

    + case_eq (Expr_eq_dec e' (Var n)); intros.
      * subst. left. constructor. assumption.
      * right. intro X. inversion X; subst; easy.

  - induction IHe1, IHe2.
    + right. intro X. inversion X; subst.
      pose (P := Subst_unique s X1).
      apply (A2 rB rA). assumption.

    + right. intro X. inversion X; subst.
      pose (P := Subst_unique a X0).

      apply (A1 rA rB). assumption.

    + right. intro X. inversion X; subst.
      pose (P := Subst_unique s X1).
      apply (A2 rB rA). assumption.

    + clear b n. induction e'.
      * right. easy.
      * destruct IHe'1, IHe'2.
        right. intro X.
        inversion X; subst.
        pose (P := Subst_unique X s0).
        pose (Q := A2 e'2 e'1). easy.

        right. intro X.
        inversion X; subst.

Fixpoint Subst_exists d x e {struct e} :
  { e' & Subst d x e e' }.
Proof.
  intros.

  induction e.

  - case_eq (Name_eq_dec x n); intros.
    + subst.
      exists d. constructor.
    + exists (Var n). constructor. assumption.

  - destruct IHe1. destruct IHe2.
    exists (App x0 x1).
    constructor; assumption.

  - destruct IHe.
    case_eq (Name_eq_dec x n); intros.
    + subst.
      exists (Lam n e).
      constructor.

    + exists x0. constructor. assumption.
      destruct (Subst_exists (Var x) n d).


Require Import Basics.
Require Import Types.
Require Import Pointed.
Require Import Spaces.Int.
Require Import Algebra.Group.
Require Import Algebra.AbelianGroup.
Require Import Homotopy.HomotopyGroup.
Require Import HIT.Circle.
Require Import HIT.Spheres.
Require Import Truncations.
Require Import Algebra.Z.
Require Import Truncations.
Import TrM.

(* Calculation of Pi 1 S1 *)

Section Pi1S1.
  Context `{Univalence}.

  Local Notation "( A , a )" := (Build_pType A a).

(*   Local Infix "≅" := GroupIsomorphism (at level 20).
  Local Notation "'π'" := HomotopyGroup (at level 0).
  Local Infix "×" := group_prod (at level 5).
 *)
  Local Open Scope int_scope.
  Local Open Scope pointed_scope.

  Theorem Pi1Circle : GroupIsomorphism (Pi 1 (S1, base)) Z.
  Proof.
    (** We give the isomorphism backwards, so we check the operation is preserved coming from the integer side. *)
    symmetry.
    serapply Build_GroupIsomorphism'.
    { equiv_via (base = base).
      2: exact (equiv_tr 0 (loops (S1, base))).
      symmetry.
      exact equiv_loopS1_int. }
    intros a b.
    cbn; apply ap.
    apply loopexp_add.
  Defined.

  Theorem Pi1S1 : GroupIsomorphism (Pi 1 (psphere 1)) Z.
  Proof.
    etransitivity.
    2: apply Pi1Circle.
    apply groupiso_pi_functor.
    apply pequiv_pSph1_to_S1.
  Defined.

End Pi1S1.


Require Import Undecidability.Synthetic.DecidabilityFacts Undecidability.Synthetic.EnumerabilityFacts Undecidability.Shared.partial Undecidability.Shared.embed_nat Undecidability.Synthetic.FinitenessFacts.
Require Import List Lia.
Export EmbedNatNotations.

(** ** Semi-decidability  *)

Lemma semi_decidable_part_iff {X} {p : X -> Prop} {Part : partiality}:
  semi_decidable p <-> exists Y (f : X -> part Y), forall x, p x <-> exists y, f x =! y.
Proof.
  split.
  - intros [f Hf].
    exists nat, (fun x => mu_tot (f x)). intros x.
    rewrite (Hf x). split; intros [n H].
    + eapply mu_tot_ter in H as [y H]. eauto.
    + eapply mu_tot_hasvalue in H as [H _]. eauto.
  - intros (Y & f & Hf). exists (fun x n => if seval (f x) n is Some _ then true else false).
    intros x. rewrite Hf. split.
    + intros [y H]. eapply seval_hasvalue in H as [n H].
      exists n. now rewrite H.
    + intros [n H]. destruct seval eqn:E; inversion H.
      eexists. eapply seval_hasvalue. eauto.
Qed.

Lemma forall_neg_exists_iff (f : nat -> bool) :
  (forall n, f n = false) <-> ~ exists n, f n = true.
Proof.
  split.
  - intros H [n Hn]. rewrite H in Hn. congruence.
  - intros H n. destruct (f n) eqn:E; try reflexivity.
    destruct H. eauto.
Qed.

Lemma semi_decider_co_semi_decider {X} (p : X -> Prop) f :
  semi_decider f p -> co_semi_decider f (complement p).
Proof.
  intros Hf.
  red in Hf. unfold complement. intros x. rewrite Hf.
  now rewrite forall_neg_exists_iff.
Qed.

Lemma semi_decidable_co_semi_decidable {X} (p : X -> Prop) :
  semi_decidable p -> co_semi_decidable (complement p).
Proof.
  intros [f Hf]. eapply ex_intro, semi_decider_co_semi_decider, Hf.
Qed.

Lemma co_semi_decidable_stable :
  forall X (p : X -> Prop), co_semi_decidable p -> stable p.
Proof.
  intros X p [f Hf] x Hx.
  eapply Hf. eapply forall_neg_exists_iff. red in Hf. rewrite Hf, forall_neg_exists_iff in Hx.
  tauto.
Qed.

Lemma decider_semi_decider  {X} {p : X -> Prop} f :
  decider f p -> semi_decider (fun x n => f x) p.
Proof.
  intros H x.
  unfold decider, reflects in H.
  rewrite H. now firstorder; econstructor.
Qed.

Lemma decider_co_semi_decider {X} {p : X -> Prop} f :
  decider f p -> co_semi_decider (fun x n => negb (f x)) p.
Proof.
  intros H x.
  unfold decider, reflects in H.
  rewrite H. split.
  - now intros -> _.
  - intros H0. destruct (f x); cbn in *; now try rewrite (H0 0).
Qed.

Lemma decidable_semi_decidable {X} {p : X -> Prop} :
  decidable p -> semi_decidable p.
Proof.
  intros [f H]. eapply ex_intro, decider_semi_decider, H.
Qed.

Lemma decidable_compl_semi_decidable {X} {p : X -> Prop} :
  decidable p -> semi_decidable (complement p).
Proof.
  intros H.
  now eapply decidable_semi_decidable, decidable_complement.
Qed.

Lemma decidable_co_semi_decidable {X} {p : X -> Prop} :
  decidable p -> co_semi_decidable p.
Proof.
  intros [f H]. eapply ex_intro, decider_co_semi_decider, H.
Qed.

Lemma semi_decidable_projection_iff X (p : X -> Prop) :
  semi_decidable p <-> exists (q : nat * X -> Prop), decidable q /\ forall x, p x <-> exists n, q (n, x).
Proof.
  split.
  - intros [d Hd].
    exists (fun '(n, x) => d x n = true). split.
    + exists (fun '(n,x) => d x n). intros [n x]. firstorder congruence.
    + intros x. eapply Hd.
  - intros (q & [f Hf] & Hq).
    exists (fun x n => f (n, x)). unfold semi_decider, decider, reflects in *.
    intros x. rewrite Hq. now setoid_rewrite Hf.
Qed.

Lemma semi_decider_and {X} {p q : X -> Prop} f g :
  semi_decider f p -> semi_decider g q -> semi_decider (fun x n => andb (existsb (f x) (seq 0 n)) (existsb (g x) (seq 0 n))) (fun x => p x /\ q x).
Proof.
  intros Hf Hg x.
  red in Hf, Hg |- *. rewrite Hf, Hg.
  setoid_rewrite Bool.andb_true_iff.
  setoid_rewrite existsb_exists.
  repeat setoid_rewrite in_seq. cbn.
  clear.
  split.
  - intros [[n1 Hn1] [n2 Hn2]].
    exists (1 + n1 + n2). firstorder lia.
  - firstorder.
Qed.

Lemma semi_decidable_and {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> semi_decidable (fun x => p x /\ q x).
Proof.
  intros [f Hf] [g Hg]. eapply ex_intro, semi_decider_and; eauto.
Qed.

Lemma reflects_cases {P} {b} :
  reflects b P -> b = true /\ P \/ b = false /\ ~ P.
Proof.
  destruct b; firstorder congruence.
Qed.

Lemma semi_decider_or {X} {p q : X -> Prop} f g :
  semi_decider f p -> semi_decider g q -> semi_decider (fun x n => orb (f x n) (g x n)) (fun x => p x \/ q x).
Proof.
  intros Hf Hg.
  red in Hf, Hg |- *. intros x.
  rewrite Hf, Hg.
  setoid_rewrite Bool.orb_true_iff.
  clear. firstorder.
Qed.

Lemma semi_decidable_or {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> semi_decidable (fun x => p x \/ q x).
Proof.
  intros [f Hf] [g Hg]. eapply ex_intro, semi_decider_or; eauto.
Qed.

Lemma semi_decidable_ex {X} {p : nat -> X -> Prop} :
  semi_decidable (fun pa => p (fst pa) (snd pa)) -> semi_decidable (fun x => exists n, p n x).
Proof.
  intros [f Hf].
  eapply semi_decidable_projection_iff.
  exists (fun '(n,x) => (fun! ⟨n1,n2⟩ => f (n1, x) n2 = true) n).
  split.
  - eapply dec_decidable. intros (n, x).
    destruct unembed. exact _.
  - intros x. setoid_rewrite (Hf (_, x)).
    split.
    + intros (n1 & n2 & H). exists ⟨n1, n2⟩. now rewrite embedP.
    + intros (n & H). destruct unembed as [n1 n2].
      exists n1, n2. eauto.
Qed.

Lemma co_semi_decider_and {X} {p q : X -> Prop} f g :
  co_semi_decider f p -> co_semi_decider g q -> co_semi_decider (fun x n => orb (f x n) (g x n)) (fun x => p x /\ q x).
Proof.
  intros Hf Hg x. red in Hf, Hg. rewrite Hf, Hg.
  setoid_rewrite Bool.orb_false_iff.
  clear. firstorder.
Qed.

Lemma co_semi_decidable_and {X} {p q : X -> Prop} :
  co_semi_decidable p -> co_semi_decidable q -> co_semi_decidable (fun x => p x /\ q x).
Proof.
  intros [f Hf] [g Hg]. eapply ex_intro, co_semi_decider_and; eauto.
Qed.

Lemma semi_decider_AC X g (R : X -> nat -> Prop) :
  semi_decider g (uncurry R) ->
  (forall x, exists y, R x y) ->
  ∑ f : X -> nat, forall x, R x (f x).
Proof.
  intros Hg Htot'. red in Hg. unfold uncurry in *.
  pose (R' x := fun! ⟨n,m⟩ => g (x,n) m = true).
  assert (Htot : forall x, exists n, R' x n). {
    subst R'. intros x. destruct (Htot' x) as (n & [m H] % (Hg (_, _))).
    exists ⟨n,m⟩. now rewrite embedP.
  }
  assert (Hdec : decider (fun '(x, nm) => let (n, m) := unembed nm in g (x, n) m) (uncurry R')). {
    unfold R'. unfold uncurry. intros (x, nm). destruct (unembed nm) as (n, m).
    destruct g; firstorder congruence.
  }
  eapply (decider_AC _ _ _ Hdec) in Htot as [f' Hf'].
  exists (fun x => (fun! ⟨n, m⟩ => n) (f' x)).
  intros x. subst R'. specialize (Hf' x). cbn in Hf'.
  destruct (unembed (f' x)). eapply (Hg (_, _)). eauto.
Qed.

(* Lemma sdec_compute_lor {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> (forall x, p x \/ q x) -> exists f : X -> bool, forall x, if f x then p x else q x.
Proof.
  intros [f_p Hp] [f_q Hq] Ho.
  unshelve eexists.
  - refine (fun x => let (n, H) := mu_nat (P := fun n => orb (f_p x n) (f_q x n) = true) (ltac:(cbn; decide equality)) _ in f_p x n).
    destruct (Ho x) as [[n H] % Hp | [n H] % Hq].
    + exists n. now rewrite H.
    + exists n. rewrite H. now destruct f_p.
  - intros x. cbn -[mu_nat]. destruct mu_nat.
    specialize (Hp x). specialize (Hq x).
    destruct (f_p) eqn:E1. eapply Hp. eauto.
    destruct (f_q) eqn:E2. eapply Hq. eauto.
    inversion e.
Qed.

 *)

(* ** Other  *)

Lemma d_semi_decidable_impl {X} {p q : X -> Prop} :
  decidable p -> semi_decidable q -> semi_decidable (fun x => p x -> q x).
Proof.
  intros [f Hf] [g Hg].
  exists (fun x n => if f x then g x n else true).
  intros x. split.
  - intros H. destruct (reflects_cases (Hf x)) as [ [-> H2] | [-> H2] ].
    + firstorder.
    + now exists 0.
  - intros [n H]. revert H.
    destruct (reflects_cases (Hf x)) as [ [-> H2] | [-> H2]]; intros H.
    + firstorder.
    + firstorder.
Qed.

Lemma d_co_semi_decidable_impl {X} {p q : X -> Prop} :
  decidable p -> semi_decidable (complement q) -> semi_decidable (complement (fun x => p x -> q x)).
Proof.
  intros [f Hf] [g Hg].
  exists (fun x n => if f x then g x n else false).
  intros x. split.
  - intros H. destruct (reflects_cases (Hf x)) as [ [-> H2] | [-> H2] ].
    + red in H. firstorder.
    + firstorder.
  - intros [n H]. revert H.
    destruct (reflects_cases (Hf x)) as [ [-> H2] | [-> H2]]; intros H.
    + firstorder.
    + firstorder congruence.
Qed.

Lemma co_semi_decidable_impl {X} {p q : X -> Prop} :
  (* (forall x, ~~ p x -> p x) -> *)
  semi_decidable (complement (complement p)) -> decidable q -> semi_decidable (complement (fun x => p x -> q x)).
Proof.
  intros [f Hf] [g Hg].
  exists (fun x n => if g x then false else f x n).
  intros x. split.
  - intros H. destruct (reflects_cases (Hg x)) as [ [-> H2] | [-> H2] ].
    + firstorder.
    + eapply Hf. firstorder.
  - intros [n H]. revert H.
    destruct (reflects_cases (Hg x)) as [ [-> H2] | [-> H2]]; intros H.
    + congruence.
    + intros ?. firstorder.
Qed.

Lemma semi_decidable_impl {X} {p q : X -> Prop} :
  semi_decidable (complement p) -> decidable q -> semi_decidable (fun x => p x -> q x).
Proof.
  intros [f Hf] [g Hg].
  exists (fun x n => if g x then true else f x n).
  intros x. split.
  - intros H. destruct (reflects_cases (Hg x)) as [ [-> H2] | [-> H2] ].
    + now exists 0.
    + eapply Hf. firstorder.
  - intros [n H]. revert H.
    destruct (reflects_cases (Hg x)) as [ [-> H2] | [-> H2]]; intros H.
    + eauto.
    + intros. firstorder.
Qed.

Lemma enumerable_semi_decidable {X} {p : X -> Prop} :
  discrete X -> enumerable p -> semi_decidable p.
Proof.
  unfold enumerable, enumerator.
  intros [d Hd] [f Hf].
  exists (fun x n => if f n is Some y then d (x,y) else false).
  intros x. rewrite Hf. split.
  - intros [n Hn]. exists n.
    rewrite Hn. now eapply Hd.
  - intros [n Hn]. exists n.
    destruct (f n); inversion Hn.
    eapply Hd in Hn. now subst.
Qed.

Lemma semi_decider_enumerator {X} {p : X -> Prop} e f :
  enumeratorᵗ e X -> semi_decider f p ->
  enumerator (fun! ⟨n,m⟩ => if e n is Some x then if f x m then Some x else None else None) p.
Proof.
  intros He Hf x. rewrite (Hf x). split.
  - intros [n Hn]. destruct (He x) as [m Hm].
    exists (embed (m,n)). now rewrite embedP, Hm, Hn.
  - intros [mn Hmn]. destruct (unembed mn) as (m, n).
    destruct (e m) as [x'|]; try congruence.
    destruct (f x' n) eqn:E; inversion Hmn. subst.
    exists n. exact E.
Qed.

Lemma semi_decidable_enumerable {X} {p : X -> Prop} :
  enumerableᵗ X -> semi_decidable p -> enumerable p.
Proof.
  unfold semi_decidable, semi_decider.
  intros [e He] [f Hf].
  now eapply ex_intro, semi_decider_enumerator.
Qed.


Require Import List.

Fixpoint tl_error (A : Type) (l : list A) : option (list A) :=
  match l with
    | nil => None
    | _ :: l' => Some l'
  end
.

Theorem tl_error_is_correct :
  forall (A : Type) (x : A) (lst : list A),
  (tl_error A (nil : list A) = None) /\ (tl_error A (x :: lst) = Some lst).
Proof.
  intros.
  refine (conj _ _).
    simpl.
    reflexivity.

    simpl.
    reflexivity.
Qed.