(* Boxed Polyhedra *)

Require Import Libs.
Require Import Errors.
Require Import Polyhedra.
Require Import Loops.
Require Import Memory.
Require Import ArithClasses.
Require Import Permutation.
Require Import Sorted.
Open Scope string_scope.
(*Set Implicit Arguments.*)
Open Scope nat_scope.

(* set the n-th parameter to 1, and the rest to 0 *)
Program Definition nth_param_at_1 depth nbr_global_parameters n
  : ZVector (depth + nbr_global_parameters) :=
  let aux :=
    (* the function will be used only in the case where n <
       nbr_global_parameters. But it is a pain to pass the prove as an argument,
       so we "build" it locally. This is not a problem because this
       function is only used in specification (no performance
       constraint) *)
    if lt_dec n nbr_global_parameters then
      ((V0 n) +++ (1%Z ::: V0 (nbr_global_parameters - S n)) <:: Vector nbr_global_parameters)
    else
    (* wrong usage. It might be "cleaner" to return an option type,
       but more painful too*)
      (V0 nbr_global_parameters) in
  V0 depth +++ aux.
Next Obligation.
  omega.
Qed.

Lemma nth_param_at_1_correct_0: forall depth nbr_global_parameters n p,
  n < nbr_global_parameters -> p <> (depth + n) ->
  Vnth (nth_param_at_1 depth nbr_global_parameters n) p = 0%Z.
Proof.
  intros * INF DIFF.
  unfold nth_param_at_1.
  destruct (lt_dec n nbr_global_parameters); [|omegaContradiction].

  destruct (lt_dec p depth); simpl_vect; auto.
  Case "depth <= p".
    replace p with (depth + (p - depth)) in *; [|omega].
    simpl_vect.
    remember (p-depth) as p' in *. clear Heqp'.
    destruct (lt_eq_lt_dec p' n) as [[|]|]; try omegaContradiction; simpl_vect; auto.
    SCase "n < p".
      replace p' with (n + S (p' - n - 1)) by omega.
      simpl_vect; auto.
Qed.

Lemma nth_param_at_1_correct_1: forall depth nbr_global_parameters n,
  n < nbr_global_parameters ->
  Vnth (nth_param_at_1 depth nbr_global_parameters n) (depth + n) = 1%Z.
Proof.
  intros *  INF.
  unfold nth_param_at_1.
  destruct (lt_dec n nbr_global_parameters); [|omegaContradiction].
  simpl_vect.
  clear INF l.
  remember (nbr_global_parameters - S n) as m. clear Heqm.
  unfold_vect. simpl.
  induction' n as [|n]; auto.
Qed.

(* a constraint that only says the n th param must be equal to x *)

Definition constraint_nth_param depth nbr_global_parameters n x:=
  {| constr_vect := nth_param_at_1 depth nbr_global_parameters n;
     constr_comp := EQ;
     constr_val := x|}.

(* move to lib *)

(* if a vector satisfies the constraint, its nth param has value x *)
Lemma satisfies_constraint_nth_param_1:
  forall depth nbr_global_parameters n (INF: n< nbr_global_parameters) x v,
  satisfy_constraint v (constraint_nth_param depth nbr_global_parameters n x) ->
  Vnth (Vdrop_p depth v) n = x.
Proof.
  intros * INF * SATISF.

  unfold satisfy_constraint, constraint_nth_param, nth_param_at_1 in *. simpl in *.
  rewrite <- (Vapp_take_drop _ _ v) in SATISF.
  simpl_vect in *.

  remember (Vdrop_p depth v) as v'. clear Heqv'.
  clear v.

  destruct (lt_dec n nbr_global_parameters); try contradiction.

  assert ((n + (S (nbr_global_parameters - S n)) = nbr_global_parameters)%nat) by omega.
  dest_vects.  simpl_vect in *. simpl in *.
  subst.

  clear INF.
  revert dependent v'.
  induction' n as [|n']; simpl in *; intros.
  Case "O".
    destruct v'.
    simpl in *; omega.
    rewrite PVprod_repeat_0.
    simpl.
    destruct z; omega.

  Case "S n'".
    destruct v'.
    simpl in *; omega.
    simpl. apply IHn'; auto.
    simpl in *. omega.
Qed.

(* if the n-th param is x, then the vector statifies the constraint *)
Lemma satisfies_constraint_nth_param_2: forall depth nbr_global_parameters n (INF: n < nbr_global_parameters) x v,
  Vnth (Vdrop_p depth v) n = x ->
  satisfy_constraint v (constraint_nth_param depth nbr_global_parameters n x).
Proof.
  intros * INF * ACCESS.

  unfold satisfy_constraint, constraint_nth_param, nth_param_at_1 in *. simpl in *.
  rewrite <- (Vapp_take_drop _ _ v). simpl_vect.

  remember (Vdrop_p depth v) as v'. clear Heqv'.
  clear v.

  destruct (lt_dec n nbr_global_parameters);[|contradiction].

(*  assert ((n + (S (nbr_global_parameters - S n)) = nbr_global_parameters)%nat) by omega.*)

  dest_vects; simpl_vect in *; simpl in *. clear l.

  remember ((nbr_global_parameters - S n)%nat) as m. clear Heqm. subst.

  revert dependent v'.
  induction' n as [|n]; intros.
  Case "O".
    simpl in *.
    destruct v'; simpl in *; auto.
    rewrite PVprod_repeat_0. destruct z; omega.

  Case "S n".
    simpl.
    destruct v'; simpl in *; auto.
    apply IHn. omega.
Qed.

(* all numbers strictly smaller than len *)
Fixpoint sequence_lesser len : list nat :=
  match len with
    | O => []
    | S len' => len' :: sequence_lesser len'
  end.

(*Notation "pol1 ∩ pol2" := (inter_poly pol1 pol2) (at level 65).*)

Definition poly_containing_params_aux {nbr_global_parameters: nat} depth
  (params: ZVector nbr_global_parameters)
   : nat -> Constraint (depth + nbr_global_parameters) :=
  fun p =>
    constraint_nth_param depth nbr_global_parameters p
    (Vnth params p).

(* the polyhedron containing all vectors v of size depth + nbr_global_parameters
   such that drop_v depth v = params *)

Definition poly_containing_params {nbr_global_parameters depth: nat}
  (params: ZVector nbr_global_parameters):
  Polyhedron (depth + nbr_global_parameters) :=
  map (poly_containing_params_aux depth params)
  (sequence_lesser nbr_global_parameters).

(* please note that those functions have pretty bad complexity, but
   are not meant to be executed. Closure containing them might be
   created at run time but (if I did nothing wrong :)) should never be
   run *)

Lemma map_sequence_lesser_forall_1: forall B (f: nat -> B) P n,
  list_forall P (map f (sequence_lesser n)) ->
  forall m, m < n -> P (f m).
Proof.
  intros *.
  induction' n as [|n]; intros.
  Case "O".
    omegaContradiction.

  Case "S n".
  simpl in *. inv H.
  dest m == n.
    SCase "m = n".
    subst. auto.
    SCase "m <> n".
    apply IHn; auto. omega.
Qed.

Lemma map_sequence_lesser_forall_2: forall B (f: nat -> B) (P: B -> Prop) n,
  (forall m, m < n -> P (f m)) ->
  list_forall P (map f (sequence_lesser n)).
Proof.
  intros *.
  induction' n as [|n]; intros FORALL.
  Case "O".
    simpl. constructor.

  Case "S n".
  simpl. constructor.
  apply FORALL. omega.
  apply IHn. intros. apply FORALL. omega.
Qed.

Lemma poly_containing_params_list_forall_1 {nbr_global_parameters depth: nat}
  (params: ZVector nbr_global_parameters) P:
  list_forall P (poly_containing_params params) ->
  forall x (INF: (x < nbr_global_parameters)%nat),
    P (poly_containing_params_aux depth params x).
Proof.
  intros. eapply (map_sequence_lesser_forall_1 _ _ P); eauto.
Qed.

Lemma poly_containing_params_list_forall_2 {nbr_global_parameters depth: nat}
  (params: ZVector nbr_global_parameters) (P: _ -> Prop):
  (forall x (INF: (x < nbr_global_parameters)%nat),
    P (poly_containing_params_aux depth params x)) ->
  list_forall P (poly_containing_params params).
Proof.
  intros. eapply (map_sequence_lesser_forall_2 _ _ P); eauto.
Qed.

(* correctness of poly_containing_params *)
Lemma poly_containing_params_drop_1 {nbr_global_parameters depth: nat}
  (params: ZVector nbr_global_parameters) (v: ZVector (depth + nbr_global_parameters)):
  v ∈ poly_containing_params params -> Vdrop_p depth v = params.
Proof.
  intros IN.
  apply Vnth_inj.
  intros.
  apply (satisfies_constraint_nth_param_1 _ _ _ H).
  unfold Pol_In, poly_containing_params, poly_containing_params_aux in IN.
  eapply map_sequence_lesser_forall_1 in IN; eauto.
Qed.

Lemma poly_containing_params_drop_2 {nbr_global_parameters depth: nat}
  (params: ZVector nbr_global_parameters) (v: ZVector (depth + nbr_global_parameters)):
  Vdrop_p depth v = params -> v ∈ poly_containing_params params.
Proof.
  intros EQ.
  unfold Pol_In, poly_containing_params, poly_containing_params_aux in *.
  apply map_sequence_lesser_forall_2.
  intros. apply satisfies_constraint_nth_param_2; auto.
  subst. reflexivity.
Qed.

(* the important definition *)

(* add to a polyhedron pol the extra constraint that the nbr_global_parameters
   last elements of the vector are equal to params by taking the
   intersection with poly_containing_params*)

Definition constrain_params {nbr_global_parameters depth: nat}
  (params: ZVector nbr_global_parameters)
  (pol: Polyhedron (depth + nbr_global_parameters)):
  Polyhedron (depth + nbr_global_parameters) :=
  poly_containing_params params ∩ pol.

(* any vector in pol that ends with params is in constain_params *)
Lemma in_pol_in_constrain_params: forall (nbr_global_parameters depth: nat)
  (params: ZVector nbr_global_parameters) (pol: Polyhedron (depth + nbr_global_parameters)) v,
  (v +++ params) ∈ pol -> (v +++ params) ∈ (constrain_params params pol).
Proof.
  intros * IN.
  unfold constrain_params.
  apply Pol_Included_intersertion; auto.
  apply poly_containing_params_drop_2.
  apply Vdrop_p_app.
Qed.

Lemma in_pol_in_constrain_params_Vdrop:  forall (nbr_global_parameters depth: nat)
  (params: ZVector nbr_global_parameters) (pol: Polyhedron (depth + nbr_global_parameters)) v,
  v ∈ pol -> Vdrop_p depth v = params -> v ∈ (constrain_params params pol).
Proof.
  intros * IN DROP.
  unfold constrain_params. apply Pol_Included_intersertion; auto.
  apply poly_containing_params_drop_2. apply DROP.
Qed.

Lemma in_constrain_param_in_pol: forall (nbr_global_parameters depth: nat)
  (params: ZVector nbr_global_parameters) (pol: Polyhedron (depth + nbr_global_parameters)),
  (constrain_params params pol) ⊂ pol.
Proof.
  intros.
  unfold constrain_params in *.
  apply Pol_intersection_Included_r.
Qed.

Lemma in_constrain_param_suffix: forall (nbr_global_parameters depth: nat)
  (params: ZVector nbr_global_parameters) (pol: Polyhedron (depth + nbr_global_parameters)) v,
  v ∈ (constrain_params params pol) ->
  exists prefix, v = prefix +++ params.
Proof.
  intros.
  exists (Vtake_p depth v).
  rewrite <- (Vapp_take_drop _ _ v) at 1.
  f_equal; auto.
  apply poly_containing_params_drop_1.
  unfold constrain_params in H.
  apply Pol_intersection_Included_l in H. auto.
Qed.

(* a boxed Polyhedron is a Polyhedron such that when the params are
   fixed, it contains a finite number of elements. Those elements are
   available through the bp_elts function. (in fact, only the prefix
   of length depth is returned, the "real" elements can be obtained by
   concatenation with the params) *)

Record Boxed_Polyhedron nbr_global_parameters depth := mk_Boxed_Polyhedron
  { bp_poly: Polyhedron (depth + nbr_global_parameters);
    bp_elts: forall params: ZVector nbr_global_parameters, list (ZVector depth);

    (* each element is returned only once *)
    bp_elts_NoDup: forall params, NoDup (bp_elts params);

    (* all the elements and only the elements are returned *)
    bp_in_elts_in_poly: forall (vect: ZVector depth) params,
      In vect (bp_elts params) ->
      (vect+++params) ∈ bp_poly;
    bp_in_poly_in_elts: forall (vect: ZVector (depth + nbr_global_parameters)) params,
      vect ∈ (constrain_params params bp_poly) ->
      In (Vtake_p depth vect) (bp_elts params)}.

Implicit Arguments bp_poly [[nbr_global_parameters] [depth]].
Implicit Arguments bp_elts [[nbr_global_parameters] [depth]].

Lemma bp_in_elts_in_poly_constrain (nbr_global_parameters depth : nat)
  (b : Boxed_Polyhedron nbr_global_parameters depth)
  (vect : ZVector depth) (params : ZVector nbr_global_parameters):
  In vect (bp_elts b params) ->
  (vect+++params) ∈ (constrain_params params b.(bp_poly)).
Proof.
  intros.
  unfold constrain_params.
  apply Pol_Included_intersertion.
  apply poly_containing_params_drop_2. simpl_vect. reflexivity.
  apply bp_in_elts_in_poly. auto.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_angletrichotomy.
Require Export GeoCoq.Elements.OriginalProofs.proposition_18.
Require Export GeoCoq.Elements.OriginalProofs.lemma_trichotomy1.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_19 :
   forall A B C,
   Triangle A B C -> LtA B C A A B C ->
   Lt A B A C.
Proof.
intros.
assert (nCol A B C) by (conclude_def Triangle ).
assert (nCol B C A) by (forward_using lemma_NCorder).
assert (nCol A C B) by (forward_using lemma_NCorder).
assert (~ Cong A C A B).
 {
 intro.
 assert (Cong A B A C) by (conclude lemma_congruencesymmetric).
 assert (isosceles A B C) by (conclude_def isosceles ).
 assert (CongA A B C A C B) by (conclude proposition_05).
 assert (CongA A C B A B C) by (conclude lemma_equalanglessymmetric).
 assert (CongA B C A A C B) by (conclude lemma_ABCequalsCBA).
 assert (CongA B C A A B C) by (conclude lemma_equalanglestransitive).
 assert (LtA B C A B C A) by (conclude lemma_angleorderrespectscongruence).
 assert (~ LtA B C A B C A) by (conclude lemma_angletrichotomy).
 contradict.
 }
assert (~ Lt A C A B).
 {
 intro.
 assert (Triangle A C B) by (conclude_def Triangle ).
 assert (LtA C B A A C B) by (conclude proposition_18).
 assert (CongA A B C C B A) by (conclude lemma_ABCequalsCBA).
 assert (LtA A B C A C B) by (conclude lemma_angleorderrespectscongruence2).
 assert (CongA B C A A C B) by (conclude lemma_ABCequalsCBA).
 assert (LtA A B C B C A) by (conclude lemma_angleorderrespectscongruence).
 assert (~ LtA A B C B C A) by (conclude lemma_angletrichotomy).
 contradict.
 }
