(*
 * Copyright 2020 Youngju Song
 *
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 *     https://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)
(* *********************************************************************)
(*                                                                     *)
(*           Software Foundations Laboratory's Lemmas & Tactic         *)
(*               based on Viktor and Gil's lemmas & tactic             *)
(*                                                                     *)
(* *********************************************************************)

(** This file collects a number of basic lemmas and tactics for better
    proof automation, structuring large proofs, or rewriting.  Most of
    the rewriting support is ported from ssreflect. *)

(** Symbols starting with [sflib__] are internal. *)

Require Import Bool List Arith ZArith String Program.
(* Require Export paconotation newtac. *)

Set Implicit Arguments.

Hint Unfold not iff id.

Export ListNotations.

(* Notation "~ x" := (forall (FH: x), False) : type_scope. *)

(* Function composition *)
Notation "f <*> g" := (compose f g) (at level 49, left associativity).

(* ************************************************************************** *)
(** * Coersion of [bool] into [Prop] *)
(* ************************************************************************** *)

(** Coersion of bools into Prop *)
Coercion is_true (b : bool) : Prop := b = true.

(** Hints for auto *)
Lemma sflib__true_is_true : true.
Proof. reflexivity. Qed.

Lemma sflib__not_false_is_true : ~ false.
Proof. discriminate. Qed.

Lemma sflib__negb_rewrite: forall {b}, negb b -> b = false.
Proof. intros []; (reflexivity || discriminate). Qed.

Lemma sflib__andb_split: forall {b1 b2}, b1 && b2 -> b1 /\ b2.
Proof. intros [] []; try discriminate; auto. Qed.

Hint Resolve sflib__true_is_true sflib__not_false_is_true.

(* ************************************************************************** *)
(** * Basic automation tactics *)
(* ************************************************************************** *)

(** Set up for basic simplification *)

Create HintDb sflib discriminated.

(** Adaptation of the ss-reflect "[done]" tactic. *)

Ltac sflib__basic_done :=
  solve [trivial with sflib | apply sym_equal; trivial | discriminate | contradiction].

Ltac done := unfold not in *; trivial with sflib; hnf; intros;
  solve [try sflib__basic_done; split;
         try sflib__basic_done; split;
         try sflib__basic_done; split;
         try sflib__basic_done; split;
         try sflib__basic_done; split; sflib__basic_done
    | match goal with H : _ -> False |- _ => solve [case H; trivial] end].

(** A variant of the ssr "done" tactic that performs "eassumption". *)

Ltac edone := try eassumption; trivial; hnf; intros;
  solve [try eassumption; try sflib__basic_done; split;
         try eassumption; try sflib__basic_done; split;
         try eassumption; try sflib__basic_done; split;
         try eassumption; try sflib__basic_done; split;
         try eassumption; try sflib__basic_done; split;
         try eassumption; sflib__basic_done
    | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

Tactic Notation "by"  tactic(tac) := (tac; done).
Tactic Notation "eby" tactic(tac) := (tac; edone).

Ltac sflib__complaining_inj f H :=
  let X := fresh in
  (match goal with | [|- ?P ] => set (X := P) end);
  injection H;
  (lazymatch goal with | [ |- f _ = f _ -> _] => fail | _ => idtac end);
  clear H; intros;
  subst X;
  try subst.

Ltac sflib__clarify1 :=
  try subst;
  repeat match goal with
  | [H: is_true (andb _ _) |- _] => case (sflib__andb_split H); clear H; intros ? H
  | [H: is_true (negb ?x) |- _] => rewrite (sflib__negb_rewrite H) in *
  | [H: is_true ?x        |- _] => rewrite H in *
  | [H: ?x = true         |- _] => rewrite H in *
  | [H: ?x = false        |- _] => rewrite H in *
  | [H: ?f _             = ?f _             |- _] => sflib__complaining_inj f H
  | [H: ?f _ _           = ?f _ _           |- _] => sflib__complaining_inj f H
  | [H: ?f _ _ _         = ?f _ _ _         |- _] => sflib__complaining_inj f H
  | [H: ?f _ _ _ _       = ?f _ _ _ _       |- _] => sflib__complaining_inj f H
  | [H: ?f _ _ _ _ _     = ?f _ _ _ _ _     |- _] => sflib__complaining_inj f H
  | [H: ?f _ _ _ _ _ _   = ?f _ _ _ _ _ _   |- _] => sflib__complaining_inj f H
  | [H: ?f _ _ _ _ _ _ _ = ?f _ _ _ _ _ _ _ |- _] => sflib__complaining_inj f H
  end; try done.

(** Perform injections & discriminations on all hypotheses *)

Ltac clarify :=
  sflib__clarify1;
  repeat match goal with
    | H1: ?x = Some _, H2: ?x = None   |- _ => rewrite H2 in H1; sflib__clarify1
    | H1: ?x = Some _, H2: ?x = Some _ |- _ => rewrite H2 in H1; sflib__clarify1
  end.

(** Kill simple goals that require up to two econstructor calls. *)

(* from CompCert-2.4/lib/Coqlib.v *)
Ltac inv H := inversion H; clear H; subst.

Ltac hinv x := move x at bottom; inversion x; clarify.

Tactic Notation "hinv" ident(a) :=
  (hinv a).
Tactic Notation "hinv" ident(a) ident(b) :=
  (hinv a; hinv b).
Tactic Notation "hinv" ident(a) ident(b) ident(c) :=
  (hinv a; hinv b c).
Tactic Notation "hinv" ident(a) ident(b) ident(c) ident(d) :=
  (hinv a b; hinv c d).

Ltac hinvc x := hinv x; clear x.

Tactic Notation "hinvc" ident(a) :=
  (hinvc a).
Tactic Notation "hinvc" ident(a) ident(b) :=
  (hinvc a; hinvc b).
Tactic Notation "hinvc" ident(a) ident(b) ident(c) :=
  (hinvc a; hinvc b c).
Tactic Notation "hinvc" ident(a) ident(b) ident(c) ident(d) :=
  (hinvc a b; hinvc c d).
Tactic Notation "hinvc" ident(a) ident(b) ident(c) ident(d) ident(e) :=
  (hinvc a b c; hinvc d e).

Ltac simpls  := simpl in *; try done.
Ltac ins := simpl in *; try done; intros.

Tactic Notation "case_eq" constr(x) := case_eq (x).

Tactic Notation "case_eq" constr(x) "as" simple_intropattern(H) :=
  destruct x as [] eqn: H; try done.

(* ************************************************************************** *)
(** * Basic simplication tactics *)
(* ************************************************************************** *)

Ltac sflib__clarsimp1 :=
  clarify; (autorewrite with sflib in * ); try done;
  match goal with
  | [H: is_true ?x |- _] => rewrite H in *; sflib__clarsimp1
  | [H: ?x = true |- _] => rewrite H in *; sflib__clarsimp1
  | [H: ?x = false |- _] => rewrite H in *; sflib__clarsimp1
  | _ => clarify; auto 1 with sflib
  end.

Ltac clarsimp := intros; simpl in *; sflib__clarsimp1.

Ltac autos   := clarsimp; auto with sflib.

(* hdesH, hdes: more general des *)

Definition  NW A (P: () -> A) : A := P ().

(* Notation "<< x : t >>" := (NW (fun x => (t):Prop)) (at level 80, x ident, no associativity). *)
Notation "<< x : t >>" := (NW (fun x => (t))) (at level 80, x ident, no associativity).
Notation "<< t >>" := (NW (fun _ => t)) (at level 79, no associativity).
Notation "<< t >>" := (NW (fun _ => (t):Prop)) (at level 79, no associativity).

Ltac unnw := unfold NW in *.
Ltac rednw := red; unnw.

Hint Unfold NW.

Ltac get_concl := lazymatch goal with [ |- ?G ] => G end.

Ltac des1 :=
  match goal with
    | H : NW _ |- _ => red in H
    | H : exists x, NW (fun y => _) |- _ =>
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y'
    | H : exists x, ?p |- _ =>
      let x' := fresh x in destruct H as [x' H]
    | H : ?p /\ ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end
    | H : ?p <-> ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => unfold NW at 1 in x'; red in y' | _ => idtac end;
      match q with | NW _ => unfold NW at 1 in y'; red in x' | _ => idtac end
    | H : ?p \/ ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => H end in
      destruct H as [x' | y'];
      [ match p with | NW _ => red in x' | _ => idtac end
      | match q with | NW _ => red in y' | _ => idtac end]
  end.

Ltac des := repeat des1.

Ltac desc :=
  repeat match goal with
    | H : exists x, NW (fun y => _) |- _ =>
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y'
    | H : exists x, ?p |- _ =>
      let x' := fresh x in destruct H as [x' H]
    | H : ?p /\ ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end
    | H : is_true (_ && _) |- _ =>
          let H' := fresh H in case (sflib__andb_split H); clear H; intros H H'
    | H : ?x = ?x   |- _ => clear H
  end.

Ltac nbdes1 :=
  match goal with
    | H : NW _ |- _ => red in H
    | H : exists x, NW (fun y => _) |- _ =>
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y'
    | H : exists x, ?p |- _ =>
      let x' := fresh x in destruct H as [x' H]
    | H : ?p /\ ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end
    | H : ?p <-> ?q |- _ =>
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => unfold NW at 1 in x'; red in y' | _ => idtac end;
      match q with | NW _ => unfold NW at 1 in y'; red in x' | _ => idtac end
    (* | H : ?p \/ ?q |- _ => *)
    (*   let x' := match p with | NW (fun z => _) => fresh z | _ => H end in *)
    (*   let y' := match q with | NW (fun z => _) => fresh z | _ => H end in *)
    (*   destruct H as [x' | y']; *)
    (*   [ match p with | NW _ => red in x' | _ => idtac end *)
    (*   | match q with | NW _ => red in y' | _ => idtac end] *)
  end.

Ltac nbdes := repeat nbdes1.
Ltac rrnbdes H := move H at bottom; repeat red in H; nbdes.

Ltac forall_split :=
  let H := fresh "__forall_split__" in first [intro; forall_split; match goal with [H:_|-_] => revert H end | split].

Definition _HID_ (A : Type) (a : A) := a.

Ltac hdesHi H P x y :=
  let FF := fresh "__hdesfalse__" in
  let TMP := fresh "__hdesHi__" in
  let P1 := fresh "__hdesHi__" in
  let P2 := fresh "__hdesHi__" in
    evar (P1 : Prop); evar (P2 : Prop);
    assert (TMP: False -> P) by
      (intro FF; forall_split;
         [ let G := get_concl in set (TMP := G); revert P1; instantiate (1:=G)
         | let G := get_concl in set (TMP := G); revert P2; instantiate (1:=G) ];
       destruct FF);
    try clear TMP;
    try (try (match goal with [Def := ?G : _ |- _] =>
              match Def with P1 =>
              match goal with [_ : G |- _] => fail 4 end end end);
         assert (x: P1) by (unfold P1; repeat (let x := fresh "__xhj__" in intro x; specialize (H x)); apply H));
    try unfold P1 in x; try clear P1;
    try (try (match goal with [Def := ?G : _ |- _] =>
              match Def with P2 =>
              match goal with [_ : G |- _] => fail 4 end end end);
         assert (y: P2) by (unfold P2; repeat (let x := fresh "__xhj__" in intro x; specialize (H x)); apply H));
    try unfold P2 in y; try clear P2;
    fold (_HID_ P) in H;
    try clear H.

Ltac hdesHP H P :=
  let H' := fresh H in let H'' := fresh H in
  match P with
  | context[ NW (fun x => _) /\ NW (fun y => _) ] =>
    let x' := fresh x in let y' := fresh y in
    hdesHi H P x' y'; red in x'; red in y'
  | context[ NW (fun x => _) /\ _ ] =>
    let x' := fresh x in
    hdesHi H P x' H'; red in x'
  | context[ _ /\ NW (fun y => _) ] =>
    let y' := fresh y in
    hdesHi H P H' y'; red in y'
  | context[ _ /\ _ ] =>
    hdesHi H P H' H''
  | context[ NW (fun x => _) <-> NW (fun y => _) ] =>
    let x' := fresh x in let y' := fresh y in
    hdesHi H P x' y'; red in x'; red in y'
  | context[ NW (fun x => _) <-> _ ] =>
    let x' := fresh x in
    hdesHi H P x' H'; red in x'
  | context[ _ <-> NW (fun y => _) ] =>
    let y' := fresh y in
    hdesHi H P H' y'; red in y'
  | context[ _ <-> _ ] =>
    hdesHi H P H' H''
  end.

Ltac hdesH H := let P := type of H in hdesHP H P; unfold _HID_ in *.

(*
(* It works, but too slows *)
Ltac hdesF P :=
  match P with
  | fun _ => _ /\ _ => idtac
  | fun _ => _ <-> _ => idtac
  | fun x => forall y : @?ty x, @?f x y =>
    let P' := eval cbv beta in (fun p : sigT ty => f (projT1 p) (projT2 p)) in
      hdesF P'
  end.

Ltac hdes :=
  repeat match goal with | H : ?P |- _ => hdesF (fun _ : unit => P); hdesHP H P end;
  unfold _HID_ in *.
*)

Ltac hdesF P :=
  match P with | _ /\ _ => idtac | _ <-> _ => idtac | forall _, _ =>
  match P with | forall _, _ /\ _ => idtac | forall _, _ <-> _ => idtac | forall _ _, _ =>
  match P with | forall _ _, _ /\ _ => idtac | forall _ _, _ <-> _ => idtac | forall _ _ _, _ =>
  match P with | forall _ _ _, _ /\ _ => idtac | forall _ _ _, _ <-> _ => idtac | forall _ _ _ _, _ =>
  match P with | forall _ _ _ _, _ /\ _ => idtac | forall _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ =>
  match P with | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ /\ _ => idtac | forall _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, _ <-> _ => idtac
  end end end end end end end end end end end end end end end end end end end end end.

(** Fail if hypothesis [H] doesn't exist. *)
Ltac check_hyp H := match H with _ => idtac end.

(** Fail if hypothesis [H1] is not [H2]. *)
Ltac check_equal H1 H2 := match H1 with H2 => idtac end.

Ltac hdes :=
  repeat match goal with | H : ?P |- _ => hdesF P; hdesHP H P end;
  unfold _HID_ in *.
Ltac rdes H := red in H; des.
Ltac rrdes H := move H at bottom; repeat red in H; des.
Ltac rhdes H := red in H; hdes.
Ltac rrhdes H := check_hyp H; repeat red in H; hdes.

Tactic Notation "rrdes" ident(a) :=
  (rrdes a).
Tactic Notation "rrdes" ident(a) ident(b) :=
  (rrdes a; rrdes b).
Tactic Notation "rrdes" ident(a) ident(b) ident(c) :=
  (rrdes a; rrdes b c).
Tactic Notation "rrdes" ident(a) ident(b) ident(c) ident(d) :=
  (rrdes a b; rrdes c d).

(** Destruct the condition of an [if] expression occuring in the goal. *)
Ltac des_if :=
  match goal with
    | [ |- context[if ?X then _ else _] ] => destruct X
  end.
(* Ltac desE_if := *)
(*   match goal with *)
(*     | [ |- context[if ?X then _ else _] ] => let E := fresh X in destruct X eqn:E *)
(*   end. *)

(** Destruct the condition of an [if] expression occuring in the given hypothesis. *)
Ltac des_ifH H :=
  match goal with
    | [ H' : context[if ?X then _ else _] |- _ ] => check_equal H' H; destruct X
  end.

(* TODO tactics such as these should always do clean at the end to remove junk like [H : x = x] *)
Ltac des_ifs :=
 clarify;
  repeat
    match goal with
      | |- context[match ?x with _ => _ end] =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
      | H: context[ match ?x with _ => _ end ] |- _ =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac desf := clarify; des; des_ifs.
Ltac isd := ins; desf.

(** Create a copy of hypothesis [H]. *)
Tactic Notation "dup" hyp(H) :=
  let H' := fresh H in assert (H' := H).

(* (** Call tactic [tac] on a copy of [H]. *) *)
(* Tactic Notation "dup" hyp(H) tactic(tac) := *)
(*   let H' := fresh H in assert (H' := H); tac H'. *)

Ltac clarassoc := clarsimp; autorewrite with sflib sflibA in *; try done.

Ltac sflib__hacksimp1 :=
   clarsimp;
   match goal with
     | H: _ |- _ => solve [rewrite H; clear H; clarsimp
                         |rewrite <- H; clear H; clarsimp]
     | _ => solve [f_equal; clarsimp]
   end.

Ltac hacksimp :=
   clarsimp;
   try match goal with
   | H: _ |- _ => solve [rewrite H; clear H; clarsimp
                              |rewrite <- H; clear H; clarsimp]
   | |- context[if ?p then _ else _] => solve [destruct p; sflib__hacksimp1]
   | _ => solve [f_equal; clarsimp]
   end.

(* ************************************************************************** *)
(** * Delineating cases in proofs *)
(* ************************************************************************** *)

(** Named case tactics (taken from Libtactics) *)

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move x at top
  | assert_eq x name
  | fail 1 "because we are working on a different case." ].

Ltac Case name := Case_aux case name.
Ltac SCase name := Case_aux subcase name.
Ltac SSCase name := Case_aux subsubcase name.
Ltac SSSCase name := Case_aux subsubsubcase name.
Ltac SSSSCase name := Case_aux subsubsubsubcase name.

(** Lightweight case tactics (without names) *)

Tactic Notation "-" tactic(c) :=
  first [
    assert (WithinCaseM := True); move WithinCaseM at top
  | fail 1 "because we are working on a different case." ]; c.

Tactic Notation "+" tactic(c) :=
  first [
    assert (WithinCaseP := True); move WithinCaseP at top
  | fail 1 "because we are working on a different case." ]; c.

Tactic Notation "*" tactic(c) :=
  first [
    assert (WithinCaseS := True); move WithinCaseS at top
  | fail 1 "because we are working on a different case." ]; c.

Tactic Notation ":" tactic(c) :=
  first [
    assert (WithinCaseC := True); move WithinCaseC at top
  | fail 1 "because we are working on a different case." ]; c.

(* ************************************************************************** *)
(** * Exploiting a hypothesis *)
(* ************************************************************************** *)

(** Exploit an assumption (adapted from CompCert). *)

Ltac exploit x :=
    refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _) _)
 || refine ((fun x y => y x) (x _ _) _)
 || refine ((fun x y => y x) (x _) _).

(* When 'exploit x' generates too many sub goals, try 'hexploit x' *)

Lemma mp: forall P Q: Type, P -> (P -> Q) -> Q.
Proof. intuition. Defined.

Lemma mp': forall P Q : Type, (P -> Q) -> P -> Q.
Proof. intuition. Qed.

Ltac hexploit x := eapply mp; [eapply x|].
Ltac hexploit' x := let H := fresh in set (H := x); clear H; eapply mp; [eapply x|].

(* set_prop N T A performs 'assert (A : P); [|set (N := T A)]' when T is a term of type (P -> _) *)

Ltac set_prop N T A :=
  let b := fresh in let ty := type of T in
  match ty with (forall (_:?P), _) => assert (A: P); [|set (N := T A)] end.

(* ************************************************************************** *)
(** * Induction tactics *)
(* ************************************************************************** *)

Tactic Notation "induction" "[" ident_list(y) "]" ident(x)  :=
  first [ try (intros until x); revert y; induction x
        | red; try (intros until x); revert y; induction x ].

Tactic Notation "induction" "[" ident_list(y) "]" ident(x) "[" ident(z) "]"  :=
  first [ try (intros until x); revert y; induction x; destruct z
        | red; try (intros until x); revert y; induction x; destruct z ].

(** Versions with hacksimp *)

Tactic Notation "induct" ident(x) := induction x; hacksimp.

Tactic Notation "induct" ident(x) "[" ident(z) "]" :=
  induction x; destruct z; hacksimp.

Tactic Notation "induct" "[" ident_list(y) "]" ident(x)  :=
  first [ try (intros until x); revert y; induction x; hacksimp
        | red; try (intros until x); revert y; induction x; hacksimp ].

Tactic Notation "induct" "[" ident_list(y) "]" ident(x) "[" ident(z) "]"  :=
  first [ try (intros until x); revert y; induction x; destruct z; hacksimp
        | red; try (intros until x); revert y; induction x; destruct z; hacksimp ].

Tactic Notation "edestructs" ident(a) :=
  (edestruct a).
Tactic Notation "edestructs" ident(a) ident(b) :=
  (edestruct a; edestruct b).
Tactic Notation "edestructs" ident(a) ident(b) ident(c) :=
  (edestruct a; edestructs b c).
Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) :=
  (edestruct a; edestructs b c d).
Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) :=
  (edestruct a; edestructs b c d e).
Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) :=
  (edestruct a; edestructs b c d e f).
Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) :=
  (edestruct a; edestructs b c d e f g).
Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) :=
  (edestruct a; edestructs b c d e f g h).
Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) :=
  (edestruct a; edestructs b c d e f g h i).
