(** * Lecture 4: Tactics in UniMath *)
(** by Ralph Matthes, IRIT, Université de Toulouse, CNRS, Toulouse INP, UT3, Toulouse, France *)

(** My employer is the CNRS, my lab is the IRIT, but the above affiliation is obligatory for
    any scientific production I release.
*)

(** This is the extended version of a presentation at the
    UniMath school 2022 in Cortona, meant for self-study
    and for exploring the UniMath library.

    The material is based on the extended version of the
    presentation at the UniMath schools 2017 and 2019 in
    Birmingham, but updated to fit with the changes in (the
    practice of) UniMath.

    Works with current UniMath (as of July 15, 2022, but also the Coq platform of April '22).
*)

(** Compiles with the command
[[
coqc -type-in-type lecture_tactics_long_version.v
]]
when Coq is set up according to the instructions for this school and the associated coqc executable
has priority in the path. However, you do not need to compile this file. The option is crucial, and
also your own developments will need the Coq options configured through the installation instructions,
most notably the present one. *)

(** Can be transformed into HTML documentation with the command
[[
coqdoc -utf8 lecture_tactics_long_version.v
]]
    (If internal links in the generated lecture_tactics_long_version.html are desired,
     compilation with coqc is needed.)
*)

(** In Coq, one can define concepts by directly giving well-typed
    terms (see Part 2), but one can also be helped in the construction by the
    interactive mode.
*)

Require Import UniMath.Foundations.Preamble.
(* Require Import UniMath.CategoryTheory.All. *)

(** ** define a concept interactively: *)

Locate bool.  (** a separate definition - [Init.Datatypes.bool] is in the Coq library,
                  not available for UniMath *)

Definition myfirsttruthvalue: bool.
  (** only the identifier and its type given, not the definiens *)

  (** This opens the interactive mode.

      The ##UniMath
      style guide## asks us to start what follows with [Proof.] in a separate line.
      In vanilla Coq, this would be optional (it is anyway a "nop"). *)
Proof.
  (** Now we still have to give the term, but we are in interactive mode. *)
  (** If you want to see everything in the currently loaded part of the UniMath library
      that *involves* booleans, then do *)
  Search bool.
  (** If you only want to find library elements that *yield* booleans, then try *)
  SearchPattern bool.
  (** [true] does not take an argument, and it is already a term we can take as definiens. *)
  exact true.
  (** [exact] is a tactic which takes the term as argument and informs Coq in the proof mode to
      finish the current goal with that term. *)

  (** We see in the response buffer: "No more subgoals."
      Hence, there is nothing more to do, except for leaving the proof mode properly. *)
Defined.

(** [Defined.] instructs Coq to complete the whole interactive construction of a term,
    verify it and to associate it with the given identifer, here [myfirsttruthvalue].
    This may go wrong for different reasons, including implementation errors of the Coq
    system - that will not affect trustworthiness of the library. *)
Search bool.
(** The new definition appears at the beginning of the list. *)
Print myfirsttruthvalue.  (** or just point to the identifier and hit the
                              key combination mentioned in Part 2 *)

(** [myfirsttruthvalue relies on an unsafe universe hierarchy] is output to indicate
    that we are using Coq with option [-type-in-type]. *)

(** *** a more compelling example *)
Definition mysecondtruthvalue: bool.
Proof.
  Search bool.
  apply negb.
  (** applies the function [negb] to obtain the required boolean,
      thus the system has to ask for its argument *)
  exact myfirsttruthvalue.
Defined.

Print mysecondtruthvalue.
(**
[[
mysecondtruthvalue = negb myfirsttruthvalue
     : bool
]]
*)

(** the definition is "as is", evaluation can be done subsequently: *)
Eval compute in mysecondtruthvalue.
(**
[[
     = false
     : bool
]]
*)

(** Again, not much has been gained by the interactive mode. *)

(** Here, we see a copy of the definition from the Coq library: *)
Definition andb (b1 b2: bool) : bool := if b1 then b2 else false.
(** only for illustration purposes - it would be better to define
    it according to UniMath style *)

Definition mythirdtruthvalue: bool.
Proof.
  Search bool.
  apply andb.
  (** [apply andb.] applies the function [andb] to obtain the required boolean,
      thus the system has to ask for its TWO arguments, one by one. *)

  (** This follows the proof pattern of "backward chaining" that tries to
      attack goals instead of building up evidence. In the course of action,
      more goals can be generated. The proof effort is over when no more
      goal remains. *)

  (** UniMath coding style asks you to use proof structuring syntax,
      while vanilla Coq would allow you to write formally verified
      "spaghetti code". *)

  (** We tell Coq that we start working on the first subgoal. *)
  -
    (** only the "focused" subgoal is now on display *)
    apply andb.
    (** this again spawns two subgoals *)

    (** we tell Coq that we start working on the first subgoal *)
    +
      (** normally, one would not leave the "bullet symbol" isolated in a line *)
      exact mysecondtruthvalue.
    + exact myfirsttruthvalue.
      (** The response buffer signals:
[[
There are unfocused goals.
]]
          ProofGeneral would give more precise instructions as how to proceed.
          But we know what we are doing...
       *)
  - exact true.
Defined.

(** The usual "UniMath bullet order" is -, +, *, --, ++, **, ---, +++, ***,
    and so on (all the ones shown are being used).

    Coq does not impose any order, so one can start with, e.g., *****,
    if need be for the sake of experimenting with a proof.

    Reuse of bullets even on one branch is possible by enclosing subproofs
    in curly braces {}.
*)

Print mythirdtruthvalue.
Eval compute in mythirdtruthvalue.

(** You only saw the tactics [exact] and [apply] at work, and there was no context. *)

(** ** doing Curry-Howard logic *)

(** Interactive mode is more wide-spread when it comes to carrying out proofs
    (the command [Proof.] is reminiscent of that). *)

(** Disclaimer: this section has a logical flavour, but the "connectives"
    are not confined to the world of propositional or predicate logic.
    In particular, there is no reference to the sort Prop of Coq.
    Prop is not used at all in UniMath!

    On first reading, it is useful to focus on the logical meaning. *)

Locate "->". (** non-dependent product, can be seen as implication *)
Locate "∅".
Print empty. (** an inductive type that has no constructor *)
Locate "¬". (** we need to refer to the UniMath library more explicitly *)

Require Import UniMath.Foundations.PartA.
(** Do not write the import statements in the middle of a vernacular file.
    Here, it is done to show the order of appearance, but this is only for
    reasons of pedagogy.
*)

Locate "¬".
Print neg.
(** Negation is not a native concept; it is reduced to implication,
    as is usual in constructive logic. *)

Locate "×".
Print dirprod.  (** non-dependent sum, can be seen as conjunction *)

Definition combinatorS (A B C: UU): (A × B -> C) × (A -> B) × A -> C.
Proof.
  (** how to infer an implication? *)
  intro Hyp123.
  set (Hyp1 := pr1 Hyp123).
  (** This is already a bit of "forward chaining" which is a fact-building process. *)
  set (Hyp23 := pr2 Hyp123).
  cbn in Hyp23.
  (** [cbn] simplifies a goal, and [cbn in H] does this for hypothesis [H];
      note that [simpl] has the same high-level description but should better
      be avoided in new developments.  *)
  set (Hyp2 := pr1 Hyp23).
  set (Hyp3 := pr2 Hyp23).
  cbn in Hyp3.
  apply Hyp1.
  apply tpair. (** could be done with [split.] as well *)
  - assumption. (** instruct Coq to look into the current context *)

                (** this could be done with [exact Hyp3.] as well *)
  - apply Hyp2.
    assumption.
Defined.

Print combinatorS.
Eval compute in combinatorS.

Local Definition combinatorS_intro_pattern (A B C: UU):
  (A × B -> C) × (A -> B) × A -> C.
Proof.
  intros [Hyp1 [Hyp2 Hyp3]]. (** deconstruct the hypothesis at the time of introduction;
                                 notice that [×] associates to the right;
                                 [intros] can also introduce multiple hypotheses, see below *)
  apply Hyp1.
  split.
  - assumption.
  - apply Hyp2.
    assumption.
Defined.

Print combinatorS_intro_pattern.

(** the two definitions are even convertible: *)
Eval compute in combinatorS_intro_pattern.

Local Lemma combinatorS_intro_pattern_is_the_same:
  combinatorS = combinatorS_intro_pattern.
Proof.
  apply idpath.
Defined.

(** In late 2017, [combinatorS_intro_pattern] would have contained [match] constructs,
    but now, the introduction patterns use less overhead when possible. The UniMath
    style guide still does not want them to be used with square brackets. *)

(** another style to make life easier: *)
Local Definition combinatorS_destruct (A B C: UU):
  (A × B -> C) × (A -> B) × A -> C.
Proof.
  intro Hyp123.
  destruct Hyp123 as [Hyp1 Hyp23]. (** deconstruct the hypothesis when needed *)
  apply Hyp1.
  destruct Hyp23 as [Hyp2 Hyp3]. (** deconstruct the hypothesis when needed *)
  split.
  - assumption.
  - apply Hyp2.
    assumption.
Defined.

Print combinatorS_destruct.

(** Again, the definition is definitionally equal to the first one: *)
Eval compute in combinatorS_destruct.

Local Lemma combinatorS_destruct_is_the_same: combinatorS = combinatorS_destruct.
Proof.
  apply idpath.
Defined.

(** In late 2017, [combinatorS_destruct] would also have contained [match] constructs,
    which is why [destruct] is forbidden in the UniMath style guide. Now, this is fine
    in our example. *)

(** The (hitherto) preferred idiom: *)
Definition combinatorS_induction (A B C: UU): (A × B -> C) × (A -> B) × A -> C.
Proof.
  intro Hyp123.
  induction Hyp123 as [Hyp1 Hyp23].
  apply Hyp1.
  induction Hyp23 as [Hyp2 Hyp3].
  split.
  - assumption.
  - apply Hyp2.
    assumption.
Defined.

Print combinatorS_induction.
Eval compute in combinatorS_induction.
(** the comfort for the user does not change the normal form of the constructed proof *)

Definition combinatorS_curried (A B C: UU): (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
  (** use [intro] three times or rather [intros] once; reasonable coding style
      gives names to all hypotheses that are not already present
      in the goal formula, see also the next definition *)
  intros H1 H2 H3.
  apply H1.
  - assumption.
  - set (proofofB := H2 H3).
    (** set up abbreviations that can make use of the current context;
        will be considered as an extra element of the context: *)
    assumption.
Defined.

Print combinatorS_curried.
(** We see that [set] gives rise to [let]-expressions that are known
    from functional programming languages, in other words: the use of
    [set] is not a "macro" facility to ease typing. *)

(** [let]-bindings disappear when computing the normal form of a term: *)
Eval compute in combinatorS_curried.

(** [set] can only be used if the term of the desired type is provided,
    but we can also work interactively as follows: *)
Definition combinatorS_curried_with_assert (A B C: UU):
  (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
  intros H1 H2 H3.
  (** we can momentarily forget about our goal and build up knowledge: *)
  assert (proofofB : B).
  (** the current goal [C] becomes the second sub-goal, and the new current goal is [B] *)

  (** It is not wise to handle this situation by "bullets" since many assertions
      can appear in a linearly thought argument. It would pretend a tree structure
      although it would rather be a comb. The proof of the assertion should
      be packaged by enclosing it in curly braces like so: *)
  { apply H2.
    assumption.
  }
  (** Now, [proofofB] is in the context with type [B]. *)
  apply H1.
  - assumption.
  - assumption.
Defined.

(** the wildcard [?] for [intros] *)
Definition combinatorS_curried_variant (A B C: UU):
  (A -> B -> C) -> (A -> B) -> forall H7: A, C.
Proof.
  intros H1 H2 ?.
(** a question mark instructs Coq to use the corresponding identifier
    from the goal formula *)
  exact (H1 H7 (H2 H7)).
Defined.
(** the wildcard [_] for [intros] forgets the respective hypothesis *)

Locate "⨿". (** this symbol is typed as \amalg when the recommended extension
                packages for VSCode are loaded *)
Print coprod. (** defined in UniMath preamble as inductive type,
  can be seen as disjunction *)

Locate "∏".

Locate "=". (** the identity type of UniMath *)
Print paths.

(** A word of warning for those who read "Coq in a Hurry": [SearchRewrite]
    does not find equations w.r.t. this notion, only w.r.t. Coq's built-in
    propositional equality. *)
SearchPattern (paths _ _).
(** Among the search results is [pathsinv0r] that has [idpath] in its conclusion. *)
SearchRewrite idpath.
(** No result! *)

(** *** How to decompose formulas *)

(** In "Coq in a Hurry", Yves Bertot gives recipes for decomposing the usual logical
    connectives. Crucially, one has to distinguish between decomposition of the goal
    or decomposition of a hypothesis in the context.

    Here, we do it alike.
*)

(** **** Decomposition of goal formulas:

    A1,...,An -> B: tactic [intro] or [intros]

    [¬ A]: idem (negation is defined through implication)

    Π-type: idem (implication is a special case of product)

    [×]: [apply dirprodpair], less specifically [apply tpair] or [split]

    Σ-type: [use tpair] or [exists] or [split with], see explanations below

    [A ⨿ B]: [apply ii1] or [apply ii2], but this constitutes a choice
             of which way to go

    [A = B]: [apply idpath], however this only works when the expressions
             are convertible

    [nat]: [exact 1000], for example (a logical reading is not
         useful for this type); beware that UniMath knows only 27 numerals,
         [Goal nat. Fail exact 2022.] leads to
[[
The command has indeed failed with message: No interpretation for number "2022".
]]
*)

(** **** Decomposition of formula of hypothesis [H]:

    [∅]: [induction H]

         This terminates a goal. (It corresponds to ex falso quodlibet.)

         There is naturally no recipe for getting rid of [∅] in the conclusion.
         But [apply fromempty] allows to replace any goal by [∅].

    A1,...,An -> B: [apply H], but the formula has to fit with the goal

    [×]: [induction H as [H1 H2]]

         As seen above, this introduces names of hypotheses for the two components.

    Σ-type: idem, but rather more asymmetric as [induction H as [x H']]

    [A ⨿ B]: [induction H as [H1 | H2]]

              This introduces names for the hypotheses in the two branches.

    [A = B]: [induction H]

             The supposedly equal [A] and [B] become the same [A] in the goal.

             This is the least intuitive rule for the non-expert in type theory.

    [nat]: [induction n as [ | n IH]]

           Here, we assume that the hypothesis has the name [n] which
           is more idiomatic than [H], and there is no extra name in
           the base case, while in the step case, the preceding number
           is now given the name [n] and the induction hypothesis is
           named [IH].
*)

(** ** Handling unfinished proofs *)

(** In the middle of a proof effort - not in the UniMath library - you can use
    [admit] to abandon the current goal. *)
Local Lemma badex1 (A: UU): ∅ × (A -> A).
Proof.
  split.
  - (** seems difficult in the current context *)
    admit.

    (** we continue with decent proof work: *)
  - intro H.
    assumption.
Admitted.

(** This is strictly forbidden to commit to UniMath! [admit] allows to pursue the other goals,
    while [Admitted.] makes the lemma available for further proofs. A warning is shown that
    [badex1] has been assumed as axiom. *)

(** An alternative to interrupt work on a proof: *)
Lemma badex2 (A: UU): ∅ × (A -> A).
Proof.
  split.
  -
Abort.
(** [badex2] is not in the symbol table. *)

(** [Abort.] is a way of documenting a problem with proving a result.
    At least, Coq can check the partial proof up to the [Abort.] command. *)

(** ** Working with holes in proofs *)

(** Our previous proofs were particularly clear because the goal formulas
    and all hypotheses were fully given by the system.
*)

Print pathscomp0.
(** This is the UniMath proof of transitivity of equality. *)

(** The salient feature of transitivity is that the intermediate
    expression cannot be deduced from the equation to be proven. *)
Lemma badex3 (A B C D: UU) : ((A × B) × (C × D)) = (A × (B × C) × D).
(** Notice that the outermost parentheses are needed here. *)
Proof.
  Fail apply pathscomp0.
(**
[[
The command has indeed failed with message:
Cannot infer the implicit parameter b of pathscomp0 whose type is
"Type" in environment:
A, B, C, D : UU
]]

[Fail] announces failure and therefore allows to continue with
the interpretation of the vernacular file.

We need to help Coq with the argument [b] to [pathscomp0].
*)
  apply (pathscomp0 (b := A × (B × (C × D)))).
  - (** is this not just associativity with third argument [C × D]? *)
    SearchPattern (_ × _ =  _ × _).
    (** Nothing for our equation - we can only hope for weak equivalence ≃. *)
Abort.

SearchPattern(_ ≃ _).
Print weqcomp.
Print weqdirprodasstor.
Print weqdirprodasstol.
Print weqdirprodf.
Print idweq.

Lemma assocex (A B C D: UU) : ((A × B) × (C × D)) ≃ (A × (B × C) × D).
Proof.
  Fail apply weqcomp.
  eapply weqcomp.
(** [eapply] generates "existential variables" for the expressions
    it cannot infer from applying a lemma.

    The further proof will narrow on those variables and finally
    make them disappear - otherwise, the proof is not considered
    completed.
 *)
  - (** We recall that on this side, only associativity was missing. *)
    apply weqdirprodasstor.
  - (** The subgoal is now fully given. *)

    (** The missing link is associativity, but only on the
        right-hand side of the top [×] symbol. *)
    apply weqdirprodf.
    + apply idweq.
    + apply weqdirprodasstol.
Defined.

(** Warning: tactic [exact] does not work if there are existential
    variables in the goal, but [eexact] can then be tried. *)

Lemma sumex (A: UU) (P Q: A -> UU):
  (∑ x: A, P x × Q x) -> (∑ x: A, P x) × ∑ x:A, Q x.
Proof.
  (** decompose the implication: *)
  intro H.
  (** decompose the Σ-type: *)
  induction H as [x H'].
  (** decompose the pair: *)
  induction H' as [H1 H2].
  (** decompose the pair in the goal *)
  split.
  - Fail split.
    (**
[[
The command has indeed failed with message:
         Unable to find an instance for the variable pr1.
]]
     *)
    Fail (apply tpair).
    (** A simple way out, by providing the first component: *)
    split with x. (** [exists x] does the same *)
    assumption.
  - (** or use [eapply] and create an existential variable: *)
    eapply tpair.
    Fail assumption. (** the assumption [H2] does not agree with the goal *)
    eexact H2.
Defined.
(** Notice that [eapply tpair] is not used in the UniMath library,
    since [use tpair] normally comes in handier, see below. *)

(** *** Warning on existential variables *)
(** It may happen that the process of instantiating existential variables
    is not completed when all goals have been treated.
 *)

(** an example adapted from one by Arnaud Spiwack, ~2007 *)

About unit. (** from the UniMath preamble *)

Local Definition P (x:nat) := unit.

Lemma uninstex: unit.
Proof.
  refine ((fun x:P _ => _) _).
  (** [refine] is like [exact], but one can leave holes with the wildcard "_".
      This tactic should hardly be needed since most uses in UniMath
      can be replaced by a use of the "tactic" [use], see further down
      on this tactic notation for an Ltac definition.

      Still, [refine] can come to rescue in difficult situations,
      in particular during proof development. Its simpler variant
      [simple refine] is captured by the [use] "tactic".
*)
  - exact tt.
  - exact tt.
    (** Now, Coq presents a subgoal that pops up from the "shelved goals".

       Still, no more "-" bullets can be used.

[[ -
Error: Wrong bullet - : No more subgoals.
]]
     *)

Show Existentials.
(** a natural number is still being asked for *)
Unshelve.
(** Like this, we can focus on the remaining goal. *)
exact 0.
Defined.

(** one can also name the existential variables in [refine]: *)
Lemma uninstexnamed: unit.
  Proof.
    refine ((fun x:P ?[n] => _) _).  (** give a name to the existential variable *)
    - exact tt.
    - exact tt.
Show Existentials.
Unshelve.
instantiate (n := 0).  (** more symbols to type but better to grasp *)
Defined.

(** ** a bit more on equational reasoning *)

Section homot.
(** A section allows to introduce local variables/parameters
    that will be bound outside of the section. *)

Locate "~".
(** printing ~ #~# *)

Print homot. (** this is just pointwise equality *)
Print idfun. (** the identity function *)
Locate "∘". (** exchanges the arguments of [funcomp] *)
Print funcomp.
(** plain function composition in diagrammatic order, i.e.,
    first the first argument, then the second argument;
    the second argument may even have a dependent type *)

Context (A B: UU).
(** makes good sense in a section, can be put in curly braces to indicate
    they will be implicit arguments for every construction in the section *)

Definition interestingstatement : UU :=
  ∏ (v w : A → B) (v' w' : B → A),
  w ∘ w' ~ idfun B → v' ∘ v ~ idfun A → v' ~ w' → v ~ w.

Check (isinjinvmap': interestingstatement).

Lemma ourisinjinvmap': interestingstatement.
Proof.
  intros. (** is a nop since the formula structure is not analyzed *)
  unfold interestingstatement. (** [unfold] unfolds a definition *)
  intros ? ? ? ? homoth1 homoth2 hyp a.
  (** the extra element [a] triggers Coq to unfold the formula further;
      [unfold interestingstatement] was there only for illustration! *)

  (** we want to use transitivity that is expressed by [pathscomp0] and
      instruct Coq to take a specific intermediate term *)
Print Ltac intermediate_path. (** not telling because implicit arg. is not shown *)
  intermediate_path (w (w' (v a))).
  - apply pathsinv0. (** apply symmetry of equality *)
    unfold homot in homoth1.
    unfold funcomp in homoth1.
    unfold idfun in homoth1.
    apply homoth1. (** all the [unfold] were only for illustration! *)
  -
    Print maponpaths.
    apply maponpaths.
    unfold homot in hyp.
    (** we use the equation in [hyp] from right to left, i.e., backwards: *)
    rewrite <- hyp.
    (** remark: for a forward rewrite, use [rewrite] without directional
        argument *)
    (** beautify the current goal: *)
    change ((v' ∘ v) a = idfun A a).
    (** just for illustration of [change] that allows to replace the goal
        by a convertible expression; also works for hypotheses, e.g.: *)
    change (v' ~ w') in hyp.
    (** since [hyp] was no longer necessary, we should rather have deleted it: *)
    clear hyp.
    apply homoth2.
Defined.

Context (v w: A -> B) (v' w': B → A).

Eval compute in (ourisinjinvmap' v w v' w').

Opaque ourisinjinvmap'.
Eval compute in (ourisinjinvmap' v w v' w').
(** [Opaque] made the definition opaque in the sense that the identifier
    is still in the symbol table, together with its type, but that it does
    not evaluate to anything but itself.

    If inhabitants of a type are irrelevant (for example if it is known
    that there is at most one inhabitant, and if one therefore is not interested
    in computing with that inhabitant), then opaqueness is an asset to make
    the subsequent proof process lighter.

    [Opaque] can be undone with [Transparent]:
 *)
Transparent ourisinjinvmap'.
Eval compute in (ourisinjinvmap' v w v' w').

(** If one uses [Compute] in place of [Eval compute in], then [Opaque] has no effect. *)

(** Full and irreversible opaqueness is obtained for a construction
    in interactive mode by completing it with [Qed.] in place of [Defined.]

    Using [Qed.] is discouraged by the UniMath style guide. In Coq,
    most lemmas, theorems, etc. (nearly every assertion in [Prop]) are
    made opaque in this way. In UniMath, many lemmas enter subsequent
    computation, and one should have good reasons for not closing an
    interactive construction with [Defined.]. More than 5kloc of the UniMath
    library have [Qed.], so these good reasons do exist and are not rare.
*)

End homot.
Check ourisinjinvmap'.
(** The section parameters [A] and [B] are abstracted away after the end
    of the section - only the relevant ones. *)

(** [assert] is a "chameleon" w.r.t. to opaqueness: *)
Definition combinatorS_curried_with_assert2 (A B C: UU):
  (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
  intros H1 H2 H3.
  assert (proofofB : B).
  { apply H2.
    assumption.
  }
  (** [proofofB] is just an identifier and not associated to the
      construction we gave. Hence, the proof is opaque for us. *)
  apply H1.
  - assumption.
  - assumption.
Defined.
Print combinatorS_curried_with_assert2.
(** We see that [proofofB] is there with its definition, so it is
    transparent.

    See much further below for [transparent assert] that is like
    [assert], but consistently transparent.
*)

(** ** composing tactics *)

(** Up to now, we "composed" tactics in two ways: we gave them sequentially,
    separated by periods, or we introduced a tree structure through the
    "bullet" notation. We did not think of these operations as composition
    of tactics, in particular since we had to trigger each of them separately
    in interactive mode. However, we can also explicitly compose them, like so:
 *)
Definition combinatorS_induction_in_one_step (A B C: UU):
  (A × B -> C) × (A -> B) × A -> C.
Proof.
  intro Hyp123;
  induction Hyp123 as [Hyp1 Hyp23];
  apply Hyp1;
  induction Hyp23 as [Hyp2 Hyp3];
  split;
  [ assumption
  | apply Hyp2;
    assumption].
Defined.

(** The sequential composition is written by (infix) semicolon,
    and the two branches reated by [split] are treated in the
    |-separated list of arguments to the brackets. *)

(** Why would we want to do such compositions? There are at least four good reasons:

    (1) We indicate that the intermediate results are irrelevant for someone who
        executes the script so as to understand how and why the construction /
        the proof works.

    (2) The same tactic (expression) can uniformly treat all sub-goals stemming
        from the preceding tactic application, as will be shown next.
 *)
Definition combinatorS_curried_with_assert_in_one_step (A B C: UU):
  (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
  intros H1 H2 H3;
  assert (proofofB : B) by
  ( apply H2;
    assumption
  );
  apply H1;
  assumption.
Defined.

(** This illustrates the grouping of tactic expressions by parentheses, the variant
    [assert by] of [assert] used when only one tactic expression forms the proof of
    the assertion, and also point (2): the last line is simpler than the expected line
[[
[assumption | assumption].
]]
*)

(** Why would we want to do such compositions (cont'd)?

    (3) We want to capture recurring patterns of construction / proof by tactics into
        reusable Ltac definitions, see below.

    (4) We want to make use of the [abstract] facility, explained now.
 *)

Definition combinatorS_induction_with_abstract (A B C: UU):
  (A × B -> C) × (A -> B) × A -> C.
Proof.
  intro Hyp123;
  induction Hyp123 as [Hyp1 Hyp23];
  apply Hyp1;
  induction Hyp23 as [Hyp2 Hyp3].
  (** Now imagine that the following proof was very complicated but had no computational
      relevance, i.e., could also be packed into a lemma whose proof would be finished
      by [Qed]. We can encapsulate it into [abstract]: *)
  abstract (split;
  [ assumption
  | apply Hyp2;
    assumption]).
Defined.

Print combinatorS_induction_with_abstract.
(** The term features an occurrence of [combinatorS_induction_with_abstract_subproof]
    that contains the abstracted part; using the latter name is forbidden by the
    UniMath style guide. Note that [abstract] is used hundreds of times in the
    UniMath library. *)

(** *** Ltac language for defining tactics *)

(** Disclaimer: Ltac can do more than that, in fact Ltac is the name of the
    whole tactic language of Coq. *)

(** Ltac definitions can associate identifiers for tactics with tactic expressions.

    We have already used one such identifier: [intermediate_path] in the [Foundations]
    package of UniMath. In file [PartA.v], we have the code
[[
Ltac intermediate_path x := apply (pathscomp0 (b := x)).
]]
*)
Print Ltac intermediate_path.
(** does not show the formal argument [x] in the right-hand side.
    Remedy (in ProofGeneral but not in VSCode): *)
Set Printing All.
Print Ltac intermediate_path.
Unset Printing All.
(** The problem with these Ltac definitions is that they are barely typed, they
    behave rather like LaTeX macros. *)
Local Ltac intermediate_path_wrong x := apply (pathscomp0 (X := x)(b := x)).
(** This definition confounds the type argument [X] and its element [b].
    The soundness of Coq is not at stake here, but the errors only appear
    at runtime, as we will see below. Normal printing output hides the difference
    with the correct tactic definition: *)
Print Ltac intermediate_path_wrong.

Section homot2.
Context (A B : UU).

Lemma ourisinjinvmap'_failed_proof: interestingstatement A B.
  Proof.
  intros ? ? ? ? homoth1 homoth2 hyp a.
  Fail intermediate_path_wrong (w (w' (v a))).
  (** The message does not point to the problem that argument [x] appears
      a second time in the Ltac definition with a different needed type. *)
Abort.
End homot2.
(** See ##[https://github.com/UniMath/UniMath/blob/master/UniMath/PAdics/frac.v#L23]##
    for a huge Ltac definition in the UniMath library to appreciate the lack
    of type information. *)

(** The UniMath library provides some Ltac definitions for general use: *)
Print Ltac etrans. (** no need to explain - rather an abbreviation *)
Set Printing All.
Print Ltac intermediate_weq. (** problem with VSCode analogous to [intermediate_path] *)
Unset Printing All.

(** for the next tactic *)
Require Import UniMath.MoreFoundations.Tactics.

Set Printing All.
Print Ltac show_id_type.
(** output with ProofGeneral (output with VSCode falls again short of crucial information)
[[
Ltac show_id_type :=
       match goal with
       | |- @paths ?ID _ _ => set (TYPE := ID); simpl in TYPE
       end
]]
Hardly ever present in proofs in the library, but it can be an excellent tool
while trying to prove an equation: it puts the index of the path space
into the context. This index is invisible in the notation with an equals
sign that one normally sees as the goal, and coercions can easily give a wrong
impression about that index. *)
Unset Printing All.

(** **** The most useful Ltac definition of UniMath *)
Print Ltac simple_rapply.
(** It applies the [simple refine] tactic with zero up to fifteen unknown
    arguments. *)

(** This tactic must not be used in UniMath since a "tactic notation"
    is favoured: [Foundations/Preamble.v] contains the definition
[[
Tactic Notation "use" uconstr(p) := simple_rapply p.
]]

Use of [use]:
*)
Lemma sumex_with_use (A: UU) (P Q: A -> UU):
  (∑ x:A, P x × Q x) -> (∑ x:A, P x) × ∑ x:A, Q x.
Proof.
  intro H; induction H as [x H']; induction H' as [H1 H2].
  split.
  - use tpair.
    + assumption.
    + cbn. (** this is often necessary since [use] does as little as possible *)
      assumption.
  - (** to remind the version where the "witness" is given explicitly: *)
    exists x; assumption.
Defined.
(** To conclude: [use tpair] is the right idiom for an interactive
    construction of inhabitants of Σ-types. Note that the second
    generated sub-goal may need [cbn] to make further tactics
    applicable.

    If the first component of the inhabitant is already at hand,
    then the "exists" tactic yields a leaner proof script.

    [use] is not confined to Σ-types. Whenever one would be
    inclined to start trying to apply a lemma [H] with a varying
    number of underscores, [use H] may be a better option.
*)

(** There is another recommendable tactic notation that is also by
    Jason Gross:
[[
Tactic Notation "transparent" "assert"
                "(" ident(name) ":" constr(type) ")" :=
                simple refine (let name := (_ : type) in _).
]]
*)
Definition combinatorS_curried_with_transparent_assert (A B C: UU):
  (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
  intros H1 H2 H3.
  transparent assert (proofofB : B).
  { apply H2; assumption. } (** There is no [transparent assert by]. *)

  (** Now, [proofB] is present with the constructed proof of [B]. *)
Abort.
(** To conclude: [transparent assert] is a replacement for [assert]
    if the construction of the assertion is needed in the rest of
    the proof.
*)

(** ** a final word, just on searching the library *)

(** [SearchPattern] searches for the given pattern in what the library
    gives as *conclusions* of definitions, lemmas, etc., and the current
    hypotheses.

    [Search] searches in the (full) types of all the library elements (and
    the current hypotheses). It may provide too many irrelevant result
    for your question. At least, it will also show all the relevant ones.

    Anyway, only the imported part of the library is searched. The quick
    way for importing the whole UniMath library is
[[
Require Import UniMath.All.
]]
You may test it with
[[
SearchPattern (_ ≃ _).
]]
with very numerous results.
*)

(** ** List of tactics that were mentioned *)
(**
[[
exact
apply
intro
set
cbn / cbn in (old but sometimes useful form: simpl / simpl in)
assumption
intros (with pattern, with wild cards)
split / split with / exists
destruct as --- not desirable in UniMath
induction / induction as
admit --- only during proof development
eapply
eexact
refine --- first consider "use" instead
instantiate
unfold / unfold in
intermediate_path (Ltac def.)
rewrite / rewrite <-
change / change in
clear
assert {} / assert by
abstract
etrans (Ltac def.)
intermediate_weq (Ltac def.)
show_id_type (Ltac def.)
simple_rapply (Ltac def., not to be used)
use (Ltac notation)
transparent assert (Ltac notation)
]]
*)

(* End of file *)


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                   Solange Coupet-Grimal & Line Jakubiec                  *)
(*                                                                          *)
(*                                                                          *)
(*              Laboratoire d'Informatique de Marseille                     *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lim.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              May 30th 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                            Factorization.v                               *)
(****************************************************************************)

Require Export Numerals.

Section factorization.

   Variable A : Set.
   Variable BASE : BT.
   Let b := base BASE.
   Let Num := num BASE.
   Let Digit := digit BASE.
   Let Tl := tl Digit.

   Let Cons := cons Digit.
   Let Nil := nil Digit.
   Let Val_bound := val_bound BASE.

 Section Definitions_for_Relations.

   Definition Diveucl (a b q r : nat) : Prop := a = b * q + r /\ r < b.
   Definition Zero : inf 1 := Val_bound 0 Nil.

   Variable R : forall n : nat, A -> inf n -> inf n -> A -> Prop.

   Definition factorizable : Prop :=
     forall (m n : nat) (q q' : inf m) (r r' : inf n)
       (a a1 a' : A) (x x' : inf (m * n)),
     Diveucl (val_inf (m * n) x) n (val_inf m q) (val_inf n r) ->
     Diveucl (val_inf (m * n) x') n (val_inf m q') (val_inf n r') ->
     R m a q q' a1 -> R n a1 r r' a' -> R (m * n) a x x' a'.

    Definition proper : Prop := forall a : A, R 1 a Zero Zero a.

 End Definitions_for_Relations.

 Section Three_inputs.

  Variable FR : forall n : nat, A -> inf n -> inf n -> A.

  Let R (n : nat) (a : A) (x y : inf n) (a' : A) : Prop := a' = FR n a x y.

  Lemma prop_Rel :
   proper R ->
   forall (X Y : Num 0) (a : A), R 1 a (Val_bound 0 X) (Val_bound 0 Y) a.
  intros P X Y a.
  replace X with (nil (digit BASE)); auto with arith.
  replace Y with (nil (digit BASE)); auto with arith.
  Qed.

   Lemma fact_Rel :
    factorizable R ->
    forall (n : nat) (X Y : Num (S n)) (a a' : A),
    R (exp b n) (FR b a (Hd Digit n X) (Hd Digit n Y))
      (Val_bound n (Tl (S n) X)) (Val_bound n (Tl (S n) Y)) a' ->
    R (exp b (S n)) a (Val_bound (S n) X) (Val_bound (S n) Y) a'.

  intros F n X Y a a' H.
  simpl in |- *.
  generalize (non_empty (inf b) n X).
  generalize (non_empty (inf b) n Y).
  intros H1 H2.
  elim H1; elim H2; clear H1 H2.
  intros d D d' D'.
  elim D; elim D'; clear D D'.
  intros D' HD' D HD.
  rewrite HD; rewrite HD'.
  apply
   F
    with
      d
      d'
      (Val_bound n (Tl (S n) X))
      (Val_bound n (Tl (S n) Y))
      (FR b a (Hd Digit n X) (Hd Digit n Y)).
  unfold Diveucl in |- *; split; simpl in |- *.
  rewrite HD; simpl in |- *.
  elim (mult_comm (val_inf b d) (exp b n)); auto with arith.
  rewrite HD; simpl in |- *.
  unfold b in |- *; apply upper_bound.
  unfold Diveucl in |- *; split; simpl in |- *.
  rewrite HD'; simpl in |- *.
  elim (mult_comm (val_inf b d') (exp b n)); auto with arith.
  rewrite HD'; simpl in |- *.
  unfold b in |- *; apply upper_bound.
  unfold R in |- *.
  rewrite HD; rewrite HD'.
  rewrite Non_empty_Hd; rewrite Non_empty_Hd; auto with arith.
  try trivial with arith.
  Qed.

 End Three_inputs.

End factorization.

(*************************************************************************************)


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.Instance.Coq.Category.
Require Import CT.Instance.Functor.Endofunctor.
Require Import FunctionalExtensionality List.

(** List functor. Just for grins. :) *)
Program Definition CoqListFunctor : @Endofunctor CoqType :=
  {| F_ob := list : @ob CoqType -> @ob CoqType;
     F_mor := map
  |}.
Next Obligation.
Proof.
  extensionality x.
  induction x.
  - simpl. reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.
Next Obligation.
  extensionality x.
  induction x.
  - simpl. reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

(** Option functor. Just for grins. :) *)
Program Definition CoqOptionFunctor : @Endofunctor CoqType :=
  {| F_ob := option : @ob CoqType -> @ob CoqType;
     F_mor := option_map
  |}.
Next Obligation.
Proof.
  extensionality x.
  destruct x.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.
Next Obligation.
Proof.
  extensionality x.
  destruct x.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.


(**
This file is part of the Elfic library

Copyright (C) Boldo, Clément, Leclerc

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(*
A formalisation of series with values in a complete normed module space in Coq.
This formalisation use the Coquelicot library.
*)

From Coq Require Import
    ssreflect
    Utf8
    Psatz

    Reals
.

From Coquelicot Require Import
    Hierarchy
    Lim_seq
.

Definition is_lim_seq {A : AbsRing} {E : NormedModule A}
    (u : nat -> E) (l : E) : Prop :=
        filterlim u eventually (locally l).

Definition convergent_seq {A : AbsRing} {E : NormedModule A}
    (u : nat -> E) : Prop :=
        ∃ l : E, is_lim_seq u l.

Definition serie {A : AbsRing} {E : NormedModule A}
    (u : nat -> E) : nat -> E :=
        (fun n => sum_n u n) : nat -> E.

Definition convergent_serie {A : AbsRing} {E : NormedModule A}
    (u : nat -> E) : Prop :=
        convergent_seq (serie u).

Section normal_convergence.

    Open Scope R_scope.

    Definition upper_bounded_by (M : R) (u : nat -> R) : Prop :=
        ∀ n : nat, (u n) <= M.

    Definition upper_bounded (u : nat -> R) : Prop :=
        ∃ M : R, (upper_bounded_by M u).

    Definition normally_bounded_serie {A : AbsRing} {E : NormedModule A}
        (u : nat -> E) : Prop :=
            upper_bounded (serie (fun n => norm (u n))).

    Definition normally_convergent_serie {A : AbsRing} {E : NormedModule A}
        (u : nat -> E) : Prop :=
            ex_finite_lim_seq (serie (fun n => norm (u n))).

    Lemma normally_bounded_serie_is_normally_convergent_serie
        {A : AbsRing} {E : NormedModule A} :
            ∀ u : nat -> E,
                normally_bounded_serie u -> normally_convergent_serie u.
    Proof.
        unfold normally_bounded_serie, normally_convergent_serie => u.
        case => M HM; unfold upper_bounded_by in HM.
        apply (ex_finite_lim_seq_incr _ M).
        (* on donne la croissance d'une série à terme positif *)
            move => n.
            unfold serie, sum_n.
            rewrite sum_n_Sm. 2 : apply Peano.le_0_n.
            assert (plus = Rplus) as HR by compute => //.
            rewrite HR.
            assert (0 <= (norm (u (S n)))) as PosNorm by apply norm_ge_0.
            replace (sum_n_m (λ n0 : nat, norm (u n0)) 0 n) with (plus (sum_n_m (λ n0 : nat, norm (u n0)) 0 n) 0) at 1.
            all : try rewrite HR; try lra.
            apply Rplus_le_compat => //.
            constructor 2 => //.
        assumption.
    Qed.

End normal_convergence.


Require Export P06.

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
	exact FILL_IN_HERE. Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2005-06-17

general results on booleans
*)

Set Implicit Arguments.

Require Import LogicUtil.
Require Export Bool.
Require Setoid.

Implicit Arguments orb_false_elim [b1 b2].
Implicit Arguments orb_true_elim [b1 b2].

Hint Rewrite negb_orb negb_andb negb_involutive eqb_negb1 eqb_negb2
  orb_true_r orb_true_l orb_false_r orb_false_l orb_negb_r orb_assoc
  andb_false_r andb_false_l andb_true_r andb_true_l andb_negb_r andb_assoc
  absoption_andb absoption_orb
  xorb_false_r xorb_false_l xorb_nilpotent xorb_assoc_reverse
  : bool.

Ltac bool := autorewrite with bool.

(***********************************************************************)
(** equality *)

Lemma false_not_true : forall b, b = false <-> ~(b = true).

Proof. destruct b; intuition. Qed.

Lemma beq_true : forall b c, b = c <-> (b = true <-> c = true).

Proof.
  split; intro h. subst. tauto. destruct c.
  tauto. rewrite false_not_true. intuition.
Qed.

(***********************************************************************)
(** implication *)

Lemma implb1 : forall b, implb b b = true.

Proof. induction b; refl. Qed.

Lemma implb2 : forall b, implb b true = true.

Proof. induction b; refl. Qed.

(***********************************************************************)
(** conjunction *)

Lemma andb_elim : forall b c, b && c = true -> b = true /\ c = true.

Proof. destruct b; destruct c; intuition. Qed.

Implicit Arguments andb_elim [b c].

Lemma andb_eliml : forall b c, b && c = true -> b = true.

Proof. destruct b; destruct c; intuition. Qed.

Implicit Arguments andb_eliml [b c].

Lemma andb_elimr : forall b c, b && c = true -> c = true.

Proof. destruct b; destruct c; intuition. Qed.

Implicit Arguments andb_elimr [b c].

Lemma andb_intro : forall b c, b = true -> c = true -> b && c = true.

Proof. intros. subst b. subst c. refl. Qed.

Lemma andb_eq : forall b c, b && c = true <-> b = true /\ c = true.

Proof. split. intro. apply andb_elim. hyp. intuition. Qed.

Lemma andb_eq_false : forall b c, b && c = false <-> b = false \/ c = false.

Proof. destruct b; destruct c; bool; intuition. Qed.

(***********************************************************************)
(** negation *)

Definition neg (A : Type) (f : A->A->bool) x y := negb (f x y).

Lemma negb_lr : forall b c, negb b = c <-> b = negb c.

Proof. destruct b; destruct c; intuition. Qed.

(***********************************************************************)
(** disjonction *)

Lemma orb_intror : forall b c, c = true -> b || c = true.

Proof. intros. subst. bool. refl. Qed.

Lemma orb_introl : forall b c, c = true -> b || c = true.

Proof. intros. subst. bool. refl. Qed.

Lemma orb_eq : forall b c, b || c = true <-> b = true \/ c = true.

Proof. intuition. destruct b; auto. Qed.

(***********************************************************************)
(** equality *)

Lemma eqb_equiv : forall b b', b = b' <-> (b = true <-> b' = true).

Proof.
  intros b b'. split; intro H. subst b'. refl.
  destruct b. sym. rewrite <- H. refl.
  destruct b'. rewrite H. refl. refl.
Qed.

(***********************************************************************)
(** decidability *)

Require Setoid.

Section dec.

  Variables (A : Type) (P : A -> Prop)
    (f : A -> bool) (f_ok : forall x, f x = true <-> P x).

  Lemma ko : forall x, f x = false <-> ~P x.

  Proof. intro x. rewrite <- f_ok. destruct (f x); intuition; discr. Qed.

  Lemma dec : forall x, {P x}+{~P x}.

  Proof.
    intro x. case_eq (f x); intros.
    left. rewrite <- f_ok. hyp. right. rewrite <- ko. hyp.
  Defined.

End dec.

Implicit Arguments ko [A P f].
Implicit Arguments dec [A P f].

(***********************************************************************)
(** correspondance between boolean functions and logical connectors *)

Section bool_ok.

  Variables (A : Type) (P Q : A->Prop) (bP bQ : A-> bool)
    (bP_ok : forall x, bP x = true <-> P x)
    (bQ_ok : forall x, bQ x = true <-> Q x).

  Lemma negb_ok : forall x, negb (bP x) = true <-> ~P x.

  Proof. intro. rewrite <- (ko bP_ok). destruct (bP x); simpl; intuition. Qed.

  Lemma andb_ok : forall x, bP x && bQ x = true <-> P x /\ Q x.

  Proof. intro. rewrite andb_eq. rewrite bP_ok. rewrite bQ_ok. refl. Qed.

  Lemma orb_ok : forall x, bP x || bQ x = true <-> P x \/ Q x.

  Proof. intro. rewrite orb_eq. rewrite bP_ok. rewrite bQ_ok. refl. Qed.

  Lemma implb_ok : forall x, implb (bP x) (bQ x) = true <-> (P x -> Q x).

  Proof.
    intro x. unfold implb. case_eq (bP x).
    rewrite bP_ok. rewrite bQ_ok. tauto.
    rewrite (ko bP_ok). tauto.
  Qed.

End bool_ok.

(***********************************************************************)
(** checking a property (P i) for all i<n *)

Require Import Arith.
Require Omega.

Section bforall_lt.

  Variables (P : nat->Prop) (bP : nat->bool)
    (bP_ok : forall x, bP x = true <-> P x).

  Definition forall_lt n := forall i, i < n -> P i.

  Fixpoint bforall_lt_aux b n := b &&
    match n with
      | 0 => true
      | S n' => bforall_lt_aux (bP n') n'
    end.

  Lemma bforall_lt_aux_ok : forall n b,
    bforall_lt_aux b n = true <-> b = true /\ forall_lt n.

  Proof.
    unfold forall_lt. induction n; simpl; intros. bool. fo.
    rewrite andb_eq. rewrite IHn. rewrite bP_ok. intuition.
    destruct (eq_nat_dec i n). subst. hyp. apply H2. omega.
  Qed.

  Definition bforall_lt := bforall_lt_aux true.

  Lemma bforall_lt_ok : forall n, bforall_lt n = true <-> forall_lt n.

  Proof. intro. unfold bforall_lt. rewrite bforall_lt_aux_ok. tauto. Qed.

End bforall_lt.


CoInductive stream (A : Set) : Set :=
  | cons : A -> stream A -> stream A.
Arguments cons {_} hd tl.

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

Definition head {A} (x : stream A) := match x with
  hd :: _ => hd end.
Definition tail {A} (x : stream A) := match x with
  _ :: tl => tl end.

CoInductive bisim {A : Set} (x y : stream A) : Set :=
  | bisim_eq : head x = head y -> bisim (tail x) (tail y) -> bisim x y.
Notation "x == y" := (bisim x y) (at level 70).

Module Introduction.

  (* Infinite sequence of ones. (not tested) *)
  CoFixpoint ones : stream nat := 1 :: ones.

  (* Infinite sequence of given value. *)
  CoFixpoint repeat {A : Set} (a : A) : stream A.
    constructor.
    assumption.
    auto.
  Defined.

  CoFixpoint even {A : Set} (x : stream A) : stream A.
    destruct x.
    constructor.
    assumption.
    apply even.
    destruct x.
    assumption.
  Defined.

  (* Elements at even and odd indexes, respectively. *)
  Definition odd {A : Set} (x : stream A) : stream A.
    destruct x.
    apply even.
    assumption.
  Defined.

  (* A stream equals its head plus its tail. (not tested) *)
  Lemma stream_unfold : forall {A : Set} (a : stream A), a = head a :: tail a.
  Proof. intros A a. destruct a. reflexivity. Qed.

End Introduction.

Module Bisimulation.

  Export Introduction.

  (* Bisimulation is reflexive. *)
  Theorem bisim_refl : forall {A : Set} (a : stream A), a == a.
  Proof.
    cofix H.
    intros.
    constructor.
    easy.
    auto.
  Defined.

Hint Resolve bisim_refl.

  (* Odd is tail of Even. *)
  (* Hint: Do you really need cofix? It may depend on your own definition of odd and even. *)
  Theorem odd_even : forall {A : Set} (x : stream A), odd x == even (tail x).
  Proof.
    intros.
    constructor.
    destruct x.
    simpl.
    easy.
    destruct x.
    simpl.
    auto.
  Defined.

End Bisimulation.

Module Merge.

  Export Bisimulation.

  (* Interleave two streams, starting with the left one. *)
  CoFixpoint merge {A : Set} (x y : stream A) : stream A.
    destruct x, y.
    constructor.
    exact a.
    constructor.
    exact a0.
    apply (merge _ x y).
  Defined.

  (* Main task: Merge even and odd, and get the original. *)
  Theorem moe : forall {A : Set} (a : stream A), merge (even a) (odd a) == a.
  Proof.
    cofix moe.
    intros.
    constructor.
    rewrite (stream_unfold (a)).
    simpl.
    rewrite (stream_unfold (tail a)).
    easy.
    constructor.
    rewrite (stream_unfold (a)).
    simpl.
    rewrite (stream_unfold (tail a)).
    simpl.
    easy.
    simpl.
    rewrite (stream_unfold (a)).
    simpl.
    rewrite (stream_unfold (tail a)).
    simpl.
    pose proof (moe A (tail (tail a))).
    rewrite (stream_unfold (tail (tail a))) in *.
    simpl.
    exact H.
  Defined.
End Merge.


Require Import Coq.omega.Omega.
Set Implicit Arguments.

Require Import Bedrock.Platform.AutoSep Coq.Arith.Arith.

(* usuful and safe hints *)
Local Hint Resolve bound_N_nat : N.
Hint Rewrite Npow2_nat : N.
Hint Rewrite natToWord_wordToNat : N.

(* ============================================================================
 * word to nat
 * ========================================================================= *)

Theorem wordToNat_inj : forall sz (x y:word sz),
                          wordToNat x = wordToNat y -> x = y.
  intros.
  apply (f_equal (natToWord sz)) in H.
  autorewrite with N in *.
  assumption.
Qed.

Theorem wordToNat_inj' : forall sz (x y:word sz), x <> y ->
                                                  wordToNat x <> wordToNat y.
  intros.
  contradict H.
  apply wordToNat_inj; assumption.
Qed.

(* ============================================================================
 * nat to word
 * ========================================================================= *)

Lemma natToWord_pow2' : forall(sz k:nat)(w:word sz),
                          natToWord sz (k * pow2 sz) ^+ w = w.
  induction k; intros; simpl.

  apply wplus_unit.

  rewrite natToWord_plus.
  rewrite <- wplus_assoc.
  rewrite natToWord_pow2.
  rewrite wplus_unit.
  apply IHk.
Qed.

Lemma natToWord_pow2_zero: forall sz n, $ (n * pow2 sz) = natToWord sz 0.
  intros.
  rewrite <- (wplus_unit $ (n * pow2 sz)).
  rewrite wplus_comm.
  apply natToWord_pow2'.
Qed.

Lemma natToWord_pow2_factor : forall (sz:nat)(w:word sz), exists n, forall k,
                                                                      (n < pow2 sz)%nat /\ w = natToWord sz (k * pow2 sz + n).
  intros.
  exists (wordToNat w).
  intro.
  split.
  apply (wordToNat_bound w).
  rewrite natToWord_plus.
  rewrite natToWord_pow2'.
  rewrite natToWord_wordToNat.
  reflexivity.
Qed.

Corollary word_eq_natToWord : forall (sz:nat)(w:word sz), exists n,
                                (n < pow2 sz)%nat /\ w = natToWord sz n.
intros.
generalize natToWord_pow2_factor; intro.
specialize (H sz w).
destruct H.
specialize (H 0).
destruct H.
simpl in H0.
exists x; auto.
Qed.

Lemma natToWord_inj' : forall sz a b, goodSize a -> goodSize b
                                      -> natToWord sz a <> $ b
                                      -> a <> b.
  intros; intro; subst; congruence.
Qed.

(* ============================================================================
 * nat to W
 * ========================================================================= *)

Transparent goodSize.

Lemma goodSize_natToW_wlt_lt : forall n m:nat, goodSize n -> goodSize m ->
                                               natToW n < natToW m -> (n < m)%nat.
  unfold goodSize, natToW.
  generalize dependent 32; intros; nomega.
Qed.

Corollary W_eq_natToW : forall(w:W), exists n, goodSize n /\ w = natToW n.
intros.
generalize word_eq_natToWord; intro.
specialize (H 32 w).
destruct H.
destruct H.
exists x.
unfold goodSize.
split; auto.
Qed.

Opaque goodSize.

Lemma wneg_natToW_pow2_minus : forall n:nat, goodSize n ->
                                             ^~ (natToW n) = natToW (pow2 32 - n).
  unfold wneg; intros.
  rewrite NToWord_nat.
  autorewrite with N; reflexivity.
Qed.

Lemma natToW_plus_pow2 : forall n : nat, natToW (pow2 32 + n) = $ n.
  unfold natToW; intros.
  rewrite natToWord_plus.
  rewrite natToWord_pow2.
  words.
Qed.

(* ============================================================================
 * destruct_word
   Turn word arithmetic into nat arithmetic.
 * ========================================================================= *)

Ltac destruct_word sz w n :=
  let H := fresh "W" in
  let Hub := fresh "Wub" in
  let Heq := fresh "Weq" in
  assert (H:exists w', (w' < pow2 sz)%nat /\ w = natToWord sz w') by
      apply word_eq_natToWord;
    elim H; clear H; intros n H; elim H; intros Hub Heq; rewrite Heq in *; clear H Heq w.

Ltac destruct_W w n :=
  let H := fresh "W" in
  let Hub := fresh "Wub" in
  let Heq := fresh "Weq" in
  assert (H:exists w', goodSize w' /\ w = natToW w') by
      apply W_eq_natToW;
    elim H; clear H; intros n H; elim H; intros Hub Heq; rewrite Heq in *; clear H Heq w.

Ltac destruct_words := repeat
                         match goal with
                           | w : W |- context[?w] =>
                             is_var w; let w' := fresh "w" in destruct_W w w'
                           | w : word 32 |- context[?w] =>
                             is_var w; let w' := fresh "w" in destruct_W w w'
                           | w : word ?sz |- context[?w] =>
                             is_var w; let w' := fresh "w" in destruct_word sz w w'
                         end.

(* ============================================================================
 * goodsize tactic
 * ========================================================================= *)

Ltac goodsize :=
  match goal with
    | |- (_ < pow2 32)%nat => apply goodSize_danger
    | _ => idtac
  end;
  match goal with
    | [ H: goodSize _ |- goodSize _ ]
      => solve [apply (goodSize_weaken _ _ H); auto; omega]
    | |- goodSize _ => solve [auto]
    | _ => omega
  end.

(* ============================================================================
 * roundTrip-related lemmas and roundtrip tactic
 * ========================================================================= *)

Corollary wordToNat_natToWord_idempotent_W : forall n,
                                               goodSize n ->
                                               wordToNat (natToW n) = n.
intros; apply wordToNat_natToWord_idempotent; auto.
Qed.
Hint Rewrite wordToNat_natToWord_idempotent_W using solve [goodsize] : N.

Corollary roundTrip : forall sz n : nat,
                        (n < pow2 sz)%nat -> wordToNat (natToWord sz n) = n.
intros; apply wordToNat_natToWord_idempotent; nomega.
Qed.
Hint Rewrite roundTrip using solve [eauto] : N.

Lemma natToW_wordToNat : forall w:W, natToW (wordToNat w) = w.
  intros; rewrite <- natToWord_wordToNat; auto.
Qed.
Hint Rewrite natToW_wordToNat : N.

Lemma wordToNat_wplus' : forall sz (x y: word sz),
                           (wordToNat x + wordToNat y < pow2 sz)%nat
                           -> wordToNat (x ^+ y) = wordToNat x + wordToNat y.
  intros.
  destruct_words.
  rewrite <- natToWord_plus.
  rewrite roundTrip; auto.
  pre_nomega; auto.
  rewrite wordToNat_natToWord_idempotent in * by nomega.
  rewrite wordToNat_natToWord_idempotent in * by nomega.
  auto.
Qed.

Corollary wordToNat_wplus'' : forall sz (x y: nat), (x + y < pow2 sz)%nat
                                                    -> wordToNat ($ x ^+ natToWord sz y) = x + y.
intros.
rewrite wordToNat_wplus' by nomega.
rewrite ! roundTrip; auto.
Qed.

Corollary wordToNat_wminus'' : forall sz (x y: nat), (x < pow2 sz)%nat
                                                     -> (y <= x)%nat
                                                     -> wordToNat ($ x ^- natToWord sz y) = x - y.
intros.
rewrite wordToNat_wminus by nomega.
rewrite ! roundTrip; auto.
Qed.

Lemma mult_S : forall x y, (x <= x * S y)%nat.
  intros; rewrite mult_comm; simpl; apply le_plus_l.
Qed.
Local Hint Resolve mult_S.

Local Hint Resolve mult_comm.

Corollary wordToNat_wmult_W : forall (x y: nat), goodSize (x * y)%nat
                                                 -> wordToNat (natToW x ^* natToW y) = x * y.
intros.
unfold natToW in *.
destruct x, y; simpl; auto.
assert (wordToNat (natToWord 32 0) = 0).
rewrite roundTrip by goodsize; auto.
rewrite wordToNat_wmult.
unfold natToW in *; rewrite H0; omega.
rewrite H0; simpl; goodsize.

assert (goodSize (S x)) by goodsize.
assert (goodSize (S y)).
{
  apply (goodSize_weaken _ _ H).
  rewrite mult_comm; auto.
}
rewrite wordToNat_wmult.
rewrite ! roundTrip by goodsize; simpl; omega.
rewrite ! roundTrip by goodsize; auto.
Qed.

(* ============================================================================
 * natToWord and operators
 * ========================================================================= *)

Lemma natToWord_mult : forall sz x y, natToWord sz (x * y)
                                      = natToWord _ x ^* natToWord _ y.
  unfold "^*", wordBin; intros.
  pre_nomega.
  rewrite <- Nat2N.inj_mul.
  rewrite NToWord_nat.
  pre_nomega.

  destruct (wordToNat_natToWord' sz x).
  rewrite <- H at 1.
  remember (wordToNat $ (x)) as x'.

  rewrite mult_plus_distr_r.
  rewrite natToWord_plus.
  replace (x0 * pow2 sz * y)%nat with ((x0 * y) * pow2 sz)%nat.
  rewrite natToWord_pow2_zero.
  rewrite <- natToWord_plus.
  rewrite plus_0_r.

  destruct (wordToNat_natToWord' sz y).
  rewrite <- H0 at 1.
  remember (wordToNat $ (y)) as y'.
  rewrite mult_plus_distr_l.
  rewrite natToWord_plus.
  replace (x' * (x1 * pow2 sz))%nat with ((x' * x1) * pow2 sz)%nat by apply mult_assoc_reverse.
  rewrite natToWord_pow2_zero.
  rewrite <- natToWord_plus; auto.

  rewrite 2 mult_assoc_reverse.
  f_equal.
  apply mult_comm.
Qed.

(* ============================================================================
 * simplification tactic
 * ========================================================================= *)

Ltac roundtrip :=
  pre_nomega; unfold natToW in *;
  repeat match goal with
           | _ => rewrite wordToNat_natToWord_idempotent_W in * by goodsize
           | _ => rewrite wordToNat_wminus'' in * by goodsize
           | _ => rewrite wordToNat_wminus in * by nomega
           | _ => rewrite wordToNat_wplus'' in * by goodsize
           | _ => rewrite wordToNat_wplus' in * by goodsize
           | _ => rewrite wordToNat_wmult_W in * by goodsize
           | _ => rewrite wordToNat_wmult in * by goodsize

           | H: _ |- _ => rewrite <- natToW_minus in H by omega; unfold natToW in H
           | H: _ |- _ => rewrite <- natToWord_plus in H
           | H: _ |- _ => rewrite <- natToWord_mult in H
           | H: natToWord ?sz _ = natToWord ?sz _ |- _
             => apply natToWord_inj with sz _ _ in H; try goodsize
           | H: not (natToWord ?sz _ = natToWord ?sz _) |- _
             => apply natToWord_inj' with sz _ _ in H; try goodsize
         end.

(* ============================================================================
 * word equality lemmas
 * ========================================================================= *)

Definition eq_W_dec : forall x y : W, { x = y } + { x <> y }.
  intros.
  destruct (Word.weqb x y) eqn:Heq; [apply weqb_sound in Heq | ]; auto.
  right; intro.
  apply weqb_true_iff in H; congruence.
Qed.

Lemma weqb_false_iff : forall sz (x y : word sz), Word.weqb x y = false <-> x <> y.
  intros.
  split; intros.
  intro Eq; apply weqb_true_iff in Eq; congruence.
  case_eq (Word.weqb x y); intro; auto.
  apply weqb_sound in H0; congruence.
Qed.

Lemma weqb_refl : forall w, weqb w w = true.
  intros; apply weqb_true_iff; auto.
Qed.
Hint Rewrite weqb_refl : N.

Lemma weqb_refl' : forall x y, x = y -> weqb x y = true.
  intros; subst; autorewrite with N; auto.
Qed.
Hint Rewrite weqb_refl' using solve [auto; words] : N.

Lemma weqb_diff : forall w1 w2, w1 <> w2 -> weqb w1 w2 = false.
  intros; apply weqb_false_iff; auto.
Qed.
Hint Rewrite weqb_diff using solve [auto; discriminate] : N.

(* ============================================================================
 * word operators
 * ========================================================================= *)

Lemma wplus_unit_r : forall sz w, w ^+ natToWord sz 0 = w.
  intros; rewrite wplus_comm; rewrite wplus_unit; auto.
Qed.
Hint Rewrite wplus_unit wplus_unit_r : N.

Lemma wminus_unit : forall sz w, w ^- natToWord sz 0 = w.
  intros.
  unfold "^-", "^~".
  roundtrip.
  rewrite N.sub_0_r.
  rewrite NToWord_nat.
  roundtrip.
  rewrite natToWord_pow2.
  autorewrite with N; auto.
Qed.

Lemma wmult_zero : forall w, natToW 0 ^* w = natToW 0.
  auto.
Qed.

Lemma wmult_zero_r : forall w, w ^* natToW 0 = natToW 0.
  intros; roundtrip; rewrite wmult_comm; auto.
Qed.
Hint Rewrite wmult_zero wmult_zero_r : N.

(* ============================================================================
 * natToW and operators
 * ========================================================================= *)

Lemma natToW_S_wminus_1 : forall n, $ (S n) ^- $1 = natToW n.
  unfold natToW; intros.
  replace (S n) with (n + 1) by omega; rewrite natToWord_plus.
  words.
Qed.
Hint Rewrite natToW_S_wminus_1 : N.

(* ============================================================================
 * word inequalities
 * ========================================================================= *)

Lemma wle_wneq_wlt : forall i j:W, i <= j -> i <> j -> i < j.
  intros; destruct_words.
  apply wordToNat_inj' in H0.
  autorewrite with N in *; nomega.
Qed.

Lemma wle_wle_antisym : forall n m:W, n <= m -> m <= n -> n = m.
  intros; destruct_words; f_equal; nomega.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable axiom_betweennessidentity_1 : (forall A B : Universe, ~(betS_ A B A)).
Variable lemma_betweennotequal_2 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_extension_3 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable lemma_3_6b_4 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ A C D) -> betS_ A B D)).
Variable axiom_betweennesssymmetry_5 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_3_5b_6 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A C D)).
Variable cn_equalityreverse_7 : (forall A B : Universe, cong_ A B B A).
Variable lemma_congruencetransitive_8 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable lemma_congruencesymmetric_9 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable cn_sumofparts_10 : (forall A B C E F G : Universe, ((cong_ A B E F /\ (cong_ B C F G /\ (betS_ A B C /\ betS_ E F G))) -> cong_ A C E G)).
Variable cn_congruencereflexive_11 : (forall A B : Universe, cong_ A B A B).
Variable lemma_differenceofparts_12 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (betS_ A B C /\ betS_ Xa Xb Xc))) -> cong_ B C Xb Xc)).
Variable lemma_extensionunique_13 : (forall A B E F : Universe, ((betS_ A B E /\ (betS_ A B F /\ cong_ B E B F)) -> E = F)).
Variable lemma_3_6a_14 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ A C D) -> betS_ B C D)).
Variable axiom_connectivity_15 : (forall A B C D : Universe, ((betS_ A B D /\ (betS_ A C D /\ (~(betS_ A B C) /\ ~(betS_ A C B)))) -> B = C)).

Theorem lemma_outerconnectivity_16 : (forall A B C D : Universe, ((betS_ A B C /\ (betS_ A B D /\ (~(betS_ B C D) /\ ~(betS_ B D C)))) -> C = D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From iris.proofmode Require Import proofmode.
From cap_machine Require Import addr_reg_sample.

(* This file contains definition and lemmas for contiguous address regions *)
(* It is used mainly in specs of programs where it is necessary to assume  *)
(* that some program lies in memory in a contiguous region                 *)

Section Contiguous.

  Inductive contiguous_between : list Addr -> Addr -> Addr -> Prop :=
    | contiguous_between_nil : ∀ a,
        contiguous_between [] a a
    | contiguous_between_cons : ∀ a a' b l,
        (a + 1)%a = Some a' ->
        contiguous_between l a' b ->
        contiguous_between (a :: l) a b.

  Lemma contiguous_between_vacuous l a b :
    contiguous_between l a b →
    (b < a)%a →
    False.
  Proof. induction 1; intros; solve_addr. Qed.

  Lemma contiguous_between_bounds l a b :
    contiguous_between l a b →
    (a <= b)%a.
  Proof.
    intros HH. generalize (contiguous_between_vacuous _ _ _ HH).
    solve_addr.
  Qed.

  Lemma contiguous_between_nil_inv l a b :
    contiguous_between l a b →
    (b <= a)%a →
    l = [].
  Proof.
    induction 1; eauto.
    destruct (Z.eq_dec a b).
    { intros. exfalso.
      eapply (contiguous_between_vacuous l a' b). 2: solve_addr. eauto. }
    { intros. exfalso. eapply contiguous_between_vacuous; eauto. solve_addr. }
  Qed.

  Lemma contiguous_between_cons_inv a b e ai :
    contiguous_between (a :: ai) b e →
    a = b ∧ ∃ a', (a+1)%a = Some a' ∧ contiguous_between ai a' e.
  Proof. inversion 1; eauto. Qed.

  Lemma contiguous_between_cons_inv_first l a a' b :
    contiguous_between (a' :: l) a b →
    a' = a.
  Proof. inversion 1; eauto. Qed.

  Lemma contiguous_between_last (a : list Addr) a0 an ai :
    contiguous_between a a0 an →
    list.last a = Some ai →
    (ai + 1)%a = Some an.
  Proof.
    revert ai. induction 1 as [| * X Y].
    { inversion 1. }
    { destruct l.
      - cbn. inversion 1. inversion Y; subst. auto.
      - eauto. }
  Qed.

  Lemma contiguous_between_middle_to_end (a: list Addr) (a0 an: Addr) i ai k :
    contiguous_between a a0 an →
    a !! i = Some ai →
    i + k = length a →
    (ai + k)%a = Some an.
  Proof.
    intros * Ha. revert i k ai. induction Ha; [done |].
    intros [| i] k ai; cbn.
    { intros. simplify_eq. enough ((a' + length l)%a = Some b) by solve_addr.
      inversion Ha; subst; cbn. solve_addr.
      apply (IHHa 0); eauto. }
    { eauto. }
  Qed.

  Lemma contiguous_between_of_region_addrs_aux l a b n :
    l = finz.seq a n →
    (a + n)%a = Some b →
    contiguous_between l a b.
  Proof.
    revert a b l. induction n.
    { intros. cbn in *. subst l. assert (a = b) as -> by solve_addr.
      constructor. }
    { intros * -> ?. cbn. eapply (contiguous_between_cons _ (a^+1)%a). solve_addr.
      apply IHn; auto. solve_addr. }
  Qed.

  Lemma region_addrs_aux_of_contiguous_between l a b (n:nat) :
    contiguous_between l a b →
    (a + n)%a = Some b →
    l = finz.seq a n.
  Proof.
    revert a b l. induction n.
    { intros. cbn in *.
      apply (contiguous_between_nil_inv l a b); eauto; solve_addr. }
    { intros * Hl Hn. cbn.
      destruct l as [| a' l].
      { inversion Hl; subst. exfalso. solve_addr. }
      { inversion Hl; subst. f_equal. eapply (IHn _ b). 2: solve_addr.
        assert ((a^+1)%a = a'0) as -> by solve_addr. auto. } }
  Qed.

  Lemma contiguous_between_of_region_addrs l a b :
    (a <= b)%a →
    l = finz.seq_between a b →
    contiguous_between l a b.
  Proof.
    intros ? ->. eapply contiguous_between_of_region_addrs_aux; eauto.
    rewrite /finz.dist. solve_addr.
  Qed.

  Lemma contiguous_between_region_addrs a e :
    (a <= e) %a → contiguous_between (finz.seq_between a e) a e.
  Proof. intros; by apply contiguous_between_of_region_addrs. Qed.

  Lemma region_addrs_of_contiguous_between l a b :
    contiguous_between l a b →
    l = finz.seq_between a b.
  Proof.
    intros.
    destruct (Z.le_dec a b).
    { eapply region_addrs_aux_of_contiguous_between; eauto.
      rewrite /finz.dist. solve_addr. }
    { rewrite /finz.seq_between (_: finz.dist a b = 0) /=.
      2: unfold finz.dist; solve_addr.
      eapply contiguous_between_nil_inv; eauto. solve_addr. }
  Qed.

  Lemma contiguous_between_length a i j :
    contiguous_between a i j →
    (i + length a = Some j)%a.
  Proof. induction 1; cbn; solve_addr. Qed.

  Lemma contiguous_between_length_minus a i j :
    contiguous_between a i j →
    (j + - (length a) = Some i)%a.
  Proof. induction 1; cbn; solve_addr. Qed.

  Lemma contiguous_between_middle_bounds (a : list Addr) i (ai a0 an : Addr) :
    contiguous_between a a0 an →
    a !! i = Some ai →
    (a0 <= ai ∧ ai < an)%a.
  Proof.
    intro HH. revert ai i. induction HH as [| * Ha Hc Hi]; [ by inversion 1 |].
    intros * Hi'. destruct i as [| i].
    { cbn in Hi'. inversion Hi'; subst; clear Hi'. split; [ solve_addr |].
      destruct (decide (a' = b)).
      { subst a'. inversion Hc; subst; solve_addr. }
      { apply contiguous_between_length in Hc. solve_addr. } }
    { cbn in Hi'. split. enough (a' <= ai)%a by solve_addr.
      all: eapply Hi; eauto. }
  Qed.

  Lemma contiguous_between_middle_bounds' (a : list Addr) (ai a0 an : Addr) :
    contiguous_between a a0 an →
    ai ∈ a →
    (a0 <= ai ∧ ai < an)%a.
  Proof.
    intros Hc Hin.
    apply elem_of_list_lookup_1 in Hin as [? ?].
    eapply contiguous_between_middle_bounds; eauto.
  Qed.

  Lemma contiguous_between_incr_addr (a: list Addr) (i : nat) a0 ai an :
    contiguous_between a a0 an →
    a !! i = Some ai →
    (a0 + i)%a = Some ai.
  Proof.
    intros Hc. revert i ai. induction Hc.
    - inversion 1.
    - intros i ai. destruct i as [| i].
      { cbn. inversion 1; subst. solve_addr. }
      { cbn. intros Hi. specialize (IHHc _ _ Hi). solve_addr. }
  Qed.

  (* the i'th element is the same as adding i to the first element *)
  Lemma contiguous_between_link_last (a : list Addr) a_first a_last ai :
    contiguous_between a a_first a_last ->
    length a > 0 ->
    (ai + 1)%a = Some a_last -> list.last a = Some ai.
  Proof.
    revert a_first. induction a; intros a_first Ha Hlen Hlink.
    - inversion Hlen.
    - destruct a0.
      + inversion Ha. subst. inversion H4. subst. cbn. solve_addr.
      + simpl in *. apply IHa with f;[|lia|auto].
        inversion Ha; subst.
        apply contiguous_between_cons_inv_first in H4 as Heq.
        congruence.
  Qed.

  Lemma contiguous_between_incr_addr_middle (a : list Addr) a0 an (i j : nat) ai aj :
    contiguous_between a a0 an ->
    a !! i = Some ai -> a !! (i + j) = Some aj -> (ai + j)%a = Some aj.
  Proof.
    intros HH Hi Hj.
    pose proof (contiguous_between_incr_addr _ _ _ _ _ HH Hi).
    pose proof (contiguous_between_incr_addr _ _ _ _ _ HH Hj). solve_addr.
  Qed.

  Lemma contiguous_between_incr_addr_middle' (a : list Addr) a0 an (i : nat) (j: Z) ai aj :
    contiguous_between a a0 an →
    (0 <= i + j < length a)%Z →
    a !! i = Some ai -> a !! (Z.to_nat (i + j)%Z) = Some aj -> (ai + j)%a = Some aj.
  Proof.
    intros HH ? Hi Hj.
    pose proof (contiguous_between_incr_addr _ _ _ _ _ HH Hi).
    pose proof (contiguous_between_incr_addr _ _ _ _ _ HH Hj). solve_addr.
  Qed.

  Lemma contiguous_between_app a a1 a2 (i j k: Addr) :
    a = a1 ++ a2 →
    contiguous_between a i j →
    (i + length a1 = Some k)%a →
    contiguous_between a1 i k ∧ contiguous_between a2 k j.
  Proof.
    revert a a2 i j k. induction a1 as [| aa a1].
    { intros * ->.  simpl. intros. assert (i = k) by solve_addr. subst i. split; auto.
      apply contiguous_between_nil. }
    { intros * ->. cbn. inversion 1. subst. intros.
      unshelve epose proof (IHa1 (a1 ++ a2) a2 _ _ _ eq_refl _ _) as [IH1 IH2];
        [ shelve | shelve | shelve | ..]; eauto; cycle 1.
      split; [| eapply IH2]. 2: by solve_addr.
      eapply contiguous_between_cons; eauto. }
  Qed.

  Lemma contiguous_between_spec (l: list Addr) a0 an :
      contiguous_between l a0 an →
      (∀ i ai aj,
       l !! i = Some ai →
       l !! (i + 1) = Some aj →
       (ai + 1)%a = Some aj).
  Proof.
    intros Hl.
    induction Hl as [| * Ha' Hl Hind].
    { intros *. inversion 1. }
    { intros * Hi Hi'. destruct i as [| i].
      { cbn in *. inversion Hi; subst ai; clear Hi.
        destruct Hl; inversion Hi'; [ subst aj; clear Hi' ]. auto. }
      { cbn in *. eauto. } }
  Qed.

  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}.

  (* Note that we are assuming that both prog1 and prog2 are nonempty *)
  Lemma contiguous_between_program_split prog1 prog2 (φ : Addr → Word → iProp Σ) a i j :
    contiguous_between a i j →
    ⊢ (([∗ list] a_i;w_i ∈ a;prog1 ++ prog2, φ a_i w_i) -∗
    ∃ (a1 a2 : list Addr) (k: Addr),
      ([∗ list] a_i;w_i ∈ a1;prog1, φ a_i w_i)
        ∗ ([∗ list] a_i;w_i ∈ a2;prog2, φ a_i w_i)
        ∗ ⌜contiguous_between a1 i k
           ∧ contiguous_between a2 k j
           ∧ a = a1 ++ a2
           ∧ (i + length a1 = Some k)%a⌝)%I.
  Proof.
    iIntros (Ha) "Hprog".
    iDestruct (big_sepL2_length with "Hprog") as %Hlength.
    rewrite app_length in Hlength.
    set (n1 := length prog1) in *.
    set (n2 := length prog2) in *.
    rewrite -(take_drop n1 a). set (k := (i ^+ n1)%a).
    iExists (take n1 a), (drop n1 a), k.
    iDestruct (big_sepL2_app' with "Hprog") as "[Hprog1 Hprog2]".
    { subst n1. rewrite take_length. lia. }
    iFrame. iPureIntro.
    pose proof (contiguous_between_length _ _ _ Ha).
    destruct (contiguous_between_app a (take n1 a) (drop n1 a) i j k); auto.
    by rewrite take_drop.
    { rewrite take_length Hlength. subst k. solve_addr. }
    rewrite take_length. repeat split; eauto. rewrite Nat.min_l; subst k; solve_addr.
  Qed.

  Lemma contiguous_between_inj l:
    forall a1 b1 b2,
      contiguous_between l a1 b1 ->
      contiguous_between l a1 b2 ->
      b1 = b2.
  Proof.
    induction l; intros.
    - inv H; inv H0; auto.
    - inv H; inv H0. rewrite H2 in H3; inv H3.
      eapply IHl; eauto.
  Qed.

End Contiguous.

Definition isCorrectPC_range p b e a0 an :=
  ∀ ai, (a0 <= ai)%a ∧ (ai < an)%a → isCorrectPC (WCap p b e ai).

Lemma isCorrectPC_inrange p b (e a0 an a: Addr) :
  isCorrectPC_range p b e a0 an →
  (a0 <= a < an)%Z →
  isCorrectPC (WCap p b e a).
Proof.
  unfold isCorrectPC_range. move=> /(_ a) HH ?. apply HH. eauto.
Qed.

Lemma isCorrectPC_contiguous_range p b e a0 an a l :
  isCorrectPC_range p b e a0 an →
  contiguous_between l a0 an →
  a ∈ l →
  isCorrectPC (WCap p b e a).
Proof.
  intros Hr Hc Hin.
  eapply isCorrectPC_inrange; eauto.
  eapply contiguous_between_middle_bounds'; eauto.
Qed.

Lemma isCorrectPC_range_perm p b e a0 an :
  isCorrectPC_range p b e a0 an →
  (a0 < an)%a →
  p = RX ∨ p = RWX.
Proof.
  intros Hr H0n.
  assert (isCorrectPC (WCap p b e a0)) as HH by (apply Hr; solve_addr).
  inversion HH; auto.
Qed.

Lemma isCorrectPC_range_perm_non_E p b e a0 an :
  isCorrectPC_range p b e a0 an →
  (a0 < an)%a →
  p ≠ E.
Proof.
  intros HH1 HH2. pose proof (isCorrectPC_range_perm _ _ _ _ _ HH1 HH2).
  naive_solver.
Qed.

Lemma isCorrectPC_range_restrict p b e a0 an a0' an' :
  isCorrectPC_range p b e a0 an →
  (a0 <= a0')%a ∧ (an' <= an)%a →
  isCorrectPC_range p b e a0' an'.
Proof.
  intros HR [? ?] a' [? ?]. apply HR. solve_addr.
Qed.


Require Import Coq.micromega.Lia Coq.ZArith.ZArith.
Require Import Crypto.Util.Tactics.Contains.
Require Import Crypto.Util.Tactics.Not.
Local Open Scope Z_scope.

Module Z.
  Lemma move_R_pX x y z : x + y = z -> x = z - y.
  Proof. lia. Qed.
  Lemma move_R_mX x y z : x - y = z -> x = z + y.
  Proof. lia. Qed.
  Lemma move_R_Xp x y z : y + x = z -> x = z - y.
  Proof. lia. Qed.
  Lemma move_R_Xm x y z : y - x = z -> x = y - z.
  Proof. lia. Qed.
  Lemma move_R_nX x y : -x = y -> x = -y.
  Proof. lia. Qed.
  Lemma move_L_pX x y z : z = x + y -> z - y = x.
  Proof. lia. Qed.
  Lemma move_L_mX x y z : z = x - y -> z + y = x.
  Proof. lia. Qed.
  Lemma move_L_Xp x y z : z = y + x -> z - y = x.
  Proof. lia. Qed.
  Lemma move_L_Xm x y z : z = y - x -> y - z = x.
  Proof. lia. Qed.
  Lemma move_L_nX x y : y = -x -> -y = x.
  Proof. lia. Qed.

  (** [linear_substitute x] attempts to maipulate equations using only
      addition and subtraction to put [x] on the left, and then
      eliminates [x].  Currently, it only handles equations where [x]
      appears once; it does not yet handle equations like [x - x + x =
      5]. *)
  Ltac linear_solve_for_in_step for_var H :=
    let LHS := match type of H with ?LHS = ?RHS => LHS end in
    let RHS := match type of H with ?LHS = ?RHS => RHS end in
    first [ match RHS with
            | ?a + ?b
              => first [ contains for_var b; apply move_L_pX in H
                       | contains for_var a; apply move_L_Xp in H ]
            | ?a - ?b
              => first [ contains for_var b; apply move_L_mX in H
                       | contains for_var a; apply move_L_Xm in H ]
            | -?a
              => contains for_var a; apply move_L_nX in H
            | for_var
              => progress symmetry in H
            end
          | match LHS with
            | ?a + ?b
              => first [ not contains for_var b; apply move_R_pX in H
                       | not contains for_var a; apply move_R_Xp in H ]
            | ?a - ?b
              => first [ not contains for_var b; apply move_R_mX in H
                       | not contains for_var a; apply move_R_Xm in H ]
            | -?a
              => contains for_var a; apply move_R_nX in H
            end ].
  Ltac linear_solve_for_in for_var H := repeat linear_solve_for_in_step for_var H.
  Ltac linear_solve_for for_var :=
    match goal with
    | [ H : for_var = _ |- _ ] => idtac
    | [ H : context[for_var] |- _ ]
      => linear_solve_for_in for_var H;
         lazymatch type of H with
         | for_var = _ => idtac
         | ?T => fail 0 "Could not fully solve for" for_var "in" T "(hypothesis" H ")"
         end
    end.
  Ltac linear_substitute for_var := linear_solve_for for_var; subst for_var.
  Ltac linear_substitute_all :=
    repeat match goal with
           | [ v : Z |- _ ] => linear_substitute v
           end.
End Z.


From Coq Require Import Arith Lia.

Require Import folLogic3.
Require Import folProp.
Require Import subProp.
Require Export NN.
From hydras Require Import Compat815.

Lemma natNE (a b : nat) :
  a <> b -> SysPrf NN (notH (equal (natToTerm a) (natToTerm b))).
Proof.
  revert a b;
    assert (* wlog ? *)
      (H: forall a b : nat,
          a < b -> SysPrf NN (notH (equal (natToTerm a) (natToTerm b)))).
  { induction a as [| a Hreca]; intros.
    - destruct b as [| n].
      + elim (Nat.nlt_0_r _ H).
      + cbn; apply impE with (notH (equal (Succ (natToTerm n)) Zero)).
        * apply cp2, impI, eqSym.
          apply Axm; right; constructor.
        * apply nn1.
    - destruct b as [| n].
      + elim (Nat.nlt_0_r _ H).
      + cbn; apply impE with (notH (equal (natToTerm a) (natToTerm n))).
        * apply cp2, nn2.
        * apply Hreca; lia.
  }
 intros a b H0;
   destruct (Nat.lt_gt_cases a b) as [H1 _]; specialize (H1 H0);
          destruct H1 as [H1 | H1].
  - now apply H.
  - apply impE with (notH (equal (natToTerm b) (natToTerm a))).
    + apply cp2, impI, eqSym.
      apply Axm; right; constructor.
    + now apply H.
Qed.

Lemma natLE (a b : nat):
 b <= a -> SysPrf NN (notH (LT (natToTerm a) (natToTerm b))).
Proof.
  intros H; induction b as [| b Hrecb].
  - apply nn7.
  - cbn; apply impE with
      (notH
         (orH (LT (natToTerm a) (natToTerm b))
            (equal (natToTerm a) (natToTerm b)))).
  + apply cp2, nn8.
  + apply nOr, andI.
    * apply Hrecb; lia.
    * apply natNE.
      intro H0; lia.
Qed.

Lemma natLT (a b : nat):
  a < b -> SysPrf NN (LT (natToTerm a) (natToTerm b)).
Proof.
  intros H; eapply orE.
  - apply nn9 with (a := natToTerm b) (b := natToTerm a).
  - apply impI; apply contradiction with (LT (natToTerm b) (natToTerm a)).
    + apply Axm; right; constructor.
    + now apply sysWeaken, natLE, Nat.lt_le_incl.
  - apply impI, orSys.
    + apply contradiction with (equal (natToTerm b) (natToTerm a)).
      * apply Axm; right; constructor.
      * apply sysWeaken, natNE.
        unfold not in |- *; intros.
        subst; lia.
    + apply Axm; right; constructor.
Qed.

Lemma natPlus (a b : nat):
 SysPrf NN (equal (Plus (natToTerm a) (natToTerm b)) (natToTerm (a + b))).
Proof.
  induction b as [| b Hrecb].
  - rewrite Nat.add_comm; cbn; apply nn3.
  - rewrite Nat.add_comm; cbn.
    apply eqTrans with (Succ (Plus (natToTerm a) (natToTerm b))).
    + apply nn4.
    + apply eqSucc.
      rewrite Nat.add_comm; apply Hrecb.
Qed.

Lemma natTimes (a b : nat):
 SysPrf NN (equal (Times (natToTerm a) (natToTerm b)) (natToTerm (a * b))).
Proof.
  - induction b as [| b Hrecb].
    + rewrite Nat.mul_comm; cbn; apply nn5.
    + rewrite Nat.mul_comm; cbn; eapply eqTrans.
      * apply nn6.
      * rewrite Nat.add_comm;
          apply eqTrans with (Plus (natToTerm (b * a)) (natToTerm a)).
        -- apply eqPlus.
           ++ rewrite Nat.mul_comm; apply Hrecb.
           ++ apply eqRefl.
        -- apply natPlus.
Qed.

Lemma boundedLT  (m : nat) (a : Formula) (x : nat):
 (forall n : nat,
  n < m -> SysPrf NN (substituteFormula LNN a x (natToTerm n))) ->
 SysPrf NN (impH (LT (var x) (natToTerm m)) a).
Proof.
  revert m a x; simple induction m; intros.
  apply impI.
  apply contradiction with (LT (var x) (natToTerm 0)).
  - apply Axm; right; constructor.
  - apply sysWeaken, nn7.
  - apply impI; eapply orE.
    + apply impE with (LT (var x) (natToTerm (S n))).
      * apply sysWeaken; cbn; apply nn8.
      * apply Axm; right; constructor.
    + apply sysWeaken, H.
      intros n0 H1; apply H0.
      apply Nat.lt_lt_succ_r; auto.
    + apply sysWeaken, impI.
      rewrite <- (subFormulaId LNN a x).
      apply impE with (substituteFormula LNN a x (natToTerm n)).
      * apply (subWithEquals LNN).
        apply eqSym.
        apply Axm; right; constructor.
      * apply sysWeaken, H0.
        apply Nat.lt_succ_diag_r .
Qed.

Lemma nnPlusNotNeeded (n:nat) :
 SysPrf NN
   (impH (orH (LT (var 1) (natToTerm n)) (equal (var 1) (natToTerm n)))
      (LT (var 1) (Succ (natToTerm n)))).
Proof.
  induction n as [| n Hrecn].
  - cbn; apply impI, orSys.
    + apply contradiction with (LT (var 1) Zero).
      * apply Axm; right; constructor.
      * apply sysWeaken, nn7.
    + rewrite <- (subFormulaId LNN (LT (var 1) (Succ Zero)) 1).
      apply impE with
        (substituteFormula LNN (LT (var 1) (Succ Zero)) 1 Zero).
      * apply (subWithEquals LNN).
        apply eqSym.
        apply Axm; right; constructor.
      * apply sysWeaken;
          replace (substituteFormula LNN (LT (var 1) (Succ Zero)) 1 Zero)
          with
          (LT (natToTerm 0) (natToTerm 1)).
      -- apply natLT; auto.
      -- unfold LT; now rewrite (subFormulaRelation LNN).
  - cbn; apply impI, orSys.
    + apply impE with
        (orH (LT (var 1) (natToTerm n)) (equal (var 1) (natToTerm n))).
      * apply sysWeaken;
          apply impTrans with (LT (var 1) (natToTerm (S n))).
        -- apply Hrecn.
        -- apply boundedLT.
           intros n0 H.
           replace
             (substituteFormula LNN (LT (var 1)
                                       (Succ (Succ (natToTerm n))))
                1 (natToTerm n0))
             with (LT (natToTerm n0) (natToTerm (S (S n)))).
           { apply natLT; now apply Nat.lt_lt_succ_r. }
           unfold LT; rewrite (subFormulaRelation LNN).
           cbn; rewrite (subTermNil LNN).
           ++ reflexivity.
           ++ apply closedNatToTerm.
      * apply impE with (LT (var 1) (Succ (natToTerm n))).
        -- apply sysWeaken, nn8.
        -- apply Axm; right; constructor.
    + rewrite <- (subFormulaId LNN (LT (var 1)
                                      (Succ (Succ (natToTerm n)))) 1).
      apply impE with
        (substituteFormula LNN (LT (var 1) (Succ (Succ (natToTerm n)))) 1
           (Succ (natToTerm n))).
      * apply (subWithEquals LNN), eqSym, Axm; right; constructor.
      * apply sysWeaken.
        replace
          (substituteFormula LNN
             (LT (var 1) (Succ (Succ (natToTerm n)))) 1
             (Succ (natToTerm n)))
          with (LT (natToTerm (S n)) (natToTerm (S (S n)))).
        { apply natLT, Nat.lt_succ_diag_r. }
        unfold LT; rewrite (subFormulaRelation LNN); cbn.
        rewrite (subTermNil LNN).
        -- reflexivity.
        -- apply closedNatToTerm.
Qed.


Require Import Coq.Lists.List Arith Lia Program.
Import ListNotations.
Require Import SyDPaCC.Support.List.

(** * List Functions using [sig] *)

(** ** [nth] with a precondition on the index *)

Program Fixpoint nth {A:Type} (l:list A) (pos:nat | pos < length l) : A :=
  match l with
  | [] => _
  | a::l =>
    if eq_nat_dec (`pos) 0
    then a
    else nth l (pred (`pos))
  end.
Next Obligation. simpl in *; lia. Qed.
Next Obligation. simpl in *; lia. Qed.

Lemma nth_spec :
  forall (A:Type) (l:list A)  (pos:nat | pos<length l) (default : A),
    nth l pos = List.nth (`pos) l default.
Proof.
  induction l; intros [pos Hpos] default; simpl in Hpos.
  - lia.
  - destruct pos; trivial.
    simpl. erewrite IHl. trivial.
Qed.

Lemma nth_pi :
  forall (A:Type)(l :list A) (pos1 pos2: {n:nat | n < length l}),
    `pos1 =  ` pos2 ->
    nth l pos1 = nth l pos2.
Proof.
  intros A l [pos1 Hpos1] [pos2 Hpos2] H; simpl in H; subst.
  destruct l.
  - simpl in Hpos1. lia.
  - now repeat rewrite nth_spec with (default := a).
Qed.

Program Lemma nth_In :
  forall (A:Type) (l:list A) (pos:nat | pos < length l),
    In (nth l pos) l.
Proof.
  intros A l [pos Hpos]; subst.
  destruct l as [ | x xs].
  - simpl in Hpos; lia.
  - rewrite nth_spec with (default:=x).
    now apply List.nth_In.
Qed.

Lemma In_nth:
  forall (A:Type) (l:list A)(a:A),
    In a l -> exists pos, a = nth l pos.
Proof.
  induction l as [|x xs IH]; intros a H.
  - contradiction.
  - destruct H as [H|H]; subst.
    + assert(0 < length(a::xs)) as H0 by (simpl; auto with arith).
      exists(exist (fun n=>n<length(a::xs)) 0 H0).
      trivial.
    + destruct(IH a H) as [[pos Hpos] Hnth].
      assert(S pos < length(x::xs)) as HSpos by (simpl; lia).
      exists(exist (fun n=>n<length (x::xs)) (S pos) HSpos).
      rewrite Hnth; repeat rewrite nth_spec with (default:=a).
      trivial.
Qed.

Definition cast {A B:Type}(a:A)(H:A=B) : B.
  rewrite <- H.
  assumption.
Defined.

Definition cast_sig {A:Type}{P P':A->Prop}(a:sig P)(H:forall a, P a<->P' a) : sig P'.
  destruct a as [a Ha].
  apply H in Ha.
  exact(exist _ a Ha).
Defined.

Lemma length_sig:
  forall A B (l:list A)(l':list B),
    length l = length l' -> forall n,  n < length l <-> n < length l'.
  lia; subst; trivial.
Qed.
Arguments length_sig [A B l l'] _ n.

Lemma nth_eq :
  forall (A:Type)(l l':list A)(H:length l = length l'),
    (forall (pos:nat|pos<length l), nth l pos =
                             nth l' (cast_sig pos (length_sig H))) ->
      l = l'.
Proof.
  induction l as [|x xs IH]; destruct l' as [|x' xs'];intros Hlen H;
    trivial; try discriminate.
  assert(x = x') as Head.
  {
    assert(0<length (x::xs)) as H0 by (simpl;lia).
    set(pos0:=exist (fun n=>n<_) 0 H0).
    now specialize (H pos0).
  }
  assert(length xs = length xs') as Hlen' by auto.
  assert(forall (pos : nat | pos < length xs),
            nth xs pos =
            nth xs' (cast_sig pos (length_sig Hlen'))) as Htail.
  {
    intros [pos Hpos].
    assert(S pos<length(x::xs)) as Hpos' by (simpl;lia).
    specialize (H (exist(fun n=>n<_) (S pos) Hpos')). simpl in H.
    match goal with
    | [ H : nth xs ?pos1 = nth xs' ?pos2 |- _] =>
      transitivity (nth xs pos1)
    end.
    repeat rewrite nth_spec with (default:=x). trivial.
    rewrite H.
    repeat rewrite nth_spec with (default:=x). trivial.
  }
  assert(xs = xs') by (now apply (IH _ Hlen')).
  now f_equal.
Qed.

Fact lt_eq:
  forall {m m':nat}(H:m=m')(n:nat), (n<m) <-> (n<m').
  intros m m' H n; rewrite H; intuition.
Qed.

Lemma nth_map:
  forall (A B : Type) (f : A -> B) (l : list A) pos,
    nth (map f l) pos = f (nth l (cast_sig pos (length_sig (map_length f l)))).
Proof.
  intros A B f; induction l as [|x xs IH]; intro pos.
  - simpl in pos; destruct pos; lia.
  - destruct pos as [ [ | pos] Hpos].
    + trivial.
    + simpl; rewrite IH; now repeat rewrite nth_spec with (default:=x).
Qed.

Lemma nth_combine:
  forall (A B:Type)(l:list A)(l':list B) pos (H: length l = length l'),
    let H1 := length_sig(combine_length' H) in
    let H2 := length_sig(combine_length'' H) in
    nth (combine l l') pos = (nth l (cast_sig pos H1),
                              nth l' (cast_sig pos H2)).
Proof.
  induction l; destruct l'; intros [pos Hpos] H; try (simpl in *; lia).
  simpl (combine (a::l) (b::l')).
  destruct pos.
  - trivial.
  - assert(length l = length l') as Hlen by auto.
    simpl; rewrite (IHl _ _ Hlen).
    f_equal; now apply nth_pi.
Qed.

(** * A [map] function that attaches a property proof to each element *)

Program Fixpoint map (A:Type)(P:A->Prop)(l:list A)(H:forall a,List.In a l->P a) :
  list (sig P) :=
  match l with
  | [] => []
      | x::xs => (exist P x (H x _))::(map _ _ xs _)
    end.
Next Obligation.
  simpl; auto.
Qed.
Next Obligation.
  apply H. simpl. auto.
Qed.

Arguments map [A P] l H.

Lemma map_pi:
  forall (A:Type)(P:A->Prop)(l l':list A)(H:forall a,List.In a l->P a)
    (H':forall a,List.In a l'->P a)
    (Inj:forall a a': sig P,  proj1_sig a = proj1_sig a' -> a = a'),
    l = l' -> map l H = map l' H'.
Proof.
  intros A P l l'; generalize l; clear l; induction l' as [ | x xs IH]; intros l H H' Inj Heq; subst.
  - trivial.
  - simpl; erewrite IH; f_equal; trivial.
    now apply Inj.
Qed.

Fact map_app_1 :
  forall {A:Type}{P:A->Prop}{l l':list A},
    (forall a,List.In a (l++l')->P a) ->
    forall a, List.In a l -> P a.
  intuition.
Qed.

Fact map_app_2 :
  forall {A:Type}{P:A->Prop}{l l':list A},
    (forall a,List.In a (l++l')->P a) ->
    forall a, List.In a l' -> P a.
  intuition.
Qed.

Lemma map_app:
  forall {A:Type}{P:A->Prop}(l l':list A)(H:forall a,List.In a (l++l')->P a),
    (forall a a': sig P,  proj1_sig a = proj1_sig a' -> a = a') ->
    map (l++l') H = map l (map_app_1 H) ++ (map l' (map_app_2 H)).
Proof.
  intros A P; induction l as [ | x xs IH]; intros l' Hin Hinj.
  - now apply map_pi.
  - simpl; f_equal.
    + now apply Hinj.
    + rewrite IH by trivial; f_equal; now apply map_pi.
Qed.

Lemma in_map_in:
  forall {A:Type}{P:A->Prop}(l:list A)(H:forall a,List.In a l->P a),
  forall (a:sig P), In a (map l H) -> In (proj1_sig a) l.
Proof.
  intros A P; induction l as [ | x xs IH]; intros Hl a H.
  - trivial.
  - simpl in H; destruct H as [H|H].
    + left; rewrite <- H; trivial.
    + right; firstorder.
Qed.

Lemma in_in_map:
  forall {A:Type}{P:A->Prop}(l:list A)(H:forall a,List.In a l->P a),
    (forall a a': sig P,  proj1_sig a = proj1_sig a' -> a = a') ->
    forall (a:sig P), In (proj1_sig a) l -> In a (map l H).
Proof.
  intros A P; induction l as [ | x xs IH]; intros Hl Hinj a H.
  - trivial.
  - simpl in H; destruct H as [H|H].
    + left. now apply Hinj.
    + right; firstorder.
Qed.

Lemma map_proj1_sig :
  forall {A}{P:A->Prop}(l:list A)(H:forall a,List.In a l->P a),
    List.map (@proj1_sig A P) (map l H) = l.
Proof.
  intros A P; induction l as [|x xs IH]; intro H.
  - trivial.
  - simpl; rewrite IH; trivial.
Qed.

Lemma map_length:
  forall {A:Type}{P:A->Prop}(l:list A) (H:forall a,In a l->P a),
    length(map l H) = length l.
Proof.
  induction l as [|x xs IH]; intro H.
  - auto.
  - simpl; rewrite IH; auto.
Qed.

Lemma map_nth:
  forall {A:Type}(P:A->Prop)(l:list A)(H:forall a,In a l->P a)
    (UIP:forall a (H1:P a)(H2:P a), H1=H2) pos,
    let H' := Sig.length_sig (map_length l H) in
    let pos' := Sig.cast_sig pos H' in
    let x := Sig.nth l pos' in
    Sig.nth (map l H) pos =
    exist P x (H x (Sig.nth_In _ l pos')).
Proof.
  intros A P l H UIP0 pos H' pos' res.
  unfold res, pos', H' in *. clear H' pos' res.
  generalize dependent l.
  induction l as [|x xs IH]; intros H [pos Hpos].
  - simpl in Hpos; lia.
  - destruct pos.
    + simpl. f_equal. apply UIP0.
    + simpl. repeat rewrite IH by assumption.
      simpl; f_equal.
      assert(forall a b:sig P, proj1_sig a = proj1_sig b -> a = b)
        as Hinj
          by
            (intros [a Ha] [b Hb] H0; simpl in H0; subst;
             assert(Ha = Hb) by apply UIP0; now subst).
      apply Hinj; auto.
      now apply Sig.nth_pi.
Qed.

#[export] Hint Rewrite @map_length : length.