assert (CongA A B C A B C) by (conclude lemma_equalanglesreflexive).
assert (neq A B) by (forward_using lemma_angledistinct).
assert (neq A C) by (forward_using lemma_angledistinct).
assert (~ ~ Lt A B A C).
 {
 intro.
 assert (Cong A B A C) by (conclude lemma_trichotomy1).
 assert (Cong A C A B) by (conclude lemma_congruencesymmetric).
 contradict.
 }
close.
Qed.

End Euclid.


Require Import nat.

Definition add1 : nat -> nat.
    intros n. apply S. apply n.
Defined.

(*
Compute add1 2.
*)


Require Import List EqNat Arith Omega.

(************* Syntax of Turing machines ***************)

(*** Specification ***)

Parameter State: Set.

(*
Definition State := nat.
*)

Parameter Sym: Set.

(*
Inductive Sym: Set := blank: Sym
                    | one: Sym
                    | zero: Sym.
*)

Inductive Head: Set := R: Head
                     | L: Head
                     | W: Sym -> Head.

Definition Spec: Set := (list (State * Sym * State * Head)).

(*** Tape ***)

CoInductive HTape: Set := Cons: Sym -> HTape -> HTape.

Definition hd (h:HTape) := match h with | Cons a k => a end.

Definition tl (h:HTape) := match h with | Cons a k => k end.

Inductive Tape: Set := pair: HTape -> HTape -> Tape.

(*** Transition Function ***)

Parameter tr: Spec -> State -> Sym -> option (State * Head).