Tactic Notation "edestructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) ident(j) :=
  (edestruct a; edestructs b c d e f g h i j).

Tactic Notation "destructs" ident(a) :=
  (destruct a).
Tactic Notation "destructs" ident(a) ident(b) :=
  (destruct a; destruct b).
Tactic Notation "destructs" ident(a) ident(b) ident(c) :=
  (destruct a; destructs b c).
Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) :=
  (destruct a; destructs b c d).
Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) :=
  (destruct a; destructs b c d e).
Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) :=
  (destruct a; destructs b c d e f).
Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) :=
  (destruct a; destructs b c d e f g).
Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) :=
  (destruct a; destructs b c d e f g h).
Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) :=
  (destruct a; destructs b c d e f g h i).
Tactic Notation "destructs" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) ident(j) :=
  (destruct a; destructs b c d e f g h i j).

Tactic Notation "depdes" ident(_something_which_shold_not_occur_in_the_goal_) :=
  (let _x_ := type of _something_which_shold_not_occur_in_the_goal_
   in dependent destruction _something_which_shold_not_occur_in_the_goal_).
Tactic Notation "depdes" ident(a) ident(b) :=
  (depdes a; depdes b).
Tactic Notation "depdes" ident(a) ident(b) ident(c) :=
  (depdes a; depdes b c).
Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) :=
  (depdes a; depdes b c d).
Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) :=
  (depdes a; depdes b c d e).
Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) :=
  (depdes a; depdes b c d e f).
Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) :=
  (depdes a; depdes b c d e f g).
Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) :=
  (depdes a; depdes b c d e f g h).
Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) :=
  (depdes a; depdes b c d e f g h i).
