(** * Decide: Programming with Decision Procedures *)

Set Warnings "-notation-overridden,-parsing".
From VFA Require Import Perm.

(* ################################################################# *)
(** * Using [reflect] to characterize decision procedures *)

(** Thus far in _Verified Functional Algorithms_ we have been using
   - propositions ([Prop]) such as [a<b] (which is Notation for [lt a b])
   - booleans ([bool]) such as [a<?b] (which is Notation for [ltb a b]). *)

Check Nat.lt.  (* : nat -> nat -> Prop *)
Check Nat.ltb.  (* : nat -> nat -> bool *)

(** The [Perm] chapter defined a tactic called [bdestruct] that
    does case analysis on (x <? y) while giving you hypotheses (above
    the line) of the form (x<y).   This tactic is built using the [reflect]
    type and the [ltb_reflect] theorem. *)

Print reflect.
(* Inductive reflect (P : Prop) : bool -> Set :=
    | ReflectT : P -> reflect P true
    | ReflectF : ~ P -> reflect P false  *)

Check ltb_reflect.  (* : forall x y, reflect (x<y) (x <? y) *)

(** The name [reflect] for this type is a reference to _computational
   reflection_,  a technique in logic.  One takes a logical formula, or
   proposition, or predicate,  and designs a syntactic embedding of
   this formula as an "object value" in the logic.  That is, _reflect_ the
   formula back into the logic. Then one can design computations
   expressible inside the logic that manipulate these syntactic object
   values.  Finally, one proves that the computations make transformations
   that are equivalent to derivations (or equivalences) in the logic.

   The first use of computational reflection was by Goedel, in 1931:
   his syntactic embedding encoded formulas as natural numbers, a
   "Goedel numbering."  The second and third uses of reflection were
   by Church and Turing, in 1936: they encoded (respectively)
   lambda-expressions and Turing machines.

   In Coq it is easy to do reflection, because the Calculus of Inductive
   Constructions (CiC) has Inductive data types that can easily encode
   syntax trees.  We could, for example, take some of our propositional
   operators such as [and], [or], and make an [Inductive] type that is an
   encoding of these, and build a computational reasoning system for
   boolean satisfiability.

   But in this chapter I will show something much simpler.  When
   reasoning about less-than comparisons on natural numbers, we have
   the advantage that [nat] already an inductive type; it is "pre-reflected,"
   in some sense.  (The same for [Z], [list], [bool], etc.)  *)

(** Now, let's examine how [reflect] expresses the coherence between
  [lt] and [ltb]. Suppose we have a value [v] whose type is
  [reflect (3<7) (3<?7)].  What is [v]?  Either it is
  - ReflectT [P] (3<?7), where [P] is a proof of [3<7],  and [3<?7] is [true], or
  - ReflectF [Q] (3<?7), where [Q] is a proof of [~(3<7)], and [3<?7] is [false].
  In the case of [3,7], we are well advised to use [ReflectT], because
   (3<?7) cannot match the [false] required by [ReflectF]. *)

Goal (3<?7 = true). Proof. reflexivity. Qed.

(** So [v] cannot be [ReflectF Q (3<?7)] for any [Q], because that would
   not type-check.  Now, the next question:  must there exist a value
   of type [reflect (3<7) (3<?7)]  ?  The answer is yes; that is the
   [ltb_reflect] theorem.  The result of [Check ltb_reflect], above, says that
   for any [x,y], there does exist a value (ltb_reflect x y) whose type
   is exactly [reflect (x<y)(x<?y)].     So let's look at that value!  That is,
   examine what [H], and [P], and [Q] are equal to at "Case 1" and "Case 2": *)

Theorem three_less_seven_1: 3<7.
Proof.
assert (H := ltb_reflect 3 7).
remember (3<?7) as b.
destruct H as [P|Q] eqn:?.
* (* Case 1: H = ReflectT (3<7) P *)
apply P.
* (* Case 2: H = ReflectF (3<7) Q *)
compute in Heqb.
inversion Heqb.
Qed.

(** Here is another proof that uses [inversion] instead of [destruct].
   The [ReflectF] case is eliminated automatically by [inversion]
   because [3<?7] does not match [false]. *)

Theorem three_less_seven_2: 3<7.
Proof.
assert (H := ltb_reflect 3 7).
inversion H as [P|Q].
apply P.
Qed.

(** The [reflect] inductive data type is a way of relating a _decision
   procedure_ (a function from X to [bool]) with a predicate (a function
   from X to [Prop]).   The convenience of [reflect], in the verification
   of functional programs, is that we can do [destruct (ltb_reflect a b)],
   which relates [a<?b] (in the program) to the [a<b] (in the proof).
   That's just how the [bdestruct] tactic works; you can go back
   to [Perm.v] and examine how it is implemented in the [Ltac]
   tactic-definition language. *)

(* ################################################################# *)
(** * Using [sumbool] to Characterize Decision Procedures *)

Module ScratchPad.

(** An alternate way to characterize decision procedures,
   widely used in Coq, is via the inductive type [sumbool].

   Suppose [Q]  is a proposition, that is, [Q: Prop].  We say [Q] is
   _decidable_ if there is an algorithm for computing a proof of
   [Q] or [~Q].  More generally, when [P] is a predicate (a function
   from some type [T] to [Prop]), we say [P] is decidable when
   [forall x:T, decidable(P)].

   We represent this concept in Coq by an inductive datatype: *)

Inductive sumbool (A B : Prop) : Set :=
 | left : A -> sumbool A B
 | right : B -> sumbool A B.

(** Let's consider [sumbool] applied to two propositions: *)

Definition t1 := sumbool (3<7) (3>2).
Lemma less37: 3<7. Proof. omega. Qed.
Lemma greater23: 3>2. Proof. omega. Qed.

Definition v1a: t1 := left (3<7) (3>2) less37.
Definition v1b: t1 := right (3<7) (3>2) greater23.

(** A value of type [sumbool (3<7) (3>2)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (3>2).   *)

(** Now let's consider: *)

Definition t2 := sumbool (3<7) (2>3).
Definition v2a: t2 := left (3<7) (2>3) less37.

(** A value of type [sumbool (3<7) (2>3)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (2>3).
  But since there are no proofs of 2>3, only [left] values (such as [v2a])
  exist.  That's OK. *)

(** [sumbool] is in the Coq standard library, where there is [Notation]
   for it:  the expression [ {A}+{B} ] means [sumbool A B]. *)

Notation "{ A } + { B }" := (sumbool A B) : type_scope.

(** A very common use of [sumbool] is on a proposition and its negation.
   For example, *)

Definition t4 := forall a b, {a<b}+{~(a<b)}.

(** That expression, [forall a b, {a<b}+{~(a<b)}], says that for any
 natural numbers [a] and [b], either [a<b] or [a>=b].  But it is _more_
 than that!  Because [sumbool] is an Inductive type with two constructors
 [left] and [right], then given the [{3<7}+{~(3<7)}] you can pattern-match
 on it and learn _constructively_ which thing is true.  *)

Definition v3: {3<7}+{~(3<7)} := left _ _ less37.

Definition is_3_less_7:  bool :=
 match v3 with
 | left _ _ _ => true
 | right _ _ _ => false
 end.

Eval compute in is_3_less_7. (* = true : bool *)

Print t4.  (* = forall a b : nat, {a < b} + {~ a < b} *)

(** Suppose there existed a value [lt_dec] of type [t4].  That would be a
  _decision procedure_ for the less-than function on natural numbers.
  For any nats [a] and [b], you could calculate [lt_dec a b], which would
  be either [left ...] (if [a<b] was provable) or [right ...] (if [~(a<b)] was
  provable).

  Let's go ahead and implement [lt_dec].  We can base it on the function
  [ltb: nat -> nat -> bool] which calculates whether [a] is less than [b],
  as a boolean.  We already have a theorem that this function on booleans
  is related to the proposition [a<b]; that theorem is called [ltb_reflect]. *)

Check ltb_reflect.  (* : forall x y, reflect (x<y) (x<?y) *)

(** It's not too hard to use [ltb_reflect] to define [lt_dec] *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match ltb_reflect a b with
| ReflectT _ P => left (a < b) (~ a < b) P
| ReflectF _ Q => right (a < b) (~ a < b) Q
end.

(** Another, equivalent way to define [lt_dec] is to use
     definition-by-tactic: *)

Definition lt_dec' (a: nat) (b: nat) : {a<b}+{~(a<b)}.
  destruct (ltb_reflect a b) as [P|Q]. left. apply P.  right. apply Q.
Defined.

Print lt_dec.
Print lt_dec'.

Theorem lt_dec_equivalent: forall a b, lt_dec a b = lt_dec' a b.
Proof.
intros.
unfold lt_dec, lt_dec'.
reflexivity.
Qed.

(** Warning: these definitions of [lt_dec] are not as nice as the
  definition in the Coq standard library, because these are not
  fully computable.  See the discussion below. *)

End ScratchPad.

(* ================================================================= *)
(** ** [sumbool] in the Coq Standard Library *)

Module ScratchPad2.
Locate sumbool. (* Coq.Init.Specif.sumbool *)
Print sumbool.

(** The output of [Print sumbool] explains that the first two arguments
   of [left] and [right] are implicit.  We use them as follows (notice that
   [left] has only one explicit argument [P]:  *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match ltb_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

Definition le_dec (a: nat) (b: nat) : {a<=b}+{~(a<=b)} :=
match leb_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

(** Now, let's use [le_dec] directly in the implementation of insertion
   sort, without mentioning [ltb] at all. *)

Fixpoint insert (x:nat) (l: list nat) :=
  match l with
  | nil => x::nil
  | h::t => if le_dec x h then x::h::t else h :: insert x t
 end.

Fixpoint sort (l: list nat) : list nat :=
  match l with
  | nil => nil
  | h::t => insert h (sort t)
end.

Inductive sorted: list nat -> Prop :=
| sorted_nil:
    sorted nil
| sorted_1: forall x,
    sorted (x::nil)
| sorted_cons: forall x y l,
   x <= y -> sorted (y::l) -> sorted (x::y::l).

(** **** Exercise: 2 stars, standard (insert_sorted_le_dec)  *)
Lemma insert_sorted:
  forall a l, sorted l -> sorted (insert a l).
Proof.
  intros a l H.
  induction H.
  - constructor.
  - unfold insert.
    destruct (le_dec a x) as [ Hle | Hgt].

   (** Look at the proof state now.  In the first subgoal, we have
      above the line, [Hle: a <= x].  In the second subgoal, we have
      [Hgt: ~ (a < x)].  These are put there automatically by the
      [destruct (le_dec a x)].  Now, the rest of the proof can proceed
      as it did in [Sort.v], but using [destruct (le_dec _ _)] instead of
      [bdestruct (_ <=? _)]. *)

(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Decidability and Computability *)

(** Before studying the rest of this chapter, it is helpful to study the
   [ProofObjects] chapter of _Software Foundations volume 1_ if you
   have not done so already.

   A predicate [P: T->Prop] is _decidable_ if there is a computable
   function [f: T->bool] such that, forall [x:T], [f x = true <-> P x].
   The second and most famous example of an _undecidable_ predicate
   is the Halting Problem (Turing, 1936): [T] is the type of Turing-machine
   descriptions, and [P(x)] is, Turing machine [x] halts.  The first, and not
   as famous, example is due to Church, 1936 (six months earlier): test
   whether a lambda-expression has a normal form.  In 1936-37, as a
   first-year PhD student before beginning his PhD thesis work, Turing
   proved these two problems are equivalent.

   Classical logic contains the axiom [forall P, P \/ ~P].  This is not provable
   in core Coq, that is, in the bare Calculus of Inductive Constructions.  But
   its negation is not provable either.   You could add this axiom to Coq
   and the system would still be consistent (i.e., no way to prove [False]).

   But [P \/ ~P] is a weaker statement than [ {P}+{~P} ], that is,
   [sumbool P (~P)].  From [ {P}+{~P} ] you can actually _calculate_ or
   [compute] either [left (x:P)] or [right(y: ~P)].     From [P \/ ~P] you cannot
   [compute] whether [P] is true.  Yes, you can [destruct] it in a proof,
   but not in a calculation.

   For most purposes its unnecessary to add the axiom [P \/ ~P] to Coq,
   because for specific predicates there's a specific way to prove [P \/ ~P]
   as a theorem.  For example,  less-than on natural numbers is decidable,
   and the existence of [ltb_reflect] or [lt_dec] (as a theorem, not as an axiom)
   is a demonstration of that.

   Furthermore, in this "book" we are interested in _algorithms_.  An axiom
   [P \/ ~P] does not give us an algorithm to compute whether P is true.  As
   you saw in the definition of [insert] above, we can use [lt_dec] not only as
   a theorem that either [3<7] or [~(3<7)], we can use it as a function to
   compute whether [3<7].  In Coq, you can't compute with axioms!
   Let's try it: *)

Axiom lt_dec_axiom_1:  forall i j: nat, i<j \/ ~(i<j).

(** Now, can we use this axiom to compute with?  *)

(* Uncomment and try this:
Definition max (i j: nat) : nat :=
   if lt_dec_axiom_1 i j then j else i.
*)

(** That doesn't work, because an [if] statement requires an [Inductive]
  data type with exactly two constructors; but [lt_dec_axiom_1 i j] has
  type [i<j \/ ~(i<j)],  which is not Inductive.  But let's try a different axiom: *)

Axiom lt_dec_axiom_2:  forall i j: nat, {i<j} + {~(i<j)}.

Definition max_with_axiom (i j: nat) : nat :=
   if lt_dec_axiom_2 i j then j else i.

(** This typechecks, because [lt_dec_axiom_2 i j]  belongs to type
     [sumbool (i<j) (~(i<j))]   (also written [ {i<j} + {~(i<j)} ]), which does have
     two constructors.

     Now, let's use this function: *)

Eval compute in max_with_axiom 3 7.
  (*  = if lt_dec_axiom_2 3 7 then 7 else 3
     : nat *)

(** This [compute] didn't compute very much!  Let's try to evaluate it
    using [unfold]: *)

Lemma prove_with_max_axiom:   max_with_axiom 3 7 = 7.
Proof.
unfold max_with_axiom.
try reflexivity.  (* does not do anything, reflexivity fails *)
(* uncomment this line and try it:
   unfold lt_dec_axiom_2.
*)
destruct (lt_dec_axiom_2 3 7).
reflexivity.
contradiction n. omega.
Qed.

(** It is dangerous to add Axioms to Coq: if you add one that's inconsistent,
   then it leads to the ability to prove [False].  While that's a convenient way
   to get a lot of things proved, it's unsound; the proofs are useless.

   The Axioms above, [lt_dec_axiom_1] and [lt_dec_axiom_2], are safe enough:
   they are consistent.  But they don't help in computation.  Axioms are not
   useful here. *)

End ScratchPad2.

(* ################################################################# *)
(** * Opacity of [Qed] *)

(** This lemma [prove_with_max_axiom] turned out to be _provable_, but the proof
    could not go by _computation_.  In contrast, let's use [lt_dec], which was built
    without any axioms: *)

Lemma compute_with_lt_dec:  (if ScratchPad2.lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
(* uncomment this line and try it:
   unfold ltb_reflect.
*)
Abort.

(** Unfortunately, even though [ltb_reflect] was proved without any axioms, it
    is an _opaque theorem_  (proved with [Qed] instead of with [Defined]), and
    one cannot compute with opaque theorems.  Not only that, but it is proved with
    other opaque theorems such as [iff_sym] and [Nat.ltb_lt].  If we want to
    compute with an implementation of [lt_dec] built from [ltb_reflect], then
    we will have to rebuild [ltb_reflect] without using [Qed] anywhere, only [Defined].

    Instead, let's use the version of [lt_dec] from the Coq standard library,
    which _is_ carefully built without any opaque ([Qed]) theorems.
*)

Lemma compute_with_StdLib_lt_dec:  (if lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
reflexivity.
Qed.

(** The Coq standard library has many decidability theorems.  You can
   examine them by doing the following [Search] command. The results
   shown here are only for the subset of the library that's currently
   imported (by the [Import] commands above); there's even more out there. *)

Search ({_}+{~_}).
(*
reflect_dec: forall (P : Prop) (b : bool), reflect P b -> {P} + {~ P}
lt_dec: forall n m : nat, {n < m} + {~ n < m}
list_eq_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall l l' : list A, {l = l'} + {l <> l'}
le_dec: forall n m : nat, {n <= m} + {~ n <= m}
in_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall (a : A) (l : list A), {In a l} + {~ In a l}
gt_dec: forall n m : nat, {n > m} + {~ n > m}
ge_dec: forall n m : nat, {n >= m} + {~ n >= m}
eq_nat_decide: forall n m : nat, {eq_nat n m} + {~ eq_nat n m}
eq_nat_dec: forall n m : nat, {n = m} + {n <> m}
bool_dec: forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}
Zodd_dec: forall n : Z, {Zodd n} + {~ Zodd n}
Zeven_dec: forall n : Z, {Zeven n} + {~ Zeven n}
Z_zerop: forall x : Z, {x = 0%Z} + {x <> 0%Z}
Z_lt_dec: forall x y : Z, {(x < y)%Z} + {~ (x < y)%Z}
Z_le_dec: forall x y : Z, {(x <= y)%Z} + {~ (x <= y)%Z}
Z_gt_dec: forall x y : Z, {(x > y)%Z} + {~ (x > y)%Z}
Z_ge_dec: forall x y : Z, {(x >= y)%Z} + {~ (x >= y)%Z}
*)

(** The type of [list_eq_dec] is worth looking at.  It says that if you
     have  a decidable equality for an element type [A], then
    [list_eq_dec] calculates for you a decidable equality for type [list A].
    Try it out: *)

Definition list_nat_eq_dec:
    (forall al bl : list nat, {al=bl}+{al<>bl}) :=
  list_eq_dec eq_nat_dec.

Eval compute in if list_nat_eq_dec [1;3;4] [1;4;3] then true else false.
 (* = false : bool *)

Eval compute in if list_nat_eq_dec [1;3;4] [1;3;4] then true else false.
 (* = true : bool *)

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

    Use [in_dec] to build this function. *)

Definition list_nat_in: forall (i: nat) (al: list nat), {In i al}+{~ In i al}
 (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example in_4_pi:  (if list_nat_in 4  [3;1;4;1;5;9;2;6] then true else false) = true.
Proof.
simpl.
(* reflexivity. *)
(* FILL IN HERE *) Admitted.
(** [] *)

(** In general, beyond [list_eq_dec] and [in_dec], one can construct a
     whole programmable calculus of decidability, using the
     programs-as-proof  language of Coq.  But is it a good idea?  Read on! *)

(* ################################################################# *)
(** * Advantages and Disadvantages of [reflect] Versus [sumbool] *)

(** I have shown two ways to program decision procedures in Coq,
    one using [reflect] and the other using [{_}+{~_}], i.e., [sumbool].

   - With [sumbool], you define _two_ things: the operator in [Prop]
      such as [lt: nat -> nat -> Prop] and the decidability "theorem"
      in [sumbool], such as [lt_dec: forall i j, {lt i j}+{~ lt i j}].  I say
      "theorem" in quotes because it's not _just_ a theorem, it's also
      a (nonopaque) computable function.

   - With [reflect], you define _three_ things:  the operator in [Prop],
      the operator in [bool] (such as [ltb: nat -> nat -> bool], and the
      theorem that relates them (such as [ltb_reflect]).

   Defining three things seems like more work than defining two.
   But it may be easier and more efficient.  Programming in [bool],
   you may have more control over how your functions are implemented,
   you will have fewer difficult uses of dependent types, and you
   will run into fewer difficulties with opaque theorems.

   However, among Coq programmers, [sumbool] seems to be more
   widely used, and it seems to have better support in the Coq standard
   library.  So you may encounter it, and it is worth understanding what
   it does.   Either of these two methods is a reasonable way of programming
   with proof.  *)

(* 2020-08-07 17:08 *)


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rlt_not_eq.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rlt_dichotomy_converse : forall r1 r2, r1 < r2 \/ r2 < r1 -> r1 <> r2.
Proof.
  intros x y.
  intros [ hxy | hyx ].
  {
    apply Rlt_not_eq.
    exact hxy.
  }
  {
    apply not_eq_sym.
    apply Rlt_not_eq.
    exact hyx.
  }
Qed.


Require Import Arith List TheoryList.

Definition var := nat.

Inductive exp : Set :=
  | Num : nat -> exp
  | Bool : bool -> exp

  | Var : var -> exp

  | Plus : exp -> exp -> exp
  | Minus : exp -> exp -> exp

  | Eq : exp -> exp -> exp.

Definition env := var -> exp.

Inductive isValue : exp -> Prop :=
  | ValueNum : forall n, isValue (Num n)
  | ValueBool : forall n, isValue (Bool n).

Definition nat_eq n1 n2 :=
  if eq_nat_dec n1 n2
    then true
    else false.

Inductive step (G : env) : exp -> exp -> Prop :=
  | StepVar : forall x, step G (Var x) (G x)

  | StepPlus : forall n1 n2,
    step G (Plus (Num n1) (Num n2)) (Num (n1 + n2))
  | StepPlus1 : forall e1 e2 e1',
    step G e1 e1'
    -> step G (Plus e1 e2) (Plus e1' e2)
  | StepPlus2 : forall e1 e2 e2',
    isValue e1
    -> step G e2 e2'
    -> step G (Plus e1 e2) (Plus e1 e2')

  | StepMinus : forall n1 n2,
    step G (Minus (Num n1) (Num n2)) (Num (n1 - n2))
  | StepMinus1 : forall e1 e2 e1',
    step G e1 e1'
    -> step G (Minus e1 e2) (Minus e1' e2)
  | StepMinus2 : forall e1 e2 e2',
    isValue e1
    -> step G e2 e2'
    -> step G (Minus e1 e2) (Minus e1 e2')

  | StepEq_False : forall n1 n2,
    step G (Eq (Num n1) (Num n2)) (Bool (nat_eq n1 n2))
  | StepEq1 : forall e1 e2 e1',
    step G e1 e1'
    -> step G (Eq e1 e2) (Eq e1' e2)
  | StepEq2 : forall e1 e2 e2',
    isValue e1
    -> step G e2 e2'
    -> step G (Eq e1 e2) (Eq e1 e2').

Inductive type : Set :=
  | TyNum : type
  | TyBool : type.

Section typing.
  Variable Gtypes : var -> type.

  Inductive hasType : exp -> type -> Prop :=
    | HT_Num : forall n,
      hasType (Num n) TyNum
    | HT_Bool : forall b,
      hasType (Bool b) TyBool

    | HT_Var : forall x,
      hasType (Var x) (Gtypes x)

    | HT_Plus : forall e1 e2,
      hasType e1 TyNum
      -> hasType e2 TyNum
      -> hasType (Plus e1 e2) TyNum
    | HT_Minus : forall e1 e2,
      hasType e1 TyNum
      -> hasType e2 TyNum
      -> hasType (Minus e1 e2) TyNum
    | HT_Eq : forall e1 e2,
      hasType e1 TyNum
      -> hasType e2 TyNum
      -> hasType (Eq e1 e2) TyBool.

  Variable G : env.

  Hypothesis vars_values : forall x, isValue (G x).
  Hypothesis vars_typed : forall x, hasType (G x) (Gtypes x).

  Hint Constructors hasType isValue step.

  Ltac ics H := inversion H; clear H; subst.

  Ltac my_inversion :=
    match goal with
      | [ H : isValue (Var _) |- _ ] => inversion H
      | [ H : isValue (Plus _ _) |- _ ] => inversion H
      | [ H : isValue (Minus _ _) |- _ ] => inversion H
      | [ H : isValue (Eq _ _) |- _ ] => inversion H

      | [ H : hasType (Num _) _ |- _ ] => ics H
      | [ H : hasType (Bool _) _ |- _ ] => ics H
      | [ H : hasType (Var _) _ |- _ ] => ics H
      | [ H : hasType (Plus _ _) _ |- _ ] => ics H
      | [ H : hasType (Minus _ _) _ |- _ ] => ics H
      | [ H : hasType (Eq _ _) _ |- _ ] => ics H

      | [ H : hasType _ TyNum |- _ ] => ics H
      | [ H : hasType _ TyBool |- _ ] => ics H
    end.

  Ltac magic_solver := firstorder; repeat (eauto; my_inversion).

  Theorem progress : forall e t,
    hasType e t
    -> isValue e
    \/ exists e', step G e e'.
    induction 1; magic_solver.
  Qed.

  Theorem preservation : forall e e',
    step G e e'
    -> forall t, hasType e t
      -> hasType e' t.
    induction 1; magic_solver.
  Qed.
End typing.


Require Import
  Coq.Classes.RelationClasses Coq.Classes.Morphisms Coq.Program.Program
  MathClasses.interfaces.universal_algebra MathClasses.interfaces.canonical_names MathClasses.theory.ua_subalgebra.

(* In theory/ua_subalgebra.v we defined closed proper subsets and showed that
they yield subalgebras. We now expand on this result and show that they
also yield subvarieties (by showing that the laws still hold in the subalgebra). *)

Section contents.
  Context `{InVariety et A} `{@ClosedSubset et A _ _ P}. (* todo: why so ugly? *)

  Definition Pvars (vars: Vars et (carrier P) nat): Vars et A nat
    := λ s n, ` (vars s n).

  (* To prove that the laws still hold in the subalgebra, we first prove that evaluation in it
   is the same as evaluation in the original: *)

  Program Fixpoint heq {o}: op_type (carrier P) o → op_type A o → Prop :=
    match o with
    | ne_list.one _ => λ a b, `a = b
    | ne_list.cons _ _ => λ a b, ∀ u, heq (a u) (b u)
    end.

  Instance heq_proper: Proper ((=) ==> (=) ==> iff) (@heq o).
  Proof with intuition.
   intros o x y U x0 y0 K.
   induction o; simpl in *.
    destruct x, y.
    change (x = x1) in U.
    simpl in *.
    split; intro.
     transitivity x...
     transitivity x0...
    transitivity x1...
    transitivity y0...
   assert (∀ u, x u = y u). intros. apply U...
   split; repeat intro.
    apply -> (IHo (x u) (y u) (H1 u) (x0 (proj1_sig u)))...
    apply K...
   apply <- (IHo (x u) (y u) (H1 u) (x0 (proj1_sig u)))...
   apply K...
  Qed.

  Lemma heq_eval vars {o} (t: T et o): heq (eval et vars t) (eval et (Pvars vars) t).
  Proof with intuition.
   induction t; simpl...
     unfold Pvars...
    simpl in IHt1.
    generalize (IHt1 (eval et vars t3)). clear IHt1.
    apply heq_proper.
     pose proof (@eval_proper et (carrier P) _ _ _ nat (ne_list.cons y t1)).
     apply H1; try intro...
    pose proof (@eval_proper et A _ _ _ nat (ne_list.cons y t1)).
    apply H1...
    unfold heq in IHt2. (* todo: this wasn't needed in a previous Coq version *)
    rewrite IHt2.
    apply (@eval_proper et A _ _ _ nat (ne_list.one y))...
   unfold impl, algebra_op.
   generalize (subset_closed P o).
   unfold algebra_op.
   generalize (AlgebraOps0 o).
   intros.
   induction (et o); simpl in *...
  Qed.

  Lemma heq_eval_const vars {o} (t: T et (ne_list.one o)): ` (eval et vars t) = eval et (Pvars vars) t.
  Proof. apply (heq_eval vars t). Qed.
    (* todo: this specialization wasn't needed in a previous Coq version *)

  Lemma laws s: et_laws et s → ∀ vars: ∀ a, nat → carrier P a, eval_stmt et vars s.
  Proof with intuition.
   intros.
   generalize (@variety_laws et A _ _ _ s H1 (Pvars vars)). clear H1.
   destruct s as [x [? [t t0]]].
   induction x as [A| [x1 [t1 t2]]]; simpl in *; intros.
    unfold equiv, sig_equiv.
    rewrite (heq_eval_const vars t).
    rewrite (heq_eval_const vars t0)...
   apply IHx, H1.
   rewrite <- (heq_eval_const vars t1).
   rewrite <- (heq_eval_const vars t2)...
  Qed.

  (* Which gives us our variety: *)

  Global Instance: InVariety et (carrier P) := { variety_laws := laws }.

End contents.


Require Import Coq.Arith.Div2.
Require Import Coq.micromega.Lia.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import bbv.N_Z_nat_conversions.
Require Export bbv.Nomega.

Set Implicit Arguments.

Fixpoint mod2 (n : nat) : bool :=
  match n with
    | 0 => false
    | 1 => true
    | S (S n') => mod2 n'
  end.

Ltac rethink :=
  match goal with
    | [ H : ?f ?n = _ |- ?f ?m = _ ] => replace m with n; simpl; auto
  end.

Theorem mod2_S_double : forall n, mod2 (S (2 * n)) = true.
  induction n; simpl; intuition; rethink.
Qed.

Theorem mod2_double : forall n, mod2 (2 * n) = false.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; rethink.
Qed.

Theorem div2_double : forall n, div2 (2 * n) = n.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; f_equal; rethink.
Qed.

Theorem div2_S_double : forall n, div2 (S (2 * n)) = n.
  induction n; simpl; intuition; f_equal; rethink.
Qed.

Notation pow2 := (Nat.pow 2).

Fixpoint Npow2 (n : nat) : N :=
  match n with
    | O => 1
    | S n' => 2 * Npow2 n'
  end%N.

Theorem untimes2 : forall n, n + (n + 0) = 2 * n.
  auto.
Qed.

Section strong.
  Variable P : nat -> Prop.

  Hypothesis PH : forall n, (forall m, m < n -> P m) -> P n.

  Lemma strong' : forall n m, m <= n -> P m.
    induction n; simpl; intuition; apply PH; intuition.
    elimtype False; omega.
  Qed.

  Theorem strong : forall n, P n.
    intros; eapply strong'; eauto.
  Qed.
End strong.

Theorem div2_odd : forall n,
  mod2 n = true
  -> n = S (2 * div2 n).
  induction n as [n] using strong; simpl; intuition.

  destruct n as [|n]; simpl in *; intuition.
    discriminate.
  destruct n as [|n]; simpl in *; intuition.
  do 2 f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem div2_even : forall n,
  mod2 n = false
  -> n = 2 * div2 n.
  induction n as [n] using strong; simpl; intuition.

  destruct n as [|n]; simpl in *; intuition.
  destruct n as [|n]; simpl in *; intuition.
    discriminate.
  f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem drop_mod2 : forall n k,
  2 * k <= n
  -> mod2 (n - 2 * k) = mod2 n.
  induction n as [n] using strong; intros.

  do 2 (destruct n; simpl in *; repeat rewrite untimes2 in *; intuition).

  destruct k; simpl in *; intuition.

  destruct k; simpl; intuition.
  rewrite <- plus_n_Sm.
  repeat rewrite untimes2 in *.
  simpl; auto.
  apply H; omega.
Qed.

Theorem div2_minus_2 : forall n k,
  2 * k <= n
  -> div2 (n - 2 * k) = div2 n - k.
  induction n as [n] using strong; intros.

  do 2 (destruct n; simpl in *; intuition; repeat rewrite untimes2 in *).
  destruct k; simpl in *; intuition.

  destruct k; simpl in *; intuition.
  rewrite <- plus_n_Sm.
  apply H; omega.
Qed.

Theorem div2_bound : forall k n,
  2 * k <= n
  -> k <= div2 n.
  intros ? n H; case_eq (mod2 n); intro Heq.

  rewrite (div2_odd _ Heq) in H.
  omega.

  rewrite (div2_even _ Heq) in H.
  omega.
Qed.

Lemma two_times_div2_bound: forall n, 2 * Nat.div2 n <= n.
Proof.
  eapply strong. intros n IH.
  destruct n.
  - constructor.
  - destruct n.
    + simpl. constructor. constructor.
    + simpl (Nat.div2 (S (S n))).
      specialize (IH n). omega.
Qed.

Lemma div2_compat_lt_l: forall a b, b < 2 * a -> Nat.div2 b < a.
Proof.
  induction a; intros.
  - omega.
  - destruct b.
    + simpl. omega.
    + destruct b.
      * simpl. omega.
      * simpl. apply lt_n_S. apply IHa. omega.
Qed.

(* otherwise b is made implicit, while a isn't, which is weird *)
Arguments div2_compat_lt_l {_} {_} _.

Lemma pow2_add_mul: forall a b,
  pow2 (a + b) = (pow2 a) * (pow2 b).
Proof.
  induction a; destruct b; firstorder; simpl.
  repeat rewrite Nat.add_0_r.
  rewrite Nat.mul_1_r; auto.
  repeat rewrite Nat.add_0_r.
  rewrite IHa.
  simpl.
  repeat rewrite Nat.add_0_r.
  rewrite Nat.mul_add_distr_r; auto.
Qed.

Lemma mult_pow2_bound: forall a b x y,
  x < pow2 a -> y < pow2 b -> x * y < pow2 (a + b).
Proof.
  intros.
  rewrite pow2_add_mul.
  apply Nat.mul_lt_mono_nonneg; omega.
Qed.

Lemma mult_pow2_bound_ex: forall a c x y,
  x < pow2 a -> y < pow2 (c - a) -> c >= a -> x * y < pow2 c.
Proof.
  intros.
  replace c with (a + (c - a)) by omega.
  apply mult_pow2_bound; auto.
Qed.

Lemma lt_mul_mono' : forall c a b,
  a < b -> a < b * (S c).
Proof.
  induction c; intros.
  rewrite Nat.mul_1_r; auto.
  rewrite Nat.mul_succ_r.
  apply lt_plus_trans.
  apply IHc; auto.
Qed.

Lemma lt_mul_mono : forall a b c,
  c <> 0 -> a < b -> a < b * c.
Proof.
  intros.
  replace c with (S (c - 1)) by omega.
  apply lt_mul_mono'; auto.
Qed.

Lemma zero_lt_pow2 : forall sz, 0 < pow2 sz.
Proof.
  induction sz; simpl; omega.
Qed.

Lemma one_lt_pow2:
  forall n,
    1 < pow2 (S n).
Proof.
  intros.
  induction n.
  simpl; omega.
  remember (S n); simpl.
  omega.
Qed.

Lemma one_le_pow2 : forall sz, 1 <= pow2 sz.
Proof.
  intros. pose proof (zero_lt_pow2 sz). omega.
Qed.

Lemma pow2_ne_zero: forall n, pow2 n <> 0.
Proof.
  intros.
  pose proof (zero_lt_pow2 n).
  omega.
Qed.

Lemma mul2_add : forall n, n * 2 = n + n.
Proof.
  induction n; firstorder.
Qed.

Lemma pow2_le_S : forall sz, (pow2 sz) + 1 <= pow2 (sz + 1).
Proof.
  induction sz; simpl; auto.
  repeat rewrite Nat.add_0_r.
  rewrite pow2_add_mul.
  repeat rewrite mul2_add.
  pose proof (zero_lt_pow2 sz).
  omega.
Qed.

Lemma pow2_bound_mono: forall a b x,
  x < pow2 a -> a <= b -> x < pow2 b.
Proof.
  intros.
  replace b with (a + (b - a)) by omega.
  rewrite pow2_add_mul.
  apply lt_mul_mono; auto.
  pose proof (zero_lt_pow2 (b - a)).
  omega.
Qed.

Lemma pow2_inc : forall n m,
  0 < n -> n < m ->
    pow2 n < pow2 m.
Proof.
  intros.
  generalize dependent n; intros.
  induction m; simpl.
  intros. inversion H0.
  unfold lt in H0.
  rewrite Nat.add_0_r.
  inversion H0.
  apply Nat.lt_add_pos_r.
  apply zero_lt_pow2.
  apply Nat.lt_trans with (pow2 m).
  apply IHm.
  exact H2.
  apply Nat.lt_add_pos_r.
  apply zero_lt_pow2.
Qed.

Lemma pow2_S: forall x, pow2 (S x) = 2 * pow2 x.
Proof. intros. reflexivity. Qed.

Lemma mod2_S_S : forall n,
  mod2 (S (S n)) = mod2 n.
Proof.
  intros.
  destruct n; auto; destruct n; auto.
Qed.

Lemma mod2_S_not : forall n,
  mod2 (S n) = if (mod2 n) then false else true.
Proof.
  intros.
  induction n; auto.
  rewrite mod2_S_S.
  destruct (mod2 n); replace (mod2 (S n)); auto.
Qed.

Lemma mod2_S_eq : forall n k,
  mod2 n = mod2 k ->
  mod2 (S n) = mod2 (S k).
Proof.
  intros.
  do 2 rewrite mod2_S_not.
  rewrite H.
  auto.
Qed.

Theorem drop_mod2_add : forall n k,
  mod2 (n + 2 * k) = mod2 n.
Proof.
  intros.
  induction n.
  simpl.
  rewrite Nat.add_0_r.
  replace (k + k) with (2 * k) by omega.
  apply mod2_double.
  replace (S n + 2 * k) with (S (n + 2 * k)) by omega.
  apply mod2_S_eq; auto.
Qed.

Lemma mod2sub: forall a b,
  b <= a ->
  mod2 (a - b) = xorb (mod2 a) (mod2 b).
Proof.
  intros. remember (a - b) as c. revert dependent b. revert a. revert c.
  change (forall c,
    (fun c => forall a b, b <= a -> c = a - b -> mod2 c = xorb (mod2 a) (mod2 b)) c).
  apply strong.
  intros c IH a b AB N.
  destruct c.
  - assert (a=b) by omega. subst. rewrite Bool.xorb_nilpotent. reflexivity.
  - destruct c.
    + assert (a = S b) by omega. subst a. simpl (mod2 1). rewrite mod2_S_not.
      destruct (mod2 b); reflexivity.
    + destruct a; [omega|].
      destruct a; [omega|].
      simpl.
      apply IH; omega.
Qed.

Theorem mod2_pow2_twice: forall n,
  mod2 (pow2 n + (pow2 n + 0)) = false.
Proof.
  intros.
  replace (pow2 n + (pow2 n + 0)) with (2 * pow2 n) by omega.
  apply mod2_double.
Qed.

Theorem div2_plus_2 : forall n k,
  div2 (n + 2 * k) = div2 n + k.
Proof.
  induction n; intros.
  simpl.
  rewrite Nat.add_0_r.
  replace (k + k) with (2 * k) by omega.
  apply div2_double.
  replace (S n + 2 * k) with (S (n + 2 * k)) by omega.
  destruct (Even.even_or_odd n).
  - rewrite <- even_div2.
    rewrite <- even_div2 by auto.
    apply IHn.
    apply Even.even_even_plus; auto.
    apply Even.even_mult_l; repeat constructor.

  - rewrite <- odd_div2.
    rewrite <- odd_div2 by auto.
    rewrite IHn.
    omega.
    apply Even.odd_plus_l; auto.
    apply Even.even_mult_l; repeat constructor.
Qed.

Lemma pred_add:
  forall n, n <> 0 -> pred n + 1 = n.
Proof.
  intros; rewrite pred_of_minus; omega.
Qed.

Lemma pow2_zero: forall sz, (pow2 sz > 0)%nat.
Proof.
  induction sz; simpl; auto; omega.
Qed.

Section omega_compat.

Ltac omega ::= lia.

Theorem Npow2_nat : forall n, nat_of_N (Npow2 n) = pow2 n.
  induction n as [|n IHn]; simpl; intuition.
  rewrite <- IHn; clear IHn.
  case_eq (Npow2 n); intuition.
Qed.

End omega_compat.

Theorem pow2_N : forall n, Npow2 n = N.of_nat (pow2 n).
Proof.
  intro n. apply nat_of_N_eq. rewrite Nat2N.id. apply Npow2_nat.
Qed.

Lemma Z_of_N_Npow2: forall n, Z.of_N (Npow2 n) = (2 ^ Z.of_nat n)%Z.
Proof.
  intros.
  rewrite pow2_N.
  rewrite nat_N_Z.
  rewrite Nat2Z.inj_pow.
  reflexivity.
Qed.

Lemma pow2_S_z:
  forall n, Z.of_nat (pow2 (S n)) = (2 * Z.of_nat (pow2 n))%Z.
Proof.
  intros.
  replace (2 * Z.of_nat (pow2 n))%Z with
      (Z.of_nat (pow2 n) + Z.of_nat (pow2 n))%Z by omega.
  simpl.
  repeat rewrite Nat2Z.inj_add.
  ring.
Qed.

Lemma pow2_le:
  forall n m, (n <= m)%nat -> (pow2 n <= pow2 m)%nat.
Proof.
  intros.
  assert (exists s, n + s = m) by (exists (m - n); omega).
  destruct H0; subst.
  rewrite pow2_add_mul.
  pose proof (pow2_zero x).
  replace (pow2 n) with (pow2 n * 1) at 1 by omega.
  apply mult_le_compat_l.
  omega.
Qed.

Lemma Zabs_of_nat:
  forall n, Z.abs (Z.of_nat n) = Z.of_nat n.
Proof.
  unfold Z.of_nat; intros.
  destruct n; auto.
Qed.

Lemma Npow2_not_zero:
  forall n, Npow2 n <> 0%N.
Proof.
  induction n; simpl; intros; [discriminate|].
  destruct (Npow2 n); auto.
  discriminate.
Qed.

Lemma Npow2_S:
  forall n, Npow2 (S n) = (Npow2 n + Npow2 n)%N.
Proof.
  simpl; intros.
  destruct (Npow2 n); auto.
  rewrite <-Pos.add_diag.
  reflexivity.
Qed.

Lemma Npow2_pos: forall a,
    (0 < Npow2 a)%N.
Proof.
  intros.
  destruct (Npow2 a) eqn: E.
  - exfalso. apply (Npow2_not_zero a). assumption.
  - constructor.
Qed.

Lemma minus_minus: forall a b c,
  c <= b <= a ->
  a - (b - c) = a - b + c.
Proof. intros. omega. Qed.

Lemma even_odd_destruct: forall n,
  (exists a, n = 2 * a) \/ (exists a, n = 2 * a + 1).
Proof.
  induction n.
  - left. exists 0. reflexivity.
  - destruct IHn as [[a E] | [a E]].
    + right. exists a. omega.
    + left. exists (S a). omega.
Qed.

Lemma mul_div_undo: forall i c,
    c <> 0 ->
    c * i / c = i.
Proof.
  intros.
  pose proof (Nat.div_mul_cancel_l i 1 c) as P.
  rewrite Nat.div_1_r in P.
  rewrite Nat.mul_1_r in P.
  apply P; auto.
Qed.

Lemma mod_add_r: forall a b,
    b <> 0 ->
    (a + b) mod b = a mod b.
Proof.
  intros. rewrite <- Nat.add_mod_idemp_r by omega.
  rewrite Nat.mod_same by omega.
  rewrite Nat.add_0_r.
  reflexivity.
Qed.

Lemma mod2_cases: forall (n: nat), n mod 2 = 0 \/ n mod 2 = 1.
Proof.
  intros.
  assert (n mod 2 < 2). {
    apply Nat.mod_upper_bound. congruence.
  }
  omega.
Qed.

Lemma div_mul_undo: forall a b,
    b <> 0 ->
    a mod b = 0 ->
    a / b * b = a.
Proof.
  intros.
  pose proof Nat.div_mul_cancel_l as A. specialize (A a 1 b).
  replace (b * 1) with b in A by omega.
  rewrite Nat.div_1_r in A.
  rewrite mult_comm.
  rewrite <- Nat.divide_div_mul_exact; try assumption.
  - apply A; congruence.
  - apply Nat.mod_divide; assumption.
Qed.

Lemma Smod2_1: forall k, S k mod 2 = 1 -> k mod 2 = 0.
Proof.
  intros k C.
  change (S k) with (1 + k) in C.
  rewrite Nat.add_mod in C by congruence.
  pose proof (Nat.mod_upper_bound k 2).
  assert (k mod 2 = 0 \/ k mod 2 = 1) as E by omega.
  destruct E as [E | E]; [assumption|].
  rewrite E in C. simpl in C. discriminate.
Qed.

Lemma mod_0_r: forall (m: nat),
    m mod 0 = 0.
Proof.
  intros. reflexivity.
Qed.

Lemma sub_mod_0: forall (a b m: nat),
    a mod m = 0 ->
    b mod m = 0 ->
    (a - b) mod m = 0.
Proof.
  intros. assert (m = 0 \/ m <> 0) as C by omega. destruct C as [C | C].
  - subst. apply mod_0_r.
  - assert (a - b = 0 \/ b < a) as D by omega. destruct D as [D | D].
    + rewrite D. apply Nat.mod_0_l. assumption.
    + apply Nat2Z.inj. simpl.
      rewrite Zdiv.mod_Zmod by assumption.
      rewrite Nat2Z.inj_sub by omega.
      rewrite Zdiv.Zminus_mod.
      rewrite <-! Zdiv.mod_Zmod by assumption.
      rewrite H. rewrite H0.
      apply Z.mod_0_l.
      omega.
Qed.

Lemma mul_div_exact: forall (a b: nat),
    b <> 0 ->
    a mod b = 0 ->
    b * (a / b) = a.
Proof.
  intros. edestruct Nat.div_exact as [_ P]; [eassumption|].
  specialize (P H0). symmetry. exact P.
Qed.


Require Import Coq.Classes.Morphisms Coq.Program.Program Coq.Unicode.Utf8.

(* First, two ways to do quoting in the naive scenario without
 holes/variables in the expression: *)

Module simple.
  (* An example term language and evaluation: *)
  Inductive Expr := Plus (a b: Expr) | Mult (a b: Expr) | Zero | One.

  Fixpoint eval (e: Expr): nat :=
    match e with
    | Plus a b => eval a + eval b
    | Mult a b => eval a * eval b
    | Zero => 0
    | One => 1
    end.

  (* First up is the simplest approach I can think of. *)
  Module approach_A.
    Class Quote (n: nat) := quote: Expr.

    Implicit Arguments quote [[Quote]].

    Section instances.

      Context n m `{Quote n} `{Quote m}.

      Global Instance: Quote 0 := Zero.
      Global Instance: Quote 1 := One.
      Global Instance: Quote (n + m) := Plus (quote n) (quote m).
      Global Instance: Quote (n * m) := Mult (quote n) (quote m).

    End instances.

    Ltac do_quote :=
      match goal with
      |- (?a = ?b) => change (eval (quote a) = eval (quote b))
      end.

    Lemma example: (1 + 0 + 1) * (1 + 1) = (1 + 1) + (1 + 1).
     do_quote.
    Admitted.
  End approach_A.

  (* This works, but there's something unsatisfying about this quotation, because
  the actual Quote instances are not validated until we get to the [change] tactic,
  which validates the quotation by requiring convertibility.

  Next, we show an alternative implementation where the Quote instances
  are all proved locally correct at their definition: *)

  Module approach_B.
    Class Quote (n: nat) := { quote: Expr; eval_quote: n = eval quote  }.

    Implicit Arguments quote [[Quote]].
    Implicit Arguments eval_quote [[Quote]].

    Section instances.

      Context n m `{Quote n} `{Quote m}.

      Global Program Instance: Quote 0 := { quote := Zero }.
      Global Program Instance: Quote 1 := { quote := One }.

      Global Instance: Quote (n + m) := { quote := Plus (quote n) (quote m) }.
      Proof. simpl. do 2 rewrite <- eval_quote. reflexivity. Qed.

      Global Instance: Quote (n * m) := { quote := Mult (quote n) (quote m) }.
      Proof. simpl. do 2 rewrite <- eval_quote. reflexivity. Qed.

    End instances.

    Lemma do_quote {n m} `{Quote n} `{Quote m}: eval (quote n) = eval (quote m) → n = m.
    Proof. intros. rewrite (eval_quote n), (eval_quote m). assumption. Qed.

    Lemma example: (1 + 0 + 1) * (1 + 1) = (1 + 1) + (1 + 1).
     apply do_quote.
    Admitted.
  End approach_B.
End simple.

(* So far so good, but the variable-less scenario isn't really interesting. We now rework approach B
 to include quotation of holes/variables, including recognition of syntactically identical ones. *)

Module with_vars.
(* Some random utilities: *)

Lemma sum_assoc {A B C}: (A+B)+C → A+(B+C). intuition. Defined.
Lemma bla {A B C}: (A+B) → A+(B+C). intuition. Defined.
Lemma monkey {A B}: False + A → A + B. intuition. Defined.

Section obvious.
  Class Obvious (T: Type) := obvious: T.

  Context (A B C: Type).

  Global Instance: Obvious (A → A) := id.
  Global Instance: Obvious (False → A) := False_rect _.
  Global Instance: Obvious (A → A + B) := inl.
  Global Instance: Obvious (A → B + A) := inr.
  Global Instance obvious_sum_src  `{Obvious (A → C)} `{Obvious (B → C)}: Obvious (A+B → C). repeat intro. intuition. Defined.
  Global Instance obvious_sum_dst_l `{Obvious (A → B)}: Obvious (A → B+C). repeat intro. intuition. Defined.
  Global Instance obvious_sum_dst_r `{Obvious (A → B)}: Obvious (A → C+B). repeat intro. intuition. Defined.
End obvious.

(* Again our example term language, this time without plus/one (they're boring), but with Var
 added: *)

Inductive Expr (V: Type) := Mult (a b: Expr V) | Zero | Var (v: V).

Implicit Arguments Var [[V]].
Implicit Arguments Zero [[V]].
Implicit Arguments Mult [[V]].

(*
Require Import monads canonical_names.

Instance: MonadReturn Expr := fun _ => Var.

Instance expr_bind: MonadBind Expr := fun A B =>
  fix F (m: Expr A) (f: A → Expr B): Expr B :=
    match m with
    | Zero => Zero
    | Mult x y => Mult (F x f) (F y f)
    | Var v => f v
    end.

Section eqs.

  Context `{e: Equiv A} `{Equivalence _ e}.

  Global Instance expr_eq: Equiv (Expr A) :=
    fix F (x y: Expr A) :=
      match x, y with
      | Var v, Var w => v = w
      | Mult v w, Mult p q => F v p ∧ F w q
      | Zero, Zero => True
      | _, _ => False
      end.

  Instance: Reflexive expr_eq.
  Proof. intro. induction x; simpl; intuition. Qed.

  Instance: Symmetric expr_eq.
  Proof. intro. induction x; destruct y; simpl in *; intuition. Qed.

  Instance: Transitive expr_eq.
  Admitted.

  Global Instance expr_equivalence: Equivalence expr_eq.

End eqs.

Instance: ∀ `{Equiv A}, Proper ((=) ==> (=)) (ret Expr).
 repeat intro.
 assumption.
Qed.

Instance bind_proper: ∀ `{Equiv A} `{Equiv B},
 Proper ((=) ==> pointwise_relation A (=) ==> (=)) (@expr_bind A B).
Proof.
 intros A H B H0 x y E.
(*
 induction x.
  destruct y; intuition.
  intros f g E'.
  simpl.
  red.
  simpl.
  split.
   red in E.
   simpl in E.

   apply IHx2.

  simpl in *.

 unfold expr_bind.

 simpl.
*)
Admitted.

Instance: Monad Expr.
  *)

(* The expression type is parameterized over the set of variable indices. Hence, we diverge
 from Claudio, who uses nat indices for variables, thereby introducing bounds problems and
 dummy variables and other nastiness. *)

(* An expression is only meaningful in the context of a variable assignment: *)

Definition Value := nat.
Definition Vars V := V → Value.

Fixpoint eval {V} (vs: Vars V) (e: Expr V): Value :=
  match e with
  | Zero => 0
  | Mult a b => eval vs a * eval vs b
  | Var v => vs v
  end.

Instance eval_proper V: Proper (pointwise_relation _ eq ==> eq ==> eq) (@eval V).
Proof.
 repeat intro. subst.
 induction y0; simpl.
   congruence.
  reflexivity.
 apply H.
Qed.

(* Some simple combinators for variable packs: *)

Definition novars: Vars False := False_rect _.
Definition singlevar (x: Value): Vars unit := fun _ => x.
Definition merge {A B} (a: Vars A) (b: Vars B): Vars (A+B) :=
  fun i => match i with inl j => a j | inr j => b j end.

(* These last two combinators are the "constructors" of an implicitly defined subset of
 Gallina terms (representing Claudio's "heaps") for which we implement syntactic
 lookup with type classes: *)

Section Lookup.
  (* Given a heap and value, Lookup instances give the value's index in the heap: *)

  Class Lookup {A} (x: Value) (f: Vars A) := { lookup: A; lookup_correct: f lookup = x }.

  Global Implicit Arguments lookup [[A] [Lookup]].

  Context (x: Value) {A B} (va: Vars A) (vb: Vars B).

  (* If the heap is a merge of two heaps and we can find the value's index in the left heap,
   we can access it by indexing the merged heap: *)

  Global Instance lookup_left `{!Lookup x va}: Lookup x (merge va vb)
    := { lookup := inl (lookup x va) }.
  Proof. apply lookup_correct. Defined.

  (* And vice-versa: *)

  Global Instance lookup_right `{!Lookup x vb}: Lookup x (merge va vb)
    := { lookup := inr (lookup x vb) }.
  Proof. apply lookup_correct. Defined.

  (* If the heap is just a singlevar, we can easily index it. *)

  Global Program Instance: Lookup x (singlevar x) := { lookup := tt }.

  (* Note that we don't have any fallback/default instances at this point. We /will/ introduce
  such an instance for our Quote class later on, which will add a new variable to the heap
  if another Quote instance that relies on Lookup into the "current" heap fails. *)
End Lookup.

(* One useful operation we need before we get to Quote relates to variables and expression
 evaluation. As its name suggests, map_var maps an expression's variable indices. *)

Definition map_var {V W: Type} (f: V → W): Expr V → Expr W :=
  fix F (e: Expr V): Expr W :=
    match e with
    | Mult a b => Mult (F a) (F b)
    | Zero => Zero
    | Var v => Var (f v)
    end.

(* An obvious identity is: *)

Lemma eval_map_var {V W} (f: V → W) v e:
  eval v (map_var f e) = eval (v ∘ f) e.
Proof.
 induction e; simpl; try reflexivity.
 rewrite IHe1, IHe2.
 reflexivity.
Qed.

(* Finally, Quote itself: *)

Section Quote.
  (* In Quote, the idea is that V, l, and n are all "input" variables, while V' and r are "output"
  variables (in the sense that we will rely on unification to generate them. V and l represent
  the "current heap", n represents the value we want to quote, and V' and r' represent the
  heap of newly encountered variables during the quotation.
    This explains the type of quote: it is an expression that refers either to variables from
  the old heap, or to newly encountered variables.
    eval_quote is the usual correctness property, which now merges the two heaps. *)

  Class Quote {V} (l: Vars V) (n: Value) {V'} (r: Vars V') :=
    { quote: Expr (V + V')
    ; eval_quote: @eval (V+V') (merge l r) quote = n }.

  Implicit Arguments quote [[V] [l] [V'] [r] [Quote]].

  (* Our first instance for Zero is easy. The "novars" in the result type reflects the fact that no new
   variables are encountered. The correctness proof is easy enough for Program. *)

  Global Program Instance quote_zero V (v: Vars V): Quote v 0 novars := { quote := Zero }.

  (* The instance for multiplication is a bit more complex. The first line is just boring
   variable declarations. The second line is important. "Quote x y z" must be read as
   "quoting y with existing heap x generates new heap z", so the second line
   basically just shuffles heaps around.
     The third line has some ugly map_var's in it because the heap shuffling must be reflected
   in the variable indices, but apart from that it's just constructing a Mult
   term with quoted subterms. *)

  Global Program Instance quote_mult V (v: Vars V) n V' (v': Vars V') m V'' (v'': Vars V'')
    `{!Quote v n v'} `{!Quote (merge v v') m v''}: Quote v (n * m) (merge v' v'') :=
      { quote := Mult (map_var bla (quote n)) (map_var sum_assoc (quote m)) }.

  Next Obligation. Proof with auto.
   destruct Quote0, Quote1.
   subst. simpl.
   do 2 rewrite eval_map_var.
   f_equal; apply eval_proper; auto; intro; intuition.
  Qed.

  (* Now follows the instance where we recognize values that are already in the heap. This
   is expressed by the Lookup requirement, which will only be fulfilled if the Lookup instances
   defined above can find the value in the heap. The novars in the [Quote v x novars] result
   reflects that this quotation does not generate new variables. *)

  Global Program Instance quote_old_var V (v: Vars V) x {i: Lookup x v}:
    Quote v x novars | 8 := { quote := Var (inl (lookup x v)) }.
  Next Obligation. Proof. apply lookup_correct. Qed.

  (* Finally, the instance for new variables. We give this lower priority so that it is only
   used if Lookup fails. *)

  Global Program Instance quote_new_var V (v: Vars V) x: Quote v x (singlevar x) | 9
    := { quote := Var (inr tt) }.
End Quote.

(* Note: Explicitly using dynamically configured variable index sets instead of plain lists
 not only removes the need for an awkward dummy value to cope with out-of-bounds
 accesses, but also means that we can prove the correctness class fields in
 Lookup/Quote without having to take the potential for out-of-bounds indexing into
 account (which would be a nightmare). *)

(* When quoting something from scratch we will want to start with an empty heap.
 To avoid having to mention this, we define quote' and eval_quote': *)

Definition quote': ∀ x {V'} {v: Vars V'} {d: Quote novars x v}, Expr _ := @quote _ _.

Definition eval_quote': ∀ x {V'} {v: Vars V'} {d: Quote novars x v},
  eval (merge novars v) quote = x
    := @eval_quote _ _ .

Implicit Arguments quote' [[V'] [v] [d]].
Implicit Arguments eval_quote' [[V'] [v] [d]].

(* Time for some tests! *)

Goal ∀ x y (P: Value → Prop), P ((x * y) * (x * 0)).
  intros.
  rewrite <- (eval_quote' _).
    (* turns the goal into
         P (eval some_variable_pack_composed_from_combinators quote)
    *)
  simpl quote.
Admitted.

(* We can also inspect quotations more directly: *)

Section inspect.
  Variables x y: Value.
  (* Eval compute in quote' ((x * y) * (x * 0)). *)
    (* = Mult (Mult (Var (inr (inl (inl ())))) (Var (inr (inl (inr ())))))
           (Mult (Var (inr (inl (inl ())))) Zero)
       : Expr (False + (() + () + (False + False))) *)

  (* The second occurrence of (Var (inr (inl (inl ())))) means
   the quoting has successfully noticed that it's the same
   expression. *)

  (* The two units in the generated variable index type reflect the
   fact that the expression contains two variables. *)

  (* I think adding some additional Quote instances might let us
   get rid of the False's, but at the moment I see little reason to. *)
End inspect.

(* If we want to quote an equation between two expressions we should make
 sure that the both sides refer to the same variable pack, and for that we write a
 little utility function. It does the same kind of shuffling that the mult
 Quote instance did. *)

Lemma quote_equality {V} {v: Vars V} {V'} {v': Vars V'} (l r: Value) `{!Quote novars l v} `{!Quote v r v'}:
  let heap := (merge v v') in
  eval heap (map_var monkey quote) = eval heap quote → l = r.
Proof with intuition.
 destruct Quote0 as [lq []].
 destruct Quote1 as [rq []].
 intros heap H.
 subst heap. simpl in H.
 rewrite <- H, eval_map_var.
 apply eval_proper... intro...
Qed.

Goal ∀ x y, x * y = y * x.
 intros.
 apply (quote_equality _ _).
 simpl quote.
 unfold map_var, monkey, sum_rect.
Admitted.

End with_vars.


Require Export Families.
Require Export Image.
Require Import ImageImplicit.

Set Implicit Arguments.

Section IndexedFamilies.

Variable A T:Type.
Definition IndexedFamily := A -> Ensemble T.
Variable F:IndexedFamily.

Inductive IndexedUnion : Ensemble T :=
  | indexed_union_intro: forall (a:A) (x:T),
    In (F a) x -> In IndexedUnion x.

Inductive IndexedIntersection : Ensemble T :=
  | indexed_intersection_intro: forall (x:T),
    (forall a:A, In (F a) x) -> In IndexedIntersection x.

End IndexedFamilies.

Section IndexedFamilyFacts.

(* unions and intersections over subsets of the index set *)
Lemma sub_indexed_union: forall {A B T:Type} (f:A->B)
  (F:IndexedFamily B T),
  let subF := (fun a:A => F (f a)) in
    Included (IndexedUnion subF) (IndexedUnion F).
Proof.
unfold Included.
intros.
destruct H.
apply indexed_union_intro with (f a).
assumption.
Qed.

Lemma sub_indexed_intersection: forall {A B T:Type} (f:A->B)
  (F:IndexedFamily B T),
  let subF := (fun a:A => F (f a)) in
    Included (IndexedIntersection F) (IndexedIntersection subF).
Proof.
unfold Included.
intros.
constructor.
destruct H.
intro.
apply H.
Qed.

Lemma empty_indexed_intersection: forall {T:Type}
  (F:IndexedFamily False T),
  IndexedIntersection F = Full_set.
Proof.
intros.
apply Extensionality_Ensembles; red; split; red; intros;
  auto with sets.
constructor.
constructor.
destruct a.
Qed.

Lemma empty_indexed_union: forall {T:Type}
  (F:IndexedFamily False T),
  IndexedUnion F = Empty_set.
Proof.
intros.
apply Extensionality_Ensembles; red; split; red; intros.
destruct H.
destruct a.
destruct H.
Qed.

End IndexedFamilyFacts.

Section IndexedFamilyToFamily.

(* relation to families of subsets of T *)
Variable T:Type.
Variable A:Type.
Variable F:IndexedFamily A T.

Definition ImageFamily : Family T :=
  Im Full_set F.

Lemma indexed_to_family_union: IndexedUnion F = FamilyUnion ImageFamily.
Proof.
apply Extensionality_Ensembles.
unfold Same_set.
unfold Included.
intuition.
destruct H.
apply family_union_intro with (F a).
apply Im_intro with a.
constructor.
reflexivity.
assumption.

destruct H.
destruct H.
apply indexed_union_intro with x0.
rewrite <- H1.
assumption.
Qed.

Lemma indexed_to_family_intersection:
  IndexedIntersection F = FamilyIntersection ImageFamily.
Proof.
apply Extensionality_Ensembles.
unfold Same_set.
unfold Included.
intuition.
constructor.
intros.
destruct H.
destruct H0.
rewrite H1.
apply H.

constructor.
intro.
destruct H.
apply H.
apply Im_intro with a.
constructor.
reflexivity.
Qed.

End IndexedFamilyToFamily.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Orders Rbase Rbasic_fun ROrderedType GenericMinMax.

(** * Maximum and Minimum of two real numbers *)

Local Open Scope R_scope.

(** The functions [Rmax] and [Rmin] implement indeed
    a maximum and a minimum *)

Lemma Rmax_l : forall x y, y<=x -> Rmax x y = x.
Proof.
 unfold Rmax. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmax_r : forall x y, x<=y -> Rmax x y = y.
Proof.
 unfold Rmax. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmin_l : forall x y, x<=y -> Rmin x y = x.
Proof.
 unfold Rmin. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmin_r : forall x y, y<=x -> Rmin x y = y.
Proof.
 unfold Rmin. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Module RHasMinMax <: HasMinMax R_as_OT.
 Definition max := Rmax.
 Definition min := Rmin.
 Definition max_l := Rmax_l.
 Definition max_r := Rmax_r.
 Definition min_l := Rmin_l.
 Definition min_r := Rmin_r.
End RHasMinMax.

Module R.

(** We obtain hence all the generic properties of max and min. *)

Include UsualMinMaxProperties R_as_OT RHasMinMax.

(** * Properties specific to the [R] domain *)

(** Compatibilities (consequences of monotonicity) *)

Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m.
Proof.
 intros. apply max_monotone.
 intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p.
Proof.
 intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
 apply plus_max_distr_l.
Qed.

Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m.
Proof.
 intros. apply min_monotone.
 intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p.
Proof.
 intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
 apply plus_min_distr_l.
Qed.

(** Anti-monotonicity swaps the role of [min] and [max] *)

Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m).
Proof.
 intros. symmetry. apply min_max_antimonotone.
 do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m).
Proof.
 intros. symmetry. apply max_min_antimonotone.
 do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m.
Proof.
 unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l.
Qed.

Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p.
Proof.
 unfold Rminus. intros. apply plus_max_distr_r.
Qed.

Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m.
Proof.
 unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l.
Qed.

Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p.
Proof.
 unfold Rminus. intros. apply plus_min_distr_r.
Qed.

End R.


Require Import Arith.
Require Import Lia.

Lemma minus_plus_commut:
forall m n q, m >= n -> m - n + q = m + q - n.
Proof.
  intros.
  assert (m = n + (m - n)).
  apply le_plus_minus; auto.
  rewrite H0.
  assert (n + (m - n) + q = n + ((m-n) + q)). lia.
  rewrite H1. assert (n + (m - n + q) - n = m - n + q).
  apply minus_plus. rewrite H2.
  assert (n + (m - n) - n = m - n).
  apply minus_plus. rewrite H3. auto.
Qed.
Hint Resolve minus_plus_commut.

Lemma sp_P2_N2:
forall sp, sp + 2 - 2 = sp.
Proof.
  intro.
  assert (sp + 2 = 2 + sp). auto with arith.
  rewrite H. auto with arith.
Qed.
Hint Resolve sp_P2_N2.

Lemma sp_P4_N2:
forall sp, sp + 4 - 2 = sp + 2.
Proof.
  intro sp.
  lia.
Qed.
Hint Resolve sp_P4_N2.

Lemma sp_P2_P2:
forall sp, sp + 2 + 2 = sp + 4.
Proof.
  intro sp. lia.
Qed.
Hint Resolve sp_P2_P2.

Lemma sp_P4_N2_N2:
forall sp, sp + 4 - 2 - 2 = sp.
Proof.
  intro sp. lia.
Qed.
Hint Resolve sp_P4_N2_N2.

Lemma ge_trans:
  forall a b c, a >= b -> b >= c -> a >= c.
Proof.
  intros.
  assert (c <= a).
  apply le_trans with b; auto with arith.
  auto with arith.
Qed.

Lemma sp_P4_P2:
forall sp, sp + 4 + 2 = sp + 6.
Proof.
  intro. lia.
Qed.
Hint Resolve sp_P4_P2.

Lemma sp_P4_N6:
forall sp, sp + 4 - 6 = sp - 2.
Proof.
  intro sp.
  lia.
Qed.
Hint Resolve sp_P4_N6.

Lemma sp_P6_N2:
forall sp, sp + 6 - 2 = sp + 4.
Proof.
  intro sp. lia.
Qed.
Hint Resolve sp_P6_N2.

Lemma sp_N2_P2:
forall sp, sp >= 2 -> sp - 2 + 2 = sp.
Proof.
  intros.
  assert (sp - 2 + 2 = sp + 2 - 2). auto.
  rewrite H0. auto.
Qed.
Hint Resolve sp_N2_P2.

Lemma sp_N2_P4:
forall sp, sp >= 2 -> sp - 2 + 4 = sp + 2.
Proof.
  intros.
  assert (sp - 2 + 4 = sp + 4 - 2). auto.
  assert (sp +  4 - 2 = sp + 2); auto.
  rewrite H1 in H0. rewrite H0. auto.
Qed.
Hint Resolve sp_N2_P4.

Lemma sp_N2_P6:
forall sp, sp >= 2 -> sp - 2 + 6 = sp + 4.
Proof.
  intros.
  assert (sp - 2 + 6 = sp + 6 - 2).
  auto. rewrite H0.
  lia.
Qed.
Hint Resolve sp_N2_P6.

Lemma sp_P2_P1:
forall sp,
    sp + 2 + 1 = sp + 3.
Proof.
  intro sp. lia.
Qed.
Hint Resolve sp_P2_P1.


(* https://coq.inria.fr/refman/Reference-Manual027.html *)
(* PROGRAM-ing Finger Trees in COQ *)

Require Import Omega.
Require Import List.
Require Import Arith.
Require Import Arith.Even.
Require Import Program.
Require Import Cpdt.CpdtTactics Cpdt.Coinductive.

Set Implicit Arguments.

Program Definition id (n : nat) : { x : nat | x = n } :=
  if dec (leb n 0) then
    0
  else
    S (pred n).
Obligation 1.
Proof.                                      (* n <= 0 -> n = 0 *)
  destruct n.
  - now auto.                               (* n = 0 *)
  - now inversion H.                        (* n >= 1 矛盾 *)

  Restart.
  now destruct n.
Defined.
Obligation 2.
Proof.
  now destruct n.
Defined.

(* DIV2 *)
Program Fixpoint div2 (n : nat) {measure n} :
  { x : nat | n = 2 * x \/ n = 2 * x + 1 } :=
  match n with
  | S (S p) => S (div2 p)
  | _ => O
  end.
Obligation 2.
Proof.
  remember (div2 _ _).
  destruct s as [n H]; simpl.
  omega.
Defined.
Obligation 3.
Proof.
  destruct n as [| n].
  - now left.                               (* n = 0 *)
  - destruct n as [| n].
    + now right.                            (* n = 1 *)
    + induction (H n).
      reflexivity.                          (* n >= 2 *)

  Restart.
  destruct n as [| n]; try auto.
  destruct n as [| n]; try auto.
  induction (H n); auto.
Defined.

(* measure なしの場合 *)
Program Fixpoint div2' (n : nat) :
  { x : nat | n = 2 * x \/ n = 2 * x + 1 } :=
  match n with
  | S (S p) => S (div2' p)
  | _ => O
  end.
Obligation 1.
Proof.
  omega.
Defined.
Obligation 2.
Proof.
  destruct n as [| n].
  - now left.                               (* n = 0 *)
  - destruct n as [| n].
    + now right.                            (* n = 1 *)
    + induction (H n).
      reflexivity.                          (* n >= 2 *)

  Restart.
  destruct n as [| n]; try auto.
  destruct n as [| n]; try auto.
  induction (H n); auto.
Defined.

(* 証明なし *)
Fixpoint div2'' (n : nat) : nat :=
  match n with
  | S (S p) => S (div2'' p)
  | _ => O
  end.

(* **** *)
(* Even *)
(* **** *)
(* Hint Constructos even odd with arith *)

Lemma not_odd_and_even n : odd n -> even n -> False.
Proof.
  induction n.
  - now intros Ho He.
  - intros Ho He.
    inversion Ho.
    inversion He.
    now auto.

  Restart.
  intros Ho He.
  generalize He Ho.
  now apply not_even_and_odd.
Qed.

Lemma not_odd_2 x : odd (x + x) -> False.
Proof.
  apply not_even_and_odd.
  cutrewrite (x + x = 2 * x).
  - now apply even_mult_l; auto with arith.
  - omega.
Qed.

Lemma not_even_2_1 x : even (x + x + 1) -> False.
Proof.
  apply not_odd_and_even.
  apply odd_plus_r.
  - cutrewrite (x + x = 2 * x).
    + now apply even_mult_l; auto with arith.
    + omega.
  - now auto with arith.
Qed.

Lemma even_2 x : even (x * 2).
Proof.
  apply even_mult_r.
  now auto with arith.
Qed.
Hint Resolve even_2.

Program Definition div2_2' (n : nat) :
  { m : nat | even m } :=
  div2 n * 2.
(* Obligation なし。 *)

Program Definition div2_2 (n : nat) :
  { m : nat | (even n -> n = m) /\ (odd n -> n - 1 = m) } :=
  div2 n * 2.
Obligation 1.
Proof.
  remember (div2 _).
  remember (_ * 2).
  destruct s as [m H].                      (* 証明のないdiv2'' だと s が出てこない。 *)
  destruct H as [H1 | H2]; simpl in *.
  - split.
    + omega.
    + clear Heqs.
      rewrite <- plus_n_O in H1.
      intro H.
      rewrite H1 in H.
      now apply not_odd_2 in H.
  - split.
    + clear Heqs.
      rewrite <- plus_n_O in H2.
      intro H.
      rewrite H2 in H.
      now apply not_even_2_1 in H.
    + omega.
Defined.

Eval compute in  ` (div2_2 4).              (* 4 *)
Eval compute in  ` (div2_2 5).              (* 4 *)

(* 次にやること。 *)
(* div2 の末尾再帰版をつくる。 *)

(* END *)


(* by Evelyne Contejean *)

(** * Some additional properties for the Coq lists. *)

Set Implicit Arguments.

Require Import List.
Require Import Arith.

(** ** Relations between length, map, append, In and nth. *)

Lemma map_map :
  forall (A B C : Set) (l : (list A)) (f : B -> C) (g : A ->B),
  map f (map g l) = map (fun x => f (g x)) l.
Proof.
intros A B C l f g; induction l as [ | x l].
trivial.
simpl; rewrite IHl; trivial.
Qed.

Lemma list_app_length :
 forall A, forall l1 l2 : list A, length (l1 ++ l2) = length l1 + length l2.
Proof.
induction l1 as [ | a1 l1 ]; trivial.
intros; simpl; rewrite IHl1; trivial.
Qed.

Lemma length_map :
 forall (A B : Set) (f : A -> B) (l : list A), length (map f l) = length l.
Proof.
intros; induction l as [ | a l ]; trivial.
simpl; rewrite IHl; trivial.
Qed.

Lemma map_app :
 forall (A B : Set) (f : A -> B) l1 l2, map f (l1 ++ l2) = (map f l1) ++ (map f l2).
Proof.
induction l1 as [ | a1 l1 ]; trivial.
intros; simpl; rewrite IHl1; trivial.
Qed.

Lemma in_in_map :
  forall (A B : Set) (f : A -> B) a l, In a l -> In (f a) (map f l).
Proof.
intros A B f a l; induction l as [ | b l ]; trivial.
intro In_a; elim In_a; clear In_a; intro In_a.
subst; left; trivial.
right; apply IHl; trivial.
Qed.

Lemma in_map_in :
  forall (A B : Set) (f : A -> B) b l, In b (map f l) ->
  exists a, In a l /\ f a = b.
Proof.
intros A B f b l; induction l as [ | a l ].
contradiction.
intro In_b; elim In_b; clear In_b; intro In_b.
exists a; split; trivial; left; trivial.
elim (IHl In_b); intros a' [H1 H2]; exists a'; split; trivial; right; trivial.
Qed.

Lemma nth_error_map :
  forall (A B : Set) (f : A -> B) (l : list A) i,
  match nth_error (map f l) i with
  | Some f_li =>
           match nth_error l i with
            | Some li => f_li = f li
            | None => False
            end
  | None =>
            match nth_error l i with
            | Some li => False
            | None => True
            end
end.
Proof.
induction l as [ | a l ];
intro i; destruct i as [ | i ]; simpl; trivial.
apply IHl; trivial.
Qed.

(** ** A measure on lists based on a measure on elements. *)

Fixpoint list_size (A : Set) (size : A -> nat) (l : list A) {struct l} : nat :=
  match l with
  | nil => 0
  | h :: tl => size h + list_size size tl
  end.

Lemma list_size_tl_compat :
  forall (A : Set) (size : A -> nat) a b l, size a < size b ->
    list_size size (a :: l) < list_size size (b :: l).
Proof.
intros A size a b l H; simpl; apply plus_lt_compat_r; trivial.
Qed.

Lemma list_size_app:
 forall (A : Set) (size : A -> nat) l1 l2,
 list_size size (l1 ++ l2) = list_size size l1 + list_size size l2.
Proof.
induction l1 as [ | a1 l1 ]; trivial.
intros; simpl; rewrite IHl1; auto with arith.
Qed.

Lemma list_size_fold :
  forall (A : Set) (size : A -> nat) l n,
  fold_left (fun (size_acc : nat) (a : A) => size_acc + size a) l n =
  n + list_size size l.
Proof.
intros A size l; induction l; trivial.
intro n; simpl; rewrite plus_assoc; apply IHl.
Qed.

Lemma list_size_size_eq :
  forall (A : Set) (size1 : A -> nat) (size2 : A -> nat) l,
 (forall a, In a l -> size1 a = size2 a) -> list_size size1 l = list_size size2 l.
Proof.
intros A size1 size2 l; induction l as [ | a l]; simpl; trivial.
intros size1_eq_size2.
rewrite (size1_eq_size2 a (or_introl _ (refl_equal _))).
apply (f_equal (fun n => size2 a + n)); apply IHl;
intros; apply size1_eq_size2; right; trivial.
Qed.

(** ** Induction principles for list.
 Induction on the length. *)
Definition list_rec2 :
  forall A, forall P : list A -> Type,
    (forall (n:nat) (l : list A), length l <= n -> P l) ->
    forall l : list A, P l.
Proof.
intros A P H l; apply (H (length l) l); apply le_n.
Defined.

Definition o_length (A : Set) (l1 l2 : list A) : Prop := length l1 < length l2.

Theorem well_founded_length : forall A, well_founded (o_length (A := A)).
Proof.
intro A; assert (Acc_nil : Acc (o_length (A:=A)) (@nil A)).
apply Acc_intro; intros l H; absurd (o_length l nil); trivial;
unfold o_length; simpl; auto with arith.

unfold well_founded, o_length;
intros l; pattern l; apply list_rec2; clear l;
induction n; intro l; destruct l; intros H; trivial.
simpl in H; absurd (S (length l) <= 0); trivial; auto with arith.
apply Acc_intro; intros l' H'; apply IHn;
apply le_trans with (length l);
simpl in H; simpl in H'; auto with arith.
Defined.

(** Induction on the the size. *)
Definition list_rec3 (A : Set) (size : A -> nat) :
  forall P : list A -> Type,
    (forall (n:nat) (l : list A), list_size size l <= n -> P l) ->
    forall l : list A, P l.
Proof.
intros P H l; apply (H (list_size size l) l); apply le_n.
Defined.

(** ** How to remove an element in a list, whenever it is present. *)
Fixpoint split_list (A : Set)
  (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (l : list A) (t : A) {struct l} : list A * list A :=
  match l with
  | nil => (nil, nil)
  | a :: l' =>
      if eqA t a
      then (nil, l')
      else let (l1,l2) := split_list eqA l' t in (a :: l1, l2)
  end.

Lemma split_list_app_cons :
 forall (A : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2}) t l,
   In t l -> let (l1, l2) := split_list eqA l t in l = l1 ++ t :: l2.
Proof.
induction l as [ | a l ].
contradiction.
simpl; elim (eqA t a); intro eq_t_a.
intros _; subst; trivial.
intros [eq_t_a' | In_t].
absurd (t = a); auto.
generalize (IHl In_t); destruct (split_list eqA l t); intro; subst; auto.
Defined.

Fixpoint remove (A : Set) (eqA : forall a1 a2 : A, {a1=a2}+{a1<>a2})
  (a : A) (l : list A) {struct l} : (option (list A)) :=
  match l with
  | nil => None
  | h :: tl =>
    if eqA a h
    then Some tl
    else
      match remove eqA a tl with
      | Some rmv => Some (h :: rmv)
      | None => None
      end
  end.

Lemma in_remove :
  forall (A : Set) (eqA : forall a1 a2 : A, {a1=a2}+{a1<>a2}) a l,
  match remove eqA a l with
  | None => ~In a l
  | Some l' => In a l /\ let (l1, l2) := split_list eqA l a in l' = l1 ++ l2
  end.
Proof.
induction l as [ | a1 l]; simpl; auto;
elim (eqA a a1); intro eq_a_a1; intuition.
destruct (remove eqA a l) as [ rmv |  ]; intuition;
destruct (split_list eqA l a); subst; auto.
Qed.

Fixpoint remove_list (A : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
(la l : list A) {struct l} : option (list A) :=
  match la with
  | nil => Some l
  | a :: la' =>
	match l with
	| nil => None
	| b :: l' =>
	   if eqA a b
	   then remove_list eqA la' l'
	   else
	     match remove_list eqA la l' with
	     | None => None
	     | Some rmv => Some (b :: rmv)
	     end
        end
  end.

(** ** Iterators. *)
Fixpoint fold_left2 (A B C : Set) (f : A -> B -> C -> A) (a : A) (l1 : list B) (l2 : list C)
  {struct l1} : option A :=
  match l1, l2 with
  | nil, nil => Some a
  | b :: t1, c :: t2 => fold_left2 f (f a b c) t1 t2
  | _, _ => None
  end.

(** ** more properties on the nth element. *)
Lemma nth_error_ok_in :
  forall (A : Set) n (l : list A) (a : A),
  nth_error l n = Some a -> In a l.
Proof.
intros A n l; generalize n; clear n; induction l as [ | a' l].
intros [ | n] a; simpl; discriminate.
intros [ | n] a; simpl.
intro H; injection H; subst; left; trivial.
intro; right; apply IHl with n; trivial.
Qed.

(** ** Association lists.
*** find. *)
Fixpoint find (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
(a : A) (l : list (A * B)) {struct l} : option (B) :=
 match l with
 | nil => None
 | (a1,b1) :: l =>
     if eqA a a1
     then Some b1
     else find eqA a l
  end.

Lemma find_not_mem :
  forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (a : A) (b : B) (l : list (A * B)) (dom : list A),
  ~In a dom -> (forall a', In a' dom -> find eqA a' ((a,b) :: l) = find eqA a' l).
Proof.
intros A B eqA a b l dom a_not_in_dom a' a'_in_dom; simpl;
destruct (eqA a' a) as [a'_eq_a | a'_diff_a].
subst a'; absurd (In a dom); trivial.
trivial.
Qed.

(** *** number of occurences of the first element of a pair. *)
Fixpoint nb_occ (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (a : A) (l : list (A * B)) {struct l} : nat :=
  match l with
  | nil => 0
  | (a',_) :: tl =>
     if (eqA a a') then S (nb_occ eqA a tl) else nb_occ eqA a tl
  end.

Lemma none_nb_occ_O :
  forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (a : A) (l : list (A * B)),
  find eqA a l = None -> nb_occ eqA a l = 0.
Proof.
intros A B eqA a l; induction l as [ | [a1 b1] l]; trivial; simpl.
destruct (eqA a a1) as [a_eq_a1 | a_diff_a1]; intros.
discriminate.
apply IHl; trivial.
Qed.

Lemma some_nb_occ_Sn :
  forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (a : A) (l : list (A * B)) b,
  find eqA a l = Some b -> 1 <= nb_occ eqA a l.
Proof.
intros A B eqA a l; induction l as [ | [a1 b1] l].
intros; discriminate.
intro b; simpl; destruct (eqA a a1) as [_ | _].
auto with arith.
intros; apply IHl with b; trivial.
Qed.

Lemma nb_occ_app :
  forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  a (l1 l2 : list (A * B)),
  nb_occ eqA a (l1++l2) = nb_occ eqA a l1 + nb_occ eqA a l2.
Proof.
intros A B eqA a l1; induction l1 as [ | [a1 b1] l1]; simpl; trivial.
intro l2; rewrite IHl1; destruct (eqA a a1) as [_ | _]; trivial.
Qed.

Lemma reduce_assoc_list :
  forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2}),
  forall (l : list (A * B)), exists l',
 (forall a, nb_occ eqA a l' <= 1) /\ (forall a, find eqA a l = find eqA a l').
Proof.
intros A B eqA l; induction l as [ | [a1 b1] l].
exists (nil : list (A * B)); split; trivial; auto.
elim IHl; intros l' [H1 H2].
assert (In_a1 : forall a, a = a1 -> find eqA a l' = find eqA a1 l').
intros; subst; trivial.
destruct (find eqA a1 l') as [ b | ];
generalize (In_a1 _ (refl_equal _)); clear In_a1; intro In_a1.
assert (In_a1' : exists l1, exists  l2, l' = l1 ++ (a1,b) :: l2).
clear H1 H2; induction l' as [ | [a' b'] l'].
discriminate.
simpl in In_a1; destruct (eqA a1 a') as [a1_eq_a' | _].
subst; inversion In_a1; exists (nil : list (A * B)); exists l'; simpl; trivial.
elim (IHl' In_a1); intros l1 [l2 H];
exists ((a',b') :: l1); exists l2; subst; trivial.
elim In_a1'; intros l1 [l2 H]; exists ((a1,b1) :: l1 ++ l2); split.
intro a; generalize (H1 a); subst l'; rewrite nb_occ_app;
simpl; destruct (eqA a a1) as [a_eq_a1 | _]; subst; rewrite nb_occ_app;
[ rewrite plus_comm; simpl; rewrite plus_comm | idtac ]; trivial.
intro a; simpl; destruct (eqA a a1) as [a_eq_a1 | a_diff_a1]; trivial.
rewrite H2; subst l'; clear H1 H2 In_a1 In_a1';
induction l1 as [ | [a1' b1'] l1]; simpl.
destruct (eqA a a1); trivial; absurd (a = a1); trivial.
rewrite IHl1; trivial.
exists ((a1,b1) :: l'); split; trivial; intro a; simpl.
destruct (eqA a a1) as [a_eq_a1 | a_diff_a1]; trivial.
rewrite none_nb_occ_O; subst; trivial.
rewrite (H2 a); trivial.
Qed.

(** map_without_repetition applies a function to the elements of a list,
but only a single time when there are several consecutive occurences of the
same element. Moreover, the function is supposed to return an option as a result,
in order to simulate exceptions, and the abnormal results are discarted.
*)
Fixpoint map_without_repetition (A B : Set)
  (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (f : A -> option B) (l : list A) {struct l} : list B :=
    match l with
    | nil => (nil : list B)
    | h :: nil =>
      match f h with
      | None => nil
      | Some f_h => f_h :: nil
      end
    | h1 :: ((h2 :: tl) as l1) =>
    if (eqA h1 h2)
    then map_without_repetition eqA f l1
    else
      match f h1 with
      | None => map_without_repetition eqA f l1
      | Some f_h1 => f_h1 :: (map_without_repetition eqA f l1)
      end
end.

Lemma prop_map_without_repetition :
 forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (P : B -> Prop) f l,
  (forall a, In a l ->
   match f a with
   | None => True
   | Some f_a => P f_a
   end) ->
   (forall b, In b (map_without_repetition eqA f l) -> P b).
Proof.
induction l as [ | a1 l].
contradiction.
assert (In_a1 : In a1 (a1 :: l)).
left; trivial.
intros H; generalize (H a1 In_a1); simpl; destruct l as [ | a2 l].
destruct (f a1) as [ f_a1 |  ]; simpl; intuition; subst; trivial.
elim (eqA a1 a2); intro eq_a1_a2.
intros; apply IHl; trivial; intros; apply H; right; trivial.
destruct (f a1) as [ f_a1 |  ].
intros P_f_a1 b [eq_f_a1_b | In_b].
subst; apply P_f_a1; left; trivial.
apply IHl; trivial; intros; apply H; right; trivial.
intros; apply IHl; trivial; intros; apply H; right; trivial.
Qed.

Lemma exists_map_without_repetition :
  forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (P : B -> Prop) f l,
  (exists a,  In a l /\ match f a with
                        | None => False
                        | Some f_a => P f_a
                        end) ->
  (exists b, In b (map_without_repetition eqA f l) /\ P b).
Proof.
intros A B eqA P f.
assert (In_map_right : forall b a l,
In b (map_without_repetition eqA f l) ->
In b (map_without_repetition eqA f (a :: l))).
intros b a1 l In_b; simpl; destruct l as [ | a2 l].
contradiction.
elim (eqA a1 a2); trivial;
destruct (f a1) as [ b1 | ]; trivial; intros _; right; trivial.
induction l as [ | a1 l].
intros [a [In_a _]]; contradiction.
intros [a [[Eq_a_a1 | In_a] P_f_a]].
simpl; subst a1; destruct l as [ | a2 l]; intuition.
destruct (f a) as [b | ]; [ exists b; intuition | contradiction ].
elim (eqA a a2).
intro; subst a; apply IHl; exists a2; intuition.
intros _;
destruct (f a) as [ b | ]; [exists b; intuition | contradiction].
assert (H: exists b : B, In b (map_without_repetition eqA f l) /\ P b).
apply IHl; exists a; intuition.
generalize H; intros [b H_b]; exists b; intuition.
Qed.

(** map12_without_repetition is similar to map_without_repetition, but the
applied function returns two optional results instead of one.
*)

Fixpoint map12_without_repetition (A B : Set)
  (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (f : A -> option B * option B) (l : list A) {struct l} : list B :=
    match l with
    | nil => (nil : list B)
    | h :: nil =>
      match f h with
      | (None, None) => nil
      | (Some f_h1, None) => f_h1 :: nil
      | (None, Some f_h1) => f_h1 :: nil
      | (Some f_h1, Some f_h2) => f_h1 :: f_h2 :: nil
      end
    | h :: ((h' :: tl) as l1) =>
    if (eqA h h')
    then map12_without_repetition eqA f l1
    else
      match f h with
      | (None, None) => map12_without_repetition eqA f l1
      | (Some f_h1, None) => f_h1 :: (map12_without_repetition eqA f l1)
      | (None, Some f_h1) => f_h1 :: (map12_without_repetition eqA f l1)
      | (Some f_h1, Some f_h2) => f_h2 :: f_h1 :: (map12_without_repetition eqA f l1)
      end
end.

Lemma prop_map12_without_repetition :
  forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (P : B -> Prop) f l,
  (forall a, In a l ->
   match f a with
   | (None, None) => True
   | (Some f1_a, None) => P f1_a
   | (None, Some f2_a) => P f2_a
   | (Some f1_a, Some f2_a) => P f1_a /\ P f2_a
   end) ->
 (forall b, In b (map12_without_repetition eqA f l) -> P b).
Proof.
intros A B eqA P f; induction l as [ | a1 l].
contradiction.
assert (In_a1 : In a1 (a1 :: l)).
left; trivial.
intros H b;
assert (Hrec :
forall b : B, In b (map12_without_repetition eqA f l) -> P b).
intros; apply IHl; trivial; intros; apply H; right; trivial.
clear IHl; simpl; generalize (H a1 In_a1).
destruct l as [ | a2 l].
destruct (f a1) as [o1 o2];
destruct o1 as [ f1_a1 | ];
destruct o2 as [ f2_a1 | ];
[ intros [P_f1_a1 P_f2_a1] | intros P_f1_a1 | intros P_f2_a1 | idtac].
intros [Eq_b_f1_a1 | [Eq_b_f2_a1 | In_b]]; subst; trivial; contradiction.
intros [Eq_b_f1_a1 | In_b]; subst; trivial; contradiction.
intros [Eq_b_f2_a1 | In_b]; subst; trivial; contradiction.
contradiction.
elim (eqA a1 a2).
intros; apply Hrec; trivial.
destruct (f a1) as [o1 o2];
destruct o1 as [ f1_a1 | ];
destruct o2 as [ f2_a1 | ];
[ intros _ [P_f1_a1 P_f2_a1]
| intros _ P_f1_a1 | intros _ P_f2_a1 | intros _].
intros [Eq_b_f1_a1 | [Eq_b_f2_a1 | In_b]];
subst; trivial; apply Hrec; trivial.
intros [Eq_b_f1_a1 | In_b]; subst; trivial; apply Hrec; trivial.
intros [Eq_b_f2_a1 | In_b]; subst; trivial; apply Hrec; trivial.
intros; apply Hrec; trivial.
Qed.

Lemma exists_map12_without_repetition :
  forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
  (P : B -> Prop) f l,
  ((exists a, In a l /\ match f a with
                        | (None, None) => False
                        | (None, Some f2_a) => P f2_a
                        | (Some f1_a, None) => P f1_a
                        | (Some f1_a, Some f2_a) => P f1_a \/ P f2_a
                        end) ->
  (exists b, In b (map12_without_repetition eqA f l) /\ P b)).
Proof.
intros A B eqA P f; induction l as [ | a1 l].
intros [a [In_a _]]; contradiction.
destruct l as [ | a2 l].
intros [a [[Eq_a_a1 | In_a] P_f_a]]; simpl.
subst a; destruct (f a1) as [o1 o2];
destruct o1 as [f1_a1 | ];
destruct o2 as [f2_a1 | ].
generalize P_f_a; clear P_f_a; intros [P_f1_a1 | P_f2_a1].
exists f1_a1; intuition.
exists f2_a1; intuition.
exists f1_a1; intuition.
exists f2_a1; intuition.
contradiction.
contradiction.
intros [a [[Eq_a_a1 | In_a] P_f_a]].
subst a; simpl; elim (eqA a1 a2).
intro; subst a1; apply IHl; exists a2; intuition.
destruct (f a1) as [o1 o2];
destruct o1 as [f1_a1 | ];
destruct o2 as [f2_a1 | ].
generalize P_f_a; clear P_f_a; intros [P_f1_a1 | P_f2_a1].
exists f1_a1; intuition.
exists f2_a1; intuition.
exists f1_a1; intuition.
exists f2_a1; intuition.
contradiction.
assert (Hrec : exists b : B,
In b (map12_without_repetition eqA f (a2 :: l)) /\ P b).
apply IHl; exists a; split; trivial.
generalize Hrec; intros [b [In_b P_b]]; exists b; split; trivial.
simpl; elim (eqA a1 a2).
intro; subst a1; trivial.
intros _; destruct (f a1) as [o1 o2];
destruct o1 as [P_f1_a1 | ];
destruct o2 as [P_f2_a1 | ].
right; right; trivial.
right; trivial.
right; trivial.
trivial.
Qed.