(*
Fixpoint eqsym (a b:Sym) {struct a}: bool :=
         match a, b with B, B => true
                    |    one, one => true
                    |    zero, zero => true
                    |    _ , _ => false
         end.

Fixpoint eqstate (q p:State) {struct q}: bool :=
         match q, p with 0, 0 => true
                    |    (S u), (S v) => (eqstate u v)
                    |    _, _ => false
         end.

Fixpoint tr (T:Spec) (q:State) (a:Sym) {struct T}: option (State * Head) :=
         match T with | nil => None
                      | (cons A T') =>
         match A with (p, b, r, x) =>
                      if (eqstate q p)
                      then if (eqsym b a)
                           then (Some (r, x))
                           else (tr T' q a)
                      else (tr T' q a)
         end end.
*)


Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Export Image.
Require Import ImageImplicit.
Require Export Relation_Definitions.
Require Import Relation_Definitions_Implicit.
Require Import Description.
Require Import ProofIrrelevance.
Require Import Proj1SigInjective.
Require Export EnsemblesSpec.

Set Implicit Arguments.
Section Quotient.
Variable A:Type.
Variable R:relation A.
Hypothesis equivR:equivalence R.

Definition equiv_class (x:A) : Ensemble A :=
  [ y:A | R x y ].

Lemma R_impl_equality_of_equiv_class:
  forall x y:A, R x y -> equiv_class x = equiv_class y.
Proof.
destruct equivR.
intros.
apply Extensionality_Ensembles; split; red; intros z ?.
constructor.
destruct H0.
apply equiv_trans with x; trivial.
apply equiv_sym; trivial.
destruct H0.
constructor.
apply equiv_trans with y; trivial.
Qed.

Lemma equality_of_equiv_class_impl_R:
  forall x y:A, equiv_class x = equiv_class y -> R x y.
Proof.
destruct equivR.
intros.
assert (In (equiv_class x) x).
constructor.
apply equiv_refl.
rewrite H in H0.
destruct H0.
apply equiv_sym.
assumption.
Qed.

Definition equiv_classes : Ensemble (Ensemble A) :=
  Im Full_set equiv_class.
Definition quotient : Type :=
  { S:Ensemble A | In equiv_classes S }.

Lemma equiv_class_in_quotient: forall x:A,
  In equiv_classes (equiv_class x).
Proof.
unfold equiv_classes.
intro.
apply Im_def.
constructor.
Qed.

Definition quotient_projection (x:A) : quotient :=
  exist _ (equiv_class x) (equiv_class_in_quotient x).

Lemma quotient_projection_correct: forall x:A,
  proj1_sig (quotient_projection x) = equiv_class x.
Proof.
trivial.
Qed.

Lemma quotient_projection_surjective: forall xbar:quotient,
  exists x:A, quotient_projection x = xbar.
Proof.
intro.
destruct xbar.
destruct i.
exists x.
unfold quotient_projection.
pose proof e.
symmetry in H; destruct H.
f_equal.
apply proof_irrelevance.
Qed.

Lemma quotient_projection_collapses_R: forall x1 x2:A,
  R x1 x2 -> quotient_projection x1 = quotient_projection x2.
Proof.
intros.
apply subset_eq_compatT.
apply R_impl_equality_of_equiv_class.
assumption.
Qed.

Lemma quotient_projection_minimally_collapses_R: forall x1 x2:A,
  quotient_projection x1 = quotient_projection x2 -> R x1 x2.
Proof.
intros.
apply equality_of_equiv_class_impl_R.
repeat rewrite <- quotient_projection_correct.
rewrite H.
reflexivity.
Qed.

End Quotient.

Section InducedFunction.

(* well-defined A->B induces a function A/R->B *)

Variable A B:Type.
Variable R:Relation A.
Variable f:A->B.
Hypothesis equiv:equivalence R.
Hypothesis well_defined: forall x y:A, R x y -> f x = f y.

Lemma description_of_fbar: forall xbar:quotient R, exists! y:B,
  exists x:A, quotient_projection R x = xbar /\ f x = y.
Proof.
intro.
pose proof (quotient_projection_surjective xbar).
destruct H.
exists (f x).
unfold unique.
split.
exists x.
tauto.
intros.
destruct H0.
destruct H0.
rewrite <- H1.
apply well_defined.
apply equality_of_equiv_class_impl_R; trivial.
transitivity (proj1_sig (quotient_projection R x)).
trivial.
rewrite H.
rewrite <- H0.
trivial.
Qed.

Definition induced_function (xbar:quotient R) : B :=
  proj1_sig (constructive_definite_description _
               (description_of_fbar xbar)).

Lemma induced_function_correct: forall x:A,
  induced_function (quotient_projection R x) = f x.
Proof.
intro.
unfold induced_function.
destruct constructive_definite_description.
simpl.
destruct e.
destruct H.
rewrite <- H0.
apply well_defined.
apply quotient_projection_minimally_collapses_R; trivial.
Qed.

Lemma induced_function_unique: forall fbar:quotient R->B,
  (forall x:A, fbar (quotient_projection R x) = f x) ->
  (forall xbar:quotient R, fbar xbar = induced_function xbar).
Proof.
intros.
destruct (quotient_projection_surjective xbar).
rewrite <- H0.
rewrite H.
rewrite induced_function_correct.
reflexivity.
Qed.

End InducedFunction.

Section InducedFunction2.

(* well-defined function A->B induces a function A/R->B/S *)

Variable A B:Type.
Variable R:relation A.
Variable S:relation B.
Variable f:A->B.
Hypothesis equivR: equivalence R.
Hypothesis equivS: equivalence S.
Hypothesis well_defined2: forall a1 a2:A, R a1 a2 -> S (f a1) (f a2).

Definition projf (a:A) : quotient S :=
  quotient_projection S (f a).
Lemma projf_well_defined: forall a1 a2:A,
  R a1 a2 -> projf a1 = projf a2.
Proof.
intros.
unfold projf.
apply quotient_projection_collapses_R; trivial.
apply well_defined2.
assumption.
Qed.

Definition induced_function2: quotient R -> quotient S :=
  induced_function projf equivR projf_well_defined.

Lemma induced_function2_correct: forall a:A,
  induced_function2 (quotient_projection R a) =
  quotient_projection S (f a).
Proof.
intros.
unfold induced_function2.
rewrite induced_function_correct.
reflexivity.
Qed.

End InducedFunction2.

Section InducedFunction2arg.

(* well-defined function A x B -> C induces a function
   (A/R) x (B/S) -> C *)

Variable A B C:Type.
Variable R:relation A.
Variable S:relation B.
Variable f:A->B->C.
Hypothesis equivR:equivalence R.
Hypothesis equivS:equivalence S.
Hypothesis well_defined_2arg: forall (a1 a2:A) (b1 b2:B),
  R a1 a2 -> S b1 b2 -> f a1 b1 = f a2 b2.

Lemma slices_well_defined: forall (a:A) (b1 b2:B),
  S b1 b2 -> f a b1 = f a b2.
Proof.
intros.
apply well_defined_2arg.
apply (equiv_refl equivR).
assumption.
Qed.

Definition induced1 (a:A) : quotient S -> C :=
   induced_function (f a) equivS (slices_well_defined a).

Definition eq_fn (f g:quotient S->C) :=
  forall b:quotient S, f b = g b.
Lemma eq_fn_equiv: equivalence eq_fn.
Proof.
constructor.
unfold reflexive.
unfold eq_fn.
reflexivity.
unfold transitive.
unfold eq_fn.
intros.
transitivity (y b).
apply H.
apply H0.
unfold symmetric.
unfold eq_fn.
symmetry.
apply H.
Qed.

Lemma well_defined_induced1: forall a1 a2:A, R a1 a2 ->
  eq_fn (induced1 a1) (induced1 a2).
Proof.
unfold eq_fn.
intros.
pose proof (quotient_projection_surjective b).
destruct H0.
rewrite <- H0.
unfold induced1.
rewrite induced_function_correct.
rewrite induced_function_correct.
apply well_defined_2arg.
assumption.
apply (equiv_refl equivS).
Qed.

Definition induced2 :=
  induced_function2 induced1 equivR eq_fn_equiv well_defined_induced1.

Definition eval (b:quotient S) (f:quotient S->C): C := f b.
Lemma well_defined_eval: forall (b:quotient S) (f g:quotient S->C),
  eq_fn f g -> eval b f = eval b g.
Proof.
intros.
unfold eval.
apply H.
Qed.

Definition induced_eval (b:quotient S) :=
  induced_function (eval b) eq_fn_equiv (well_defined_eval b).

Definition induced_function2arg (a:quotient R) (b:quotient S) : C :=
  induced_eval b (induced2 a).

Lemma induced_function2arg_correct: forall (a:A) (b:B),
  induced_function2arg (quotient_projection R a) (quotient_projection S b) =
  f a b.
Proof.
intros.
unfold induced_function2arg.
unfold induced_eval.
unfold induced2.
rewrite induced_function2_correct.
rewrite induced_function_correct.
unfold eval.
unfold induced1.
rewrite induced_function_correct.
reflexivity.
Qed.

End InducedFunction2arg.

Section InducedFunction3.

(* well-defined function A x B -> C induces a function
   (A/R) x (B/S) -> C/T *)

Variable A B C:Type.
Variable R:relation A.
Variable S:relation B.
Variable T:relation C.
Variable f:A->B->C.
Hypothesis equivR:equivalence R.
Hypothesis equivS:equivalence S.
Hypothesis equivT:equivalence T.
Hypothesis well_defined3: forall (a1 a2:A) (b1 b2:B),
  R a1 a2 -> S b1 b2 -> T (f a1 b1) (f a2 b2).

Definition projf2 (a:A) (b:B) :=
  quotient_projection T (f a b).

Lemma projf2_well_defined: forall (a1 a2:A) (b1 b2:B),
  R a1 a2 -> S b1 b2 -> projf2 a1 b1 = projf2 a2 b2.
Proof.
intros.
apply quotient_projection_collapses_R; trivial.
apply well_defined3.
assumption.
assumption.
Qed.

Definition induced_function3 : quotient R -> quotient S -> quotient T :=
  induced_function2arg projf2 equivR equivS projf2_well_defined.

Lemma induced_function3_correct: forall (a:A) (b:B),
  induced_function3 (quotient_projection R a)
                    (quotient_projection S b) =
  quotient_projection T (f a b).
Proof.
intros.
unfold induced_function3.
rewrite induced_function2arg_correct.
reflexivity.
Qed.

End InducedFunction3.


Require Import List Arith Bool Maps FinFun Basics.

(** *We try to create a simple data structure to store Graphs, using dependent typing *)
Fixpoint f_maker (a b: nat) := fun (x:nat) => if beq_nat x a then b else 0.

(** let us represent edges of graphs using functions ( -> type for -> edges) *)
Definition edge_maker (x y:id) :=
  match x,y with Id x1,Id y1 =>
                 fun (a : id) => match a with Id a1 => Id ((f_maker x1 y1) a1) end
  end.

(** define some sample points *)
Definition V1 := Id 5.
Definition V2 := Id 6.
Definition V3 := Id 7.
Definition V4 := Id 8.

(** sample edges *)
Definition f := edge_maker V1 V2.
Definition g := edge_maker V2 V3.
Definition h := edge_maker V3 V4.

Eval compute in (f (Id 5)).

Definition nodeList := list id.
Definition edgeList := list (id -> id).

Check compose.
(** similar to function composition, we get edge composition*)
Definition edge_compose (f g : id -> id) := compose g f.

Definition f_inv := edge_maker (Id 6) (Id 5).
Eval compute in  (edge_compose f f_inv) (Id 5).

(** and we can use edge_compose to get to the last connected vertex *)
Eval compute in ((edge_compose (edge_compose f g) h) (Id 5)).

(** However the above representation was not very useful, let's put more data in types*)

Section phoas_graph.
(** a universal constructor for nodes *)
Inductive u (i : id) : Type :=
  | U : u i.

Definition v1 := U (Id 5).
Check v1.

(** need a new definition for checking equality of nodes *)
Definition beq_U  {i j: id} (x : u i) (y : u j) := beq_id i j.

(** need a new way to create edges *)
Definition edge_maker2 {i j: id} (x : u i) (y : u j) : u i -> u j :=
  fun (a : u i) => U j.

Definition edge_compose2 {i j k : id} (f : u i -> u j) (g : u j -> u k) :=
  compose g f.

Definition f1 := edge_maker2 (U V1) (U V2).
Definition g1 := edge_maker2 (U V2) (U V3).
Definition h1 := edge_maker2 (U V3) (U V4).

Check f1.

Check edge_compose2 (edge_compose2 f1 g1) h1.

(** inductive definition for a list of our new edge types. Note that we couldn't use the regular List as it wouldn't accept elements of different types*)
Inductive edge_list : Type :=
  | ni : edge_list
  | co {i j : id} : (u i -> u j) -> edge_list -> edge_list.

Definition ex_edge_list : edge_list := co f1 (co g1 (co h1 ni)).

(** better to use relations than functions, for pattern matching*)
Definition fromNode {i j : id} (e : u i -> u j) := i.

(** Now we can even write a function to convert list of edges to adjacency map *)
Fixpoint edgeListToAdjMap (el : edge_list) (m : total_map edge_list) : total_map edge_list :=
  match el with
  | ni => m
  | co hd tl => edgeListToAdjMap tl (t_update m (fromNode hd) tl)
  end.

End phoas_graph.


Inductive tree (Node: Type): Type :=
| E : tree Node
| T (l: tree Node) (x: Node) (r: tree Node).

Arguments E {_}.
Arguments T {_} _ _ _.

Inductive half_tree (Node: Type): Type :=
| LH (x: Node) (r: tree Node): half_tree Node
| RH (l: tree Node) (x: Node): half_tree Node.

Arguments LH {_} _ _.
Arguments RH {_} _ _.

Fixpoint tree_rel {Node1 Node2: Type} (node_rel: Node1 -> Node2 -> Prop)
                  (t1: tree Node1) (t2: tree Node2): Prop :=
  match t1, t2 with
  | E, E => True
  | T l1 x1 r1, T l2 x2 r2 =>
    tree_rel node_rel l1 l2 /\ node_rel x1 x2 /\ tree_rel node_rel r1 r2
  | _, _ => False
  end.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section playfair_par_trans.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** This is Legendre theorem XXV http://gallica.bnf.fr/ark:/12148/bpt6k202689z/f29.image *)

Lemma playfair_implies_par_trans :
  playfair_s_postulate -> postulate_of_transitivity_of_parallelism.
Proof.
  intros HP A1 A2 B1 B2 C1 C2 HAB HBC.
  assert_diffs.
  destruct (cop_dec A1 A2 C1 B1) as [|HNCop]; [induction (col_dec A1 A2 C1)|].

  - right.
    destruct (HP B1 B2 C1 C2 A1 A2 C1); Par; Col.

  - left.
    repeat split; auto.
    { apply par_symmetry in HBC.
      destruct HBC; [destruct HAB|]; [|spliter..].
      - assert_ncols; apply coplanar_pseudo_trans with B1 B2 C1; [Col| | |Cop..];
          apply coplanar_pseudo_trans with A1 A2 B1; Col; Cop.
      - apply coplanar_perm_16, col2_cop__cop with B1 B2; Col; Cop.
      - apply col2_cop__cop with B1 B2; Col; Cop.
    }
    intros [X []].
    destruct (HP B1 B2 A1 A2 C1 C2 X); Par; Col.

  - apply (par_not_col_strict A1 A2 B1 B2 B1) in HAB; [|Col|intro; apply HNCop; Cop].
    apply (par_not_col_strict B1 B2 C1 C2 C1) in HBC;
      [|Col|intro; apply HNCop, coplanar_perm_1, col_cop__cop with B2; Cop].
    destruct (cop_osp__ex_cop2 A1 A2 C1 B1 B2 C1) as [C' [HCop1 [HCop2 HC1C']]]; Cop.
      apply cop2_os__osp with A1 A2; Cop; Side.
    assert (HC' : forall X, Coplanar A1 A2 B1 X -> ~ Col X C1 C').
    { intros X HX1 HX2.
      apply (par_not_col A1 A2 B1 B2 X HAB).
      - apply (l9_30 A1 A2 C1 A1 A2 B1 B1); Cop.
          apply par_strict_not_col_1 with B2, HAB.
        apply col_cop__cop with C'; Col.
      - apply (l9_30 A1 A2 B1 B1 B2 C1 C1); Cop.
          apply par_strict_not_col_1 with C2, HBC.
        apply col_cop__cop with C'; Col.
    }
    left; apply par_strict_col_par_strict with C'; auto.
    { repeat split; auto.
      intros [X []].
      apply HC' with X; Cop.
    }
    assert (HBC' : Par_strict B1 B2 C1 C').
    { repeat split; Col.
      intros [X []].
      apply HC' with X; trivial.
      apply col_cop__cop with B2; Col; Cop.
    }
    destruct (HP B1 B2 C1 C2 C1 C' C1); Par; Col.
Qed.

End playfair_par_trans.


(** Adapted from "Elements of Set Theory" Chapter 5 **)
(** Coq coding by choukh, June 2020 **)

Require Export ZFC.Elements.EST5_1.
Require Import ZFC.Lib.FuncFacts.

Local Ltac mr := apply mul_ran; auto.
Local Ltac ar := apply add_ran; auto.
Local Ltac amr := apply add_ran; apply mul_ran; auto.

(*** EST第五章2：整数乘法，整数的序，自然数嵌入 ***)

Close Scope Int_scope.
Open Scope omega_scope.

Definition PreIntMul : set :=
  PlaneArith ω ω (λ m n p q, <m⋅p + n⋅q, m⋅q + n⋅p>).
Notation "a ⋅ᵥ b" := (PreIntMul[<a, b>])
  (at level 50) : PreInt_scope.

Lemma mul_split : ∀ a b ∈ ω, ∃ m n p q ∈ ω,
  a = m⋅p + n⋅q ∧ b = m⋅q + n⋅p.
Proof with try apply ω_inductive; nauto.
  intros a Ha b Hb.
  exists a. split... exists b. split...
  exists 1. split... exists 0. split...
  repeat rewrite mul_1_r, mul_0_r...
  rewrite add_0_r, add_0_l...
Qed.

Lemma preIntMul_maps_onto : PreIntMul: (ω²)² ⟹ ω².
Proof with eauto.
  apply planeArith_maps_onto.
  - intros m Hm n Hn p Hp q Hq.
    apply CPrdI; apply add_ran; apply mul_ran...
  - intros a Ha b Hb. pose proof mul_split
      as [m [Hm [n [Hn [p [Hp [q [Hq H1]]]]]]]].
    apply Ha. apply Hb.
    exists m. split... exists n. split...
    exists p. split... exists q. split...
    apply op_iff...
Qed.

Lemma preIntMul_m_n_p_q : ∀ m n p q ∈ ω,
  <m, n> ⋅ᵥ <p, q> = <m⋅p + n⋅q, m⋅q + n⋅p>.
Proof with auto.
  intros m Hm n Hn p Hp q Hq.
  eapply func_ap. destruct preIntMul_maps_onto...
  apply SepI. apply CPrdI; apply CPrdI;
    try apply CPrdI; try apply add_ran; try apply mul_ran...
  zfc_simple...
Qed.

Lemma preIntMul_binCompatible :
  binCompatible (PlaneEquiv ω ω IntEq) ω² PreIntMul.
Proof with auto.
  split. apply intEquiv_equiv. split.
  destruct preIntMul_maps_onto as [Hf [Hd Hr]].
  split... split... rewrite Hr. apply sub_refl.
  intros x Hx y Hy u Hu v Hv H1 H2.
  apply CPrdE1 in Hx as [m [Hm [n [Hn Hxeq]]]].
  apply CPrdE1 in Hy as [p [Hp [q [Hq Hyeq]]]].
  apply CPrdE1 in Hu as [m' [Hm' [n' [Hn' Hueq]]]].
  apply CPrdE1 in Hv as [p' [Hp' [q' [Hq' Hveq]]]]. subst.
  apply planeEquiv in H1... apply planeEquiv in H2...
  rewrite preIntMul_m_n_p_q, preIntMul_m_n_p_q...
  apply SepI. apply CPrdI; apply CPrdI;
    apply add_ran; apply mul_ran... zfc_simple. simpl.
  unfold IntEq in *.
  assert (H3: (m+n')⋅p = (m'+n)⋅p) by congruence.
  rewrite mul_distr', mul_distr' in H3; [|auto..].
  assert (H4: (m'+n)⋅q = (m+n')⋅q) by congruence.
  rewrite mul_distr', mul_distr' in H4; [|auto..].
  assert (H5: m'⋅(p+q') = m'⋅(p'+q)) by congruence.
  rewrite mul_distr, mul_distr in H5; [|auto..].
  assert (H6: n'⋅(p'+q) = n'⋅(p+q')) by congruence.
  rewrite mul_distr, mul_distr in H6; [|auto..].
  rewrite (add_comm (m'⋅p)) in H3; [|mr;auto..].
  rewrite (add_comm (m'⋅p)) in H5; [|mr;auto..].
  assert (H35: m⋅p + n'⋅p + (m'⋅q' + m'⋅p) =
    n⋅p + m'⋅p + (m'⋅p' + m'⋅q)) by congruence.
  rewrite (add_comm (n⋅p + m'⋅p)) in H35; [|amr;auto..].
  rewrite <- add_assoc, <- add_assoc in H35; [|amr|mr|mr|amr|mr..].
  apply add_cancel in H35; [|ar;[amr|mr]|ar;[amr|mr]|mr].
  assert (H46: m'⋅q + n⋅q + (n'⋅p' + n'⋅q) =
               m⋅q + n'⋅q + (n'⋅p + n'⋅q')) by congruence.
  rewrite (add_comm (m⋅q + n'⋅q)) in H46; [|amr;auto..].
  rewrite <- add_assoc, <- add_assoc in H46; [|amr|mr|mr|amr|mr..].
  apply add_cancel in H46; swap 2 4; [|mr|ar;[amr|mr]..].
  rewrite (add_comm (m⋅p)), add_assoc in H35; [|mr;auto..].
  assert (H: n'⋅p + (m⋅p + m'⋅q') + (m'⋅q + n⋅q + n'⋅p') =
    m'⋅p' + m'⋅q + n⋅p + (n'⋅p + n'⋅q' + m⋅q)) by congruence.
  rewrite add_assoc in H; [|mr|amr|ar;[amr|mr]].
  rewrite (add_comm (m'⋅p' + m'⋅q + n⋅p)) in H; [|ar;[amr|mr];auto..].
  rewrite (add_assoc (n'⋅p)) in H; [|mr;auto..].
  rewrite (add_assoc (n'⋅p)) in H; [|mr|amr|ar;[amr|mr]].
  apply add_cancel' in H; swap 2 4; [|mr|ar;[ar|ar;[ar|]];mr..].
  rewrite (add_comm (m'⋅q)) in H; [|mr;auto..].
  rewrite (add_comm (n⋅q + m'⋅q)) in H; [|amr|mr].
  rewrite <- add_assoc in H; [|amr|mr|amr].
  rewrite <- add_assoc in H; [|ar;[ar|];mr|mr..].
  rewrite (add_comm (m'⋅p' + m'⋅q)) in H; [|amr|mr].
  rewrite <- add_assoc in H; [|amr|mr|amr].
  rewrite <- add_assoc in H; [|ar;[ar|];mr|mr..].
  apply add_cancel in H; swap 2 4; [|mr|ar;[ar;[ar|]|];mr..].
  rewrite add_assoc; [|mr|mr|amr].
  rewrite (add_comm (n⋅q)); [|mr|amr].
  rewrite <- add_assoc, <- add_assoc; swap 2 6; [|amr|mr..].
  rewrite (add_assoc (m'⋅p')); [|mr|mr|amr].
  rewrite (add_comm (m'⋅p')); [|mr|ar;[mr|amr]].
  rewrite <- (add_assoc (n'⋅q')); [|mr;auto..]. apply H.
Qed.

Close Scope omega_scope.
Open Scope Int_scope.

(** 整数乘法 **)
Definition IntMul : set :=
  QuotionFunc (PlaneEquiv ω ω IntEq) ω² PreIntMul.
Notation "a ⋅ b" := (IntMul[<a, b>]) : Int_scope.

Lemma intMul_maps_onto : IntMul: ℤ × ℤ ⟹ ℤ.
Proof.
  apply quotionFunc_maps_onto.
  apply preIntMul_binCompatible.
  apply preIntMul_maps_onto.
Qed.

Lemma intMul_a_b : ∀ a b ∈ ω², [a]~ ⋅ [b]~ = [a ⋅ᵥ b]~.
Proof.
  intros a Ha b Hb. apply binCompatibleE; auto.
  apply preIntMul_binCompatible.
Qed.

Global Opaque IntMul.

Lemma intMul_m_n_p_q : ∀ m n p q ∈ ω,
  [<m, n>]~ ⋅ [<p, q>]~ = ([<m⋅p + n⋅q, m⋅q + n⋅p>]~)%ω.
Proof with auto.
  intros m Hm n Hn p Hp q Hq.
  rewrite intMul_a_b, preIntMul_m_n_p_q...
  apply CPrdI... apply CPrdI...
Qed.

Lemma intMul_0_r_r : ∀a ∈ ℤ, a ⋅ Int 0 = Int 0.
Proof with nauto.
  intros a Ha.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  unfold Int. rewrite intMul_m_n_p_q...
  repeat rewrite mul_0_r...
  repeat rewrite add_0_r...
Qed.

Lemma intMul_ran : ∀ a b ∈ ℤ, a ⋅ b ∈ ℤ.
Proof with auto.
  intros a Ha b Hb.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst b.
  rewrite intMul_m_n_p_q...
  apply pQuotI; apply add_ran; apply mul_ran...
Qed.

Example intMul_2_n2 : Int 2 ⋅ -Int 2 = -Int 4.
Proof with nauto.
  unfold Int. rewrite intAddInv, intAddInv...
  rewrite intMul_m_n_p_q...
  rewrite mul_0_l, mul_0_r, mul_0_r, add_0_r, add_0_r...
  rewrite mul_2_2... apply mul_ran...
Qed.

Close Scope Int_scope.
Open Scope omega_scope.

Theorem intMul_comm : ∀ a b ∈ ℤ, (a ⋅ b = b ⋅ a)%z.
Proof with try assumption.
  intros a Ha b Hb.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst.
  rewrite intMul_m_n_p_q, intMul_m_n_p_q...
  rewrite (mul_comm p), (mul_comm n)...
  rewrite (mul_comm m Hm q), (mul_comm n Hn p)...
  rewrite (add_comm (q⋅m)); [|apply mul_ran; auto..]. reflexivity.
Qed.

Theorem intMul_assoc : ∀ a b c ∈ ℤ, (a ⋅ b ⋅ c = a ⋅ (b ⋅ c))%z.
Proof.
  intros a Ha b Hb c Hc.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]].
  apply pQuotE in Hc as [r [Hr [s [Hs Hc]]]]. subst.
  repeat rewrite intMul_m_n_p_q; [|auto;amr..].
  apply int_ident; swap 1 5; [|ar;mr;ar;mr..].
  repeat rewrite mul_distr, mul_distr'; [|auto;mr..].
  repeat rewrite <- mul_assoc; [|auto..].
  cut (∀ x1 x2 x3 x4 x5 x6 x7 x8 ∈ ω,
    x1 + x4 + (x2 + x3) + (x5 + x7 + (x8 + x6)) =
    x1 + x2 + (x3 + x4) + (x5 + x6 + (x7 + x8))).
  intros H. apply H; mr; mr.
  clear Hm Hn Hp Hq Hr Hs m n p q r s.
  intros x1 H1 x2 H2 x3 H3 x4 H4 x5 H5 x6 H6 x7 H7 x8 H8.
  rewrite (add_assoc x1), (add_comm x4); [|auto;ar;auto..].
  rewrite (add_assoc x2), <- (add_assoc x1); [|auto;ar;auto..].
  rewrite (add_assoc x5), <- (add_assoc x7); [|auto;ar;auto..].
  rewrite (add_comm (x7+x8)), (add_assoc x5); [|auto;ar;auto..].
  reflexivity.
Qed.

Theorem intMul_distr : ∀ a b c ∈ ℤ, (a ⋅ (b + c) = a ⋅ b + a ⋅ c)%z.
Proof.
  intros a Ha b Hb c Hc.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]].
  apply pQuotE in Hc as [r [Hr [s [Hs Hc]]]]. subst.
  rewrite intAdd_m_n_p_q; [|auto..].
  rewrite intMul_m_n_p_q, intMul_m_n_p_q, intMul_m_n_p_q; [|auto;ar..].
  repeat rewrite intAdd_m_n_p_q; [|amr;auto..].
  apply int_ident; [ar;mr;ar|ar;mr;ar|
    ar;amr|ar;amr|].
  repeat rewrite mul_distr; [|auto..].
  cut (∀ x1 x2 x3 x4 x5 x6 x7 x8 ∈ ω,
    x1 + x3 + (x2 + x4) + (x5 + x7 + (x6 + x8)) =
    x1 + x2 + (x3 + x4) + (x5 + x6 + (x7 + x8))).
  intros H. apply H; mr; auto.
  clear Hm Hn Hp Hq Hr Hs m n p q r s.
  intros x1 H1 x2 H2 x3 H3 x4 H4 x5 H5 x6 H6 x7 H7 x8 H8.
  rewrite (add_assoc x1), <- (add_assoc x3),
    (add_comm x3), (add_assoc x2), <- (add_assoc x1);
    swap 2 4; swap 3 15; [|ar|ar|auto..].
  rewrite (add_assoc x5), <- (add_assoc x7),
    (add_comm x7), (add_assoc x6), <- (add_assoc x5);
    swap 2 4; swap 3 15; [|ar|ar|auto..].
  reflexivity.
Qed.

Theorem intMul_distr' : ∀ a b c ∈ ℤ, ((b + c) ⋅ a = b ⋅ a + c ⋅ a)%z.
Proof with auto.
  intros a Ha b Hb c Hc.
  rewrite (intMul_comm (b + c)%z), intMul_distr, intMul_comm,
    (intMul_comm c)... apply intAdd_ran...
Qed.

Theorem int_suc_neq_0 : ∀ n, Int (S n) ≠ Int 0.
Proof with neauto.
  intros n H. apply int_ident in H...
  rewrite add_0_r, add_0_r in H... eapply suc_neq_0...
Qed.
Global Hint Immediate int_suc_neq_0 : number_hint.

Theorem int_no_0_div : ∀ a b ∈ ℤ,
  (a ⋅ b = Int 0)%z → a = Int 0 ∨ b = Int 0.
Proof with nauto.
  intros a Ha b Hb Heq.
  destruct (classic (a = Int 0)) as [|H1];
  destruct (classic (b = Int 0)) as [|H2]... exfalso.
  cut ((a ⋅ b)%z ≠ Int 0). intros... clear Heq.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]].
  subst a b. rewrite intMul_m_n_p_q...
  cut (m⋅p + n⋅q ≠ m⋅q + n⋅p). intros Hnq Heq. apply Hnq.
  apply int_ident in Heq; [|nauto;amr..]...
  rewrite add_0_r, add_0_l in Heq; auto; amr...
  assert (Hmn: m ≠ n). {
    intros H. apply H1. apply int_ident...
    rewrite add_0_r, add_0_l...
  }
  assert (Hpq: p ≠ q). {
    intros H. apply H2. apply int_ident...
    rewrite add_0_r, add_0_l...
  }
  clear H1 H2.
  assert (Hw: m⋅q + n⋅p ∈ ω) by (amr; auto).
  apply nat_connected in Hmn as [H1|H1];
  apply nat_connected in Hpq as [H2|H2]; auto;
  intros Heq; eapply nat_irrefl; revgoals.
  pose proof (ex4_25 m Hm n Hn p Hp q Hq H1 H2).
  rewrite Heq in H. apply H. auto.
  pose proof (ex4_25 m Hm n Hn q Hq p Hp H1 H2).
  rewrite Heq in H. apply H. auto.
  pose proof (ex4_25 n Hn m Hm p Hp q Hq H1 H2).
  rewrite add_comm, (add_comm (n⋅p)), Heq in H; [|mr;auto..]. apply H. auto.
  pose proof (ex4_25 n Hn m Hm q Hq p Hp H1 H2).
  rewrite add_comm, (add_comm (n⋅q)), Heq in H; [|mr;auto..]. apply H. auto.
Qed.

Close Scope omega_scope.
Open Scope Int_scope.

Theorem intMul_1_r : ∀a ∈ ℤ, a ⋅ Int 1 = a.
Proof with nauto.
  intros a Ha.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  unfold Int. rewrite intMul_m_n_p_q...
  rewrite mul_1_r, mul_1_r, mul_0_r, mul_0_r, add_0_r, add_0_l...
Qed.

Corollary intMul_1_l : ∀a ∈ ℤ, Int 1 ⋅ a = a.
Proof with nauto.
  intros a Ha. rewrite intMul_comm, intMul_1_r...
Qed.

Lemma intMul_addInv : ∀a ∈ ℤ, -Int 1 ⋅ a = -a.
Proof with nauto.
  intros a Ha.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  unfold Int. rewrite intAddInv, intAddInv, intMul_m_n_p_q...
  rewrite mul_0_l, mul_0_l, (mul_comm 1), (mul_comm 1)...
  rewrite mul_1_r, mul_1_r, add_0_l, add_0_l...
Qed.

Lemma intMul_0_l : ∀a ∈ ℤ, Int 0 ⋅ a = Int 0.
Proof.
  intros a Ha. rewrite intMul_comm, intMul_0_r_r; nauto.
Qed.

Lemma intMul_addInv_lr : ∀ a b ∈ ℤ, a ⋅ -b = -a ⋅ b.
Proof with auto.
  intros a Ha b Hb.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst b.
  rewrite intAddInv, intAddInv, intMul_m_n_p_q, intMul_m_n_p_q,
    add_comm, (add_comm (m⋅p)%ω); auto; mr; auto.
Qed.

Lemma intMul_addInv_r : ∀ a b ∈ ℤ, a ⋅ -b = -(a ⋅ b).
Proof with auto.
  intros a Ha b Hb.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst b.
  rewrite intAddInv, intMul_m_n_p_q, intMul_m_n_p_q, intAddInv;
    auto; amr; auto.
Qed.

Lemma intMul_addInv_l : ∀ a b ∈ ℤ, -a ⋅ b = -(a ⋅ b).
Proof with auto.
  intros a Ha b Hb.
  rewrite <- intMul_addInv_lr, intMul_addInv_r...
Qed.

Close Scope Int_scope.
Open Scope omega_scope.

(** 整数的序 **)

Lemma int_orderable : ∀ m n m' n' p q p' q',
  <m, n> ~ <m', n'> → <p, q> ~ <p', q'> →
  m + q ∈ p + n ↔ m' + q' ∈ p' + n'.
Proof.
  intros * H1 H2.
  apply planeEquivE2 in H1 as [H1 [Hm [Hn [Hm' Hn']]]].
  apply planeEquivE2 in H2 as [H2 [Hp [Hq [Hp' Hq']]]].
  assert (Hmq: m + q ∈ ω) by (ar; auto).
  assert (Hpn: p + n ∈ ω) by (ar; auto).
  assert (Hn'q': n' + q' ∈ ω) by (ar; auto).
  rewrite (add_preserve_lt _ Hmq _ Hpn _ Hn'q').
  rewrite (add_assoc m), (add_comm q), <- (add_assoc m),
  <- (add_assoc m), (add_comm n'), (add_assoc p),
    (add_comm n), <- (add_assoc p), <- (add_assoc p),
    H1, H2, (add_assoc m'), (add_comm n), <- (add_assoc m'),
    (add_assoc (m'+q')), (add_assoc p'), (add_comm q),
    <- (add_assoc p'), (add_assoc (p'+n')), (add_comm q);
    [|auto;ar;auto..].
  assert (Hm'q': m' + q' ∈ ω) by (ar; auto).
  assert (Hp'n': p' + n' ∈ ω) by (ar; auto).
  assert (Hnq: n + q ∈ ω) by (ar; auto).
  rewrite <- (add_preserve_lt _ Hm'q' _ Hp'n' _ Hnq).
  reflexivity.
Qed.

(* 整数的小于关系 *)
Definition IntLt : set := BinRel ℤ (λ a b,
  let u := IntProj a in let v := IntProj b in
  let m := π1 u in let n := π2 u in
  let p := π1 v in let q := π2 v in
  m + q ∈ p + n
).
Notation "a <𝐳 b" := (<a, b> ∈ IntLt) (at level 70).

Lemma intLtI : ∀ m n p q ∈ ω,
  m + q ∈ p + n → [<m, n>]~ <𝐳 [<p, q>]~.
Proof with auto.
  intros m Hm n Hn p Hp q Hq Hlt.
  apply binRelI. apply pQuotI... apply pQuotI...
  pose proof (intProj m Hm n Hn)
    as [m' [Hm' [n' [Hn' [H11 [H12 _]]]]]].
  pose proof (intProj p Hp q Hq)
    as [p' [Hp' [q' [Hq' [H21 [H22 _]]]]]].
  pose proof intEquiv_equiv as [_ [_ [Hsym _]]].
  rewrite H11, H21. simpl. zfc_simple. eapply int_orderable.
  apply Hsym. apply H12. apply Hsym. apply H22. apply Hlt.
Qed.

Lemma intLtE : ∀ a b, a <𝐳 b → ∃ m n p q ∈ ω,
  a = [<m, n>]~ ∧ b = [<p, q>]~ ∧ m + q ∈ p + n.
Proof with auto.
  intros a b Hlt. apply SepE in Hlt as [H1 H2].
  apply CPrdE2 in H1 as [Ha Hb]. zfc_simple.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst.
  exists m. split... exists n. split...
  exists p. split... exists q. split... split... split...
  pose proof (intProj m Hm n Hn) as [r [Hr [s [Hs [H11 [H12 _]]]]]].
  pose proof (intProj p Hp q Hq) as [u [Hu [v [Hv [H21 [H22 _]]]]]].
  rewrite H11, H21 in H2. simpl in H2. zfc_simple.
  eapply int_orderable; eauto.
Qed.

Lemma intLt : ∀ m n p q ∈ ω,
  [<m, n>]~ <𝐳 [<p, q>]~ ↔ m + q ∈ p + n.
Proof.
  intros m Hm n Hn p Hp q Hq. split; intros.
  - apply SepE in H as [H1 H2].
    apply CPrdE2 in H1 as [Ha Hb]. zfc_simple.
    pose proof (intProj m Hm n Hn) as [r [Hr [s [Hs [H11 [H12 _]]]]]].
    pose proof (intProj p Hp q Hq) as [u [Hu [v [Hv [H21 [H22 _]]]]]].
    rewrite H11, H21 in H2. simpl in H2. zfc_simple.
    eapply int_orderable; eauto.
  - apply intLtI; auto.
Qed.

Lemma intNeqE : ∀ m n p q ∈ ω,
  [<m, n>]~ ≠ [<p, q>]~ → m + q ≠ p + n.
Proof with auto.
  intros m Hm n Hn p Hp q Hq Hnq Heq.
  apply Hnq. apply int_ident...
Qed.

Lemma intLt_trans : tranr IntLt.
Proof with auto.
  intros x y z H1 H2.
  assert (H1' := H1). assert (H2' := H2).
  apply intLtE in H1'
    as [m [Hm [n [Hn [p [Hp [q [Hq [Hx [Hy _]]]]]]]]]].
  apply intLtE in H2'
    as [_ [_ [_ [_ [r [Hr [s [Hs [_ [Hz _]]]]]]]]]]. subst x y z.
  apply intLt in H1... apply intLt in H2... apply intLt...
  assert (H1': m + q + s ∈ p + n + s)
    by (apply add_preserve_lt; auto; ar; auto).
  assert (H2': p + s + n ∈ r + q + n)
    by (apply add_preserve_lt; auto; ar; auto).
  rewrite (add_assoc m), (add_comm q), <- (add_assoc m),
    (add_assoc p), (add_comm n), <- (add_assoc p) in H1'...
  rewrite (add_assoc r), (add_comm q), <- (add_assoc r) in H2'...
  eapply add_preserve_lt; revgoals; swap 1 2; [apply Hq| |ar..].
  eapply nat_trans; revgoals; eauto; ar; ar.
Qed.

Lemma intLt_irrefl : irrefl IntLt.
Proof with auto.
  intros a Hlt. assert (H := Hlt). apply intLtE in H
    as [m [Hm [n [Hn [_ [_ [_ [_ [Ha _]]]]]]]]].
  subst a. apply intLt in Hlt...
  eapply nat_irrefl; revgoals. apply Hlt. ar...
Qed.

Lemma intLt_connected : connected IntLt ℤ.
Proof with auto.
  intros x Hx y Hy Hnq.
  apply pQuotE in Hx as [m [Hm [n [Hn Hx]]]].
  apply pQuotE in Hy as [p [Hp [q [Hq Hy]]]].
  subst x y. apply intNeqE in Hnq...
  apply nat_connected in Hnq as []; [| |ar;auto..].
  + left. apply intLtI...
  + right. apply intLtI...
Qed.

Lemma intLt_trich : trich IntLt ℤ.
Proof.
  eapply trich_iff. apply binRel_is_binRel.
  apply intLt_trans. split.
  apply intLt_irrefl. apply intLt_connected.
Qed.

Theorem intLt_linearOrder : linearOrder IntLt ℤ.
Proof.
  split. apply binRel_is_binRel. split.
  apply intLt_trans. apply intLt_trich.
Qed.

Close Scope omega_scope.
Open Scope Int_scope.

Definition intPos : set → Prop := λ a, Int 0 <𝐳 a.
Definition intNeg : set → Prop := λ a, a <𝐳 Int 0.

Lemma int_neq_0 : ∀a ∈ ℤ, intPos a ∨ intNeg a → a ≠ Int 0.
Proof.
  intros a Ha [Hpa|Hna]; intros H; subst;
  eapply intLt_irrefl; eauto.
Qed.

Lemma intLt_addInv : ∀ a b ∈ ℤ, a <𝐳 b ↔ -b <𝐳 -a.
Proof with auto.
  intros a Ha b Hb.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]].
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]].
  subst a b. split; intros.
  - apply intLt in H...
    rewrite intAddInv, intAddInv... apply intLt...
    rewrite add_comm, (add_comm n)...
  - rewrite intAddInv, intAddInv in H... apply intLt in H...
    apply intLt... rewrite add_comm, (add_comm p)...
Qed.

Lemma intPos_neg : ∀ a, intPos a → intNeg (-a).
Proof with nauto.
  intros. assert (Ha: a ∈ ℤ). {
    apply SepE in H as [H _]. apply CPrdE2 in H as []...
  }
  apply intLt_addInv in H... rewrite intAddInv_0 in H...
Qed.

Lemma intNeg_pos : ∀ a, intNeg a → intPos (-a).
Proof with nauto.
  intros. assert (Ha: a ∈ ℤ). {
    apply SepE in H as [H _]. apply CPrdE2 in H as []...
  }
  apply intLt_addInv in H... rewrite intAddInv_0 in H...
Qed.

Close Scope Int_scope.
Open Scope omega_scope.

Theorem intAdd_preserve_lt : ∀ a b c ∈ ℤ,
  a <𝐳 b ↔ (a + c <𝐳 b + c)%z.
Proof with auto.
  intros a Ha b Hb c Hc.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst b.
  apply pQuotE in Hc as [r [Hr [s [Hs Hc]]]]. subst c.
  rewrite (intLt m Hm n Hn p Hp q Hq).
  rewrite intAdd_m_n_p_q, intAdd_m_n_p_q...
  assert (Hw1: m + r ∈ ω) by (ar; auto).
  assert (Hw2: n + s ∈ ω) by (ar; auto).
  assert (Hw3: p + r ∈ ω) by (ar; auto).
  assert (Hw4: q + s ∈ ω) by (ar; auto).
  rewrite (intLt (m+r) Hw1 (n+s) Hw2 (p+r) Hw3 (q+s) Hw4).
  rewrite (add_assoc m), <- (add_assoc r), (add_comm r),
    (add_assoc q), <- (add_assoc m),
    (add_assoc p), <- (add_assoc r), (add_comm r Hr n Hn),
    (add_assoc n), <- (add_assoc p); [|auto;ar;auto..].
  apply add_preserve_lt; ar...
Qed.

Theorem intMul_preserve_lt : ∀ a b c ∈ ℤ,
  intPos c → a <𝐳 b ↔ (a ⋅ c <𝐳 b ⋅ c)%z.
Proof with neauto.
  cut (∀ a b c ∈ ℤ, intPos c → a <𝐳 b → (a ⋅ c <𝐳 b ⋅ c)%z).
  intros Hright a Ha b Hb c Hc Hpc. split; intros Hlt.
  apply Hright... destruct (classic (a = b)).
  subst. exfalso. eapply intLt_irrefl...
  apply intLt_connected in H as []... exfalso.
  eapply (Hright b Hb a Ha c Hc Hpc) in H.
  eapply intLt_irrefl. eapply intLt_trans...
  intros a Ha b Hb c Hc Hpc Hlt.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst b.
  apply pQuotE in Hc as [r [Hr [s [Hs Hc]]]]. subst c.
  apply intLt in Hpc... rewrite add_0_r, add_0_l in Hpc...
  rewrite (intLt m Hm n Hn p Hp q Hq) in Hlt.
  rewrite (intMul_m_n_p_q m Hm n Hn r Hr s Hs).
  rewrite (intMul_m_n_p_q p Hp q Hq r Hr s Hs).
  assert (Hw1: m ⋅ r + n ⋅ s ∈ ω) by (amr; auto).
  assert (Hw2: m ⋅ s + n ⋅ r ∈ ω) by (amr; auto).
  assert (Hw3: p ⋅ r + q ⋅ s ∈ ω) by (amr; auto).
  assert (Hw4: p ⋅ s + q ⋅ r ∈ ω) by (amr; auto).
  rewrite (intLt (m⋅r + n⋅s) Hw1 (m⋅s + n⋅r) Hw2
    (p⋅r + q⋅s) Hw3 (p⋅s + q⋅r) Hw4).
  rewrite (add_comm (p⋅s)), (add_assoc (m⋅r)),
    <- (add_assoc (n⋅s)), (add_comm (n⋅s)),
    (add_assoc (q⋅r)), <- (add_assoc (m⋅r));
    swap 2 4; swap 3 15; [|amr|amr|mr..]...
  rewrite (add_comm (m⋅s)), (add_assoc (p⋅r)),
    <- (add_assoc (q⋅s)), (add_comm (q⋅s)),
    (add_assoc (n⋅r)), <- (add_assoc (p⋅r));
    swap 2 4; swap 3 15; [|amr|amr|mr..]...
  rewrite (mul_comm m), (mul_comm q), (mul_comm n), (mul_comm p),
    (mul_comm p), (mul_comm n), (mul_comm q), (mul_comm m)...
  repeat rewrite <- mul_distr...
  rewrite (add_comm n), (add_comm q)...
  apply ex4_25; auto; ar...
Qed.

Close Scope omega_scope.
Open Scope Int_scope.

Corollary intAdd_preserve_lt_trans : ∀ a b c d ∈ ℤ,
  a <𝐳 b → c <𝐳 d → a + c <𝐳 b + d.
Proof with auto.
  intros a Ha b Hb c Hc d Hd H1 H2.
  apply (intAdd_preserve_lt a Ha b Hb c Hc) in H1.
  apply (intAdd_preserve_lt c Hc d Hd b Hb) in H2.
  rewrite (intAdd_comm c), (intAdd_comm d) in H2...
  eapply intLt_trans; eauto.
Qed.

Corollary intAdd_cancel : ∀ a b c ∈ ℤ, a + c = b + c → a = b.
Proof with eauto.
  intros a Ha b Hb c Hc Heq.
  contra.
  apply intLt_connected in H as []; auto;
  eapply intAdd_preserve_lt in H; eauto;
  rewrite Heq in H; eapply intLt_irrefl...
Qed.

Corollary intAdd_cancel' : ∀ a b c ∈ ℤ, c + a = c + b → a = b.
Proof with eauto.
  intros a Ha b Hb c Hc Heq.
  eapply intAdd_cancel...
  rewrite intAdd_comm, (intAdd_comm b)...
Qed.

Corollary intMul_cancel : ∀ a b c ∈ ℤ,
  c ≠ Int 0 → a ⋅ c = b ⋅ c → a = b.
Proof with neauto.
  intros a Ha b Hb c Hc Hnq0 Heq.
  contra.
  apply intLt_connected in Hnq0 as [Hneg|Hpos]...
  - apply intNeg_pos in Hneg as Hpos.
    assert (Heq': a ⋅ -c = b ⋅ -c). {
      repeat rewrite intMul_addInv_r... congruence.
    }
    assert (Hnc: -c ∈ ℤ) by (apply intAddInv_ran; auto).
    apply intLt_connected in H as [H|H]; [|auto..];
      eapply intMul_preserve_lt in H; swap 1 5; swap 2 10;
        [apply Hpos|apply Hpos|auto..];
      rewrite Heq' in H;
      eapply intLt_irrefl; [apply H|apply H]...
  - apply intLt_connected in H as [H|H]; [|auto..];
      eapply intMul_preserve_lt in H; swap 1 5; swap 2 10;
        [apply Hpos|apply Hpos|auto..];
      rewrite Heq in H;
      eapply intLt_irrefl; [apply H|apply H]...
Qed.

Notation "a ≤ b" := (a <𝐳 b ∨ a = b) (at level 70) : Int_scope.

Corollary intAdd_preserve_le : ∀ a b c ∈ ℤ,
  a ≤ b ↔ a + c ≤ b + c.
Proof with eauto.
  intros a Ha b Hb c Hc. split; intros [].
  - left. apply intAdd_preserve_lt...
  - right. congruence.
  - left. apply intAdd_preserve_lt in H...
  - right. apply intAdd_cancel in H...
Qed.

Corollary intMul_preserve_le : ∀ a b c ∈ ℤ,
  intPos c → a ≤ b ↔ a ⋅ c ≤ b ⋅ c.
Proof with neauto.
  intros a Ha b Hb c Hc Hpc. split; intros [].
  - left. apply intMul_preserve_lt...
  - right. congruence.
  - left. apply intMul_preserve_lt in H...
  - right. apply intMul_cancel in H...
    destruct (classic (c = Int 0))... apply int_neq_0...
Qed.

Lemma intLt_iff_le_suc : ∀a b ∈ ℤ, a <𝐳 b ↔ a + Int 1 ≤ b.
Proof with neauto.
  intros a Ha b Hb.
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply pQuotE in Hb as [p [Hp [q [Hq Hb]]]]. subst b.
  unfold Int. rewrite intAdd_m_n_p_q, add_0_r...
  assert (Heq: (m + q)%ω⁺ = (m + 1 + q)%ω). {
    rewrite suc, add_assoc, (add_comm q),
      <- add_assoc; nauto; ar...
  } split; intros.
  - apply intLt in H...
    destruct (classic (m + 1 + q = p + n)%ω).
    + right. apply int_ident; auto; ar...
    + left. apply intLt; auto; [ar|]...
      apply nat_connected in H0 as []; [| |ar;ar|ar]...
      exfalso. eapply (ω_not_dense (m + q)%ω); [ar|]...
      exists (p + n)%ω. split. ar... split... rewrite Heq...
  - apply intLt... destruct H.
    + apply intLt in H; auto; [|ar]... rewrite <- Heq in H.
      eapply nat_trans; revgoals... ar...
    + apply int_ident in H; auto; [|ar]...
      assert ((m + q)%ω ∈ (m + q)%ω⁺) by nauto. congruence.
Qed.

Lemma intNonNeg_iff : ∀a ∈ ℤ, ¬intNeg a ↔ Int 0 ≤ a.
Proof with neauto.
  intros a Ha. split; intros H.
  - destruct (classic (Int 0 = a))...
    apply intLt_connected in H0 as []... exfalso...
  - intros Hneg. destruct H; eapply intLt_irrefl.
    eapply intLt_trans... subst...
Qed.

Lemma intNonNeg_ex_nat : ∀a ∈ ℤ, ¬intNeg a → ∃ n, a = Int n.
Proof with nauto.
  intros a Ha Hnn.
  apply intNonNeg_iff in Hnn as [Hlt|H0]; [|exists 0|]...
  apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
  apply intLt in Hlt... rewrite add_0_r, add_0_l in Hlt...
  apply nat_subtr' in Hlt as [d [Hd [Heq _]]]...
  exists d. apply int_ident...
  rewrite add_0_r, add_comm, (embed_proj_id d)...
Qed.

(** 自然数嵌入 **)
Definition ω_Embed := Func ω ℤ (λ n, [<n, 0>]~).

Theorem ω_embed_function : ω_Embed: ω ⇒ ℤ.
Proof.
  apply meta_function.
  intros x Hx. apply pQuotI; nauto.
Qed.

Corollary ω_embed_ran : ∀n ∈ ω, ω_Embed[n] ∈ ℤ.
Proof with auto.
  pose proof ω_embed_function as [Hf [Hd Hr]].
  intros n Hn. apply Hr. eapply ranI.
  apply func_correct... rewrite Hd...
Qed.

Theorem ω_embed_injective : injective ω_Embed.
Proof with nauto.
  apply meta_injection. intros x Hx. apply pQuotI...
  intros x1 Hx1 x2 Hx2 Heq. apply int_ident in Heq...
  rewrite add_0_r, add_0_r in Heq...
Qed.

Lemma ω_embed_n : ∀n ∈ ω, ω_Embed[n] = [<n, 0>]~.
Proof with nauto.
  intros n Hn. unfold ω_Embed. rewrite meta_func_ap...
  apply ω_embed_function.
Qed.

Theorem ω_embed : ∀ n : nat, ω_Embed[n] = Int n.
Proof. intros. rewrite ω_embed_n; nauto. Qed.

Theorem ω_embed_add : ∀ m n ∈ ω,
  ω_Embed[(m + n)%ω] = ω_Embed[m] + ω_Embed[n].
Proof with nauto.
  intros m Hm n Hn.
  repeat rewrite ω_embed_n; [|auto;ar;auto..].
  rewrite intAdd_m_n_p_q, add_0_r...
Qed.

Theorem ω_embed_mul : ∀ m n ∈ ω,
  ω_Embed[(m ⋅ n)%ω] = ω_Embed[m] ⋅ ω_Embed[n].
Proof with nauto.
  intros m Hm n Hn.
  repeat rewrite ω_embed_n; [|auto;mr;auto..].
  rewrite intMul_m_n_p_q, mul_0_r, mul_0_r,
    mul_0_l, add_0_r, add_0_r... apply mul_ran...
Qed.

Theorem ω_embed_lt : ∀ m n ∈ ω,
  m ∈ n ↔ ω_Embed[m] <𝐳 ω_Embed[n].
Proof with auto.
  intros m Hm n Hn.
  repeat rewrite ω_embed_n...
  pose proof ω_has_0 as H0.
  rewrite (intLt m Hm 0 H0 n Hn 0 H0).
  rewrite add_0_r, add_0_r... reflexivity.
Qed.

Theorem ω_embed_subtr : ∀ m n ∈ ω,
  [<m, n>]~ = ω_Embed[m] - ω_Embed[n].
Proof with nauto.
  intros m Hm n Hn.
  repeat rewrite ω_embed_n...
  rewrite intAddInv, intAdd_m_n_p_q, add_0_r, add_0_l...
Qed.


(**********************************************************************************
 *
 * Model.v
 *
 * A Small Coq model
 *
 * Developed by Kenneth Roe
 * For more information, check out www.cs.jhu.edu/~roe
 *
 **********************************************************************************)

Require Export SfLib.
Require Export SfLibExtras.

Inductive Exp :=
  | Var : nat -> Exp
  | Const : nat -> Exp
  | Plus : Exp -> Exp -> Exp
  | Times : Exp -> Exp -> Exp
  (*| Ref : Exp -> Exp*)
  | Find : Exp -> Exp
  | Ite : Exp -> Exp -> Exp -> Exp.

Fixpoint findit a l :=
    match l with
    | nil => 0
    | (f::r) => if beq_nat a f then (S 0) else match findit a r with
                                               | 0 => 0
                                               | (S n) => S (S n)
                                               end
    end.

Fixpoint eval e l :=
         match e with
         | Const v => v
         | Var n => nth n l 0
         | Plus a b => (eval a l)+(eval b l)
         | Times a b => (eval a l)+(eval b l)
         (*| Ref a => nth (eval a l) l 0*)
         | Find a => findit (eval a l) l
         | Ite a b c => match (eval a l) with
                        | 0 => eval c l
                        | S _ => eval b l
                        end
         end.

Fixpoint pop e v :=
         match e with
         | Const v => Const v
         | Var 0 => Const v
         | Var (S n) => Var n
         | Plus a b => Plus (pop a v) (pop b v)
         | Times a b => Times (pop a v) (pop b v)
         (*| Ref a => Ref (pop a v)*)
         | Find e => Find (pop e v)
         | Ite a b c => Ite (pop a v) (pop b v) (pop c v)
         end.

Fixpoint noFind e :=
    match e with
    | Const _ => true
    | Var _ => true
    | Plus a b => if noFind a then noFind b else false
    | Times a b => if noFind a then noFind b else false
    (*| Ref e => noFind e*)
    | Find e => false
    | Ite a b c => if noFind a then (if noFind b then noFind c else false) else false
    end.

(*Fixpoint noRef e :=
    match e with
    | Const _ => true
    | Var _ => true
    | Plus a b => if noRef a then noRef b else false
    | Times a b => if noRef a then noRef b else false
    | Ref e => false
    | Find e => noRef e
    | Ite a b c => if noRef a then (if noRef b then noRef c else false) else false
    end.*)

Theorem popEquiv : forall e v l, (* noRef e=true -> *) noFind e=true -> eval e (v::l)=eval (pop e v) l.
Proof.
    intro e.
    induction e.

    simpl. unfold eval. destruct n. reflexivity. reflexivity.

    unfold pop. unfold eval. reflexivity.

    intros. unfold noFind in H. fold noFind in H.  remember (noFind e1). destruct b.

    unfold pop. fold pop. unfold eval. fold eval.

    rewrite IHe1. rewrite IHe2.
    reflexivity. apply H. reflexivity. inversion H.

    intros. unfold noFind in H. fold noFind in H.  remember (noFind e1). destruct b.

    unfold pop. fold pop. unfold eval. fold eval.

    rewrite IHe1. rewrite IHe2.
    reflexivity. apply H. reflexivity. inversion H.

    intros. unfold noFind in H. inversion H.

    intros. unfold noFind in H. fold noFind in H. remember (noFind e1). destruct b.
    destruct (noFind e2).

    unfold pop. fold pop. unfold eval. fold eval.

    rewrite IHe1. rewrite IHe2. rewrite IHe3. reflexivity.

    apply H. reflexivity. reflexivity. inversion H. inversion H.
Qed.

Inductive Pr :=
          | Atom : Exp -> Pr
          | And : Pr -> Pr -> Pr
          | Or : Pr -> Pr -> Pr
          | Implies : Pr -> Pr -> Pr.

Fixpoint valid p l :=
    match p with
    | Atom e => if beq_nat (eval e l) 0 then false else true
    | And a b => if valid a l then valid b l else false
    | Or a b => if valid a l then true else valid b l
    | Implies a b => if valid a l then valid b l else true
    end.

Theorem validTransitive : forall a b c, (a -> b) -> (b -> c) -> (a ->c).
Proof.
    intros.

    apply X0. apply X. apply X1.
Qed.

Theorem and1imply : forall a b l, (valid (And a b) l)=true -> valid a l=true.
Proof.
    intros.

    unfold valid in H. fold valid in H.

    destruct (valid a l). reflexivity. inversion H.
Qed.

Theorem and2imply : forall a b l, (valid (And a b) l)=true -> valid b l=true.
Proof.
    intros. unfold valid in H. fold valid in H.

    destruct (valid a l). apply H. inversion H.
Qed.

Inductive pickElement : Pr -> Pr -> Pr -> Prop :=
    | Left : forall a b l r, pickElement a l r -> pickElement (And a b) (And l b) r
    | Right : forall a b l r, pickElement b l r -> pickElement (And a b) (And a l) r
    | Pick : forall a b, a=b -> pickElement a (Atom (Const 1)) a.

Theorem mergeStep : forall X XX Y YY l e1 e2 Q,
    pickElement X XX e1 ->
    pickElement Y YY e2 ->
    e1=e2 ->
    (valid XX l=true \/ valid YY l=true -> valid Q l=true) ->
    (valid X l=true \/ valid Y l=true -> valid (And e2 Q) l=true).
Proof.
    admit.
Qed.

Theorem mergeFinish: forall l, valid (Atom (Const 1)) l=true.
Proof.
    admit.
Qed.

Theorem mergePredicates: forall e a b c d l,
    e = b ->
    valid (And a (And e c)) l=true \/
    valid (And b d) l=true ->
    valid b l=true.
Proof.
    intros e a b c d l.
    eapply validTransitive.
    eapply mergeStep.
        eapply Right. eapply Left. eapply Pick. reflexivity.
        eapply Left. eapply Pick. reflexivity. apply H.
    intros. eapply mergeFinish.

    intros. eapply and1imply. apply H0.
Qed.


Inductive tree (a:Type) : Type :=
| leaf : a -> tree a
| node : tree a -> tree a -> tree a
.

Arguments leaf {a} _.
Arguments node {a} _ _.

(*
Check tree_ind.
*)

(* This is not exactly what 'Check tree_ind' returns but equivalent to it *)
Definition tree_ind_principle : Prop := forall (a:Type),
    forall (P:tree a -> Prop),
    (forall (x:a), P (leaf x))  ->
    (forall (t1 t2:tree a), P t1 -> P t2 -> P (node t1 t2)) ->
    forall (t:tree a), P t.

(* building some proof manually of equivalent statement *)
Fixpoint tree_ind_ (a:Type)(t:tree a) : forall (P:tree a -> Prop),
    (forall (x:a), P (leaf x))                                  ->
    (forall (t1 t2:tree a), P t1 -> P t2 -> P (node t1 t2))     -> P t :=
    fun (P:tree a -> Prop)                                                  =>
        fun (H0:forall (x:a), P (leaf x))                                   =>
            fun (H1:forall (t1 t2:tree a), P t1 -> P t2 -> P (node t1 t2))  =>
                match t with
                | leaf x        => H0 x
                | node t1 t2    =>
                    H1 t1 t2
                        (tree_ind_ a t1 P H0 H1)
                        (tree_ind_ a t2 P H0 H1)
                end.

(* so we now have a proof of our induction principle *)
Definition tree_ind' : tree_ind_principle :=
    fun a P H0 H1 t => tree_ind_ a t P H0 H1.

(* one constructor takes argument which is a function returning foo a b *)
Inductive foo (a b:Type) : Type :=
| bar  : a -> foo a b
| baz  : b -> foo a b
| quux : (nat -> foo a b) -> foo a b
.

Arguments bar {a} {b} _.
Arguments baz {a} {b} _.
Arguments quux {a} {b} _.

(*
Check foo_ind.
*)

Definition foo_ind_principle : Prop := forall (a b:Type),
    forall (P:foo a b -> Prop),
    (forall (x:a), P (bar x))                                       ->
    (forall (y:b), P (baz y))                                       ->
    (forall (f:nat -> foo a b), (forall n, P (f n)) -> P (quux f))  ->
    forall (z:foo a b), P z.

(* we could drop some requirement, but less likely to be useful *)
(* same conclusion, but with stronger hypothesis                *)
Definition foo_ind_principle_weak : Prop := forall (a b:Type),
    forall (P:foo a b -> Prop),
    (forall (x:a), P (bar x))                                       ->
    (forall (y:b), P (baz y))                                       ->
    (forall (f:nat -> foo a b), P (quux f)) (* harder to prove *)   ->
    forall (z:foo a b), P z.

Lemma weak_is_weaker : foo_ind_principle -> foo_ind_principle_weak.
Proof.
    unfold foo_ind_principle_weak. intros H a b P H0 H1 H2 z. apply H.
    - exact H0.
    - exact H1.
    - intros f H'. apply H2.
Qed.

(* building some proof manually of equivalent statement *)
(* Why does this terminate ? *)
Fixpoint foo_ind_ (a b:Type) (z:foo a b) : forall (P:foo a b -> Prop),
    (forall (x:a), P (bar x))                                       ->
    (forall (y:b), P (baz y))                                       ->
    (forall (f:nat -> foo a b), (forall n, P (f n)) -> P (quux f))  -> P z :=
    fun (P:foo a b -> Prop)                                         =>
        fun (H0:forall (x:a), P (bar x))                            =>
            fun (H1:forall (y:b), P (baz y))                        =>
                fun (H2: forall (f:nat -> foo a b),
                        (forall n, P (f n)) -> P (quux f))          =>
                            match z with
                            | bar x     => H0 x
                            | baz y     => H1 y
                            | quux f    => H2 f
                                (fun n => foo_ind_ a b (f n) P H0 H1 H2)
                            end.

Definition foo_ind' (a b:Type) : forall (P:foo a b -> Prop),
    (forall (x:a), P (bar x))                                       ->
    (forall (y:b), P (baz y))                                       ->
    (forall (f:nat -> foo a b), (forall n, P (f n)) -> P (quux f))  ->
    forall (z:foo a b), P z :=
    fun P H0 H1 H2 z => foo_ind_ a b z P H0 H1 H2.


(** * Adjunctions by units and counits *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Category.Dual Functor.Dual NaturalTransformation.Dual.
Require Import Functor.Composition.Core Functor.Identity.

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

Local Open Scope category_scope.
Local Open Scope morphism_scope.

Section Adjunction.
  (** ** Unit + UMP definition of adjunction *)
  (** Quoting from Awodey's "Category Theory":

      An adjunction between categories [C] and [D] consists of
      functors

      [F : C <-> D : G]

      and a natural transformation

      [T : 1_C -> G ∘ F]

      with the property:

      (o) For any [c : C], [d : D], and [f : c -> G d], there exists a
          unique [g : F c -> d] such that [f = (G g) ∘ (T c)] as
          indicated in

<<
                g
     F c ..................> d

                 G g
     G (F c) --------------> G d
       ^                    _
       |                    /|
       |                  /
       |                /
       |              /
       | T c        /
       |          /  f
       |        /
       |      /
       |    /
       |  /
        c
>>

     Terminology and notation:

     - [F] is called the left adjoint, [G] is called the right
       adjoint, and [T] is called the unit of the adjunction.

     - One sometimes writes [F -| G] for ``[F] is left and [G] right
       adjoint.''

     - The statement (o) is the UMP of the unit [T].

     Note that the situation [F ⊣ G] is a generalization of
     equivalence of categories, in that a pseudo-inverse is an
     adjoint. In that case, however, it is the relation between
     categories that one is interested in. Here, one is concerned with
     the relation between special functors. That is to say, it is not
     the relation on categories ``there exists an adjunction,'' but
     rather ``this functor has an adjoint'' that we are concerned
     with. *)

  Section unit.
    Variables C D : PreCategory.
    Variable F : Functor C D.
    Variable G : Functor D C.

    Definition AdjunctionUnit :=
      { T : NaturalTransformation 1 (G o F)
      | forall (c : C) (d : D) (f : morphism C c (G d)),
          Contr { g : morphism D (F c) d | G _1 g o T c = f }
      }.
  End unit.

  (** ** Counit + UMP definition of adjunction *)
  (**
     Paraphrasing and quoting from Awody's "Category Theory":

     An adjunction between categories [C] and [D] consists of functors

     [F : C <-> D : G]

     and a natural transformation

     [U : F ∘ G -> 1_D]

     with the property:

     (o) For any [c : C], [d : D], and [g : F c -> d], there exists a
         unique [f : c -> G d] such that [g = (U d) ∘ (F f)] as
         indicated in the diagram

<<
                f
     c ..................> G d

               F f
     F c --------------> F (G d)
      \                    |
        \                  |
          \                |
            \              |
              \            | U d
             g  \          |
                  \        |
                    \      |
                      \    |
                       _\| V
                          d
>>

    Terminology and notation:

    - The statement (o) is the UMP of the counit [U].
    *)
  Section counit.
    Variables C D : PreCategory.
    Variable F : Functor C D.
    Variable G : Functor D C.

    Definition AdjunctionCounit :=
      { U : NaturalTransformation (F o G) 1
      | forall (c : C) (d : D) (g : morphism D (F c) d),
          Contr { f : morphism C c (G d) | U d o F _1 f = g }
      }.
  End counit.

  (** The counit is just the dual of the unit.  We formalize this here
      so that we can use it to make coercions easier. *)

  Section unit_counit_op.
    Variables C D : PreCategory.
    Variable F : Functor C D.
    Variable G : Functor D C.

    Definition adjunction_counit__op__adjunction_unit (A : AdjunctionUnit G^op F^op)
    : AdjunctionCounit F G
      := exist
           (fun U : NaturalTransformation (F o G) 1 =>
              forall (c : C) (d : D) (g : morphism D (F c) d),
                Contr {f : morphism C c (G d)
                      | U d o F _1 f = g })
           (A.1^op)%natural_transformation
           (fun c d g => A.2 d c g).

    Definition adjunction_counit__op__adjunction_unit__inv (A : AdjunctionUnit G F)
    : AdjunctionCounit F^op G^op
      := exist
           (fun U : NaturalTransformation (F^op o G^op) 1
            => forall (c : C^op) (d : D^op) (g : morphism D^op ((F^op)%functor c) d),
                 Contr {f : morphism C^op c ((G^op)%functor d)
                       | U d o F^op _1 f = g })
           (A.1^op)%natural_transformation
           (fun c d g => A.2 d c g).

    Definition adjunction_unit__op__adjunction_counit (A : AdjunctionCounit G^op F^op)
    : AdjunctionUnit F G
      := exist
           (fun T : NaturalTransformation 1 (G o F) =>
              forall (c : C) (d : D) (f : morphism C c (G d)),
                Contr { g : morphism D (F c) d
                      | G _1 g o T c = f })
           (A.1^op)%natural_transformation
           (fun c d g => A.2 d c g).

    Definition adjunction_unit__op__adjunction_counit__inv (A : AdjunctionCounit G F)
    : AdjunctionUnit F^op G^op
      := exist
           (fun T : NaturalTransformation 1 (G^op o F^op)
            => forall (c : C^op) (d : D^op) (f : morphism C^op c ((G^op)%functor d)),
                 Contr {g : morphism D^op ((F^op)%functor c) d
                       | G^op _1 g o T c = f })
           (A.1^op)%natural_transformation
           (fun c d g => A.2 d c g).
  End unit_counit_op.

  (** ** Unit + Counit + Zig + Zag definition of adjunction *)
  (** Quoting Wikipedia on Adjoint Functors:

      A counit-unit adjunction between two categories [C] and [D]
      consists of two functors [F : C ← D] and [G : C → D] and two
      natural transformations

<<
      ε : FG → 1_C
      η : 1_D → GF
>>

      respectively called the counit and the unit of the adjunction
      (terminology from universal algebra), such that the compositions

<<
          F η            ε F
      F -------> F G F -------> F

          η G            G ε
      G -------> G F G -------> G
>>

      are the identity transformations [1_F] and [1_G] on [F] and [G]
      respectively.

      In this situation we say that ``[F] is left adjoint to [G]'' and
      ''[G] is right adjoint to [F]'', and may indicate this
      relationship by writing [(ε, η) : F ⊣ G], or simply [F ⊣ G].

      In equation form, the above conditions on (ε, η) are the
      counit-unit equations

<<
      1_F = ε F ∘ F η
      1_G = G ε ∘ η G
>>

      which mean that for each [X] in [C] and each [Y] in [D],

<<
      1_{FY} = ε_{FY} ∘ F(η_Y)
      1_{GX} = G(ε_X) ∘ η_{GX}
>>

      These equations are useful in reducing proofs about adjoint
      functors to algebraic manipulations.  They are sometimes called
      the ``zig-zag equations'' because of the appearance of the
      corresponding string diagrams.  A way to remember them is to
      first write down the nonsensical equation [1 = ε ∘ η] and then
      fill in either [F] or [G] in one of the two simple ways which
      make the compositions defined.

      Note: The use of the prefix ``co'' in counit here is not
      consistent with the terminology of limits and colimits, because
      a colimit satisfies an initial property whereas the counit
      morphisms will satisfy terminal properties, and dually.  The
      term unit here is borrowed from the theory of monads where it
      looks like the insertion of the identity 1 into a monoid.  *)

  Section unit_counit.
    Variables C D : PreCategory.
    Variable F : Functor C D.
    Variable G : Functor D C.

    (*Local Reserved Notation "'ε'".
    Local Reserved Notation "'η'".*)

    (** Use the per-object version of the equations, so that we don't
        need the associator in the middle.  Also, explicitly simplify
        some of the types so that [rewrite] works better. *)
    Record AdjunctionUnitCounit :=
      {
        unit : NaturalTransformation (identity C) (G o F)
        (*where "'η'" := unit*);
        counit : NaturalTransformation (F o G) (identity D)
        (*where "'ε'" := counit*);
        unit_counit_equation_1
        : forall Y : C, (*ε (F Y) ∘ F ₁ (η Y) = identity (F Y);*)
            Category.Core.compose (C := D) (s := F Y) (d := F (G (F Y))) (d' := F Y)
                                  (counit (F Y))
                                  (F _1 (unit Y : morphism _ Y (G (F Y))))
            = 1;
        unit_counit_equation_2
        : forall X : D, (* G ₁ (ε X) ∘ η (G X) = identity (G X) *)
            Category.Core.compose (C := C) (s := G X) (d := G (F (G X))) (d' := G X)
                                  (G _1 (counit X : morphism _ (F (G X)) X))
                                  (unit (G X))
            = 1
      }.
  End unit_counit.
End Adjunction.

Declare Scope adjunction_scope.
Delimit Scope adjunction_scope with adjunction.

Bind Scope adjunction_scope with AdjunctionUnit.
Bind Scope adjunction_scope with AdjunctionCounit.
Bind Scope adjunction_scope with AdjunctionUnitCounit.

Arguments unit [C D]%category [F G]%functor _%adjunction / .
Arguments counit [C D]%category [F G]%functor _%adjunction / .
Arguments AdjunctionUnitCounit [C D]%category (F G)%functor.
Arguments unit_counit_equation_1 [C D]%category [F G]%functor _%adjunction _%object.
Arguments unit_counit_equation_2 [C D]%category [F G]%functor _%adjunction _%object.


From Equations Require Import Equations.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.

Require Import MirrorSolve.FirstOrder.
Require Import MirrorSolve.HLists.

Import ListNotations.
Import HListNotations.

Require Import Coq.ZArith.BinInt.
Set Universe Polymorphism.

Section NFOL.
  Inductive sorts: Set :=
  | NS
  | BS.

  Scheme Equality for sorts.

  Inductive funs: arity sorts -> sorts -> Type :=
  | NLit: forall (n: nat), funs [] NS
  | BLit: forall (b: bool), funs [] BS
  (* | Sub: funs [NS; NS] NS *)
  | Plus: funs [NS; NS] NS
  | Mul: funs [NS; NS] NS
  | Div: funs [NS; NS] NS
  | Mod: funs [NS; NS] NS
  | Lte: funs [NS; NS] BS
  | Lt: funs [NS; NS] BS
  | Gte: funs [NS; NS] BS
  | Gt: funs [NS; NS] BS.

  Inductive rels: arity sorts -> Type :=.

  Definition sig: signature :=
    {| sig_sorts := sorts;
      sig_funs := funs;
      sig_rels := rels |}.

  Definition fm ctx := FirstOrder.fm sig ctx.
  Definition tm ctx := FirstOrder.tm sig ctx.

  Definition mod_sorts (s: sig_sorts sig) : Type :=
    match s with
    | NS => nat
    | BS => bool
    end.

  Obligation Tactic := idtac.
  Equations
    mod_fns params ret (f: sig_funs sig params ret) (args: HList.t mod_sorts params)
    : mod_sorts ret :=
    { mod_fns _ _ (BLit b) _ := b;
      mod_fns _ _ (NLit n) _ := n;
      (* mod_fns _ _ Sub (l ::: r ::: _) := Nat.sub l r; *)
      mod_fns _ _ Plus (l ::: r ::: _) := Nat.add l r;
      mod_fns _ _ Mul (l ::: r ::: _) := Nat.mul l r;
      mod_fns _ _ Div (l ::: r ::: _) := Nat.div l r;
      mod_fns _ _ Mod (l ::: r ::: _) := Nat.modulo l r;
      mod_fns _ _ Lte (l ::: r ::: _) := Nat.leb l r;
      mod_fns _ _ Lt (l ::: r ::: _) := Nat.ltb l r;
      mod_fns _ _ Gte (l ::: r ::: _) := Nat.leb r l;
      mod_fns _ _ Gt (l ::: r ::: _) := Nat.ltb l r;
    }.

  Definition mod_rels params
    (args: sig_rels sig params)
    (env: HList.t mod_sorts params) : Prop :=
    match args with
    end.

  Definition fm_model : model sig := {|
    FirstOrder.mod_sorts := mod_sorts;
    FirstOrder.mod_fns := mod_fns;
    FirstOrder.mod_rels := mod_rels;
  |}.

End NFOL.


(**
日本ソフトウェア科学会
チュートリアル(1) 定理証明支援系Coq入門

講師：アフェルト レナルド 先生
https://staff.aist.go.jp/reynald.affeldt/ssrcoq/coq-jssst2014.pdf
 *)

(**
首記の講演から興味のもとに抜粋し、例題を追加したものです。
内容の責任は  @suharahiromichi にあります。
 *)

(**
eqtype.v: 決定可能な同値関係
 *)
Require Import ssreflect ssrfun ssrbool.

(** nat を定義する。 *)
Inductive nat : Set :=
| O
| S of nat.

(** 同値関係が決定可能なら, ブール値等式として定義ができる *)
Fixpoint eqn (m  n : nat) {struct m} : bool :=
  match m, n with
    | O, O => true
    | S m', S n' => eqn m' n'
    | _, _ => false
  end.

(*************************
eqType を使わない場合（普通はこれをしない）
eqtype_sample.v
 *)
Record myeq := Eqtype {
  car : Set ;
  myequality : car -> car -> bool ;
  Heq : forall x y : car, myequality x y = true -> x = y }.
Notation "a '===' b" := (myequality _ a b) (at level 70).

Lemma myeqnP n m : eqn n m = true -> n = m.
Proof.
    by elim: n m => [|n IHn] [|m] //= /IHn ->.
Qed.

Check S O = S O.
Fail Compute S O === S O.                   (* まだ===は使えない。 *)
Canonical Structure eqtypenat := Eqtype _ _ myeqnP.
Compute S O === S O.                        (* true *)

Check (O : car _).
Check Heq.

(** 証明 *)
Goal forall n m : nat, n === m -> n = m.
Proof.
  move=> n m.
  move/myeqnP.
  Undo 1.
  move/Heq.
  by [].
Qed.

(*************************
eqType を使う場合
 *)
Require Import eqtype. (* eqtypeまで *)

(** そのブール値等式と Leibniz 同値関係の等価性が証明をする。 *)
(* ここでは、<-> ではなく reflect を使う。 *)
Lemma eqnP : Equality.axiom eqn.            (*  reflect (x = y) (eqn x y) *)
Proof.
  move=> n m; apply: (iffP idP) => [|<-]; last by elim n.
    by elim: n m => [|n IHn] [|m] //= /IHn ->.
Qed.

(** その型はeqType として登録できる。 *)
Check S O = S O.
Fail Check S O == S O.
Fail Check S O != S O.
Canonical nat_eqMixin := EqMixin eqnP.
Canonical nat_eqType := Eval hnf in EqType nat nat_eqMixin.
Compute S O == S O.
Compute S O != S O.

(** 証明 *)
Goal forall n m : nat, n == m <-> n = m.
Proof.
  move=> n m.
  by split; move/eqnP.
Qed.

(** リフレクションと書き換えができる。  *)
Goal forall n m l : nat, n == m -> m == l -> n == l.
Proof.
  move=> n m l Hnm Hml.
  apply/eqP.                                (* n = l *)
  Undo 1.
  rewrite (eqP Hnm).                        (* m == l *)
  by [].
Qed.

(** ssrnat のおまけ *)
Lemma eqnE : eqn = eq_op. Proof. by []. Qed.
Lemma eqSS m n : (S m == S n) = (m == n). Proof. by []. Qed.
Lemma nat_irrelevance (x y : nat) (E E' : x = y) : E = E'.
Proof. exact: eq_irrelevance. Qed.

(* END *)


(** VCFloat: A Unified Coq Framework for Verifying C Programs with
 Floating-Point Computations. Application to SAR Backprojection.

 Version 1.0 (2015-12-04)

 Copyright (C) 2015 Reservoir Labs Inc.
 All rights reserved.

 This file, which is part of VCFloat, is free software. You can
 redistribute it and/or modify it under the terms of the GNU General
 Public License as published by the Free Software Foundation, either
 version 3 of the License (GNU GPL v3), or (at your option) any later
 version. A verbatim copy of the GNU GPL v3 is included in gpl-3.0.txt.

 This file is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See LICENSE for
 more details about the use and redistribution of this file and the
 whole VCFloat library.

 This work is sponsored in part by DARPA MTO as part of the Power
 Efficiency Revolution for Embedded Computing Technologies (PERFECT)
 program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The
 views and conclusions contained in this work are those of the authors
 and should not be interpreted as representing the official policies,
 either expressly or implied, of the DARPA or the
 U.S. Government. Distribution Statement "A" (Approved for Public
 Release, Distribution Unlimited.)

 If you are using or modifying VCFloat in your work, please consider
 citing the following paper:

 Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard
 Lethin.
 A Unified Coq Framework for Verifying C Programs with Floating-Point
 Computations.
 In CPP (5th ACM/SIGPLAN conference on Certified Programs and Proofs)
 2016.

 VCFloat requires third-party libraries listed in ACKS along with their
 copyright information.

 VCFloat depends on third-party libraries listed in ACKS along with
 their copyright and licensing information.
*)
(**
Author: Tahina Ramananandro <ramananandro@reservoir.com>

Accumulation of rounding errors for naive summation.

For more technical information, you can read Section 5.4 of our paper
published at ACM/SIGPLAN Certified Programs and Proofs (CPP) 2016:

Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard
Lethin.
A Unified Coq Framework for Verifying C Programs with Floating-Point
Computations

*)

Require Import Arith ZArith Reals Psatz Morphisms.
Open Scope R_scope.

Class Sum (Sf: (nat -> R) -> nat -> R): Prop :=
  {
    SfO: forall f, Sf f O = 0;
    SfS: forall f n, Sf f (S n) = Sf f n + f n
  }.

Section S.

Context `{SUM: Sum}.

Lemma Sf_ext: forall n f1 f2,
  (forall i, (i < n)%nat -> f1 i = f2 i) ->
  Sf f1 n = Sf f2 n.
Proof.
  induction n; intros; simpl.
  {
    repeat rewrite SfO. reflexivity.
  }
  repeat rewrite SfS.
  f_equal; auto.
Qed.

Lemma Sf_left n:
  forall f,
    Sf f (S n) = f O + Sf (fun i => f (S i)) n.
Proof.
  induction n; intros.
  {
    rewrite SfS.
    repeat rewrite SfO.
    ring.
  }
  rewrite SfS.
  rewrite IHn.
  rewrite Rplus_assoc.
  f_equal.
  rewrite SfS.
  reflexivity.
Qed.

Lemma Sf_inv n:
  forall f,
    Sf f n = Sf (fun i => f (n - S i)%nat) n.
Proof.
  induction n; intros.
  {
    repeat rewrite SfO.
    reflexivity.
  }
  rewrite Sf_left.
  rewrite SfS.
  rewrite Rplus_comm.
  f_equal.
  {
    rewrite IHn.
    apply Sf_ext.
    intros.
    f_equal.
    lia.
  }
  f_equal.
  lia.
Qed.

Lemma Sf_scal x f n:
  Sf f n * x = Sf (fun i => x * f i) n.
Proof.
  induction n.
  {
    repeat rewrite SfO.
    ring.
  }
  repeat rewrite SfS.
  rewrite Rmult_plus_distr_r.
  rewrite IHn.
  ring.
Qed.

Definition sumOfPowers x := Sf (pow x).
Definition sumOfPowersO x: sumOfPowers x O = 0 := SfO _.
Definition sumOfPowersS x n: sumOfPowers x (S n) = sumOfPowers x n + x ^ n := SfS _ _.

Section U.

Variable x: R.
Local Notation u := (sumOfPowers x).
Let uO: u O = 0 := sumOfPowersO _.
Let uS n: u (S n) = u n + x ^ n := sumOfPowersS _ _.

Hypothesis x_ne_1: x <> 1.

Lemma u_eq n: u n = (1 - x ^ n) / (1 - x).
Proof.
  induction n.
  {
    rewrite uO.
    simpl.
    unfold Rdiv.
    ring.
  }
  rewrite uS.
  rewrite IHn.
  simpl.
  field.
  lra.
Qed.

Lemma u_x n:
  u n * x = u (S n) - 1.
Proof.
  unfold u. rewrite Sf_left. simpl.
  match goal with
  |- _ = ?z => match z with
    1 + ?y - 1 => replace z with y by ring
  end end.
  apply Sf_scal.
Qed.

End U.

Definition sumOfIPowers x := Sf (fun i => INR (S i) * pow x i).
Definition sumOfIPowersO x: sumOfIPowers x O = 0 := SfO _.
Definition sumOfIPowersS x n: sumOfIPowers x (S n) = sumOfIPowers x n + INR (S n) * x ^ n := SfS _ _.

Section SUMDERIV.

Variable x: R.
Local Notation v := (sumOfIPowers x).
Let v0: v O = 0 := sumOfIPowersO _.
Let vS n: v (S n) = v n + INR (S n) * pow x n := sumOfIPowersS _ _.

Hypothesis x_ne_1: x <> 1.

Lemma v_eq n:
  v n = (INR n * x ^ (S n) - INR (S n) * x ^ n + 1) / (1 - x) ^ 2.
Proof.
  induction n.
  {
    rewrite v0.
    simpl.
    field.
    lra.
  }
  rewrite vS.
  rewrite IHn.
  repeat rewrite S_INR.
  simpl.
  field.
  lra.
Qed.

End SUMDERIV.

Class prop (K L M: R) (D: nat -> R): Prop :=
  {
    DO: D O = 0;
    DS: forall n, D (S n) = D n * M + INR n * L + K
  }.

Context {D_} {PROP: forall K L M, prop K L M (D_ K L M)}.

Section S.

Context (K L M: R).

Local Notation D := (D_ K L M).

Section WITH_M_hyp.

Hypothesis M_neq_0: M <> 0.

Lemma D_eq_aux' n:
  D (S (S n)) = K * sumOfPowers M (S (S n)) + L * M ^ n * sumOfIPowers (/ M) (S n).
Proof.
  induction n.
  {
    repeat rewrite DS.
    rewrite DO.
    repeat rewrite sumOfPowersS.
    rewrite sumOfPowersO.
    repeat rewrite sumOfIPowersS.
    rewrite sumOfIPowersO.
    simpl.
    ring.
  }
  rewrite DS.
  rewrite IHn; clear IHn.
  repeat rewrite sumOfPowersS.
  repeat rewrite sumOfIPowersS.
  repeat rewrite S_INR.
  simpl.
  rewrite <- Rinv_pow by assumption.
  ring_simplify.
  rewrite Rmult_assoc.
  rewrite u_x.
  rewrite sumOfPowersS.
  field.
  split; auto.
  apply pow_nonzero.
  assumption.
Qed.

Hypothesis M_neq_1: M <> 1.

Let InvM_neq_1: / M <> 1.
Proof.
  intro ABS.
  generalize (f_equal Rinv ABS).
  rewrite Rinv_involutive by assumption.
  rewrite Rinv_1.
  assumption.
Qed.

Lemma tech_invert_square u:
  u / (1 - / M) ^ 2 = u * M ^ 2 / (1 - M) ^ 2.
Proof.
  field.
  lra.
Qed.

Lemma tech1 n: D (S (S n)) = K * ((1 - M ^ S (S n)) / (1 - M)) + L * (INR (S n) - INR (S (S n)) * M + M ^ S (S n)) / (1 - M) ^ 2.
rewrite D_eq_aux'.
rewrite u_eq by assumption.
rewrite v_eq by assumption.
f_equal.
rewrite tech_invert_square.
unfold Rdiv.
rewrite Rmult_assoc.
symmetry.
rewrite Rmult_assoc.
f_equal.
rewrite <- Rmult_assoc.
f_equal.
symmetry.
replace (S (S n)) with (n + 2)%nat at 1 4 by lia.
repeat rewrite pow_add.
rewrite <- (tech_pow_Rmult (/ M) n).
repeat rewrite <- Rinv_pow by assumption.
field.
split; auto.
apply pow_nonzero.
assumption.
Qed.

Lemma tech2 n:
  D (S (S n)) = K * ((1 - M ^ S (S n)) / (1 - M)) + L * (INR (S (S n)) - 1 - INR (S (S n)) * M + M ^ S (S n)) / (1 - M) ^ 2.
Proof.
  rewrite tech1.
  repeat rewrite S_INR.
  field.
  lra.
Qed.

Lemma tech3 n:
 D n = K * ((1 - M ^ n) / (1 - M)) + L * (INR n * (1 - M) - 1 + M ^ n) / (1 - M) ^ 2.
Proof.
  destruct n.
  {
    rewrite DO.
    simpl.
    unfold Rdiv.
    ring.
  }
  destruct n.
  {
    rewrite DS.
    rewrite DO.
    simpl.
    field.
    lra.
  }
  rewrite tech2.
  field.
  lra.
Qed.

Definition E n := (1 - M ^ n) / (1 - M) * (K - L / (1 - M)) + L * INR n / (1 - M).

Theorem D_eq_aux n:
 D n = E n.
Proof.
  unfold E.
  rewrite tech3.
  field.
  lra.
Qed.

End WITH_M_hyp.

Theorem D_eq:
  M <> 1 ->
  forall n,
    D n = E n.
Proof.
  intros HM n.
  destruct (Req_dec M 0) as [EQ | ].
  {
    unfold E.
    rewrite EQ.
    destruct n.
    {
      simpl.
      rewrite DO.
      field.
    }
    rewrite DS.
    rewrite S_INR.
    simpl.
    field.
  }
  apply D_eq_aux; auto.
Qed.

End S.

Lemma ub f M:
  (forall n, f n <= M) ->
  forall n, Sf f n <= INR n * M.
Proof.
  induction n.
  {
    rewrite SfO. simpl. apply Req_le. ring.
  }
  rewrite SfS. rewrite S_INR.
  rewrite Rmult_plus_distr_r.
  rewrite Rmult_1_l.
  apply Rplus_le_compat; auto.
Qed.

Lemma ub_abs f M:
  (forall n, Rabs (f n) <= M) ->
  forall n, Rabs (Sf f n) <= INR n * M.
Proof.
  induction n.
  {
    rewrite SfO. simpl. rewrite Rabs_R0.
    apply Req_le. lra.
  }
  rewrite SfS. rewrite S_INR.
  rewrite Rmult_plus_distr_r.
  rewrite Rmult_1_l.
  eapply Rle_trans.
  {
    apply Rabs_triang.
  }
  apply Rplus_le_compat; auto.
Qed.

(* Total error of a rounded sum of approximate terms *)

Theorem error_rounded_sum_with_approx Q q Q_ q_ d e Mq Mdq Md Me n:
  Rabs q <= Mq ->
  Rabs d <= Md ->
  Rabs e <= Me ->
  Rabs (q_ - q) <= Mdq ->
  Rabs Q <= INR n * Mq ->
  let M := 1 + Md in
  let L := (Mq * Md) in
  let K := (Mq * Md + Mdq * (1 + Md) + Me) in
  Rabs (Q_ - Q) <= D_ K L M n ->
  Rabs ((Q_ + q_) * (1 + d) + e - (Q + q)) <= D_ K L M (S n).
Proof.
  intros H H0 H1 H2 H3 M L K H4.
  pose (dq := q_ - q).
  assert
    ((Q_ + q_) * (1 + d) + e - (Q + q)
     = (Q_ - Q) * (1 + d) + Q * d + (q * d + dq * (1 + d) + e))
    as V_m_U.
  {
    unfold dq.
    ring.
  }
  assert
  (Rabs ((Q_ + q_) * (1 + d) + e - (Q + q)) <= Rabs (Q_ - Q) * M + INR n * L + K)
  as V_m_U_le.
  {
    unfold K, L, M.
    rewrite V_m_U.
    eapply Rle_trans.
    {
      apply Rabs_triang.
    }
    apply Rplus_le_compat.
    {
      eapply Rle_trans.
      {
        apply Rabs_triang.
      }
      apply Rplus_le_compat.
      {
        rewrite Rabs_mult.
        apply Rmult_le_compat_l; auto using Rabs_pos.
        eapply Rle_trans.
        {
          apply Rabs_triang.
        }
        rewrite Rabs_R1.
        apply Rplus_le_compat_l; auto.
      }
      rewrite Rabs_mult.
      rewrite <- Rmult_assoc.
      apply Rmult_le_compat; auto using Rabs_pos.
    }
    eapply Rle_trans.
    {
      apply Rabs_triang.
    }
    apply Rplus_le_compat; auto.
    eapply Rle_trans.
    {
      apply Rabs_triang.
    }
    apply Rplus_le_compat.
    {
      rewrite Rabs_mult.
      apply Rmult_le_compat; auto using Rabs_pos.
    }
    rewrite Rabs_mult.
    apply Rmult_le_compat; auto using Rabs_pos.
    eapply Rle_trans.
    {
      apply Rabs_triang.
    }
    rewrite Rabs_R1.
    apply Rplus_le_compat_l; auto.
  }
  eapply Rle_trans.
  {
    apply V_m_U_le.
  }
  rewrite DS.
  apply Rplus_le_compat_r.
  apply Rplus_le_compat_r.
  apply Rmult_le_compat_r; auto.
  unfold M.
  generalize (Rabs_pos (d)).
  lra.
Qed.

(* Range of a sum with rounding errors. (We assume that we already know the range of each computed term of the sum.) *)

Lemma next_rounded_sum_range Q n q d e Mq Md Me:
  Rabs q <= Mq ->
  Rabs d <= Md ->
  Rabs e <= Me ->
  let M := 1 + Md in
  let K' := (Mq * (1 + Md) + Me) in
  Rabs Q <=  D_ K' 0 M (n) ->
  Rabs ((Q + q) * (1 + d) + e) <= D_ K' 0 (M) (S n).
Proof.
  intros H H0 H1 M K' H2.
  assert (Rabs ((Q + q) * (1 + d) + e) <= Rabs Q * M + INR n * 0 + K') as H3.
  {
    replace ((Q + q) * (1 + d) + e) with
    (Q * (1 + d) + INR n * 0 + (q * (1 + d) + e))
      by ring.
    unfold K', M.
    rewrite Rmult_0_r.
    repeat rewrite Rplus_0_r.
    eapply Rle_trans.
    {
      apply Rabs_triang.
    }
    apply Rplus_le_compat.
    {
      rewrite Rabs_mult.
      apply Rmult_le_compat_l; auto using Rabs_pos.
      eapply Rle_trans.
      {
        apply Rabs_triang.
      }
      rewrite Rabs_R1.
      apply Rplus_le_compat_l; auto.
    }
    eapply Rle_trans.
    {
      apply Rabs_triang.
    }
    apply Rplus_le_compat; auto.
    rewrite Rabs_mult.
    apply Rmult_le_compat; auto using Rabs_pos.
    eapply Rle_trans.
    {
      apply Rabs_triang.
    }
    rewrite Rabs_R1.
    apply Rplus_le_compat_l; auto.
  }
  eapply Rle_trans.
  {
    apply H3.
  }
  rewrite DS.
  apply Rplus_le_compat_r.
  apply Rplus_le_compat_r.
  apply Rmult_le_compat_r; auto.
  unfold M.
  generalize (Rabs_pos d).
  lra.
Qed.

End S.

(* Implementations *)

Fixpoint Sf (f: nat -> R) (n: nat): R :=
  match n with
  | O => 0
  | S n' => Sf f n' + f n'
  end.

Global Instance: Sum Sf.
Proof.
  split; reflexivity.
Qed.

Fixpoint D (K L M: R) (n: nat): R :=
  match n with
  | O => 0
  | S n' => D K L M n' * M + INR n' * L + K
  end.

Global Instance: forall K L M, prop K L M (D K L M).
Proof.
  split; reflexivity.
Qed.


Require Import Bool.
Require Import FunInd.

Inductive ctx : Set :=
  | ctx_nil : ctx
  | ctx_cons : (nat * bool) -> ctx -> ctx.

Fixpoint ctx_v (n : nat) (c : ctx) {struct c} : option bool :=
  match c with
  | ctx_nil => None
  | ctx_cons (n', v) c => if Nat.eqb n n' then Some v else ctx_v n c
  end.

Inductive prop : Set :=
  | p_sym : nat -> prop
  | p_neg : prop -> prop
  | p_and : prop -> prop -> prop
  | p_or : prop -> prop -> prop
  | p_impl : prop -> prop -> prop.

Function prop_val (c : ctx) (p : prop) {struct p} : option bool :=
  match p with
  | p_sym n => ctx_v n c
  | p_neg p =>
      match prop_val c p with
      | None => None
      | Some b => Some (negb b)
      end
  | p_and p1 p2 =>
      match prop_val c p1 with
      | None => None
      | Some b1 =>
          match prop_val c p2 with
          | None => None
          | Some b2 => Some (andb b1 b2)
          end
      end
  | p_or p1 p2 =>
      match prop_val c p1 with
      | None => None
      | Some b1 =>
          match prop_val c p2 with
          | None => None
          | Some b2 => Some (orb b1 b2)
          end
      end
  | p_impl p1 p2 =>
      match prop_val c p1 with
      | None => None
      | Some b1 =>
          match prop_val c p2 with
          | None => None
          | Some b2 => Some (implb b1 b2)
          end
      end
  end.

Lemma prop_val_neg_b : forall c p b,
  prop_val c p = Some b -> prop_val c (p_neg p) = Some (negb b).
Proof.
  intros c p b H.
  rewrite prop_val_equation. rewrite H. reflexivity.
Qed.

Lemma prop_val_neg_n : forall c p,
  prop_val c p = None -> prop_val c (p_neg p) = None.
Proof.
  intros c p H.
  rewrite prop_val_equation. rewrite H. reflexivity.
Qed.

Lemma prop_val_or_b : forall c p0 p1 b0 b1,
  prop_val c p0 = Some b0 -> prop_val c p1 = Some b1 ->
  prop_val c (p_or p0 p1) = Some (orb b0 b1).
Proof.
  intros c p0 p1 b0 b1 Hprop0 Hprop1.
  rewrite prop_val_equation. rewrite Hprop0. rewrite Hprop1. reflexivity.
Qed.

Lemma prop_val_or_n_l : forall c p0 p1,
  prop_val c p0 = None -> prop_val c (p_or p0 p1) = None.
Proof.
  intros c p0 p1 Hprop.
  rewrite prop_val_equation. rewrite Hprop. reflexivity.
Qed.

Lemma prop_val_or_n_r : forall c p0 p1,
  prop_val c p1 = None -> prop_val c (p_or p0 p1) = None.
Proof.
  intros c p0 p1 Hprop0.
  rewrite prop_val_equation. rewrite Hprop0.
  case_eq (prop_val c p0); auto.
Qed.

Lemma prop_val_and_b : forall c p0 p1 b0 b1,
  prop_val c p0 = Some b0 -> prop_val c p1 = Some b1 ->
  prop_val c (p_and p0 p1) = Some (andb b0 b1).
Proof.
  intros c p0 p1 b0 b1 Hprop0 Hprop1.
  rewrite prop_val_equation. rewrite Hprop0. rewrite Hprop1. reflexivity.
Qed.

Lemma prop_val_and_n_l : forall c p0 p1,
  prop_val c p0 = None -> prop_val c (p_and p0 p1) = None.
Proof.
  intros c p0 p1 Hprop.
  rewrite prop_val_equation. rewrite Hprop. reflexivity.
Qed.

Lemma prop_val_and_n_r : forall c p0 p1,
  prop_val c p1 = None -> prop_val c (p_and p0 p1) = None.
Proof.
  intros c p0 p1 Hprop0.
  rewrite prop_val_equation. rewrite Hprop0.
  case_eq (prop_val c p0); auto.
Qed.

Lemma prop_val_impl_b : forall c p0 p1 b0 b1,
  prop_val c p0 = Some b0 -> prop_val c p1 = Some b1 ->
  prop_val c (p_impl p0 p1) = Some (implb b0 b1).
Proof.
  intros c p0 p1 b0 b1 Hprop0 Hprop1.
  rewrite prop_val_equation. rewrite Hprop0. rewrite Hprop1. reflexivity.
Qed.

Lemma prop_val_impl_n_l : forall c p0 p1,
  prop_val c p0 = None -> prop_val c (p_impl p0 p1) = None.
Proof.
  intros c p0 p1 Hprop.
  rewrite prop_val_equation. rewrite Hprop. reflexivity.
Qed.

Lemma prop_val_impl_n_r : forall c p0 p1,
  prop_val c p1 = None -> prop_val c (p_impl p0 p1) = None.
Proof.
  intros c p0 p1 Hprop0.
  rewrite prop_val_equation. rewrite Hprop0.
  case_eq (prop_val c p0); auto.
Qed.

Inductive seq_l : Set :=
  | seq_l_nil : seq_l
  | seq_l_cons : prop -> seq_l -> seq_l.

Function seq_l_val (c : ctx) (s : seq_l) {struct s} : option bool :=
  match s with
  | seq_l_nil => Some true
  | seq_l_cons p s =>
      match prop_val c p with
      | None => None
      | Some b1 =>
          match seq_l_val c s with
          | None => None
          | Some b2 => Some (andb b1 b2)
          end
      end
  end.

Lemma seq_l_val_lem : forall c p s b0 b1,
  seq_l_val c s = Some b0 -> prop_val c p = Some b1 ->
  seq_l_val c (seq_l_cons p s) = Some (andb b1 b0).
Proof.
  intros c p s b0 b1 Hs Hp.
  rewrite (seq_l_val_equation c (seq_l_cons p s)).
  rewrite Hp. rewrite Hs. reflexivity.
Qed.

Inductive seq_r : Set :=
  | seq_r_nil : seq_r
  | seq_r_cons : prop -> seq_r -> seq_r.

Function seq_r_val (c : ctx) (s : seq_r) {struct s} : option bool :=
  match s with
  | seq_r_nil => Some false
  | seq_r_cons p s =>
      match prop_val c p with
      | None => None
      | Some b1 =>
          match seq_r_val c s with
          | None => None
          | Some b2 => Some (orb b1 b2)
          end
      end
  end.

Lemma seq_r_val_lem : forall c p s b0 b1,
  seq_r_val c s = Some b0 -> prop_val c p = Some b1 ->
  seq_r_val c (seq_r_cons p s) = Some (orb b1 b0).
Proof.
  intros c p s b0 b1 Hs Hp.
  rewrite (seq_r_val_equation c (seq_r_cons p s)).
  rewrite Hp. rewrite Hs. reflexivity.
Qed.

Inductive seq_t : Set :=
  | seq : seq_l -> seq_r -> seq_t.

Definition seq_val (c : ctx) (s : seq_t) : option bool :=
  match s with
  | seq l r =>
      match seq_l_val c l with
      | None => None
      | Some b1 =>
          match seq_r_val c r with
          | None => None
          | Some b2 => Some (implb b1 b2)
          end
      end
  end.

Lemma satisfying_ctx_r : forall c l r b b1 b2,
  (seq_l_val c l = Some b1 /\ seq_r_val c r = Some b2 /\ b = implb b1 b2) ->
  (seq_val c (seq l r) = Some b).
Proof.
  intros c l r b b1 b2 [ Hbl [ Hbr Himpl ] ].
  unfold seq_val. rewrite Hbl. rewrite Hbr. rewrite Himpl. reflexivity.
Qed.

(* `exists` is required as implies is not an injective function *)
Lemma satisfying_ctx_l : forall c l r b,
  (seq_val c (seq l r) = Some b) ->
  (exists b1 b2, seq_l_val c l = Some b1 /\ seq_r_val c r = Some b2 /\ b = implb b1 b2).
Proof.
  intros c l r b.
  unfold seq_val. destruct (seq_l_val c l). destruct (seq_r_val c r).
  - intros H. inversion H. exists b0. exists b1. repeat split.
  - intros H. discriminate.
  - intros H. discriminate.
Qed.

Inductive eval_unary : seq_t -> seq_t -> Prop :=
  | neg_l : forall p l r,
      eval_unary (seq (seq_l_cons (p_neg p) l) r)
           (seq l (seq_r_cons p r))
  | neg_r : forall p l r,
      eval_unary (seq l (seq_r_cons (p_neg p) r))
           (seq (seq_l_cons p l) r)
  | or_r : forall p0 p1 l r,
      eval_unary (seq l (seq_r_cons (p_or p0 p1) r))
           (seq l (seq_r_cons p0 (seq_r_cons p1 r)))
  | impl_r : forall p0 p1 l r,
      eval_unary (seq l (seq_r_cons (p_impl p0 p1) r))
          (seq (seq_l_cons p0 l) (seq_r_cons p1 r)).

Inductive eval_binary : seq_t -> seq_t -> seq_t -> Prop :=
  | or_l : forall p0 p1 l r,
      eval_binary (seq (seq_l_cons (p_or p0 p1) l) r)
           (seq (seq_l_cons p0 l) r)
           (seq (seq_l_cons p1 l) r).