Tactic Notation "depdes" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) ident(g) ident(h) ident(i) ident(j) :=
  (depdes a; depdes b c d e f g h i j).

Tactic Notation "depgen" ident(x) := generalize dependent x.

(* eappleft, eappright *)

Ltac eappleft H :=
  let X := fresh "__lem__" in let X1 := fresh "__lem__" in let X2 := fresh "__lem__" in
  assert (X:= H); let P := type of X in hdesHi X P X1 X2;
  eapply X1; clear X1 X2.

Ltac eappright H :=
  let X := fresh "__lem__" in let X1 := fresh "__lem__" in let X2 := fresh "__lem__" in
  assert (X:= H); let P := type of X in hdesHi X P X1 X2;
  eapply X2; clear X1 X2.

(* guard for simpl *)

(* for Coq8.4 *)

Definition __guard__ A (a : A) : A := a.
Definition __GUARD__ A (a : A) : A := a.
Arguments __guard__ A a : simpl never.
Arguments __GUARD__ A a : simpl never.

Tactic Notation "guard" constr(t) "in" hyp(H) := fold (__guard__ t) in H.
Tactic Notation "guardH" hyp(H) := let t := type of H in guard t in H.
Tactic Notation "guard" :=
  repeat match goal with [H: ?P |- _] =>
    try (match P with __guard__ _ => fail 2 end); guardH H
  end.
Tactic Notation "sguard" constr(t) "in" hyp(H) := fold (__GUARD__ t) in H.
Tactic Notation "sguard" "in" hyp(H) := let t := type of H in sguard t in H.

Ltac unguard := unfold __guard__ in *.
Ltac unguardH H := unfold __guard__ in H.
Ltac unsguard H := unfold __GUARD__ in H.

Ltac desH H := guard; unguardH H; des; unguard.

Ltac splits :=
  intros; unfold NW;
  repeat match goal with
  | [ |- _ /\ _ ] => split
  end.
Ltac esplits :=
  intros; unfold NW;
  repeat match goal with
  | [ |- @ex _ _ ] => eexists
  | [ |- _ /\ _ ] => split
  | [ |- @sig _ _ ] => eexists
  | [ |- @sigT _ _ ] => eexists
  | [ |- @prod _  _ ] => split
  end.

Tactic Notation "replace_all" constr(e) := repeat (
  let X := fresh in assert (X: e) by (clarify; eauto; done);
  first [rewrite !X | setoid_rewrite X]; clear X).

Lemma all_conj_dist: forall A (P Q: A -> Prop),
  (forall a, P a /\ Q a) -> (forall a, P a) /\ (forall a, Q a).
Proof. intros; hdes; eauto. Qed.

(* extensionalities *)

Tactic Notation "extensionalities" :=
  repeat let x := fresh in extensionality x.
Tactic Notation "extensionalities" ident(a) :=
  (extensionality a).
Tactic Notation "extensionalities" ident(a) ident(b) :=
  (extensionality a; extensionality b).
Tactic Notation "extensionalities" ident(a) ident(b) ident(c) :=
  (extensionality a; extensionalities b c).
Tactic Notation "extensionalities" ident(a) ident(b) ident(c) ident(d) :=
  (extensionality a; extensionalities b c d).
Tactic Notation "extensionalities" ident(a) ident(b) ident(c) ident(d) ident(e) :=
  (extensionality a; extensionalities b c d e).
Tactic Notation "extensionalities" ident(a) ident(b) ident(c) ident(d) ident(e) ident(f) :=
  (extensionality a; extensionalities b c d e f).

(* short for common tactics *)

Tactic Notation "inst" := instantiate.
Tactic Notation "econs" := econstructor.
Tactic Notation "econs" int_or_var(x) := econstructor x.
Tactic Notation "i" := intros.
Tactic Notation "ii" := repeat intro.
Tactic Notation "s" := simpl.
Tactic Notation "s" ident(a) := simpl a.
Tactic Notation "s" constr(t) := simpl t.
Tactic Notation "s" "in" hyp(H) := simpl in H.
Tactic Notation "ss" := simpls.
Tactic Notation "r" := red.
Tactic Notation "r" "in" hyp(H) := red in H.
Tactic Notation "rr" := repeat red.
Tactic Notation "rr" "in" hyp(H) := repeat red in H.

(* running a tactic selectively on subgoals *)

Definition __mark__ A (a : A) : A := a.

Tactic Notation "M" :=
  match goal with [|-?G] => fold (__mark__ G) end.

Tactic Notation "Mdo" tactic(tac) :=
  first [ try match goal with [|- __mark__ _ ] => fail 2 end | unfold __mark__; tac ].

Tactic Notation "Mskip" tactic(tac) :=
  first [ match goal with [|- __mark__ _ ] => unfold __mark__ end | tac ].

Tactic Notation "Mfirst" tactic(main) ";;" tactic(post) :=
   main; (Mdo (post; M)); (Mskip post).

(* revert until *)

Ltac on_last_hyp tac :=
  match goal with [ H : _ |- _ ] => first [ tac H | fail 1 ] end.

Ltac revert_until id :=
  on_last_hyp ltac:(fun id' =>
    match id' with
      | id => idtac
      | _ => revert id' ; revert_until id
    end).

Open Scope string_scope.
Open Scope list_scope.

Fixpoint beq_str (s1 s2: string) : bool :=
  match s1, s2 with
  | "", "" => true
  | String a s1', String b s2' => if Ascii.ascii_dec a b then beq_str s1' s2' else false
  | _, _ => false
  end.

Ltac uf := (autounfold with * in *).

Tactic Notation "patout" constr(z) "in" hyp(a) :=
  pattern z in a; match goal with [a:=?f z|-_] => unfold a; clear a; set (a:=f) end.

Ltac clear_upto H :=
  repeat (match goal with [Hcrr : _ |- _ ] => first [ check_equal Hcrr H; fail 2
 | clear Hcrr ] end).

Definition _Evar_sflib_ (A:Type) (x:A) := x.

