(* Copyright (c) 2008-2012, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import List.

Require Import CpdtTactics MoreSpecif.

Set Implicit Arguments.
(* end hide *)

(** %\chapter{Proof by Reflection}% *)

(** The last chapter highlighted a very heuristic approach to proving.  In this chapter, we will study an alternative technique,%\index{proof by reflection}% _proof by reflection_ %\cite{reflection}%.  We will write, in Gallina, decision procedures with proofs of correctness, and we will appeal to these procedures in writing very short proofs.  Such a proof is checked by running the decision procedure.  The term _reflection_ applies because we will need to translate Gallina propositions into values of inductive types representing syntax, so that Gallina programs may analyze them, and translating such a term back to the original form is called _reflecting_ it. *)

(** * Proving Evenness *)

(** Proving that particular natural number constants are even is certainly something we would rather have happen automatically.  The Ltac-programming techniques that we learned in the last chapter make it easy to implement such a procedure. *)

Inductive isEven : nat -> Prop :=
| Even_O : isEven O
| Even_SS : forall n, isEven n -> isEven (S (S n)).

(* begin thide *)
Ltac prove_even := repeat constructor.
(* end thide *)

Theorem even_256 : isEven 256.
  prove_even.
Qed.

Print even_256.
(** %\vspace{-.15in}% [[
even_256 =
Even_SS
  (Even_SS
     (Even_SS
        (Even_SS
    ]]

    %\noindent%...and so on.  This procedure always works (at least on machines with infinite resources), but it has a serious drawback, which we see when we print the proof it generates that 256 is even.  The final proof term has length super-linear in the input value.  Coq's implicit arguments mechanism is hiding the values given for parameter [n] of [Even_SS], which is why the proof term only appears linear here.  Also, proof terms are represented internally as syntax trees, with opportunity for sharing of node representations, but in this chapter we will measure proof term size as simple textual length or as the number of nodes in the term's syntax tree, two measures that are approximately equivalent.  Sometimes apparently large proof terms have enough internal sharing that they take up less memory than we expect, but one avoids having to reason about such sharing by ensuring that the size of a sharing-free version of a term is low enough.

    Superlinear evenness proof terms seem like a shame, since we could write a trivial and trustworthy program to verify evenness of constants.  The proof checker could simply call our program where needed.

    It is also unfortunate not to have static typing guarantees that our tactic always behaves appropriately.  Other invocations of similar tactics might fail with dynamic type errors, and we would not know about the bugs behind these errors until we happened to attempt to prove complex enough goals.

    The techniques of proof by reflection address both complaints.  We will be able to write proofs like in the example above with constant size overhead beyond the size of the input, and we will do it with verified decision procedures written in Gallina.

    For this example, we begin by using a type from the [MoreSpecif] module (included in the book source) to write a certified evenness checker. *)

(* begin hide *)
(* begin thide *)
Definition paartial := partial.
(* end thide *)
(* end hide *)

Print partial.
(** %\vspace{-.15in}% [[
Inductive partial (P : Prop) : Set :=  Proved : P -> [P] | Uncertain : [P]
    ]]

    A [partial P] value is an optional proof of [P]. The notation [[P]] stands for [partial P]. *)

Local Open Scope partial_scope.

(** We bring into scope some notations for the [partial] type.  These overlap with some of the notations we have seen previously for specification types, so they were placed in a separate scope that needs separate opening. *)

(* begin thide *)
Definition check_even : forall n : nat, [isEven n].
  Hint Constructors isEven.

  refine (fix F (n : nat) : [isEven n] :=
    match n with
      | 0 => Yes
      | 1 => No
      | S (S n') => Reduce (F n')
    end); auto.
Defined.

(** The function [check_even] may be viewed as a _verified decision procedure_, because its type guarantees that it never returns %\coqdocnotation{%#<tt>#Yes#</tt>#%}% for inputs that are not even.

   Now we can use dependent pattern-matching to write a function that performs a surprising feat.  When given a [partial P], this function [partialOut] returns a proof of [P] if the [partial] value contains a proof, and it returns a (useless) proof of [True] otherwise.  From the standpoint of ML and Haskell programming, it seems impossible to write such a type, but it is trivial with a [return] annotation. *)

Definition partialOut (P : Prop) (x : [P]) :=
  match x return (match x with
                    | Proved _ => P
                    | Uncertain => True
                  end) with
    | Proved pf => pf
    | Uncertain => I
  end.

(** It may seem strange to define a function like this.  However, it turns out to be very useful in writing a reflective version of our earlier [prove_even] tactic: *)

Ltac prove_even_reflective :=
  match goal with
    | [ |- isEven ?N] => exact (partialOut (check_even N))
  end.
(* end thide *)

(** We identify which natural number we are considering, and we "prove" its evenness by pulling the proof out of the appropriate [check_even] call.  Recall that the %\index{tactics!exact}%[exact] tactic proves a proposition [P] when given a proof term of precisely type [P]. *)

Theorem even_256' : isEven 256.
  prove_even_reflective.
Qed.

Print even_256'.
(** %\vspace{-.15in}% [[
even_256' = partialOut (check_even 256)
     : isEven 256
    ]]

    We can see a constant wrapper around the object of the proof.  For any even number, this form of proof will suffice.  The size of the proof term is now linear in the number being checked, containing two repetitions of the unary form of that number, one of which is hidden above within the implicit argument to [partialOut].

    What happens if we try the tactic with an odd number? *)

Theorem even_255 : isEven 255.
  (** %\vspace{-.275in}%[[
  prove_even_reflective.
]]

<<
User error: No matching clauses for match goal
>>

  Thankfully, the tactic fails.  To see more precisely what goes wrong, we can run manually the body of the [match].

  %\vspace{-.15in}%[[
  exact (partialOut (check_even 255)).
]]

<<
  Error: The term "partialOut (check_even 255)" has type
 "match check_even 255 with
  | Yes => isEven 255
  | No => True
  end" while it is expected to have type "isEven 255"
>>

  As usual, the type checker performs no reductions to simplify error messages.  If we reduced the first term ourselves, we would see that [check_even 255] reduces to a %\coqdocnotation{%#<tt>#No#</tt>#%}%, so that the first term is equivalent to [True], which certainly does not unify with [isEven 255]. *)

Abort.

(** Our tactic [prove_even_reflective] is reflective because it performs a proof search process (a trivial one, in this case) wholly within Gallina, where the only use of Ltac is to translate a goal into an appropriate use of [check_even]. *)

(** * Reifying the Syntax of a Trivial Tautology Language *)

(** We might also like to have reflective proofs of trivial tautologies like this one: *)

Theorem true_galore : (True /\ True) -> (True \/ (True /\ (True -> True))).
  tauto.
Qed.

(* begin hide *)
(* begin thide *)
Definition tg := (and_ind, or_introl).
(* end thide *)
(* end hide *)

Print true_galore.
(** %\vspace{-.15in}% [[
true_galore =
fun H : True /\ True =>
and_ind (fun _ _ : True => or_introl (True /\ (True -> True)) I) H
     : True /\ True -> True \/ True /\ (True -> True)
    ]]

    As we might expect, the proof that [tauto] builds contains explicit applications of natural deduction rules.  For large formulas, this can add a linear amount of proof size overhead, beyond the size of the input.

   To write a reflective procedure for this class of goals, we will need to get into the actual "reflection" part of "proof by reflection."  It is impossible to case-analyze a [Prop] in any way in Gallina.  We must%\index{reification}% _reify_ [Prop] into some type that we _can_ analyze.  This inductive type is a good candidate: *)

(* begin thide *)
Inductive taut : Set :=
| TautTrue : taut
| TautAnd : taut -> taut -> taut
| TautOr : taut -> taut -> taut
| TautImp : taut -> taut -> taut.

(** We write a recursive function to _reflect_ this syntax back to [Prop].  Such functions are also called%\index{interpretation function}% _interpretation functions_, and we have used them in previous examples to give semantics to small programming languages. *)

Fixpoint tautDenote (t : taut) : Prop :=
  match t with
    | TautTrue => True
    | TautAnd t1 t2 => tautDenote t1 /\ tautDenote t2
    | TautOr t1 t2 => tautDenote t1 \/ tautDenote t2
    | TautImp t1 t2 => tautDenote t1 -> tautDenote t2
  end.

(** It is easy to prove that every formula in the range of [tautDenote] is true. *)

Theorem tautTrue : forall t, tautDenote t.
  induction t; crush.
Qed.

(** To use [tautTrue] to prove particular formulas, we need to implement the syntax reification process.  A recursive Ltac function does the job. *)

Ltac tautReify P :=
  match P with
    | True => TautTrue
    | ?P1 /\ ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautAnd t1 t2)
    | ?P1 \/ ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautOr t1 t2)
    | ?P1 -> ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautImp t1 t2)
  end.

(** With [tautReify] available, it is easy to finish our reflective tactic.  We look at the goal formula, reify it, and apply [tautTrue] to the reified formula. *)

Ltac obvious :=
  match goal with
    | [ |- ?P ] =>
      let t := tautReify P in
        exact (tautTrue t)
  end.

(** We can verify that [obvious] solves our original example, with a proof term that does not mention details of the proof. *)
(* end thide *)

Theorem true_galore' : (True /\ True) -> (True \/ (True /\ (True -> True))).
  obvious.
Qed.

Print true_galore'.
(** %\vspace{-.15in}% [[
true_galore' =
tautTrue
  (TautImp (TautAnd TautTrue TautTrue)
     (TautOr TautTrue (TautAnd TautTrue (TautImp TautTrue TautTrue))))
     : True /\ True -> True \/ True /\ (True -> True)
    ]]

    It is worth considering how the reflective tactic improves on a pure-Ltac implementation.  The formula reification process is just as ad-hoc as before, so we gain little there.  In general, proofs will be more complicated than formula translation, and the "generic proof rule" that we apply here _is_ on much better formal footing than a recursive Ltac function.  The dependent type of the proof guarantees that it "works" on any input formula.  This benefit is in addition to the proof-size improvement that we have already seen.

    It may also be worth pointing out that our previous example of evenness testing used a function [partialOut] for sound handling of input goals that the verified decision procedure fails to prove.  Here, we prove that our procedure [tautTrue] (recall that an inductive proof may be viewed as a recursive procedure) is able to prove any goal representable in [taut], so no extra step is necessary. *)

(** * A Monoid Expression Simplifier *)

(** Proof by reflection does not require encoding of all of the syntax in a goal.  We can insert "variables" in our syntax types to allow injection of arbitrary pieces, even if we cannot apply specialized reasoning to them.  In this section, we explore that possibility by writing a tactic for normalizing monoid equations. *)

Section monoid.
  Variable A : Set.
  Variable e : A.
  Variable f : A -> A -> A.

  Infix "+" := f.

  Hypothesis assoc : forall a b c, (a + b) + c = a + (b + c).
  Hypothesis identl : forall a, e + a = a.
  Hypothesis identr : forall a, a + e = a.

  (** We add variables and hypotheses characterizing an arbitrary instance of the algebraic structure of monoids.  We have an associative binary operator and an identity element for it.

     It is easy to define an expression tree type for monoid expressions.  A [Var] constructor is a "catch-all" case for subexpressions that we cannot model.  These subexpressions could be actual Gallina variables, or they could just use functions that our tactic is unable to understand. *)

(* begin thide *)
  Inductive mexp : Set :=
  | Ident : mexp
  | Var : A -> mexp
  | Op : mexp -> mexp -> mexp.

  (** Next, we write an interpretation function. *)

  Fixpoint mdenote (me : mexp) : A :=
    match me with
      | Ident => e
      | Var v => v
      | Op me1 me2 => mdenote me1 + mdenote me2
    end.

  (** We will normalize expressions by flattening them into lists, via associativity, so it is helpful to have a denotation function for lists of monoid values. *)

  Fixpoint mldenote (ls : list A) : A :=
    match ls with
      | nil => e
      | x :: ls' => x + mldenote ls'
    end.

  (** The flattening function itself is easy to implement. *)

  Fixpoint flatten (me : mexp) : list A :=
    match me with
      | Ident => nil
      | Var x => x :: nil
      | Op me1 me2 => flatten me1 ++ flatten me2
    end.

  (** This function has a straightforward correctness proof in terms of our [denote] functions. *)

  Lemma flatten_correct' : forall ml2 ml1,
    mldenote ml1 + mldenote ml2 = mldenote (ml1 ++ ml2).
    induction ml1; crush.
  Qed.

  Theorem flatten_correct : forall me, mdenote me = mldenote (flatten me).
    Hint Resolve flatten_correct'.

    induction me; crush.
  Qed.

  (** Now it is easy to prove a theorem that will be the main tool behind our simplification tactic. *)

  Theorem monoid_reflect : forall me1 me2,
    mldenote (flatten me1) = mldenote (flatten me2)
    -> mdenote me1 = mdenote me2.
    intros; repeat rewrite flatten_correct; assumption.
  Qed.

  (** We implement reification into the [mexp] type. *)

  Ltac reify me :=
    match me with
      | e => Ident
      | ?me1 + ?me2 =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          constr:(Op r1 r2)
      | _ => constr:(Var me)
    end.

  (** The final [monoid] tactic works on goals that equate two monoid terms.  We reify each and change the goal to refer to the reified versions, finishing off by applying [monoid_reflect] and simplifying uses of [mldenote].  Recall that the %\index{tactics!change}%[change] tactic replaces a conclusion formula with another that is definitionally equal to it. *)

  Ltac monoid :=
    match goal with
      | [ |- ?me1 = ?me2 ] =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          change (mdenote r1 = mdenote r2);
            apply monoid_reflect; simpl
    end.

  (** We can make short work of theorems like this one: *)

(* end thide *)

  Theorem t1 : forall a b c d, a + b + c + d = a + (b + c) + d.
    intros; monoid.
    (** [[
  ============================
   a + (b + (c + (d + e))) = a + (b + (c + (d + e)))

        ]]

        Our tactic has canonicalized both sides of the equality, such that we can finish the proof by reflexivity. *)

    reflexivity.
  Qed.

  (** It is interesting to look at the form of the proof. *)

  Print t1.
  (** %\vspace{-.15in}% [[
t1 =
fun a b c d : A =>
monoid_reflect (Op (Op (Op (Var a) (Var b)) (Var c)) (Var d))
  (Op (Op (Var a) (Op (Var b) (Var c))) (Var d))
  (eq_refl (a + (b + (c + (d + e)))))
     : forall a b c d : A, a + b + c + d = a + (b + c) + d
      ]]

      The proof term contains only restatements of the equality operands in reified form, followed by a use of reflexivity on the shared canonical form. *)

End monoid.

(** Extensions of this basic approach are used in the implementations of the %\index{tactics!ring}%[ring] and %\index{tactics!field}%[field] tactics that come packaged with Coq. *)

(** * A Smarter Tautology Solver *)

(** Now we are ready to revisit our earlier tautology solver example.  We want to broaden the scope of the tactic to include formulas whose truth is not syntactically apparent.  We will want to allow injection of arbitrary formulas, like we allowed arbitrary monoid expressions in the last example.  Since we are working in a richer theory, it is important to be able to use equalities between different injected formulas.  For instance, we cannot prove [P -> P] by translating the formula into a value like [Imp (Var P) (Var P)], because a Gallina function has no way of comparing the two [P]s for equality.

   To arrive at a nice implementation satisfying these criteria, we introduce the %\index{tactics!quote}%[quote] tactic and its associated library. *)

Require Import Quote.

(* begin thide *)
Inductive formula : Set :=
| Atomic : index -> formula
| Truth : formula
| Falsehood : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula.
(* end thide *)

(** The type %\index{Gallina terms!index}%[index] comes from the [Quote] library and represents a countable variable type.  The rest of [formula]'s definition should be old hat by now.

   The [quote] tactic will implement injection from [Prop] into [formula] for us, but it is not quite as smart as we might like.  In particular, it wants to treat function types specially, so it gets confused if function types are part of the structure we want to encode syntactically.  To trick [quote] into not noticing our uses of function types to express logical implication, we will need to declare a wrapper definition for implication, as we did in the last chapter. *)

Definition imp (P1 P2 : Prop) := P1 -> P2.
Infix "-->" := imp (no associativity, at level 95).

(** Now we can define our denotation function. *)

Definition asgn := varmap Prop.

(* begin thide *)
Fixpoint formulaDenote (atomics : asgn) (f : formula) : Prop :=
  match f with
    | Atomic v => varmap_find False v atomics
    | Truth => True
    | Falsehood => False
    | And f1 f2 => formulaDenote atomics f1 /\ formulaDenote atomics f2
    | Or f1 f2 => formulaDenote atomics f1 \/ formulaDenote atomics f2
    | Imp f1 f2 => formulaDenote atomics f1 --> formulaDenote atomics f2
  end.
(* end thide *)

(** The %\index{Gallina terms!varmap}%[varmap] type family implements maps from [index] values.  In this case, we define an assignment as a map from variables to [Prop]s.  Our interpretation function [formulaDenote] works with an assignment, and we use the [varmap_find] function to consult the assignment in the [Atomic] case.  The first argument to [varmap_find] is a default value, in case the variable is not found. *)

Section my_tauto.
  Variable atomics : asgn.

  Definition holds (v : index) := varmap_find False v atomics.

  (** We define some shorthand for a particular variable being true, and now we are ready to define some helpful functions based on the [ListSet] module of the standard library, which (unsurprisingly) presents a view of lists as sets. *)

  Require Import ListSet.

  Definition index_eq : forall x y : index, {x = y} + {x <> y}.
    decide equality.
  Defined.

  Definition add (s : set index) (v : index) := set_add index_eq v s.

  Definition In_dec : forall v (s : set index), {In v s} + {~ In v s}.
    Local Open Scope specif_scope.

    intro; refine (fix F (s : set index) : {In v s} + {~ In v s} :=
      match s with
        | nil => No
        | v' :: s' => index_eq v' v || F s'
      end); crush.
  Defined.

  (** We define what it means for all members of an index set to represent true propositions, and we prove some lemmas about this notion. *)

  Fixpoint allTrue (s : set index) : Prop :=
    match s with
      | nil => True
      | v :: s' => holds v /\ allTrue s'
    end.

  Theorem allTrue_add : forall v s,
    allTrue s
    -> holds v
    -> allTrue (add s v).
    induction s; crush;
      match goal with
        | [ |- context[if ?E then _ else _] ] => destruct E
      end; crush.
  Qed.

  Theorem allTrue_In : forall v s,
    allTrue s
    -> set_In v s
    -> varmap_find False v atomics.
    induction s; crush.
  Qed.

  Hint Resolve allTrue_add allTrue_In.

  Local Open Scope partial_scope.

  (** Now we can write a function [forward] that implements deconstruction of hypotheses, expanding a compound formula into a set of sets of atomic formulas covering all possible cases introduced with use of [Or].  To handle consideration of multiple cases, the function takes in a continuation argument, which will be called once for each case.

     The [forward] function has a dependent type, in the style of Chapter 6, guaranteeing correctness.  The arguments to [forward] are a goal formula [f], a set [known] of atomic formulas that we may assume are true, a hypothesis formula [hyp], and a success continuation [cont] that we call when we have extended [known] to hold new truths implied by [hyp]. *)

  Definition forward : forall (f : formula) (known : set index) (hyp : formula)
    (cont : forall known', [allTrue known' -> formulaDenote atomics f]),
    [allTrue known -> formulaDenote atomics hyp -> formulaDenote atomics f].
    refine (fix F (f : formula) (known : set index) (hyp : formula)
      (cont : forall known', [allTrue known' -> formulaDenote atomics f])
      : [allTrue known -> formulaDenote atomics hyp -> formulaDenote atomics f] :=
      match hyp with
        | Atomic v => Reduce (cont (add known v))
        | Truth => Reduce (cont known)
        | Falsehood => Yes
        | And h1 h2 =>
          Reduce (F (Imp h2 f) known h1 (fun known' =>
            Reduce (F f known' h2 cont)))
        | Or h1 h2 => F f known h1 cont && F f known h2 cont
        | Imp _ _ => Reduce (cont known)
      end); crush.
  Defined.

  (** A [backward] function implements analysis of the final goal.  It calls [forward] to handle implications. *)

(* begin thide *)
  Definition backward : forall (known : set index) (f : formula),
    [allTrue known -> formulaDenote atomics f].
    refine (fix F (known : set index) (f : formula)
      : [allTrue known -> formulaDenote atomics f] :=
      match f with
        | Atomic v => Reduce (In_dec v known)
        | Truth => Yes
        | Falsehood => No
        | And f1 f2 => F known f1 && F known f2
        | Or f1 f2 => F known f1 || F known f2
        | Imp f1 f2 => forward f2 known f1 (fun known' => F known' f2)
      end); crush; eauto.
  Defined.
(* end thide *)

  (** A simple wrapper around [backward] gives us the usual type of a partial decision procedure. *)

  Definition my_tauto : forall f : formula, [formulaDenote atomics f].
(* begin thide *)
    intro; refine (Reduce (backward nil f)); crush.
  Defined.
(* end thide *)
End my_tauto.

(** Our final tactic implementation is now fairly straightforward.  First, we [intro] all quantifiers that do not bind [Prop]s.  Then we call the [quote] tactic, which implements the reification for us.  Finally, we are able to construct an exact proof via [partialOut] and the [my_tauto] Gallina function. *)

Ltac my_tauto :=
  repeat match goal with
           | [ |- forall x : ?P, _ ] =>
             match type of P with
               | Prop => fail 1
               | _ => intro
             end
         end;
  quote formulaDenote;
  match goal with
    | [ |- formulaDenote ?m ?f ] => exact (partialOut (my_tauto m f))
  end.
(* end thide *)

(** A few examples demonstrate how the tactic works. *)

Theorem mt1 : True.
  my_tauto.
Qed.

Print mt1.
(** %\vspace{-.15in}% [[
mt1 = partialOut (my_tauto (Empty_vm Prop) Truth)
     : True
    ]]

    We see [my_tauto] applied with an empty [varmap], since every subformula is handled by [formulaDenote]. *)

Theorem mt2 : forall x y : nat, x = y --> x = y.
  my_tauto.
Qed.

(* begin hide *)
(* begin thide *)
Definition nvm := (Node_vm, Empty_vm, End_idx, Left_idx, Right_idx).
(* end thide *)
(* end hide *)

Print mt2.
(** %\vspace{-.15in}% [[
mt2 =
fun x y : nat =>
partialOut
  (my_tauto (Node_vm (x = y) (Empty_vm Prop) (Empty_vm Prop))
     (Imp (Atomic End_idx) (Atomic End_idx)))
     : forall x y : nat, x = y --> x = y
    ]]

    Crucially, both instances of [x = y] are represented with the same index, [End_idx].  The value of this index only needs to appear once in the [varmap], whose form reveals that [varmap]s are represented as binary trees, where [index] values denote paths from tree roots to leaves. *)

Theorem mt3 : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  --> y > z /\ (x < y \/ x < S y).
  my_tauto.
Qed.

Print mt3.
(** %\vspace{-.15in}% [[
fun x y z : nat =>
partialOut
  (my_tauto
     (Node_vm (x < S y) (Node_vm (x < y) (Empty_vm Prop) (Empty_vm Prop))
        (Node_vm (y > z) (Empty_vm Prop) (Empty_vm Prop)))
     (Imp
        (Or (And (Atomic (Left_idx End_idx)) (Atomic (Right_idx End_idx)))
           (And (Atomic (Right_idx End_idx)) (Atomic End_idx)))
        (And (Atomic (Right_idx End_idx))
           (Or (Atomic (Left_idx End_idx)) (Atomic End_idx)))))
     : forall x y z : nat,
       x < y /\ y > z \/ y > z /\ x < S y --> y > z /\ (x < y \/ x < S y)
    ]]

    Our goal contained three distinct atomic formulas, and we see that a three-element [varmap] is generated.

    It can be interesting to observe differences between the level of repetition in proof terms generated by [my_tauto] and [tauto] for especially trivial theorems. *)

Theorem mt4 : True /\ True /\ True /\ True /\ True /\ True /\ False --> False.
  my_tauto.
Qed.

Print mt4.
(** %\vspace{-.15in}% [[
mt4 =
partialOut
  (my_tauto (Empty_vm Prop)
     (Imp
        (And Truth
           (And Truth
              (And Truth (And Truth (And Truth (And Truth Falsehood))))))
        Falsehood))
     : True /\ True /\ True /\ True /\ True /\ True /\ False --> False
    ]]
    *)

Theorem mt4' : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
  tauto.
Qed.

(* begin hide *)
(* begin thide *)
Definition fi := False_ind.
(* end thide *)
(* end hide *)

Print mt4'.
(** %\vspace{-.15in}% [[
mt4' =
fun H : True /\ True /\ True /\ True /\ True /\ True /\ False =>
and_ind
  (fun (_ : True) (H1 : True /\ True /\ True /\ True /\ True /\ False) =>
   and_ind
     (fun (_ : True) (H3 : True /\ True /\ True /\ True /\ False) =>
      and_ind
        (fun (_ : True) (H5 : True /\ True /\ True /\ False) =>
         and_ind
           (fun (_ : True) (H7 : True /\ True /\ False) =>
            and_ind
              (fun (_ : True) (H9 : True /\ False) =>
               and_ind (fun (_ : True) (H11 : False) => False_ind False H11)
                 H9) H7) H5) H3) H1) H
     : True /\ True /\ True /\ True /\ True /\ True /\ False -> False
    ]]

The traditional [tauto] tactic introduces a quadratic blow-up in the size of the proof term, whereas proofs produced by [my_tauto] always have linear size. *)

(** ** Manual Reification of Terms with Variables *)

(* begin thide *)
(** The action of the [quote] tactic above may seem like magic.  Somehow it performs equality comparison between subterms of arbitrary types, so that these subterms may be represented with the same reified variable.  While [quote] is implemented in OCaml, we can code the reification process completely in Ltac, as well.  To make our job simpler, we will represent variables as [nat]s, indexing into a simple list of variable values that may be referenced.

   Step one of the process is to crawl over a term, building a duplicate-free list of all values that appear in positions we will encode as variables.  A useful helper function adds an element to a list, preventing duplicates.  Note how we use Ltac pattern matching to implement an equality test on Gallina terms; this is simple syntactic equality, not even the richer definitional equality.  We also represent lists as nested tuples, to allow different list elements to have different Gallina types. *)

Ltac inList x xs :=
  match xs with
    | tt => false
    | (x, _) => true
    | (_, ?xs') => inList x xs'
  end.

Ltac addToList x xs :=
  let b := inList x xs in
    match b with
      | true => xs
      | false => constr:(x, xs)
    end.

(** Now we can write our recursive function to calculate the list of variable values we will want to use to represent a term. *)

Ltac allVars xs e :=
  match e with
    | True => xs
    | False => xs
    | ?e1 /\ ?e2 =>
      let xs := allVars xs e1 in
        allVars xs e2
    | ?e1 \/ ?e2 =>
      let xs := allVars xs e1 in
        allVars xs e2
    | ?e1 -> ?e2 =>
      let xs := allVars xs e1 in
        allVars xs e2
    | _ => addToList e xs
  end.

(** We will also need a way to map a value to its position in a list. *)

Ltac lookup x xs :=
  match xs with
    | (x, _) => O
    | (_, ?xs') =>
      let n := lookup x xs' in
        constr:(S n)
  end.

(** The next building block is a procedure for reifying a term, given a list of all allowed variable values.  We are free to make this procedure partial, where tactic failure may be triggered upon attempting to reify a term containing subterms not included in the list of variables.  The type of the output term is a copy of [formula] where [index] is replaced by [nat], in the type of the constructor for atomic formulas. *)

Inductive formula' : Set :=
| Atomic' : nat -> formula'
| Truth' : formula'
| Falsehood' : formula'
| And' : formula' -> formula' -> formula'
| Or' : formula' -> formula' -> formula'
| Imp' : formula' -> formula' -> formula'.

(** Note that, when we write our own Ltac procedure, we can work directly with the normal [->] operator, rather than needing to introduce a wrapper for it. *)

Ltac reifyTerm xs e :=
  match e with
    | True => constr:Truth'
    | False => constr:Falsehood'
    | ?e1 /\ ?e2 =>
      let p1 := reifyTerm xs e1 in
      let p2 := reifyTerm xs e2 in
        constr:(And' p1 p2)
    | ?e1 \/ ?e2 =>
      let p1 := reifyTerm xs e1 in
      let p2 := reifyTerm xs e2 in
        constr:(Or' p1 p2)
    | ?e1 -> ?e2 =>
      let p1 := reifyTerm xs e1 in
      let p2 := reifyTerm xs e2 in
        constr:(Imp' p1 p2)
    | _ =>
      let n := lookup e xs in
        constr:(Atomic' n)
  end.

(** Finally, we bring all the pieces together. *)

Ltac reify :=
  match goal with
    | [ |- ?G ] => let xs := allVars tt G in
      let p := reifyTerm xs G in
        pose p
  end.

(** A quick test verifies that we are doing reification correctly. *)

Theorem mt3' : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  -> y > z /\ (x < y \/ x < S y).
  do 3 intro; reify.

(** Our simple tactic adds the translated term as a new variable:
[[
f := Imp'
         (Or' (And' (Atomic' 2) (Atomic' 1)) (And' (Atomic' 1) (Atomic' 0)))
         (And' (Atomic' 1) (Or' (Atomic' 2) (Atomic' 0))) : formula'
]]
*)
Abort.

(** More work would be needed to complete the reflective tactic, as we must connect our new syntax type with the real meanings of formulas, but the details are the same as in our prior implementation with [quote]. *)
(* end thide *)

(** * Building a Reification Tactic that Recurses Under Binders *)

(** All of our examples so far have stayed away from reifying the syntax of terms that use such features as quantifiers and [fun] function abstractions.  Such cases are complicated by the fact that different subterms may be allowed to reference different sets of free variables.  Some cleverness is needed to clear this hurdle, but a few simple patterns will suffice.  Consider this example of a simple dependently typed term language, where a function abstraction body is represented conveniently with a Coq function. *)

Inductive type : Type :=
| Nat : type
| NatFunc : type -> type.

Inductive term : type -> Type :=
| Const : nat -> term Nat
| Plus : term Nat -> term Nat -> term Nat
| Abs : forall t, (nat -> term t) -> term (NatFunc t).

Fixpoint typeDenote (t : type) : Type :=
  match t with
    | Nat => nat
    | NatFunc t => nat -> typeDenote t
  end.

Fixpoint termDenote t (e : term t) : typeDenote t :=
  match e with
    | Const n => n
    | Plus e1 e2 => termDenote e1 + termDenote e2
    | Abs _ e1 => fun x => termDenote (e1 x)
  end.

(** Here is a %\%naive%{}% first attempt at a reification tactic. *)

Ltac refl' e :=
  match e with
    | ?E1 + ?E2 =>
      let r1 := refl' E1 in
      let r2 := refl' E2 in
        constr:(Plus r1 r2)

    | fun x : nat => ?E1 =>
      let r1 := refl' E1 in
        constr:(Abs (fun x => r1 x))

    | _ => constr:(Const e)
  end.

(** Recall that a regular Ltac pattern variable [?X] only matches terms that _do not mention new variables introduced within the pattern_.  In our %\%naive%{}% implementation, the case for matching function abstractions matches the function body in a way that prevents it from mentioning the function argument!  Our code above plays fast and loose with the function body in a way that leads to independent problems, but we could change the code so that it indeed handles function abstractions that ignore their arguments.

   To handle functions in general, we will use the pattern variable form [@?X], which allows [X] to mention newly introduced variables that are declared explicitly.  A use of [@?X] must be followed by a list of the local variables that may be mentioned.  The variable [X] then comes to stand for a Gallina function over the values of those variables.  For instance: *)

Reset refl'.
Ltac refl' e :=
  match e with
    | ?E1 + ?E2 =>
      let r1 := refl' E1 in
      let r2 := refl' E2 in
        constr:(Plus r1 r2)

    | fun x : nat => @?E1 x =>
      let r1 := refl' E1 in
        constr:(Abs r1)

    | _ => constr:(Const e)
  end.

(** Now, in the abstraction case, we bind [E1] as a function from an [x] value to the value of the abstraction body.  Unfortunately, our recursive call there is not destined for success.  It will match the same abstraction pattern and trigger another recursive call, and so on through infinite recursion.  One last refactoring yields a working procedure.  The key idea is to consider every input to [refl'] as _a function over the values of variables introduced during recursion_. *)

Reset refl'.
Ltac refl' e :=
  match eval simpl in e with
    | fun x : ?T => @?E1 x + @?E2 x =>
      let r1 := refl' E1 in
      let r2 := refl' E2 in
        constr:(fun x => Plus (r1 x) (r2 x))

    | fun (x : ?T) (y : nat) => @?E1 x y =>
      let r1 := refl' (fun p : T * nat => E1 (fst p) (snd p)) in
        constr:(fun x => Abs (fun y => r1 (x, y)))

    | _ => constr:(fun x => Const (e x))
  end.

(** Note how now even the addition case works in terms of functions, with [@?X] patterns.  The abstraction case introduces a new variable by extending the type used to represent the free variables.  In particular, the argument to [refl'] used type [T] to represent all free variables.  We extend the type to [T * nat] for the type representing free variable values within the abstraction body.  A bit of bookkeeping with pairs and their projections produces an appropriate version of the abstraction body to pass in a recursive call.  To ensure that all this repackaging of terms does not interfere with pattern matching, we add an extra [simpl] reduction on the function argument, in the first line of the body of [refl'].

   Now one more tactic provides an example of how to apply reification.  Let us consider goals that are equalities between terms that can be reified.  We want to change such goals into equalities between appropriate calls to [termDenote]. *)

Ltac refl :=
  match goal with
    | [ |- ?E1 = ?E2 ] =>
      let E1' := refl' (fun _ : unit => E1) in
      let E2' := refl' (fun _ : unit => E2) in
        change (termDenote (E1' tt) = termDenote (E2' tt));
          cbv beta iota delta [fst snd]
  end.

Goal (fun (x y : nat) => x + y + 13) = (fun (_ z : nat) => z).
  refl.
(** %\vspace{-.15in}%[[
  ============================
   termDenote
     (Abs
        (fun y : nat =>
         Abs (fun y0 : nat => Plus (Plus (Const y) (Const y0)) (Const 13)))) =
   termDenote (Abs (fun _ : nat => Abs (fun y0 : nat => Const y0)))
]]
*)

Abort.

(** Our encoding here uses Coq functions to represent binding within the terms we reify, which makes it difficult to implement certain functions over reified terms.  An alternative would be to represent variables with numbers.  This can be done by writing a slightly smarter reification function that identifies variable references by detecting when term arguments are just compositions of [fst] and [snd]; from the order of the compositions we may read off the variable number.  We leave the details as an exercise (though not a trivial one!) for the reader. *)


Require Import init.

Require Export relation.
Require Export set_base.
Require Export set_type.

Definition is_least {U} (op : U → U → Prop) (S : U → Prop) (x : U)
    := S x ∧ ∀ y, S y → op x y.
Definition is_greatest {U} (op : U → U → Prop) (S : U → Prop) (x : U)
    := S x ∧ ∀ y, S y → op y x.
Definition is_minimal {U} (op : U → U → Prop) (S : U → Prop) (x : U)
    := S x ∧ ∀ y, S y → y ≠ x → ¬(op y x).
Definition is_maximal {U} (op : U → U → Prop) (S : U → Prop) (x : U)
    := S x ∧ ∀ y, S y → y ≠ x → ¬(op x y).
Definition has_least {U} (op : U → U → Prop) (S : U → Prop)
    := ∃ x, is_least op S x.
Definition has_greatest {U} (op : U → U → Prop) (S : U → Prop)
    := ∃ x, is_greatest op S x.
Definition has_minimal {U} (op : U → U → Prop) (S : U → Prop)
    := ∃ x, is_minimal op S x.
Definition has_maximal {U} (op : U → U → Prop) (S : U → Prop)
    := ∃ x, is_maximal op S x.

Definition open_interval {U} `{Order U} a b := λ x, a < x ∧ x < b.
Definition open_closed_interval {U} `{Order U} a b := λ x, a < x ∧ x ≤ b.
Definition closed_open_interval {U} `{Order U} a b := λ x, a ≤ x ∧ x < b.
Definition closed_interval {U} `{Order U} a b := λ x, a ≤ x ∧ x ≤ b.
Definition open_inf_interval {U} `{Order U} a := λ x, a < x.
Definition closed_inf_interval {U} `{Order U} a := λ x, a ≤ x.
Definition inf_open_interval {U} `{Order U} a := λ x, x < a.
Definition inf_closed_interval {U} `{Order U} a := λ x, x ≤ a.

Definition is_chain {U} (op : U → U → Prop) (S : U → Prop)
    := ∀ a b : U, S a → S b → op a b ∨ op b a.

Definition well_orders {U} (op : U → U → Prop) (S : U → Prop)
    := ∀ A : U → Prop, A ⊆ S → (∃ x, A x) → ∃ a, is_least op A a.

Definition initial_segment {U} `{Order U} x := λ a, a < x.

Section SetOrder.

Context {U} `{
    op : U → U → Prop,
    Reflexive U op,
    Antisymmetric U op,
    Transitive U op
}.

Theorem chain_subset : ∀ S, is_chain op S → ∀ T, T ⊆ S → is_chain op T.
Proof.
    intros S S_chain T sub a b Ta Tb.
    apply S_chain.
    all: apply sub; assumption.
Qed.

Theorem well_orders_subset :
    ∀ S, well_orders op S → ∀ T, T ⊆ S → well_orders op T.
Proof.
    intros S S_wo T sub A A_sub A_ex.
    apply S_wo.
    -   exact (trans A_sub sub).
    -   exact A_ex.
Qed.

Theorem well_orders_chain : ∀ S, well_orders op S → is_chain op S.
Proof.
    intros S S_wo a b Sa Sb.
    specialize (S_wo ❴a, b❵).
    prove_parts S_wo.
    -   intros x [|]; subst x; assumption.
    -   exists a.
        left; reflexivity.
    -   destruct S_wo as [x [x_in x_least]].
        destruct x_in as [|]; subst x.
        +   left.
            apply x_least.
            right; reflexivity.
        +   right.
            apply x_least.
            left; reflexivity.
Qed.

End SetOrder.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

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

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  zNil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

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

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem plus_comm: forall (n m: natural), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (len (qreva x y)) (plus (len x) (len y)).
Proof.
  induction x; induction y; simpl; try reflexivity.
  +
    rewrite plus_comm. simpl.
    rewrite IHx. simpl. rewrite plus_comm.
    simpl. reflexivity.
  +
    rewrite plus_comm. simpl. rewrite IHx.
    rewrite plus_comm.
    simpl. reflexivity.
Qed.


   Theorem t75_5: forall (P Q : Set -> Prop),
                   (forall x : Set, P x <-> Q x)
                     -> ((forall x : Set, P x) <-> (forall x : Set, Q x)).
   Proof.
      intros. split. intros. cut(P x <-> Q x). intros.
      apply H1. apply H0. apply H.
      intros. cut(P x <-> Q x). intros.
      apply H1. apply H0. apply H.
    Qed.

   Theorem t75_6: forall (P Q : Set -> Prop),
                   (forall x : Set, P x <-> Q x)
                     -> ((exists x : Set, P x) <-> (exists x : Set, Q x)).
   Proof.
      intros. split. intros. elim H0. intros. exists x.
      cut(P x <-> Q x). intros. apply H2. assumption. apply H.
      intros. elim H0. intros. exists x.
      cut(P x <-> Q x). intros. apply H2. assumption. apply H.
    Qed.

   Theorem t76: forall (A : Set -> Prop) (b : Set),
                   (forall x : Set, A x) -> (exists x : Set, A x).
   Proof.
      intros. exists b. apply H.
    Qed.

   Theorem t77: forall (A : Set -> Set -> Prop),
                   (exists x : Set, forall y : Set, A y x)
                   -> (forall x : Set, exists y : Set, A x y).
   Proof.
      intros. elim H. intros. exists x0. apply H0.
    Qed.

   Theorem t78: forall (A B : Set -> Prop),
                   (exists x : Set, A x /\ B x)
                   -> ((exists x : Set, A x) /\ (exists x : Set, B x)).
   Proof.
      intros. elim H. intros. split.
      exists x. apply H0.
      exists x. apply H0.
    Qed.

   Theorem t78_1: forall (P Q : Set -> Prop),
                   (exists x : Set, P x /\ ~(Q x))
               <-> ~(forall x : Set, P x -> Q x).
   Proof.
      intros. split. intros. elim H. intros. intro. elim H0. intros.
      cut(P x -> Q x). intros. apply H3. apply H4. apply H0. apply H1.
      Require Import Classical.
      intros. apply NNPP. intro. apply H. intros. apply NNPP. intro.
      apply H0. exists x. split. assumption. assumption.
    Qed.

   Theorem t78_2: forall (P Q : Set -> Prop) (E : Prop),
                   (exists x : Set, Q x /\ P x /\ E)
               <-> E /\ (exists x : Set, Q x /\ P x).
   Proof.
      intros. split. intros. elim H. intros. split.
      apply H0. exists x. split. apply H0. apply H0.
      intros. elim H. intros. elim H1. intros. exists x. split.
      apply H2. split. apply H2. apply H0.
    Qed.

   Theorem t79: forall (A B : Set -> Prop),
                   ((forall x : Set, A x) \/ (forall x : Set, B x))
                      -> (forall x : Set, A x \/ B x).
   Proof.
      intros. elim H. intros. left. apply H0.
      intros. right. apply H0.
    Qed.

   Theorem t80: forall (A B : Set -> Prop),
                   ((exists x : Set, A x) -> (forall x : Set, B x))
                      -> (forall x : Set, A x -> B x).
   Proof.
      intros. apply H. exists x. assumption.
    Qed.

   Theorem t80_1: forall (A B : Set -> Prop) (b : Set),
                   ((exists x : Set, A x) -> (exists x : Set, B x))
                      -> (exists x : Set, A x -> B x).
   Proof.
      Require Import Classical.
      intros. apply NNPP. intro. apply H0. exists b. intros.
      elim H. intros. apply NNPP.  intro.  apply H0. exists x. intro. assumption.
      exists b. assumption.
    Qed.

   Theorem t81: forall (A : Set -> Set -> Prop),
                   (forall x y : Set, A x y)
                      -> (forall x : Set, A x x ).
   Proof.
      intros. apply H.
    Qed.

   Theorem t82: forall (A : Set -> Set -> Prop) (b : Set),
                   (exists x : Set, A x x)
                      -> (exists x : Set, exists y : Set, A x y).
   Proof.
      intros. elim H.  intros. exists x. exists x. assumption.
    Qed.

   Theorem t83: forall (A : Set -> Prop)
                       (t : Set),
                   (forall x : Set, A x) -> A t.
   Proof.
      intros. apply H.
   Qed.

   Theorem t84: forall (A : Set -> Prop)
                       (t : Set),
                   A t -> (exists x : Set, A x).
   Proof.
      intros. exists t. assumption.
   Qed.

   Theorem t85: forall (A : Set -> Prop)
                       (t : Set),
                   (exists x : Set, A x) \/ (exists x : Set, ~(A x)).
   Proof.
      Require Import Classical.
      intros. generalize(classic(A t)). intros. elim H.
      intros. left. exists t. assumption.
      intros. right. exists t. assumption.
   Qed.

   Theorem t86: forall (P Q : Set -> Prop)
                       (R : Set -> Set -> Prop)
                       (b : Set),
                   (exists x : Set, (P x /\ (exists y : Set, Q y /\ R x y)))
               <-> (exists y : Set, (Q y /\ (exists x : Set, P x /\ R x y))).
   Proof.
      intros. split. intros. elim H. intros. elim H0. intros. elim H2. intros.
      elim H3. intros.
      exists x0. split. assumption. exists x. split. assumption. assumption.
      intros. elim H. intros. elim H0. intros. elim H2. intros.
      elim H3. intros.
      exists x0. split. assumption. exists x. split. assumption. assumption.
   Qed.

   Theorem t87: forall (P Q : Set -> Prop)
                       (R : Set -> Set -> Prop)
                       (b : Set),
                   (exists x : Set, (P x /\ (forall y : Set, Q y -> R x y)))
                -> (forall y : Set, (Q y -> (exists x : Set, P x /\ R x y))).
   Proof.
      intros. elim H. intros. elim H1. intros.
      exists x. split. assumption. apply H3. assumption.
   Qed.


Require Export D.

(** **** Exercise: 3 stars (swap_if_branches)  *)
(** Show that we can swap the branches of an IF by negating its
    condition *)

Lemma bool_negb : forall b1 b2,
  negb b1 = b2 -> b1 = negb b2.
Proof. intros. destruct b1; destruct b2; try inversion H; try reflexivity. Qed.

Theorem swap_if_branches: forall b e1 e2,
  cequiv
    (IFB b THEN e1 ELSE e2 FI)
    (IFB BNot b THEN e2 ELSE e1 FI).
Proof.
  split; intros.
  Case "->". inversion H; subst.
    SCase "True". apply E_IfFalse. simpl. rewrite H5. reflexivity. assumption.
    SCase "False". apply E_IfTrue. simpl. rewrite H5. reflexivity.  assumption.
  Case "<-".  inversion H; subst. inversion H5.
    SCase "False". apply E_IfFalse. simpl. apply bool_negb in H1;simpl in H1. assumption. assumption.
    SCase "True". apply E_IfTrue. simpl in H5. apply bool_negb in H5. simpl in H5. assumption. assumption.
  Qed.


Require Import  Coq.Lists.List.

Definition insert (n:nat) (lst: list nat) :list nat := n::lst.

Definition remove (lst: list nat) : ((option nat) * list nat) :=
match rev(lst) with
| nil => (None, nil)
| l::lst' => (Some l,lst')
end.

Definition listProd: Set := (list nat * list nat) %type.

Definition insert' (n:nat) (lst: listProd) :listProd :=
match lst with
| (bs,fs) => (n::bs,fs)
end.

Definition remove' (lst:listProd): ((option nat) * listProd) :=
match lst with
| (bs , nil) => match rev(bs) with
                    | nil => (None,lst)
                    | i::bs' => (Some i, (nil,bs'))
                    end
| (bs, f::fs') => (Some f, (bs,fs'))
end.

Definition R (lst: list nat) (lstProd:listProd) : Prop :=
let (bs,fs):=lstProd in
lst = app (bs) (rev(fs)).

Lemma emptyR:
R nil (nil,nil).
Proof.  simpl. auto. Qed.

Lemma insertR:
forall lst lstProd d, R lst lstProd -> R (insert d lst) (insert' d lstProd).
Proof.
intros.  unfold R.
unfold insert. destruct lstProd.
simpl. inversion H. auto.
Qed.

Lemma removeR:
forall lst lstProd,
R lst lstProd ->
(lst = nil /\ lstProd = (nil,nil)
\/ (exists d d' lst' lstProd',  remove lst = (Some d,lst') -> remove' lstProd =(Some d', lstProd') -> R lst' lstProd')).
Proof.
intros. destruct lstProd.
destruct l0. destruct l. inversion H. left. split; simpl; auto.
inversion H. simpl in H0. right.
exists n. exists n. exists l.   exists ((nil,rev l)).
intros. unfold R. simpl. rewrite rev_involutive.   auto.
inversion H. right.
exists n.  exists n. exists (l++ rev l0).
exists ((l,l0)).
intros. unfold R. auto.
Qed.


Require Export Basics_J.

Module NatList.
Inductive natprod : Type :=
 pair : nat -> nat -> natprod.

Definition fst (p : natprod) : nat :=
 match p with
  | pair x y => x
 end.

Definition snd (p : natprod) : nat :=
 match p with
  | pair x y => y
 end.

Notation "( x , y )" := (pair x y).

Definition fst' (p : natprod) : nat :=
 match p with
  | (x,y) => x
 end.

Definition snd' (p : natprod) : nat :=
 match p with
  | (x,y) => y
 end.

Definition swap_pair (p : natprod) : natprod :=
 match p with
  | (x,y) => (y,x)
 end.

Theorem surjective_pairing' : forall (n m : nat), (n,m) = (fst (n,m), snd (n,m)).
Proof.
intros.
simpl.
reflexivity.
Qed.

Theorem surjective_pairing : forall (p : natprod), p = (fst p, snd p).
Proof.
intros p.
destruct p as (n,m).
simpl.
reflexivity.
Qed.

Theorem snd_fst_is_swap : forall (p : natprod), (snd p, fst p) = swap_pair p.
Proof.
intros.
destruct p as (n,m).
simpl.
reflexivity.
Qed.

Inductive natlist : Type :=
 | nil : natlist
 | cons : nat -> natlist -> natlist.

Definition l_123 := cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l)(at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

Fixpoint repeat (n count : nat) : natlist :=
 match count with
  | O => nil
  | S count' => n :: (repeat n count')
 end.

Fixpoint length (l : natlist) : nat :=
 match l with
  | nil => O
  | h :: t => S (length t)
 end.

Fixpoint app (l1 l2 : natlist) : natlist :=
 match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
 end.

Notation "x ++ y" := (app x y) (right associativity, at level 60).

Example test_app1: [1,2,3] ++ [4,5] = [1,2,3,4,5].
Proof.
simpl.
reflexivity.
Qed.

Example test_app2: nil ++ [4,5] = [4,5].
Proof.
simpl.
reflexivity.
Qed.

Example test_app3: [1,2,3] ++ nil = [1,2,3].
Proof.
simpl.
reflexivity.
Qed.

Definition hd (default : nat)(l : natlist) : nat :=
 match l with
  | nil => default
  | h :: t => h
 end.

Definition tail (l : natlist) : natlist :=
 match l with
  | nil => nil
  | h :: t => t
 end.

Example test_hd1 : hd O [1,2,3] = 1.
Proof.
simpl.
reflexivity.
Qed.

Example test_hd2 : hd O [] = 0.
Proof.
simpl.
reflexivity.
Qed.

Example test_tail : tail [1,2,3] = [2,3].
Proof.
simpl.
reflexivity.
Qed.

Definition bag := natlist.

(*-----<<< Inference about the lists >>>------*)
Theorem nil_app : forall (l : natlist), [] ++ l = l.
Proof.
intros.
simpl.
reflexivity.
Qed.

Theorem tl_lentgh_pred : forall (l : natlist), pred (length l) = length (tail l).
Proof.
intros.
destruct l.
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

End NatList.

(*---------<<< start Dictionary >>>-----------*)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Extraction Utf8. (* → λ ∀ ∃ ↔ ∧ ∨ *)

Require Import induction.

Require Import dfs_graph_def dfs_fun dfs_fix dfs_partial_corr.

Set Implicit Arguments.

Section dfs_domain_characterization.

  (* Hence dfs v l cannot terminate unless such a finite invariant exists
     (because that is what it computes ...)
     Let us show that this condition is also sufficient *)

  Theorem 𝔻dfs_domain v l : 𝔻dfs v l ↔ ∃i, dfs_invariant_t v l i.
  Proof.
    split.
    + (* The direct implication is trivially derived from partial correctness *)

      intros D; exists (dfs D); apply dfs_invariant.
    + (* The reverse implication is more complicated, much more ...
         We proceed by lexicographic product
           a) strict reverse inclusion bounded by i for v
           b) structural induction for l *)

      unfold dfs_invariant_t, incl.
      intros (i & H1 & H2 & H3).
      revert v H1 l H2 H3.

      (** Induction on v using upper-bounded strict reverse inclusion as well-founded relation *)

      induction v as [ v IHv ] using (well_founded_induction (wf_sincl_maj i)); intros Hv.

      (** Structural induction on l *)

      induction l as [ | x l IHl ]; intros Hl H.
      1: apply 𝔻dfs_1.
      case_eq (mem x v);
        [ rewrite mem_true_iff
        | rewrite mem_false_iff ]; intros Hx.
      * (* dfs v (x::_) where x ∈ v *)
        clear IHv.
        apply 𝔻dfs_2; auto.
        apply IHl; auto.                (* Induction on l *)
        intros; apply Hl; right; auto.
      * (* dfs v (x::_) where x ∉ v *)
        clear IHl.
        apply 𝔻dfs_3; auto.
        assert (Hx' : In x i)
          by (apply Hl; left; auto).
        apply IHv.                     (* Induction on v *)
        - split;
          [ right; auto
          | exists x; repeat split; auto; left; auto ].
        - intros y [ ? | ? ]; subst; auto.
        - intros y Hy.
          apply in_app_or in Hy.
          destruct Hy as [ Hy | Hy ].
          ++ apply H in Hx'.
             destruct Hx' as [ Hx' | Hx' ].
             ** tauto.
             ** apply Hx'; auto.
          ++ apply Hl; right; auto.
        - intros y Hy; apply H in Hy; simpl; tauto.
  Qed.

  (* Using the domain characterized by invariants,
     monotonicity properties are easy to establish ...
     it is much harder with d_dfs based induction. *)

  Fact 𝔻dfs_mono v v' l l' : v ⊆ v' → l' ⊆ v'++l → 𝔻dfs v l → 𝔻dfs v' l'.
  Proof.
    intros H1 H2.
    do 2 rewrite 𝔻dfs_domain.
    intros (lP & H3 & H4 & H5).
    exists (v'++lP); repeat split; auto.
    + intros ? ?; apply in_or_app; left; auto.
    + intros x Hx; apply in_or_app.
      apply H2, in_app_or in Hx.
      destruct Hx; auto.
    + intros x Hx.
      apply in_app_or in Hx.
      destruct Hx as [ Hx | Hx ]; auto.
      apply H5 in Hx.
      destruct Hx as [ Hx | Hx ].
      * left; apply H1; auto.
      * right; intros ? ?; apply in_or_app; right; auto.
  Qed.

  (* dfs is usually called as dfs nil l.
     In that case, the invariant is simpler

     It is list containing l and closed under succs
   *)

  (* → λ ∀ ∃ ↔ ∧ ∨ *)

  Definition dfs_nil_invariant_t l i := l ⊆ i ∧ ∀x, x ∈ i → succs x ⊆ i.

  (* Partial correctness of dfs nil: it computes the minimal invariant *)

  Corollary dfs_nil_invariant l D : dfs_nil_invariant_t l (@dfs nil l D)
                              ∧ ∀i, dfs_nil_invariant_t l i → dfs D ⊆ i.
  Proof.
    generalize (dfs_invariant D); intros ((_ & H2 & H3) & H4).
    repeat split; auto.
    + intros x Hx.
      destruct (H3 _ Hx) as [ [] | ]; auto.
    + intros i (G1 & G2); apply H4.
      repeat split; auto.
      intros _ [].
  Qed.

  (* "Total" correctedness: dfs terminates provided an invariant exists *)

  Corollary 𝔻dfs_nil_domain l : 𝔻dfs nil l ↔ ex (dfs_nil_invariant_t l).
  Proof.
    split.
    + intros D; exists (dfs D); apply dfs_nil_invariant.
    + rewrite 𝔻dfs_domain.
      intros (inv & H1 & H2).
      exists inv; split; auto.
      intros _ [].
  Qed.

End dfs_domain_characterization.

Section finite_domain.

  (* In particular, if 𝓔 is finite then dfs terminate *)

  Hypothesis (H𝓥 : ∃l𝓥, ∀x:𝓥, x ∈ l𝓥).

  Fact 𝔻dfs_total v l : 𝔻dfs v l.
  Proof.
    apply 𝔻dfs_domain.
    destruct H𝓥 as (l𝓥 & ?).
    unfold dfs_invariant_t, incl.
    exists l𝓥; auto.
  Qed.

End finite_domain.

Section non_termination.

  (* We assume as an example that 𝓔 is isomorphic to nat
     and succs x = [S x] *)

  Hypothesis (f : nat -> 𝓥) (g : 𝓥 -> nat)
             (Hfg : forall x, f (g x) = x)
             (Hgf : forall n, g (f n) = n)
             (Hsuccs : forall x, succs x = f (S (g x)) :: nil).

  Fact max_list l : { m | m ∈ l ∧ ∀k, k ∈ l → k <= m } + { l = nil }.
  Proof.
    induction l as [ | n l IHl ].
    + right; auto.
    + left; destruct IHl as [ (m & H1 & H2) | H ].
      * destruct (le_lt_dec m n) as [ H | H ].
        - exists n; simpl; split; auto.
          intros k [ <- | H3 ]; auto.
          apply H2 in H3; lia.
        - exists m; simpl; split; auto.
          intros k [ <- | H3 ]; auto; lia.
      * exists n; subst; split; simpl; auto.
        intros ? [ <- | [] ]; auto.
  Qed.

  Fact unbounded_list_absurd l : (∀n, n ∈ l → S n ∈ l) → l = nil.
  Proof.
    intros H.
    destruct (max_list l) as [ (m & H1 & H2) | -> ]; auto.
    apply H, H2 in H1; lia.
  Qed.

  Fact dfs_non_termination l : 𝔻dfs nil l ↔ l = nil.
  Proof.
    split.
    * rewrite 𝔻dfs_nil_domain.
      intros (i & H1 & H2).
      assert (map g l ⊆ map g i) as H3.
      { intro n; rewrite !in_map_iff.
        intros (x & <- & ?); exists x; auto. }
      rewrite (unbounded_list_absurd (map g i)) in H3.
      + destruct l as [ | x ]; auto; exfalso; apply (H3 (g x)); simpl; auto.
      + intros n; rewrite !in_map_iff.
        intros (x & <- & Hx).
        exists (f (S (g x))).
        rewrite Hgf; split; auto.
        apply (H2 x); auto.
        rewrite Hsuccs; left; auto.
    * intros ->; apply 𝔻dfs_nil_domain.
      exists nil; repeat split; unfold incl; firstorder.
  Qed.

End non_termination.

Check 𝔻dfs.
Print Assumptions 𝔻dfs.

Check dfs.
Print Assumptions dfs.

Check 𝔻dfs_total.
Print Assumptions 𝔻dfs_total.

Check dfs_non_termination.
Print Assumptions dfs_non_termination.

Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
(* Extract Inlined Constant app => "(@)". *)

Recursive Extraction dfs.


Require Import Coq.Bool.Bvector.
Require Import Coq.ZArith.BinInt.
Require Import Coq.ZArith.Zdigits.

Module Bits.

(* An 8-bit binary number. *)
Definition B8 := Bvector 8.

(* A 64-bit binary number. *)
Definition B64 := Bvector 64.

(* Map a natural number to an 8-bit binary number. *)
Definition nat_to_B8 (n: nat) : B8 := Z_to_binary 8 (Z.of_nat n).

(* Map a natural number to a 64-bit binary number. *)
Definition nat_to_B64 (n: nat) : B64 := Z_to_binary 64 (Z.of_nat n).

(* Map an 8-bit number to an integer. *)
Definition B8_to_Z (bv : B8) : Z := binary_value 8 bv.

(* Map a 64-bit number to an integer. *)
Definition B64_to_Z (bv : B64) : Z := binary_value 64 bv.

(* Map an integer to a  64-bit number. *)
Definition Z_to_B64 (z : Z) : B64 := Z_to_binary 64 z.

(* Perform an AND operation on two BV64 values. *)
Definition B64_and (x y : B64) : B64 := BVand 64 x y.

(* Perform an OR operation on two BV64 values. *)
Definition B64_or (x y : B64) : B64 := BVor 64 x y.

(* Perform an XOR operation on two BV64 values. *)
Definition B64_xor (x y : B64) : B64 := BVxor 64 x y.

Module ZStuff.

    Local Open Scope Z_scope.

    (* Do a left shift of a B64 value. *)
    Definition B64_shl (bv : B64) := Z_to_B64 ((B64_to_Z bv) * 2).

    (* Do an iterative left shift of a B64 value. *)
    Definition B64_shl_iter (n : nat) (bv : B64) :=
        Z_to_B64 ((B64_to_Z bv) * (two_power_nat n)).

    (* Do a right shift of a B64 value. *)
    Definition B64_shr (bv : B64) := Z_to_B64 ((B64_to_Z bv) / 2).

    (* Do an iterative right shift of a B64 value. *)
    Definition B64_shr_iter (n : nat) (bv : B64) :=
        Z_to_B64 ((B64_to_Z bv) / (two_power_nat n)).

    (* Determine if x equals y. *)
    Definition B64_eql (x y : B64) :=
        match (B64_to_Z x) ?= (B64_to_Z y) with
            | Eq => nat_to_B64 1
            | _ => nat_to_B64 0
        end.

    (* Determine if x < y. *)
    Definition B64_lt (x y : B64) :=
        match (B64_to_Z x) ?= (B64_to_Z y) with
            | Lt => nat_to_B64 1
            | _ => nat_to_B64 0
        end.

    (* Determine if x > y. *)
    Definition B64_gt (x y : B64) :=
        match (B64_to_Z x) ?= (B64_to_Z y) with
            | Gt => nat_to_B64 1
            | _ => nat_to_B64 0
        end.

    (* Determine if x <= y. *)
    Definition B64_le (x y : B64) :=
        match (B64_to_Z x) ?= (B64_to_Z y) with
            | Eq => nat_to_B64 1
            | Lt => nat_to_B64 1
            | _ => nat_to_B64 0
        end.

    (* Determine if x >= y. *)
    Definition B64_ge (x y : B64) :=
        match (B64_to_Z x) ?= (B64_to_Z y) with
            | Eq => nat_to_B64 1
            | Gt => nat_to_B64 1
            | _ => nat_to_B64 0
        end.

    (* Determine if x != y. *)
    Definition B64_neq (x y : B64) :=
        match (B64_to_Z x) ?= (B64_to_Z y) with
            | Eq => nat_to_B64 0
            | _ => nat_to_B64 1
        end.

    (* Add two numbers. *)
    Definition B64_add (x y : B64) :=
        (Z_to_B64 ((B64_to_Z x) + (B64_to_Z y))).

    (* Subtract two numbers. *)
    Definition B64_sub (x y : B64) :=
        (Z_to_B64 ((B64_to_Z x) - (B64_to_Z y))).

    (* Multiply two numbers. *)
    Definition B64_mul (x y : B64) :=
        (Z_to_B64 ((B64_to_Z x) * (B64_to_Z y))).

    (* Divide two numbers. *)
    Definition B64_div (x y : B64) :=
        (Z_to_B64 ((B64_to_Z x) / (B64_to_Z y))).

    (* Compute x modulo y. *)
    Definition B64_mod (x y : B64) :=
        (Z_to_B64 ((B64_to_Z x) mod (B64_to_Z y))).

End ZStuff.

Export ZStuff.

End Bits.


(****************************************************************************

          IEEE754  :  Fop

          Laurent Thery

  ******************************************************************************)
Require Export Fcomp.
Section operations.
Variable radix : Z.

Let FtoRradix := FtoR radix.
Local Coercion FtoRradix : float >-> R.

Hypothesis radixNotZero : (0 < radix)%Z.

Definition Fplus (x y : float) :=
  Float
    (Fnum x * Zpower_nat radix (Zabs_nat (Fexp x - Zmin (Fexp x) (Fexp y))) +
     Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Zmin (Fexp x) (Fexp y))))
    (Zmin (Fexp x) (Fexp y)).

Theorem Fplus_correct : forall x y : float, Fplus x y = (x + y)%R :>R.
intros x y; unfold Fplus, Fshift, FtoRradix, FtoR in |- *; simpl in |- *.
rewrite plus_IZR.
rewrite Rmult_comm; rewrite Rmult_plus_distr_l; auto.
repeat rewrite Rmult_IZR.
repeat rewrite (Rmult_comm (Fnum x)); repeat rewrite (Rmult_comm (Fnum y)).
repeat rewrite Zpower_nat_Z_powerRZ; auto.
repeat rewrite <- Rmult_assoc.
repeat rewrite <- powerRZ_add; auto with real zarith arith.
repeat rewrite inj_abs; auto with real zarith.
repeat rewrite Zplus_minus; auto.
Qed.

Definition Fopp (x : float) := Float (- Fnum x) (Fexp x).

Theorem Fopp_correct : forall x : float, Fopp x = (- x)%R :>R.
unfold FtoRradix, FtoR, Fopp in |- *; simpl in |- *.
intros x.
rewrite Ropp_Ropp_IZR; auto with real.
Qed.

Theorem Fopp_Fopp : forall p : float, Fopp (Fopp p) = p.
intros p; case p; unfold Fopp in |- *; simpl in |- *; auto.
intros; rewrite Zopp_involutive; auto.
Qed.

Theorem Fzero_opp : forall f : float, ~ is_Fzero f -> ~ is_Fzero (Fopp f).
intros f; case f; intros n e; case n; unfold is_Fzero in |- *; simpl in |- *;
 auto with zarith; intros; red in |- *; intros; discriminate.
Qed.

Theorem Fdigit_opp : forall x : float, Fdigit radix (Fopp x) = Fdigit radix x.
intros x; unfold Fopp, Fdigit in |- *; simpl in |- *.
rewrite <- (digit_abs radix (- Fnum x)).
rewrite <- (digit_abs radix (Fnum x)).
case (Fnum x); simpl in |- *; auto.
Qed.

Definition Fabs (x : float) := Float (Zabs (Fnum x)) (Fexp x).

Theorem Fabs_correct1 :
 forall x : float, (0 <= FtoR radix x)%R -> Fabs x = x :>R.
intros x; case x; unfold FtoRradix, FtoR in |- *; simpl in |- *.
intros Fnum1 Fexp1 H'.
repeat rewrite <- (Rmult_comm (powerRZ radix Fexp1)); apply Rmult_eq_compat_l;
 auto.
cut (0 <= Fnum1)%Z.
unfold Zabs, Zle in |- *.
case Fnum1; simpl in |- *; auto.
intros p H'0; case H'0; auto.
apply Znot_gt_le; auto.
Contradict H'.
apply Rgt_not_le; auto.
rewrite Rmult_comm.
replace 0%R with (powerRZ radix Fexp1 * 0)%R; auto with real.
red in |- *; apply Rmult_lt_compat_l; auto with real zarith.
Qed.

Theorem Fabs_correct2 :
 forall x : float, (FtoR radix x <= 0)%R -> Fabs x = (- x)%R :>R.
intros x; case x; unfold FtoRradix, FtoR in |- *; simpl in |- *.
intros Fnum1 Fexp1 H'.
rewrite <- Ropp_mult_distr_l_reverse;
 repeat rewrite <- (Rmult_comm (powerRZ radix Fexp1));
 apply Rmult_eq_compat_l; auto.
cut (Fnum1 <= 0)%Z.
unfold Zabs, Zle in |- *.
case Fnum1; unfold IZR; auto with real.
intros p H'0; case H'0; auto.
apply Znot_gt_le.
Contradict H'.
apply Rgt_not_le; auto.
rewrite Rmult_comm.
replace 0%R with (powerRZ radix Fexp1 * 0)%R; auto with real.
red in |- *; apply Rmult_lt_compat_l; auto with real arith.
replace 0%R with (IZR 0); auto with real zarith arith.
Qed.

Theorem Fabs_correct : forall x : float, Fabs x = Rabs x :>R.
intros x; unfold Rabs in |- *.
case (Rcase_abs x); intros H1.
unfold FtoRradix in |- *; apply Fabs_correct2; auto with arith.
apply Rlt_le; auto.
unfold FtoRradix in |- *; apply Fabs_correct1; auto with arith.
apply Rge_le; auto.
Qed.

Theorem RleFexpFabs :
 forall p : float, p <> 0%R :>R -> (Float 1%nat (Fexp p) <= Fabs p)%R.
intros p H'.
unfold FtoRradix, FtoR, Fabs in |- *; simpl in |- *.
apply Rmult_le_compat_r; auto with real arith.
rewrite Zabs_absolu.
replace 1%R with (INR 1); auto with real.
repeat rewrite <- INR_IZR_INZ; apply Rle_INR; auto.
cut (Zabs_nat (Fnum p) <> 0); auto with zarith.
Contradict H'.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
replace (Fnum p) with 0%Z; try (simpl;ring).
generalize H'; case (Fnum p); simpl in |- *; auto with zarith arith;
 intros p0 H'3; Contradict H'3; auto with zarith arith.
Qed.

Theorem Fabs_Fzero : forall x : float, ~ is_Fzero x -> ~ is_Fzero (Fabs x).
intros x; case x; unfold is_Fzero in |- *; simpl in |- *.
intros n m; case n; simpl in |- *; auto with zarith; intros; red in |- *;
 discriminate.
Qed.
Hint Resolve Fabs_Fzero: float.

Theorem Fdigit_abs : forall x : float, Fdigit radix (Fabs x) = Fdigit radix x.
intros x; unfold Fabs, Fdigit in |- *; simpl in |- *.
case (Fnum x); auto.
Qed.

Definition Fminus (x y : float) := Fplus x (Fopp y).

Theorem Fminus_correct : forall x y : float, Fminus x y = (x - y)%R :>R.
intros x y; unfold Fminus in |- *.
rewrite Fplus_correct.
rewrite Fopp_correct; auto.
Qed.

Theorem Fopp_Fminus : forall p q : float, Fopp (Fminus p q) = Fminus q p.
intros p q; case p; case q; unfold Fopp, Fminus, Fplus in |- *; simpl in |- *;
 auto.
intros; apply floatEq; simpl in |- *; repeat rewrite (Zmin_sym Fexp0 Fexp);
 repeat rewrite Zopp_mult_distr_l_reverse; auto with zarith.
Qed.

Theorem Fopp_Fminus_dist :
 forall p q : float, Fopp (Fminus p q) = Fminus (Fopp p) (Fopp q).
intros p q; case p; case q; unfold Fopp, Fminus, Fplus in |- *; simpl in |- *;
 auto.
intros; apply floatEq; simpl in |- *; repeat rewrite (Zmin_sym Fexp0 Fexp);
 repeat rewrite Zopp_mult_distr_l_reverse; auto with zarith.
Qed.

Theorem minusSameExp :
 forall x y : float,
 Fexp x = Fexp y -> Fminus x y = Float (Fnum x - Fnum y) (Fexp x).
intros x y; case x; case y; unfold Fminus, Fplus, Fopp in |- *; simpl in |- *.
intros Fnum1 Fexp1 Fnum2 Fexp2 H'; rewrite <- H'.
repeat rewrite Zmin_n_n.
apply floatEq; simpl in |- *; auto.
replace (Zabs_nat (Fexp2 - Fexp2)) with 0; auto with zarith arith.
replace (Zpower_nat radix 0) with (Z_of_nat 1); simpl in |- *;
 auto with zarith arith.
replace (Fexp2 - Fexp2)%Z with 0%Z; simpl in |- *; auto with zarith arith.
Qed.

Definition Fmult (x y : float) := Float (Fnum x * Fnum y) (Fexp x + Fexp y).

Definition Fmult_correct : forall x y : float, Fmult x y = (x * y)%R :>R.
intros x y; unfold FtoRradix, FtoR, Fmult in |- *; simpl in |- *; auto.
rewrite powerRZ_add; auto with real zarith.
repeat rewrite Rmult_IZR.
repeat rewrite Rmult_assoc.
repeat rewrite (Rmult_comm (Fnum y)).
repeat rewrite <- Rmult_assoc.
repeat rewrite Zmult_assoc_reverse; auto.
Qed.

Theorem oneZplus :
 forall x y : Z,
 Float 1%nat (x + y) = Fmult (Float 1%nat x) (Float 1%nat y).
intros x y; unfold Fmult in |- *; auto.
Qed.
End operations.
Hint Resolve Fabs_Fzero: float.
Hint Resolve Fzero_opp: float.


From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* This is a scratch pad for dealing with Chapter 2 of Using Z: Specification, Refinement, Proof *)
Theorem and_comm : forall P Q : Prop, P /\ Q -> Q /\ P.
Proof.
  (* TYLER: Ok, I'm doing this in CoqIDE, like a god-damn Caveman...
            I switched to vim a while ago, and I just really dont want
            to jack with anything.

            So before I critique (hmm, no spelling... just bare with me)
            let's just write this out by hand:
       Assuming I know P and Q, can I show Q and P?
         to show Q and P, I must first show Q, then P
         I know Q
         I know P
         QED.

      What does this look like in Coq?*)
  intros P Q [HP HQ].
  split.
  - apply HQ.
  - apply HP.
Qed.

(* Here's an attempt to redo it using SSReflect *)
Theorem and_comm' : forall P Q : Prop, P /\ Q -> Q /\ P.
Proof.
  (* TYLER: Yeah, I've... literally never used ssreflect before, so
            reading up really quick...
  *)
  move => P Q [HP HQ].
  by split.
Qed.

Theorem disj_comm : forall P Q : Prop, P \/ Q -> Q \/ P.
Proof.
  intros P Q H.
  destruct H. right. apply H.
  left. apply H.
Qed.

(* and here's disj_comm in ssreflect *)
Theorem disj_comm' : forall P Q : Prop, P \/ Q -> Q \/ P.
Proof. move => P Q. by case; [right | left]. Qed.

(* Here's another proof from Using Z *)
Theorem paqir_implies_piqir : forall P Q R : Prop, (P /\ Q -> R) -> (P -> (Q -> R)).
Proof.
  intros P Q R H HP HQ.
  assert (HPQ: P /\ Q).
  split. exact HP. exact HQ.
  pose (HR := H HPQ).
  exact HR.
  (* I worry this is on the ugly side for what I'm trying to do. *)
Qed.

(* TYLER: Yeah, that was ugly. Let me try: *)
Theorem paqir_implies_piqir' : forall P Q R : Prop, (P /\ Q -> R) -> (P -> (Q -> R)).
Proof.
  intros P Q R H HP HQ.
  assert (HPQ: P /\ Q). split. exact HP. exact HQ.
  apply H. exact HPQ.
Qed.
(* TYLER: So I have never used pose before. Seems fine. So bassically the same *)

(* These two were stolen from a tutorial *)

Theorem backward_small : (forall A B : Prop,  A -> (A -> B) -> B).
Proof.
  intros A B.
  intros proof_of_A A_implies_B.
  refine (A_implies_B _).
  exact proof_of_A.
Qed.

Theorem forward_small : forall A B : Prop, A -> (A -> B) -> B.
Proof.
  intros A B proof_of_A A_implies_B.
  pose (proof_of_B := A_implies_B proof_of_A).
  exact proof_of_B.
Qed.

Lemma p_and_q_implies_p A B : A /\ B -> A.
Proof.
  move => [HA _].
    by [].
Qed.

(* This is Example 2.9 from _Using Z_ *)

Theorem p_stronger_q : forall P Q : Prop, (P -> Q) -> (P /\ Q) <-> P.
Proof.
  intros P Q H.
  split.
  - (* P /\ Q -> P *) intros [HP HQ].
    apply HP.
  - (* P -> P /\ Q *) intros HP.
    pose (H2 := conj HP (H HP)).
    apply H2.
    (* alternate approach, instead of 'pose...':
    apply H in HP as HQ.
    apply conj. apply HP. apply HQ. *)
Qed.

Lemma my_demorgan1 P Q : ~(P \/ Q) -> ~P /\ ~Q.
Proof.
  intros H.
  split.
  - (* ~ (P \/ Q) -> ~P *) intro HP. apply H. left. exact HP.
  - (* ~ (P \/ Q) -> ~Q *) intro HQ. apply H. right. exact HQ.
Qed.


(*
  Author(s):
    Dominique Larchey-Wendling (1)
    Andrej Dudenhefner (2)
    Johannes Hostert (2)
  Affiliation(s):
    (1) LORIA -- CNRS
    (2) Saarland University, Saarbrücken, Germany
*)

(** * Satisfiability of elementary, square, and uniform Diophantine constraints H10C_SAT, H10SQC_SAT, and H10UC_SAT *)

(*
  Problems(s):
    Diophantine Constraint Solvability (H10C_SAT)
    Square Diophantine Constraint Solvability (H10SQC_SAT)
    Uniform Diophantine Constraint Solvability (H10UC_SAT)
    Uniform Diophantine Pair Constraint Solvability (H10UPC_SAT)
*)

Require Import List.

(* Diophantine constraints (h10c) are of three shapes:
      x = 1 | x + y = z | x * y = z  with x, y, z in nat
*)

Inductive h10c : Set :=
  | h10c_one : nat -> h10c
  | h10c_plus : nat -> nat -> nat -> h10c
  | h10c_mult : nat -> nat -> nat -> h10c.

Definition h10c_sem c φ :=
  match c with
    | h10c_one x      => φ x = 1
    | h10c_plus x y z => φ x + φ y = φ z
    | h10c_mult x y z => φ x * φ y = φ z
  end.

(*
  Diophantine Constraint Solvability:
    given a list of Diophantine constraints, is there a valuation that satisfies each constraint?
*)
Definition H10C_SAT (cs: list h10c) := exists (φ: nat -> nat), forall c, In c cs -> h10c_sem c φ.

(* Square Diophantine constraints are of three shapes:
      x = 1 | x + y = z | x * x = y  with x, y, z in nat
*)

Inductive h10sqc : Set :=
  | h10sqc_one : nat -> h10sqc
  | h10sqc_plus : nat -> nat -> nat -> h10sqc
  | h10sqc_sq : nat -> nat -> h10sqc.

Definition h10sqc_sem φ c :=
  match c with
    | h10sqc_one x      => φ x = 1
    | h10sqc_plus x y z => φ x + φ y = φ z
    | h10sqc_sq x y => φ x * φ x = φ y
  end.

(*
  Square Diophantine Constraint Solvability:
    given a list of Diophantine constraints, is there a valuation that satisfies each constraint?
*)
Definition H10SQC_SAT (cs: list h10sqc) := exists (φ: nat -> nat), forall c, In c cs -> h10sqc_sem φ c.

(* Uniform Diophantine constraints (h10uc) are of shape:
      1 + x + y * y = z
*)
Definition h10uc := (nat * nat * nat)%type.

Definition h10uc_sem φ (c : h10uc) :=
  match c with
    | (x, y, z) => 1 + φ x + φ y * φ y = φ z
  end.

(*
  Uniform Diophantine Constraint Solvability:
    given a list of uniform Diophantine constraints, is there a valuation that satisfies each constraint?
*)
Definition H10UC_SAT (cs: list h10uc) := exists (φ: nat -> nat), forall c, In c cs -> h10uc_sem φ c.

(* Uniform Diophantine pairs constraints (h10upc) are of shape:
    (x, y) # (1 + x + y, y * (1 + y) / 2)
*)
Definition h10upc := ((nat * nat) * (nat * nat))%type.

(** Direct semantics of h10upc_sem *)
Definition h10upc_sem_direct (c : h10upc) :=
  match c with
    | ((x, y), (z1, z2)) =>
        1 + x + y = z1 /\ y * (1 + y) = z2 + z2
  end.

Definition h10upc_sem φ (c : h10upc) :=
  match c with
    | ((x, y), (z1, z2)) => h10upc_sem_direct (φ x, φ y, (φ z1, φ z2))
  end.

(*
  Uniform Diophantine Pair Constraint Solvability:
    given a list of uniform Diophantine pair constraints,
    is there a valuation that satisfies each constraint?
*)
Definition H10UPC_SAT (cs: list h10upc) :=
  exists (φ: nat -> nat), forall c, In c cs -> h10upc_sem φ c.


Require Export TopologicalSpaces.
Require Export InverseImage.
Require Export Continuity.

Section StrongTopology.

Variable A:Type.
Variable X:forall a:A, TopologicalSpace.
Variable Y:Type.
Variable f:forall a:A, point_set (X a) -> Y.

Definition strong_open (S:Ensemble Y) : Prop :=
  forall a:A, open (inverse_image (f a) S).

Definition StrongTopology : TopologicalSpace.
refine (Build_TopologicalSpace Y strong_open _ _ _).
intros.
red; intro.
assert (inverse_image (f a) (FamilyUnion F) =
  IndexedUnion (fun U:{ U:Ensemble Y | In F U } =>
                 inverse_image (f a) (proj1_sig U))).
apply Extensionality_Ensembles; red; split; red; intros.
destruct H0.
inversion H0.
exists (exist _ S H1).
constructor.
exact H2.

destruct H0.
destruct H0.
destruct a0 as [U].
constructor.
exists U; trivial.

rewrite H0.
apply open_indexed_union.
intros.
destruct a0 as [U].
simpl.
apply H; trivial.

intros.
red; intro.
rewrite inverse_image_intersection.
apply open_intersection2; (apply H || apply H0).

red; intro.
rewrite inverse_image_full.
apply open_full.
Defined.

Lemma strong_topology_makes_continuous_funcs:
  forall a:A, continuous (f a) (Y:=StrongTopology).
Proof.
intros.
red.
intros.
auto.
Qed.

Lemma strong_topology_strongest: forall (T':Ensemble Y->Prop)
  (H1:_) (H2:_) (H3:_),
  (forall a:A, continuous (f a)
          (Y:=Build_TopologicalSpace Y T' H1 H2 H3)) ->
  forall V:Ensemble Y, T' V -> strong_open V.
Proof.
intros.
unfold continuous in H.
simpl in H.
red; intros; apply H; trivial.
Qed.

End StrongTopology.

Implicit Arguments StrongTopology [[A] [X] [Y]].


Require Import init.

Require Import order_mult.

Definition min {U} `{Order U} x y :=
    If (x ≤ y) then x else y.
Definition max {U} `{Order U} x y :=
    If (x ≤ y) then y else x.

(* begin hide *)
Section MinMax.

Context {U} `{OrderedField U}.
(* end hide *)
Theorem min_leq : ∀ a b, a ≤ b → min a b = a.
Proof.
    intros a b leq.
    unfold min; case_if [leq'|leq'].
    -   reflexivity.
    -   contradiction.
Qed.
Theorem min_req : ∀ a b, b ≤ a → min a b = b.
Proof.
    intros a b leq.
    unfold min; case_if [leq'|leq'].
    -   exact (antisym leq' leq).
    -   reflexivity.
Qed.
Theorem max_leq : ∀ a b, b ≤ a → max a b = a.
Proof.
    intros a b leq.
    unfold max; case_if [leq'|leq'].
    -   exact (antisym leq leq').
    -   reflexivity.
Qed.
Theorem max_req : ∀ a b, a ≤ b → max a b = b.
Proof.
    intros a b leq.
    unfold max; case_if [leq'|leq'].
    -   reflexivity.
    -   contradiction.
Qed.

Theorem min_comm : ∀ a b, min a b = min b a.
Proof.
    intros a b.
    destruct (connex a b) as [leq|leq].
    -   rewrite min_leq, min_req by exact leq.
        reflexivity.
    -   rewrite min_req, min_leq by exact leq.
        reflexivity.
Qed.

Theorem max_comm : ∀ a b, max a b = max b a.
Proof.
    intros a b.
    destruct (connex a b) as [leq|leq].
    -   rewrite max_req, max_leq by exact leq.
        reflexivity.
    -   rewrite max_leq, max_req by exact leq.
        reflexivity.
Qed.

Theorem min_assoc : ∀ a b c, min a (min b c) = min (min a b) c.
Proof.
    intros a b c.
    destruct (connex a b) as [ab|ab].
    -   rewrite (min_leq a b ab).
        destruct (connex b c) as [bc|bc].
        +   rewrite (min_leq b c bc).
            rewrite (min_leq a b ab).
            rewrite (min_leq a c (trans ab bc)).
            reflexivity.
        +   rewrite (min_req b c bc).
            reflexivity.
    -   rewrite (min_req a b ab).
        destruct (connex b c) as [bc|bc].
        +   rewrite (min_leq b c bc).
            exact (min_req a b ab).
        +   rewrite (min_req b c bc).
            exact (min_req a c (trans bc ab)).
Qed.

Theorem max_assoc : ∀ a b c, max a (max b c) = max (max a b) c.
Proof.
    intros a b c.
    destruct (connex a b) as [ab|ab].
    -   rewrite (max_req a b ab).
        destruct (connex b c) as [bc|bc].
        +   rewrite (max_req b c bc).
            exact (max_req a c (trans ab bc)).
        +   rewrite (max_leq b c bc).
            exact (max_req a b ab).
    -   rewrite (max_leq a b ab).
        destruct (connex b c) as [bc|bc].
        +   rewrite (max_req b c bc).
            reflexivity.
        +   rewrite (max_leq b c bc).
            rewrite (max_leq a c (trans bc ab)).
            exact (max_leq a b ab).
Qed.

Theorem rmin : ∀ a b, min a b ≤ b.
Proof.
    intros a b.
    destruct (connex a b) as [ab|ab].
    -   rewrite (min_leq a b ab).
        exact ab.
    -   rewrite (min_req a b ab).
        apply refl.
Qed.
Theorem lmin : ∀ a b, min a b ≤ a.
Proof.
    intros a b.
    rewrite min_comm.
    apply rmin.
Qed.

Theorem lmax : ∀ a b, a ≤ max a b.
Proof.
    intros a b.
    destruct (connex a b) as [ab|ab].
    -   rewrite (max_req a b ab).
        exact ab.
    -   rewrite (max_leq a b ab).
        apply refl.
Qed.
Theorem rmax : ∀ a b, b ≤ max a b.
Proof.
    intros a b.
    rewrite max_comm.
    apply lmax.
Qed.

Theorem min_max_plus : ∀ a b, min a b + max a b = a + b.
Proof.
    intros a b.
    destruct (connex a b) as [ab|ab].
    -   rewrite (min_leq a b ab), (max_req a b ab).
        reflexivity.
    -   rewrite (min_req a b ab), (max_leq a b ab).
        apply plus_comm.
Qed.
(* begin hide *)
End MinMax.
(* end hide *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) (z : natural) (x : natural)
  : natural := plus z (mult z x).


Require Import Classical.

Lemma ex1 : forall a b:Prop, a \/ (a -> b).
Proof.
  intros a b.
  classical_right.
  intro H0.
  contradiction. (* temos ~a  e a *)
Qed.

Lemma ex2 : forall a b:Prop, ((a -> b) /\ ~b) -> ~a.
Proof.
  intros a b H.
  destruct H as [H1 H2].
  intro H0.
  absurd b.
  - exact H2.

  - cut a.
    exact H1. exact H0.
Qed.

Lemma ex3 : forall A:Set, forall P Q:(A -> Prop),
forall x:A,(forall x:A, (P x) -> (Q x)) -> ((forall x:A,(P x)) -> (exists x:A,(Q x))).
Proof.
  intros A P Q X H H0.
  exists X.
  cut (P X).
  apply H. apply H0.
Qed.


Local Set Warnings "-notation-overridden".
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype tuple.
From mathcomp Require Import fingroup.
Local Set Warnings "all".

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

Section Def.
  Variable K M C : finType.

  Record impl := Impl {enc : K -> M -> C; dec : K -> C -> M}.

  Definition correct (i : impl)
    := forall k, cancel (enc i k) (dec i k).
  Definition secure (i : impl)
    := exists n, forall c m, #|[pred k | enc i k m == c]| = n.

End Def.

Section Theory.
  Variable K M C : finType.
  Variable i : impl K M C.
  Hypothesis correct_i : correct i.
  Hypothesis secure_i : secure i.
  Variable (k0 : K) (m0 : M).

  Theorem card_ciphertext_ge : #|M| <= #|C|.
  Proof.
    rewrite -(cardC (mem_seq (image (enc i k0) M))).
    apply/(leq_trans _ (leq_addr _ _)).
    rewrite card_image => //.
    by apply (can_inj (correct_i k0)).
  Qed.

  Theorem card_key_ge : #|C| <= #|K|.
  Proof.
    have find_k : forall c m, exists k, enc i k m == c.
    {
      move=> c m.
      move: secure_i => [n Hsecuren].
      have Hgtn : 0 < n.
      {
        rewrite -(Hsecuren (enc i k0 m0) m0).
        by apply/card_gt0P; exists k0; rewrite inE.
      }
      move: Hgtn; rewrite -(Hsecuren c m).
      by move/card_gt0P => [k Hk]; exists k.
    }
    pose fun_c2k c := xchoose (find_k c m0).
    rewrite -(cardC (mem_seq (image fun_c2k C))).
    apply/(leq_trans _ (leq_addr _ _)).
    rewrite card_image => //.
    apply (can_inj (g:=(enc i)^~ m0)).
    move=> c; rewrite /fun_c2k.
    by apply (eqP (xchooseP (find_k _ _))).
  Qed.
End Theory.

Section OneTimePad.
  Variable T : finGroupType.

  Definition one_time_pad : impl T T T
    := Impl mulg (mulg \o invg).

  Theorem correct_otp : correct one_time_pad.
  Proof.
    move=> k m /=. by rewrite mulgA mulVg mul1g.
  Qed.

  Theorem secure_otp : secure one_time_pad.
  Proof.
    exists 1.
    move=> c m /=.
    apply (eq_card1 (x:=(c * m^-1)%g)).
    move=> k.
    rewrite !inE.
    rewrite -(inj_eq (mulIg (invg m))).
    by rewrite -mulgA mulgV mulg1.
  Qed.
End OneTimePad.

Section Pair.
  Variable K1 M1 C1 : finType.
  Variable i1 : impl K1 M1 C1.
  Hypothesis correct_i1 : correct i1.
  Hypothesis secure_i1 : secure i1.

  Variable K2 M2 C2 : finType.
  Variable i2 : impl K2 M2 C2.
  Hypothesis correct_i2 : correct i2.
  Hypothesis secure_i2 : secure i2.

  Local Notation K := [finType of (K1 * K2)].
  Local Notation M := [finType of (M1 * M2)].
  Local Notation C := [finType of (C1 * C2)].

  Definition compose_pair : impl K M C
    := Impl
         (fun '(k1, k2) '(m1, m2) => (enc i1 k1 m1, enc i2 k2 m2))
         (fun '(k1, k2) '(c1, c2) => (dec i1 k1 c1, dec i2 k2 c2)).

  Theorem correct_compose_pair : correct compose_pair.
  Proof.
    by move=> [k1 k2] [m1 m2] /=; rewrite correct_i1 correct_i2.
  Qed.

  Theorem secure_compose_pair : secure compose_pair.
  Proof.
    move: secure_i1 => [n1 Hsecure1].
    move: secure_i2 => [n2 Hsecure2].
    exists (n1 * n2) => [[c1 c2] [m1 m2]].
    rewrite -(Hsecure1 c1 m1) -(Hsecure2 c2 m2) -cardX.
    apply eq_card => [[k1 k2]].
    by rewrite !inE /=.
  Qed.
End Pair.

Section BijectTuplePair.
  Variable T : Type.
  Variable n : nat.

  Definition pair_to_tuple_cons (p : (T * n.-tuple T)) := [tuple of p.1 :: p.2].
  Definition tuple_cons_to_pair (t : n.+1.-tuple T) := (thead t, behead_tuple t).

  Theorem can_pttc_tctp : cancel pair_to_tuple_cons tuple_cons_to_pair.
  Proof.
    move=> [h t].
    rewrite /pair_to_tuple_cons /tuple_cons_to_pair /= theadE.
    set ht := tuple _.
    suff H : t = behead_tuple ht by rewrite H.
    rewrite {}/ht.
    apply/eq_from_tnth => i.
    by rewrite tnth_behead !(tnth_nth h) /= inordK // ltnS.
  Qed.

  Theorem can_tctp_pttc : cancel tuple_cons_to_pair pair_to_tuple_cons.
  Proof.
    move=> t.
    rewrite /pair_to_tuple_cons /tuple_cons_to_pair /=.
    by symmetry; apply tuple_eta.
  Qed.

  Theorem bij_tctp : bijective tuple_cons_to_pair.
  Proof. exact (Bijective can_tctp_pttc can_pttc_tctp). Qed.
End BijectTuplePair.

Arguments bij_tctp {T n}.

Section Tuple.
  Variable K0 M0 C0 : finType.
  Variable i0 : impl K0 M0 C0.
  Hypothesis correct_i0 : correct i0.
  Hypothesis secure_i0 : secure i0.
  Variable n : nat.
  Local Notation K := [finType of (n.-tuple K0)].
  Local Notation M := [finType of (n.-tuple M0)].
  Local Notation C := [finType of (n.-tuple C0)].

  Definition lift_tuple2 {A B C} (f : A -> B -> C) (a : n.-tuple A) (b : n.-tuple B)
    := map_tuple (prod_curry f) (zip_tuple a b).

  Definition compose : impl K M C
    := Impl (lift_tuple2 (enc i0)) (lift_tuple2 (dec i0)).

  Lemma tnth_zip {A B} n' (a : n'.-tuple A) (b : n'.-tuple B) j
    : tnth (zip_tuple a b) j = (tnth a j, tnth b j).
  Proof.
    rewrite /tnth nth_zip_cond size_zip !size_tuple minnn ltn_ord.
    by apply injective_projections; apply set_nth_default; rewrite size_tuple ltn_ord.
  Qed.

  Theorem correct_compose : correct compose.
  Proof.
    move=> k m /=; apply eq_from_tnth => j /=.
    by rewrite tnth_map tnth_zip tnth_map tnth_zip /prod_curry correct_i0.
  Qed.

  Theorem secure_compose : secure compose.
  Proof.
    move: secure_i0 => [l Hsecure]; exists (l^n) => c m.
    rewrite /compose /lift_tuple2 /=.
    have cHsecure cm := Hsecure cm.1 cm.2.
    elim: n c m => [|n' IHn] c m.
    {
      rewrite expn0.
      rewrite (eq_card1 (x:=[tuple])) // => k.
      rewrite !inE.
      by rewrite [k]tuple0 [c]tuple0 [map_tuple _ _]tuple0.
    }
    {
      rewrite expnS.
      rewrite -(IHn (behead_tuple c) (behead_tuple m)).
      rewrite -(Hsecure (thead c) (thead m)).
      rewrite -cardX.
      rewrite !cardE -(size_map (@tuple_cons_to_pair _ _)).
      apply perm_size.
      apply uniq_perm;
        [by rewrite (map_inj_uniq (bij_inj bij_tctp)); apply enum_uniq|exact: enum_uniq|]
        => [[headk tailk]].
      rewrite -{1}[(headk, tailk)]can_pttc_tctp (mem_map (bij_inj bij_tctp)) !mem_enum !inE.
      apply/(sameP idP)/(iffP idP).
      {
        move=> /andP [Hheadk Htailk].
        apply/eqP/eq_from_tnth => j.
        rewrite [m]tuple_eta [c]tuple_eta.
        rewrite tnth_map tnth_zip /prod_curry.
        move: j => [[|j] Hj].
        {
          rewrite (_:Hj=ltn0Sn n'); last by apply bool_irrelevance.
          by rewrite !tnth0; apply/eqP.
        }
        {
          rewrite (tnth_nth (headk)) (tnth_nth (thead m)) (tnth_nth (thead c)) /=.
          rewrite (_ : behead c = behead_tuple c) //.
          rewrite ltnS in Hj.
          pose oj := Ordinal Hj.
          rewrite (_:j=oj) //.
          rewrite -!tnth_nth.
          rewrite -(eqP Htailk).
          by rewrite tnth_map tnth_zip /prod_curry.
        }
      }
      {
        move=> /eqP <- /=.
        apply/andP; split.
        { by rewrite /thead tnth_map tnth_zip. }
        {
          apply/eqP/eq_from_tnth => j.
          rewrite tnth_behead !tnth_map !tnth_zip /=.
          rewrite {2}[m]tuple_eta.
          rewrite [tnth _ (inord _)](tnth_nth headk).
          rewrite [tnth _ (inord _)](tnth_nth (thead m)).
          rewrite inordK /=; last by rewrite ltnS.
          by rewrite -!tnth_nth.
        }
      }
    }
  Qed.
End Tuple.