Tactic Notation "hide_evar" int_or_var(n) := let QQ := fresh "QQ" in
  hget_evar n; intro;
  lazymatch goal with [ H := ?X |- _] =>
    set (QQ := X) in *; fold (_Evar_sflib_ X) in QQ; clear H
  end.

Ltac hide_evars := repeat (hide_evar 1).

Ltac show_evars := repeat (match goal with [ H := @_Evar_sflib_ _ _ |- _ ] => unfold
 _Evar_sflib_ in H; unfold H in *; clear H end).

Ltac revert1 := match goal with [H: _|-_] => revert H end.

Lemma eqimpl: forall P Q : Prop, P = Q -> P -> Q.
Proof. by i; subst; auto. Qed.

Ltac ginduction H :=
  move H at top; revert_until H; induction H.

Tactic Notation "greflgen" constr(t) "as" ident(g)  :=
  let EQ := fresh "XEQ" in
  generalize (eq_refl t); generalize t at -2 as g
  ; intros ? EQ ?; revert EQ.

Ltac eadmit :=
  exfalso; clear; admit.

Ltac special H :=
  (* eapply mp; refine (H _). *)
  match type of H with
    | ?A -> ?B =>
      let a := fresh in assert (a: A); [|specialize (H a)]
  end.

(** Useful for e.g. [ex @nil]. *)
Ltac ex x := eapply (ex_intro _ (x _)).

Ltac inst_pairs :=
  repeat first
    [instantiate (9 := (_, _))
    |instantiate (8 := (_, _))
    |instantiate (7 := (_, _))
    |instantiate (6 := (_, _))
    |instantiate (5 := (_, _))
    |instantiate (4 := (_, _))
    |instantiate (3 := (_, _))
    |instantiate (2 := (_, _))
    |instantiate (1 := (_, _))].

(* Problem: unfold fst doesn't always result in a lambda *)
(* Ltac fold_proj := *)
(*   try match goal with |- context[fun _ : ?A * ?B => _] => *)
(*     first [fold (@fst A B) | fold (@snd A B)]; fail *)
(*   end. *)
(* Ltac fold_projH H := *)
(*   match type of H with | context[fun _ : ?A * ?B => _] => *)
(*     first [fold (@fst A B) in H | fold (@snd A B) in H]; fail *)
(*   end. *)
(* Ltac simpl_proj := *)
(*   unfold fst in *; Hdo fold_projH; fold_proj. *)

(* Lemma simpl_fst: forall A (a: A) B (b: B), *)
(*   fst (a, b) = a. *)
(* Proof. *)
(*   auto. *)
(* Qed. *)

(* Lemma simpl_snd: forall B (b: B) A (a: A), *)
(*   snd (a, b) = b. *)
(* Proof. *)
(*   auto. *)
(* Qed. *)

Ltac simpl_proj :=
  do 5 (simpl (fst (_, _)) in *; simpl (snd (_, _)) in *).
  (* ; repeat first [rewrite !simpl_fst | rewrite !simpl_snd] *)
  (* ; Hdo (fun H => repeat first [rewrite !simpl_fst in H | rewrite !simpl_snd in H]). *)

Ltac clean :=
  repeat match goal with
    | H: True |- _
      => clear H
    | H: ?x = ?y |- _
      => try (has_evar x; fail 2); try (has_evar y; fail 2);
         change x with y in H; clear H
  end
  ; simpl_proj.
  (* without the evar check, clean removes equations such as the following:
     X : length (getVal ?28711 ?28712 ?28713 ?28714) = S n *)

Tactic Notation "lhs" tactic(tac) :=
  match goal with |- ?op ?lhs ?rhs =>
    let tmp := fresh in set (tmp := rhs); tac; unfold tmp; clear tmp
  end.

(* Variant of lhs that allows prover to combine lhs/rhs tactics in
 * tacticals. For example:
 * lhs (rewrite blah); rhs (rewrite blah).
 * is allowed. lhs fails because the precedence for the tactic
 * was higher than the ";" and so tac = rewrite blah; rhs (rewrite blah).
 * TODO: Check whether it's safe to override the definition of lhs/rhs.
 *)
Tactic Notation "lhs3" tactic3(tac) :=
  match goal with |- ?op ?lhs ?rhs =>
    let tmp := fresh in set (tmp := rhs); tac; unfold tmp; clear tmp
  end.

Tactic Notation "rhs" tactic(tac) :=
  match goal with |- ?op ?lhs ?rhs =>
    let tmp := fresh in set (tmp := lhs); tac; unfold tmp; clear tmp
  end.

(* See the comment for lhs3. *)
Tactic Notation "rhs3" tactic3(tac) :=
  match goal with |- ?op ?lhs ?rhs =>
    let tmp := fresh in set (tmp := lhs); tac; unfold tmp; clear tmp
  end.

(* TODO generalize to hyps *)

(** Execute a tactic only if the goal contains no evars. *)
Tactic Notation "safe" tactic(tac) :=
  try match goal with |- ?G => try (has_evar G; fail 2); tac end.

(** Rename a hypothesis to a fresh name. *)
Ltac ren H :=
  let X := fresh H in rename H into X.

(* (** Instantiate consecutive evars. *) *)
(* Tactic Notation "insts" constr(terms) := *)
(*   Hdo (fun x => instantiate (1 := x)) terms. *)
(* (* TODO this is not very useful after all *) *)

(** Automation using econstructor.
    What it does is clear from the definition below. *)
Tactic Notation "econsby" tactic(tac) :=
  first [econstructor  1; (by tac)
        |econstructor  2; (by tac)
        |econstructor  3; (by tac)
        |econstructor  4; (by tac)
        |econstructor  5; (by tac)
        |econstructor  6; (by tac)
        |econstructor  7; (by tac)
        |econstructor  8; (by tac)
        |econstructor  9; (by tac)
        |econstructor 10; (by tac)
        |econstructor 11; (by tac)
        |econstructor 12; (by tac)
        |econstructor 13; (by tac)
        |econstructor 14; (by tac)
        |econstructor 15; (by tac)
        |econstructor 16; (by tac)
        |econstructor 17; (by tac)
        |econstructor 18; (by tac)
        |econstructor 19; (by tac)
        |econstructor 20; (by tac)
  ].

(* Youngju's Tactics *)

Lemma f_equal6 (A1 A2 A3 A4 A5 A6 B: Type) (f: A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> B)
      (x1 y1: A1) (EQ1: x1 = y1)
      (x2 y2: A2) (EQ2: x2 = y2)
      (x3 y3: A3) (EQ3: x3 = y3)
      (x4 y4: A4) (EQ4: x4 = y4)
      (x5 y5: A5) (EQ5: x5 = y5)
      (x6 y6: A6) (EQ6: x6 = y6)
  :
    <<EQ: f x1 x2 x3 x4 x5 x6 = f y1 y2 y3 y4 y5 y6>>
.
Proof. subst. reflexivity. Qed.

Lemma f_equal7 (A1 A2 A3 A4 A5 A6 A7 B: Type) (f: A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> A7 -> B)
      (x1 y1: A1) (EQ1: x1 = y1)
      (x2 y2: A2) (EQ2: x2 = y2)
      (x3 y3: A3) (EQ3: x3 = y3)
      (x4 y4: A4) (EQ4: x4 = y4)
      (x5 y5: A5) (EQ5: x5 = y5)
      (x6 y6: A6) (EQ6: x6 = y6)
      (x7 y7: A7) (EQ7: x7 = y7)
  :
    <<EQ: f x1 x2 x3 x4 x5 x6 x7 = f y1 y2 y3 y4 y5 y6 y7>>
.
Proof. subst. reflexivity. Qed.

Lemma f_equal8 (A1 A2 A3 A4 A5 A6 A7 A8 B: Type) (f: A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> A7 -> A8 -> B)
      (x1 y1: A1) (EQ1: x1 = y1)
      (x2 y2: A2) (EQ2: x2 = y2)
      (x3 y3: A3) (EQ3: x3 = y3)
      (x4 y4: A4) (EQ4: x4 = y4)
      (x5 y5: A5) (EQ5: x5 = y5)
      (x6 y6: A6) (EQ6: x6 = y6)
      (x7 y7: A7) (EQ7: x7 = y7)
      (x8 y8: A8) (EQ8: x8 = y8)
  :
    <<EQ: f x1 x2 x3 x4 x5 x6 x7 x8 = f y1 y2 y3 y4 y5 y6 y7 y8>>
.
Proof. subst. reflexivity. Qed.

Ltac rpapply_raw H :=
  first[erewrite f_equal8 | erewrite f_equal7 | erewrite f_equal6 | erewrite f_equal5 |
        erewrite f_equal4 | erewrite f_equal3 | erewrite f_equal2 | erewrite f_equal];
  [eapply H|..]; try reflexivity.

Ltac is_applied_function TARGET :=
  match TARGET with
  | ?f ?x =>
    idtac
  | _ => fail
  end
.

Ltac has_inside_strict A B :=
  match A with
  | context[B] => tryif (check_equal A B) then fail else idtac
  | _ => fail
  end
.

Ltac is_inside_others_body TARGET :=
  tryif (repeat multimatch goal with
                | [ |- context[?f ?x] ] =>
                  (* idtac f; idtac x; *)
                  tryif (has_inside_strict x TARGET)
                  then fail 2
                  else fail
                end)
  then fail
  else idtac
.

Ltac on_leftest_function TAC :=
  (* repeat *)
  multimatch goal with
  | [ |- context[?f ?x] ] =>
    tryif (is_applied_function f)
    then fail
    else
      tryif (is_inside_others_body f)
      then fail
      else TAC f
  (* else TAC constr:(f) *)
  (* TODO: What is the difference? *)
  end
.
(* TODO: more cannonical way to get leftest function? *)
(* I tried match reverse but it was not good *)
(* TODO: I want to define "get_leftest_function" *)
(* TODO: try tactic notation ? *)

Ltac leftest_rpapply H :=
  on_leftest_function ltac:(fun f =>
     (idtac f; first
                 (* TODO: why rewrite "with" doesn't work? *)
                 [ erewrite (f_equal8 f)
                 | erewrite (f_equal7 f)
                 | erewrite (f_equal6 f)
                 | erewrite (f_equal5 f)
                 | erewrite (f_equal4 f)
                 | erewrite (f_equal3 f)
                 | erewrite (f_equal2 f)
                 | erewrite (f_equal  f) | fail]); [ eapply H | .. ]; try reflexivity)
.

Ltac is_type x :=
     match type of x with
     | Type => idtac
     | Set => idtac
     | Prop => idtac (* TODO: needed? *)
     | _ => fail
     end.

Ltac is_term_applied_function TARGET :=
  match TARGET with
  | ?f ?x =>
    tryif (is_type x) then fail else idtac
  | _ => fail
  end
.

Ltac on_leftest_function_with_type TAC :=
  (* repeat *)
  multimatch goal with
  | [ |- context[?f ?x] ] =>
    tryif (is_term_applied_function f)
    then fail
    else
      tryif (is_inside_others_body f)
      then fail
      else TAC f
  end
.

Ltac rpapply H :=
  on_leftest_function_with_type ltac:(fun f =>
     (idtac f; first
                 (* TODO: why rewrite "with" doesn't work? *)
                 [ erewrite (f_equal8 f)
                 | erewrite (f_equal7 f)
                 | erewrite (f_equal6 f)
                 | erewrite (f_equal5 f)
                 | erewrite (f_equal4 f)
                 | erewrite (f_equal3 f)
                 | erewrite (f_equal2 f)
                 | erewrite (f_equal  f) | fail]); [ eapply H | .. ]; try reflexivity)
.

(* it may run infinite loop *)
Ltac all TAC :=
  repeat multimatch goal with
         | H: _ |- _ => TAC H
         end;
  try TAC
.

Ltac fold_in x H := fold x in H; fold x.

Ltac fold_all x := all ltac:(fold_in x).

Ltac clears x :=
  repeat match goal with
         | H: context[x] |- _ => clear H
         | |- context[x] => fail 2 "It appears in the goal!"
         end
.

Ltac hide_goal :=
  match goal with
  | [ |- ?G ] => let name := fresh "HIDDEN_GOAL" in
                 set (name := G); replace G with name by reflexivity
  (* ; move name at top <---- it breaks "unhide (hide X) = X". User may do it manually *)
  end.
Ltac unhide_goal :=
  match goal with
  | [ |- ?G ] => subst G
  end.
Ltac is_local_definition X :=
  hide_goal;
  tryif (unfold X)
  then (unhide_goal)
  else (unhide_goal; fail)
.
Ltac negate TAC := tryif TAC then fail else idtac.
Ltac clear_unused :=
  repeat multimatch goal with
         | [H: ?T |- _] =>
           negate ltac:(is_local_definition H);
           match (type of T) with
           | Prop => idtac
           | _ => try clear H
           end
         end
.
Goal let x := 0 in forall n: nat, False.
Proof.
  intros.
  clear_unused.
Abort.

(* TODO: Currently I use "is_local_definition" filter, but it may replaced with checking if it is Prop *)
Ltac clear_tautology :=
  repeat multimatch goal with
         | [H: ?A = ?B, H2: ?B = ?A |- _] => clear H2
         (* | [H: True |- _] => clear H *) (* clear_universal_truth takes care of this now *)
         | [H: ?X, H2: ?X |- _] =>
           negate ltac:(is_local_definition H2);
           clear H2
         (* | [H: ?A = ?A |- _] => clear H *) (* clear_universal_truth takes care of this now *)
         end
.

Ltac clear_reducible_truth :=
  let smart_tac := ss in
  repeat multimatch goal with
         | [H: ?P |- _ ] =>
           match (type of P) with
           | Prop =>
             let temp := fresh "temp" in
             tryif assert(temp: P) by (clear H; smart_tac)
             (* check if it is reducible from other premises *)
             then clear temp; clear H
             else idtac
           | _ => idtac
           end
         end
.

Ltac clear_universal_truth :=
  let smart_tac := ss in
  repeat multimatch goal with
         | [H: ?P |- _ ] =>
           match (type of P) with
           | Prop =>
             let temp := fresh "temp" in
             tryif assert(temp: P) by (all clear; smart_tac)
             (* check if it is reducible without any premise *)
             then clear temp; clear H
             else idtac
           | _ => idtac
           end
         end
.

Ltac clear_tac := repeat (clear_unused; clear_tautology; clear_universal_truth).

Ltac des_ifs_safe_aux TAC :=
  TAC;
  repeat
    multimatch goal with
    | |- context[match ?x with _ => _ end] =>
      match (type of x) with
      | { _ } + { _ } => destruct x; TAC; []
      | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; TAC; []
      end
    | H: context[ match ?x with _ => _ end ] |- _ =>
      match (type of x) with
      | { _ } + { _ } => destruct x; TAC; []
      | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; TAC; []
      end
    end.
Tactic Notation "des_ifs_safe" := des_ifs_safe_aux clarify.
Tactic Notation "des_ifs_safe" tactic(TAC) := des_ifs_safe_aux TAC.

Ltac abstr_aux x var_name :=
  let hyp_name := fresh "abstr_hyp_name" in
  remember x as var_name eqn:hyp_name; clear hyp_name
.

Tactic Notation "abstr" constr(H) := let var_name := fresh "abstr_var_name" in abstr_aux H var_name.
Tactic Notation "abstr" constr(H) ident(var_name) := abstr_aux H var_name.

Hint Rewrite
     andb_true_iff andb_false_iff
     orb_true_iff orb_false_iff
     negb_true_iff negb_false_iff

     andb_true_r andb_true_l andb_false_r andb_false_l
     orb_true_r orb_true_l orb_false_r orb_false_l
     negb_andb negb_orb negb_involutive
  : simpl_bool.

Ltac simpl_bool := unfold Datatypes.is_true; unfold is_true;  autorewrite with simpl_bool in *.

Ltac des_safe_aux TAC :=
  TAC;
  repeat (des1; TAC; [])
.

Tactic Notation "des_safe" := des_safe_aux clarify.
Tactic Notation "des_safe" tactic(TAC) := des_safe_aux TAC.

Definition admit (excuse: String.string) {T: Type} : T.  Admitted.
Tactic Notation "admit" constr(excuse) := idtac excuse; exact (admit excuse).

(* Copied from SoftwareFoundations - LibTactics.v *)
(* ---------------------------------------------------------------------- *)
(** ** Generalization *)

(** [gen X1 .. XN] is a shorthand for calling [generalize dependent]
    successively on variables [XN]...[X1]. Note that the variables
    are generalized in reverse order, following the convention of
    the [generalize] tactic: it means that [X1] will be the first
    quantified variable in the resulting goal. *)

Tactic Notation "gen" ident(X1) :=
  generalize dependent X1.
Tactic Notation "gen" ident(X1) ident(X2) :=
  gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) :=
  gen X3; gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4)  :=
  gen X4; gen X3; gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5) :=
  gen X5; gen X4; gen X3; gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5)
 ident(X6) :=
  gen X6; gen X5; gen X4; gen X3; gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5)
 ident(X6) ident(X7) :=
  gen X7; gen X6; gen X5; gen X4; gen X3; gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5)
 ident(X6) ident(X7) ident(X8) :=
  gen X8; gen X7; gen X6; gen X5; gen X4; gen X3; gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5)
 ident(X6) ident(X7) ident(X8) ident(X9) :=
  gen X9; gen X8; gen X7; gen X6; gen X5; gen X4; gen X3; gen X2; gen X1.
Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5)
 ident(X6) ident(X7) ident(X8) ident(X9) ident(X10) :=
  gen X10; gen X9; gen X8; gen X7; gen X6; gen X5; gen X4; gen X3; gen X2; gen X1.

(* ---------------------------------------------------------------------- *)

Ltac exists_prop PROP :=
  tryif
    (repeat multimatch goal with
            | [H: PROP |- _ ] => (* idtac "Found!"; idtac H; *) fail 2
            end)
  then fail
  else idtac
.

Ltac propagate_eq :=
  repeat (multimatch goal with
          | [H1: ?A = ?B, H2: ?B = ?C |- _ ] =>
            tryif (check_equal A C)
            then fail
            else
              tryif (exists_prop (A = C) + exists_prop (C = A))
              then idtac
              else
                let name := fresh "EQ_CLOSURE_TAC" in
                hexploit eq_trans; [exact H1|exact H2|]; intro name
          | [H1: ?B = ?A, H2: ?B = ?C |- _ ] =>
            tryif (check_equal A C)
            then fail
            else
              tryif (exists_prop (A = C) + exists_prop (C = A))
              then idtac
              else
                let name := fresh "EQ_CLOSURE_TAC" in
                hexploit eq_trans; [exact (eq_sym H1)|exact H2|]; intro name
          end)
.

(* get equality's transitive closure *)
(* TODO: it checks equality too naive way; "(0, 1).fst != 0" here. *)
Ltac eq_closure_tac :=
  repeat (propagate_eq; clarify); clear_tac
.

Ltac rev_all TAC :=
  repeat multimatch reverse goal with
         | H: _ |- _ => TAC H
         end;
  try TAC
.

(* Adapted from CompCert's Coqlib *)
Definition proj_sumbool (P Q: Prop) (pq: {P} + {Q}): bool := if pq then true else false.
Coercion proj_sumbool: sumbool >-> bool.

Lemma proj_sumbool_true
      P Q
      (pq: {P} + {Q})
      (PROJ: proj_sumbool pq = true)
  :
    P
.
Proof. destruct pq; ss. Qed.

Lemma proj_sumbool_is_true
      P
      (pq: {P} + {~P})
      (p: P)
  :
    proj_sumbool pq = true
.
Proof. destruct pq; ss. Qed.

Lemma proj_sumbool_false
      P Q
      (pq: {P} + {Q})
      (FALSE: proj_sumbool pq = false)
  :
    Q
.
Proof. destruct pq; ss. Qed.

Lemma proj_sumbool_is_false
      P
      (a: {P} + {~ P})
      (FALSE: ~ P)
  :
    proj_sumbool a = false
.
Proof. unfold proj_sumbool. case a; tauto. Qed.

Ltac des_sumbool :=
  repeat
    (unfold Datatypes.is_true, is_true in *;
     match goal with
     | [ H: proj_sumbool ?x = true |- _ ] => apply proj_sumbool_true in H
     | [ H: proj_sumbool ?x = false |- _ ] => apply proj_sumbool_false in H
     | [ H: true = proj_sumbool ?x |- _ ] => symmetry in H; apply proj_sumbool_true in H
     | [ H: false = proj_sumbool ?x |- _ ] => symmetry in H; apply proj_sumbool_false in H

     | [ |- proj_sumbool ?x = true ] => apply proj_sumbool_is_true
     | [ |- proj_sumbool ?x = false ] => apply proj_sumbool_is_false
     | [ |- true = proj_sumbool ?x ] => symmetry; apply proj_sumbool_is_true
     | [ |- false = proj_sumbool ?x ] => symmetry; apply proj_sumbool_is_false
     end)
.

Fixpoint update A (la: list A) (idx: nat) (a: A): (list A) :=
  match idx with
  | O =>
    match la with
    | hd :: tl => a :: tl
    | _ => la
    end
  | S midx =>
    match la with
    | hd :: tl => hd :: (update tl midx a)
    | _ => la
    end
  end
.

Lemma update_spec
      A (la: list A) idx a
  :
    forall n (LT: (n < List.length la)%nat),
      <<NTH: nth_error (update la idx a) n = if Nat.eqb n idx
                                              then Some a
                                              else nth_error la n>>.
Proof.
  ginduction la; ii; ss.
  { omega. }
  destruct n; ss.
  { des_ifs; ss. }
  destruct idx; ss.
  exploit (IHla idx a0 n); eauto. { omega. }
Qed.

Fixpoint update_err A (la: list A) (idx: nat) (a: A): option (list A) :=
  match idx with
  | O =>
    match la with
    | hd :: tl => Some (a :: tl)
    | _ => None
    end
  | S midx =>
    match la with
    | hd :: tl =>
      match (update_err tl midx a) with
      | Some tl => Some (hd :: tl)
      | _ => None
      end
    | _ => None
    end
  end
.


(* -*- coq-prog-args: ("-nois") -*- *)
Delimit Scope type_scope with type.
Delimit Scope function_scope with function.

Bind Scope type_scope with Sortclass.
Bind Scope function_scope with Funclass.

Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
Notation "A -> B" := (forall (_ : A), B) : type_scope.

Definition compose {A B C} (g : B -> C) (f : A -> B) :=
  fun x : A => g (f x).

Notation " g ∘ f " := (compose g f)
  (at level 40, left associativity) : function_scope.

Fail Check (fun x => x) ∘ (fun x => x). (* this [Check] should fail, as [function_scope] is not opened *)
Check compose ((fun x => x) ∘ (fun x => x)) (fun x => x). (* this check should succeed, as [function_scope] should be automatically bound in the arugments to [compose] *)


(** * Tutorial for Mtac2 *)
(** Author: Beta Ziliani *)
(** with fixes from Michael Soegtrop *)

(** * Introduction

Mtac2 is a typechecked language for proof automation. In its core, it
consists of a monadic type [M A] for a type [A], which is interpreted
via a tactic [mrun]. The best way of understanding the type [M A] is
as _maybe_ [A], so, for instance, a function of type [M nat] _may_
return a natural number. It can also fail or loop forever, but it can
never produce a value of a different type (that is, the interpreter is
sound). We call functions of type [M A] _Mtactics_, to distinguish
them from the usual tactics provided by Coq. *)

(** One of the key aspects of Mtac2 is that it subsumes Gallina, the
language of Coq, and it inherits from Coq the beta delta iota zeta
reduction rules. This makes programming tactics very pleasant, since
developers only need to learn the new features and their semantics,
since the rest is _exactly the same_. These new features are, among
others:

- Exceptions,
- Unbounded fixpoints,
- Unification,
- Fresh name generation,
- Abstraction of variables.
*)

(** In this tutorial we illustrate these features, building up from
simple examples. In order to execute the code in this file you will
need to install our plugin. For details, follow this link: #Mtac2 home page#
*)

(** * Simple examples *)

(** To begin working with the new language we need to import the [M]
type. *)
Require Import Mtac2.Mtac2.

(** In Mtac2 there are two major modules, in our case we are going to
use the module with basic operators, called also [M]. We import it alongside with its notations: *)
Import M.
Import M.notations.

(** In addition, we import a couple of modules from the standard
library that we are going to use in some examples. *)

Require Import Arith.Arith Arith.Div2.
Require Import Lists.List.
Require Import Strings.String.

Set Implicit Arguments.
Notation "x == y" := (beq_nat x y) (at level 60).

(** We start by showing the standard _unit_ and _bind_ operators,
which in our language are called [ret] (for return) and [bind]. The
language also defines the standard notation [x <- a; b] for
[bind]. This example computes the value [1] by passing the result of
computing [0] to the successor.
*)

Definition produces_a_value :=
  x <- ret 0;
  ret (S x).

(** We check the type of the definition. It has type [M nat]. *)

Check produces_a_value.

(** There are different ways to execute it. The first one is to call
the tactic [mrun]. *)
Definition the_value_tactic : nat.
Proof. mrun produces_a_value. Defined.

Print the_value_tactic.

(** The result should be [the_value = 1 : nat]. As you can see, [mrun
produces_a_value] solved the goal with the result of computing the
code in [produces_a_value]. *)

(** Another option is to use the [MProof] command, which implicitly
appends an [mrun] at each line. *)
Definition the_value_mproof : nat.
MProof. produces_a_value. Defined.

(** Finally, it is also possible to use the Ltac keyword [ltac:] to
execute the tactic. One advantage is that we can bake it into regular
Gallina terms. In our case, this means that we do not need to annotate
the type of the definition. *)
Definition the_value_ltac := ltac:(mrun produces_a_value).

(** Throughout the tutorial we are going to use this last one a lot,
so we better make some nice notation: *)

Notation "! t" := ltac:(mrun t) (at level 200).

(** ** Exceptions *)
(** The monad includes exceptions, like the following silly example
illustrates. [Exception]s are constructed with the constructor
[exception]. In order to make distinguishable exceptions we make them
opaque, sealing the definition with the [Qed] word. *)

Definition AnException : Exception.
  exact exception.
Qed.

(* They can be parametrized as well. *)

Definition MyException (s : string) : Exception.
  exact exception.
Qed.

(** Note how they are equal to [exception], but we can still
differentiate them. *)

Definition test_ex e :=
  mtry raise e
  with
  | AnException => ret ""%string
  | MyException "hello"%string => ret "world"%string
  | [? s] MyException s => ret s
  end.

Definition empty_string := ! test_ex AnException.
Definition world_string := ! test_ex (MyException "hello"%string).
Definition other_string := ! test_ex (MyException "other"%string).

Print empty_string.
Print world_string.
Print other_string.

(** Results should be the empty string, the string "world" and the
string "other" respectively. *)

(** If an exception is not caught, then we get a meaningful error.
The [Fail] command below will show the exception thrown by the code: *)

Fail Check (! raise (MyException "This is printed out"%string) : M nat).
(** (We need to provide a type to the expression because [ltac:]
doesn't like open terms.) *)

(** ** Unbounded fixpoints *)

(** Fixpoints in Coq should terminate to ensure soundness. Checking
termination is hard, so Coq relies on a pretty restrictive syntactic
condition to ensure termination. We allow non-termination in our
language via an unbounded fixpoint, which we call [mfix].
For instance, an endless loop can be written simply as: *)

Definition endless_loop := mfix1 f (n : nat) : M False := f n.

(** In this definition we decided to add the type annotation
[M False], since otherwise it is impossible for the type inference
mechanism to guess the type. It is important to note that the body of
[mfix] should always be of type [M]. *)

(** Uncomment the code below and execute it: it will loop forever! You
will have to interrupt the proof assistant (C-c C-c in Emacs). *)

(**[
Check (! endless_loop 0).
]*)

(** *** Endless loop... Is it still safe? *)

(** The key to understanding why it is perfectly safe to allow for
such effects is to notice that [mrun] is not a function living in the
kernel typechecker of Coq. That is, for [t] of type [M A], [mrun t]
constructs a witness for [A] only if it's safe to do so, but _it
itself is not a witness for [A]_. Take as example the definitions we
constructed so far: we used [mrun] but when we printed them we saw no
[mrun] in their proof terms.

As an exercise, we can try to break soundness of Coq by constructing an
 element of type [False] without any further hypothesis. Take the
 function [endless_loop] above, which has type [nat -> M False]. To
 get an element of type [False] we have to execute it through [mrun] as
 in the commented code. Since it will not terminate, [mrun
 (endless_loop 0)] doesn't produce an offending witness. *)

(** *** Constructing Collatz sequences *)

(** To show the use of this unbounded fixpoint we define a function
computing the #Collatz
sequence#, which cannot be defined in vanilla Coq since its
termination is a conjecture. *)

(* begin hide *)
Fixpoint is_even n :=
  match n with
    0 => true
  | S n' => negb (is_even n')
  end.
(* end hide *)

Definition collatz :=
  mfix1 f (n : nat) : M (list nat) :=
    let n := rcbv n in
    let rest :=
      if n == 1 then
        ret nil
      else if is_even n then
        f (div2 n)
      else
        f (3 * n + 1)
    in
      s <- rest;
      ret (n :: s).

(** We perform reduction on the natural number *)

(** We try it with the value [6]. *)
Definition the_sequence_6 := ! (collatz 6).

Print the_sequence_6.
(** Result: [(6 :: 3 :: 10 :: 5 :: 16 :: 8 :: 4 :: 2 :: 1 :: nil) : list nat] *)

(** ** Unification match *)

(** Mtac2 provides a powerful construct: the unification
match. Unlike the native Coq pattern matching, the unification match
let us specify any term as a pattern, even patterns containing
variables bound in the context.

For instance, the code below shows a function that searches for an
element in a list. *)

Mtac Do New Exception NotFound.
(** (This is just a handy way of declaring an exception without parameters.) *)

Definition inlist A (x : A) :=
  mfix1 f (s : list A) : M (In x s) :=
    mmatch s as s' return M (In x s') with
    | [? s'] (x :: s') => ret (in_eq _ _)
    | [? y s'] (y :: s') =>
      r <- f s';
      ret (in_cons y _ _ r)
    | _ => raise NotFound
    end.

Check inlist.

(** We also depart from the standard notation for patterns: since they
may now refer to variables in the context, we need to specify a list
of pattern variables, like [[? s']] in the first pattern. All the
variables not included in this list should be bound by the context,
like [x] in the same pattern, which is bound to the argument of the
definition. That is, this pattern matches a list containing the
element [x] in the head.
*)

(** So far we have constructed the proof terms directly, without using
the interactive mode of Coq. We can use any standard tactic ([apply],
[refine], [exact], [set], ...) with [run], although not all of them
are suitable if we want to avoid writing inferable arguments.  For
instance, if we have to prove a goal of the form [In x s] for some
list [s] and some element [x], then we would like to use [mrun (inlist
_ _)], that is, without specifying the arguments. This will help us
build more robust proof scripts, since tomorrow we may replace [x] by
some other element in the list and still get a valid proof script. *)

Example x_in_zyx (x y z : nat) : In x (z :: y :: x :: nil).
Proof.
  mrun (inlist _ _).
Qed.

(** One tricky thing about our nice notation [!] is that it doesn't
work for open terms: *)

Fail Example z_in_xyz (x y z : nat) : In z (x :: y :: z :: nil)
  := ! (inlist _ _).

(** We can still call it with the [ltac:] construct directly: *)
Example z_in_xyz (x y z : nat) : In z (x :: y :: z :: nil)
  := ltac:(mrun (inlist _ _)).

(** An alternative is to use [eval], which is similar to [mrun],
except that it performs the execution of the Mtactic after the type
inference mechanism of Coq has done its job: *)

Example y_in_zyx (x y z : nat) : In y (z :: y :: x :: nil)
  := eval (inlist _ _).

(** Behinds the scene, [eval] uses the typeclass mechanism. As a
drawback, it leaves the tactic code in the proof term: *)
Print y_in_zyx. (** Note the call to [inlist] showing up here. *)

(** *** Interaction with [Program] *)

(** When writing tactics, we can use [Program] to avoid having to
write the proof terms ourselves. As an example, we will extend our
[inlist] function to handle list concatenation in order to handle more
cases and get shorter proof terms. By using [Program], Coq will ask us
to provide (interactively) the proof terms for the cases where there is
a hole ([_]) and it cannot guess what to fill in that hole.
*)

Program
Definition inlist' A (x : A) :=
  mfix1 f (s : list A) : M (In x s) :=
    mmatch s as s' return M (In x s') with
    | [? l r] l ++ r =>
      mtry
        il <- f l;
        ret _
      with _ =>
        ir <- f r;
        ret _
      end
    | [? s'] (x :: s') => ret (in_eq _ _)
    | [? y s'] (y :: s') =>
      r <- f s';
      ret (in_cons y _ _ r)
    | _ => raise NotFound
    end.
Next Obligation.
intros; apply in_or_app; left; assumption.
Qed.
Next Obligation.
intros; apply in_or_app; right; assumption.
Qed.

(** If the list is a concatenation of two lists [l] and [r], we first
try to search for the element on [l] and, if it fails, on [r]. Notice
that the pattern is not a constructor, but the application of the
function [++] to two lists. As mentioned before, we can use _any_ Coq term
as a pattern!  It is important to make this case the first case of the
match, as the unification of the scrutinee with the pattern takes into
account beta delta iota zeta reductions. That is, if the concatenation case were
put third in the match, then the list [(x :: nil) ++ (z :: nil)] will
be matched against the pattern [(x :: s')], by reducing it to [(x :: z
:: nil)]. *)

(** One problem with [Program] is that it tends to generate
unnecessarily big proof terms. *)

Print inlist'.

(** Let's look at the proof terms generated in the obligations and plug
those terms into the holes. *)

Print inlist'_obligation_1.
Print inlist'_obligation_2.

(** The important bits are [in_or_app l r x (or_introl H)] and
[in_or_app l r x (or_intror H)]. We write our function again filling
in the holes with these two terms. *)

Definition inlist'' A (x : A) :=
  mfix1 f (s : list A) : M (In x s) :=
    mmatch s as s' return M (In x s') with
    | [? l r] l ++ r =>
      mtry
        il <- f l;
        ret (in_or_app l r x (or_introl il))
      with _ =>
        ir <- f r;
        ret (in_or_app l r x (or_intror ir))
      end
    | [? s'] (x :: s') => ret (in_eq _ _)
    | [? y s'] (y :: s') =>
      r <- f s';
      ret (in_cons y _ _ r)
    | _ => raise NotFound
    end.

(** Let's prove an example using the three functions just created to
compare the proof terms they generate.
*)

Example ex_inlist (x y z : nat) : In x ((y :: z :: nil)++(x :: z :: nil)).
Proof.
  mrun (inlist _ _).
Qed.

Example ex_inlist' (x y z : nat) : In x ((y :: z :: nil)++(x :: z :: nil)).
Proof.
  mrun (inlist' _ _).
Qed.

Example ex_inlist'' (x y z : nat) : In x ((y :: z :: nil)++(x :: z :: nil)).
Proof.
  mrun (inlist'' _ _).
Qed.

Print ex_inlist.
Print ex_inlist'.
Print ex_inlist''.

(** Inspect the result. The last example has the shortest proof term. *)

(** * A simple tautology prover *)

(** We show by example some useful constructs for dealing with Higher
Order Abstract Syntax (HOAS). As the driving example we will write a
rudimentary tautology prover similar to that found in VeriML [[1]] and
CPDT [[2]]. Compared to VeriML, our approach has the benefit that it
doesn't require any special context treatment, since for us a context is
nothing more than a Coq list. And unlike in the Ltac version
presented in [[2]], we have meaningful types to prevent ourselves from
shooting ourselves in the foot.
*)

(** ** Warming the engine: a simple propositional prover *)

(** We start with a very simple propositional prover. It considers
only three cases:

- The proposition is [True]. In this case, it returns the trivial proof [I].
- The proposition is a conjunction of [p1] and [p2]. In this case, it proves both propositions and returns the introduction form of the conjunction.
- The proposition is a disjunction of [p1] and [p2]. In this case, it tries to prove the proposition [p1], and if it fails it tries to prove the proposition [p2]. The corresponding introduction form of the disjunction is returned.
- In any other case, it raises an exception, since no proof could be found.
*)

Definition simpl_prop_auto :=
  mfix1 f (p : Prop) : M p :=
    mmatch p as p' return M p' with
    | True => ret I
    | [? p1 p2 ] p1 /\ p2 =>
         r1 <- f p1 ;
         r2 <- f p2 ;
         ret (conj r1 r2)
    | [? p1 p2]  p1 \/ p2 =>
         mtry
           r1 <- f p1 ;
           ret (or_introl r1)
         with _ =>
           r2 <- f p2 ;
           ret (or_intror r2)
         end
    | _ => raise NotFound
    end.

(** Given this definition we can easily discharge the following example. *)
Example ex1 : True /\ (False \/ True).
Proof.
  mrun (simpl_prop_auto _).
Qed.

Print ex1.

(** The proof term is exactly what we would have written by hand:

 [ex1 = conj I (or_intror I)] *)

(** ** Adding a context *)

(** Our previous function is very limited since it cannot prove
tautologies as simple as [P -> P]. To handle implications we need a
list of hypotheses where we can search for a proof of the atom we are
considering. We create a record type containing a proposition and a
witness for the proposition.  *)

Record dyn := Dyn { prop : Prop ; elem : prop }.

(** We will need to search a list of [dyn]s to find a witness for some
proposition. The [search] function below is similar to the [inlist] above,
but keying on the [prop] projector of the record. We have to prepend [Program]
because it calls a more agressive typechecker, otherwise it fails to notice
that the element in the body of the first case should return a [P]. *)

Definition search (P : Prop) :=
  mfix1 f (s:list dyn) : M P :=
    mmatch s with
    | [? (x:P) s'] (Dyn x) :: s' => ret x
    | [? d s'] d :: s' => f s'
    | _ => raise NotFound
    end.

(** The proposition in the [Dyn] constructor is implicit, since it can
be inferred from the element, so we write [Dyn x] instead of [Dyn A
x]. *)

(** The tautology prover takes a context [c] (e.g., a list of [dyn]s)
and a proposition. The first three cases are the same as before.  *)

Definition prop_auto' :=
  mfix2 f (c : list dyn) (p : Prop) : M p :=
    mmatch p in Prop as p' return M p' with
    | True => ret I
    | [? p1 p2 ] p1 /\ p2 =>
         r1 <- f c p1 ;
         r2 <- f c p2 ;
         ret (conj r1 r2)
    | [? p1 p2]  p1 \/ p2 =>
         mtry
           r1 <- f c p1 ;
           ret (or_introl r1)
         with _ =>
           r2 <- f c p2 ;
           ret (or_intror r2)
         end
    | [? (p1 p2 : Prop)] p1 -> p2 =>
          \nu x:p1,
          r <- f (Dyn x :: c) p2;
          abs_fun x r
    | [? p'] p' : Prop => search p' c
    end.

(** Let's look at the new case for handling the implication. We need
 to return an element of type [M (p1 -> p2)], that is, _maybe_ a
 function from [p1] to [p2]. Of course, we cannot simply write

[ret (fun x:p1 => f (Dyn x :: c) p2)]

since this code has type [M (p1 -> M p2)] which is not what we
want. Instead, we use two new operators: [nu] and [abs_fun]. The first one
is analogous to the nu operator in [[3]] and [[4]], but a bit more low-level.
Its type is the following: *)

About nu.

(* That is: [forall {A B}, name -> moption -> (A -> M B) -> M B].  [name] is a
structure to control the naming of the variable to be introduced, and
[moption] is a universe polymorphic [option] type. The effect of
computing [nu n None (fun x=>b)], where [b : T B], is the result of
executing [b], replacing any occurrence of [x] with a fresh
_parameter_ [a] named after [n]. If the execution results in a term
[ret t] for some [t] with [a] not appearing free in it, then the value
[ret t] is used as result for [nu n None (fun x => b)]. Otherwise, a
failure is raised. Intuitively, the idea is that it is safe to execute
the body of a function as long as it doesn't get stuck (i.e., it
shouldn't inspect its argument), and the returning value doesn't
return the argument (i.e., it shouldn't violate the context).

The name can be generated fresh (this is what the notation [\nu]
does); it can be named with a specific name (a string), in which case
it shouldn't have a name clash with other variable in scope; or it can
be generated fresh from a given string (for instance, with "H" it will
generate H0, H1, ...).

[abs_fun] abstracts over parameters created by [nu]. It has type [forall A
P (x : A), P x -> M (forall x, P x)] where [A] and [P] are left
implicit. If [a] is a parameter created by [nu] and [t] is a term with
[a] appearing free in it, then [abs_fun a t] is replaced by [ret (fun
x=>r)], where [r] is [t] with [a] replaced by [x]. That is, [a] is
abstracted from [t].

Coming back to the implication case, we use [nu] to create a parameter
[x] as a witness for [p1]. Then we add it to the list of hypothesis to
prove [p2] and get the result [r], which may refer to [x]. Therefore,
we use [abs_fun x r] to abstract [x] from the result. We encourage the
reader to check that the type of the whole expression returned in the
implication case indeed has type [M (p1 -> p2)].

Finally, we changed the last case of the algorithm: instead of
throwing an error, now we search for a witness for the proposition in
the list using the [search] function defined before.
*)

(** We create a definition to avoid passing the empty list *)
Definition prop_auto {P} :=
  @prop_auto' nil P.

(** We can now easily prove this tautology. *)
Example ex_with_implication (p q : Prop) : p -> q -> p /\ q.
Proof.
  mrun prop_auto.
Qed.

(** Again, the proof term generated is exactly what we would expect
for such a proof. *)

Print ex_with_implication.

(** Result:
[ex_with_implication = fun (p q : Prop) (H : p) (H0 : q) => conj H H0] *)

(** * Getting first order *)

(** We can generalize our algorithm very easily to deal with [forall] and
[exists]. Below is the code, where the first four cases and the last one
are the same as before. *)

Definition tauto' :=
  mfix2 f (c : list dyn) (p : Prop) : M p :=
    mmatch p as p' return M p' with
    | True => ret I
    | [? p1 p2] p1 /\ p2 =>
         r1 <- f c p1 ;
         r2 <- f c p2 ;
         ret (conj r1 r2)
    | [? p1 p2]  p1 \/ p2 =>
         mtry
           r1 <- f c p1 ;
           ret (or_introl r1)
         with _ =>
           r2 <- f c p2 ;
           ret (or_intror r2)
         end
    | [? (p1 p2 : Prop)] p1 -> p2 =>
          \nu x:p1,
          r <- f (Dyn x :: c) p2;
          abs_fun x r
    | [? A (q:A -> Prop)] (forall x:A, q x) =>
          \nu x:A,
          r <- f c (q x);
          abs_fun x r
    | [? A (q:A -> Prop)] (exists x:A, q x) =>
          X <- evar A;
          r <- f c (q X) ;
          b <- is_evar X;
          if b then
            raise NotFound
          else
            ret (ex_intro q X r)
    | [? p'] p':Prop => search p' c
    end.

(** The [forall] case is similar to the implication case from before but taking
into account the following:
- The type of [x] is any type [A], not just [Prop].
- The possible dependency of [x] in [q], the body of the [forall]. This dependency is marked by making [q] a function from [A] to [Prop]. The unification algorithm used to unify the pattern with the proposition [p] will take care of instantiating [q] with a function taking an element of type [A] and returning the body of the [forall].
- The context is not extended.

For the existential case, we create a fresh meta-variable [X] via the
command [evar], which takes a type (in this case [A]) and returns a
new meta-variable of that type. Then, we call the function recursively
with the body [q] of the existential, replacing the argument [x] with
[X]. Hopefully, the result will instantiate [X] and we return this as
the witness for the existential. If not, that is, if [X] is still
an uninstantiated meta-variable, then we raise an error.

As before, we create a definition to avoid passing the empty list:
*)

Definition tauto {P} :=
  @tauto' nil P.

(** Here is an example to test [tauto]: *)
Example ex_first_order (p q : nat -> Prop) :
  forall x, p x -> q x -> exists y, p y /\ q y.
Proof.
  mrun tauto.
Qed.

(** If we cannot instantiate an existential, then an error is thrown. *)
Example ex_fail (p q : nat -> Prop) :
  exists y, p y /\ q y.
Proof.
  Fail mrun tauto.
Abort.

(** Actually, we can omit the check for the existential and let the
user come up with the witness by itself. *)

(** * Delayed execution via [eval] *)

(** We mentioned brefly that with [eval] we can delay the execution of
the Mtactic in order to get arguments from the goal, and that we
must use it with care, as the proof term generated is bigger than with
[mrun]. This said, [eval] is particularly useful when rewriting
procedures returning equalities. Here is an example using boolean
equality of natural numbers. *)

Program Definition eq_nats  :=
  mfix2 f (x : nat) (y : nat) : M (x == y = true) :=
    mmatch (x, y)  with
    | (x, x) => [H] ret _
    | [? x1 x2] (x1 + x2, x2 + x1) => [H]
      ret _
    end.
Next Obligation.
  inversion H.
  symmetry.
  apply beq_nat_refl.
Qed.
Next Obligation.
  inversion H.
  rewrite beq_nat_true_iff.
  apply plus_comm.
Qed.
(** Notice how we use the [[H]] notation after the right arrow in the
pattern. The name [H] will be instantiated with a proof of equality of
the scrutinee with the pattern, which we use to apply [inverstion] on
it. Of course, we could (should!) avoid [Program] and write the proof
term directly, but that's unnecessary for illustrating the use of
[eval] with [rewrite], the purpose of the section. *)

(** We call the Mtactic with [eval]: *)
Example plus_S n m : n + m == m + n = true /\ m == m = true /\ n == n = true.
Proof.
  rewrite !(eval (eq_nats _ _)). (** Notice how at each rewrite it picks the right terms. *)
  auto.
Qed.

(** * Where now? *)

(** After seeing the basics of the Mtac2 infrastructure, and until
newer documentation comes, you are invited to see the examples in the
same directory as this tutorial, and the theory files. Mtac2 comes
with a lot of different useful tools. And feel free to ask any
question in the Zulip channel! [[6]] *)

(** * References *)
(** [[1]] VeriML: Typed Computation of Logical Terms inside a Language
with Effects. Antonis Stampoulis and Zhong Shao. In Proc. 2010 ACM
SIGPLAN International Conference on Functional Programming (ICFP'10).

[[2]] http://adam.chlipala.net/cpdt/

[[3]] Aleksandar Nanevski. Meta-programming with names and
necessity. In Proceedings of the seventh ACM SIGPLAN international
conference on Functional programming, ICFP'02, pages 206-217, New
York, NY, USA, 2002. ACM.

[[4]] Carsten Schuermann, Adam Poswolsky, and Jeffrey Sarnat. The
nabla-calculus. functional programming with higher-order encodings. In
Proceedings of the 7th international conference on Typed Lambda
Calculi and Applications, TLCA'05, pages 339-353, Berlin, Heidelberg,
2005. Springer-Verlag.

[[5]] https://math-comp.github.io/mcb/

[[6]] https://coq.zulipchat.com/#narrow/stream/254619-Mtac2
*)