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

#
        Simple Circuit Description Language
#
#
-   Syntax and some useful small circuits
#
#                                           *)
(*          Pascal Fradet - 2014_2015                      *)
(* ------------------------------------------------------- *)

Require Import Omega.
Require Export Signals.

Set Implicit Arguments.

(* ####################################################### *)
(** *            Syntax of circuits                        *)
(* ####################################################### *)

(* ####################################################### *)
(** **                    Logic gates                      *)
(* ####################################################### *)

Inductive gate : bus -> bus -> Set :=
| Not : gate § §
| And : gate (§#§) §
| Or  : gate (§#§) §.

(** A dependent destruction for gates without axioms *)

(* the general destruction lemma for gates *)
Lemma gate_case :
  forall S T (P : gate S T -> Type),
    (forall (pf : (§,§)=(S,T)), P (eq_rect (§,§)  (fun s => gate (fst s) (snd s)) (Not) (S,T) pf)) ->
    (forall (pf : (§#§,§)=(S,T)), P (eq_rect (§#§,§) (fun s => gate (fst s) (snd s)) (And) (S,T) pf)) ->
    (forall (pf : (§#§,§)=(S,T)), P (eq_rect (§#§,§) (fun s => gate (fst s) (snd s)) (Or)  (S,T) pf)) ->
    (forall x, P x).
Proof.
intros.
destruct x.
- specialize (X  eq_refl).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in X by (decide equality; apply eqdec_bus).
  easy.
- specialize (X0 eq_refl).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in X0 by (decide equality; apply eqdec_bus).
  easy.
- specialize (X1 eq_refl).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in X1 by (decide equality; apply eqdec_bus).
  easy.
Qed.

(* special case : Not *)
Lemma unary_gate : forall (P : gate § § -> Type), (P Not) -> (forall x, P x).
Proof.
intros.
apply gate_case; intros.
- rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus).
  apply X.
- Inverts pf.
- Inverts pf.
Qed.

(* special case : And, Or  *)
Lemma binary_gate : forall (P : gate (§#§) § -> Type), (P And) -> (P Or) -> (forall x, P x).
Proof.
intros.
apply gate_case; intros.
- Inverts pf.
- rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus).
  apply X.
- rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus).
  apply X0.
Qed.

Ltac case_gate g :=
match type of g with
| gate § §     => apply unary_gate
| gate (§#§) § => apply binary_gate
| _            =>  apply gate_case; intro _pf; inversion _pf; subst;
                  rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus)
end.

Ltac ddestruct_g_base g :=
     repeat  match goal with
           | H : context[g] |- _ => revert H
             end;
             pattern g; case_gate g; clear g.

Tactic Notation "Destruct_g" hyp(g) :=
   ddestruct_g_base g; intros.

(* Equality of gates is decidable *)
Lemma eqdec_gate S T (g1 g2:gate S T) : sumbool (g1=g2) (g1 <> g2). (* notation issue : {s=t} + {s<>t} %type *)
Proof.
destruct g1; Destruct_g g2;
try (solve [right; intro X; Inverts X]); try (left; easy).
Qed.

(*      syntactic equality of gates          *)
Fixpoint beq_gate S T U V (g1:gate S T) (g2:gate U V): bool :=
match g1,g2 with
| Not , Not  => true
| And , And  => true
| Or  , Or   => true
|  _  , _    => false
end.

(** Syntactic equality of gates and input bus implies equality of output buses *)
Lemma beq_gate_eq_out : forall S T U (g1:gate S T) (g2:gate S U),
                        beq_gate g1 g2 = true -> T=U.
Proof.
introv H. destruct g1; Destruct_g g2; easy.
Qed.

(** Syntactic equality of gates and types implies equality of gates *)
Lemma beq_gate_imp_eq : forall S T (g1 g2:gate S T), beq_gate g1 g2 = true -> g1=g2.
Proof.
induction g1; introv H; Destruct_g g2; Inverts H; try easy.
Qed.

Lemma beq_gate_reflx : forall S T (g:gate S T), beq_gate g g = true.
Proof.
destruct g; easy.
Qed.

(* ####################################################### *)
(** **                  Plugs                              *)
(* ####################################################### *)
(**               Wiring primitives                        *)
Inductive plug : bus -> bus -> Set :=
| Pid : forall S, plug S S
| Fork: forall S, plug S (S#S)
| Swap: forall S T, plug (S#T) (T#S)
| Lsh : forall S T U, plug ((S#T)#U) (S#(T#U))
| Rsh : forall S T U, plug (S#(T#U)) ((S#T)#U).

(** A dependent destruction for plugs without axioms *)

(* the general destruction lemma for plugs *)

(* the general destruction lemma for plugs *)

Lemma plug_case :
  forall S T (P : plug S T -> Type),
    (forall A (_pf : (A,A)=(S,T)),
            P (eq_rect (A,A)  (fun s => plug (fst s) (snd s)) (Pid A) (S,T) _pf)) ->
    (forall A (_pf : (A,A#A)=(S,T)),
            P (eq_rect (A,A#A) (fun s => plug (fst s) (snd s)) (Fork A) (S,T) _pf)) ->
    (forall A B (_pf : (A#B,B#A)=(S,T)),
            P (eq_rect (A#B,B#A) (fun s => plug (fst s) (snd s)) (Swap A B)  (S,T) _pf)) ->
    (forall A B C (_pf : ((A#B)#C,A#(B#C))=(S,T)),
            P (eq_rect ((A#B)#C,A#(B#C)) (fun s => plug (fst s) (snd s)) (Lsh A B C)  (S,T) _pf)) ->
    (forall A B C (_pf : (A#(B#C),(A#B)#C)=(S,T)),
            P (eq_rect (A#(B#C),(A#B)#C) (fun s => plug (fst s) (snd s)) (Rsh A B C)  (S,T) _pf)) ->
    (forall x, P x).
Proof.
intros.
destruct x.
- specialize (X S eq_refl).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in X by (decide equality; apply eqdec_bus).
  easy.
- specialize (X0 S eq_refl).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in X0 by (decide equality; apply eqdec_bus).
  easy.
- specialize (X1 S T eq_refl).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in X1 by (decide equality; apply eqdec_bus).
  easy.
- specialize (X2 S T U eq_refl).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in X2 by (decide equality; apply eqdec_bus).
  easy.
- specialize (X3 S T U eq_refl).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in X3 by (decide equality; apply eqdec_bus).
  easy.
Qed.

Ltac case_plug p :=
     apply plug_case; intros; inversion _pf; try subst;
     try (rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus));
     try (
     match goal with
   | H : context[eq_rect] |- _ =>  rewrite <- Eqdep_dec.eq_rect_eq_dec in H  by (decide equality; apply eqdec_bus)
     end).

(* rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus). *)

Ltac ddestruct_p_base p :=
     repeat  match goal with
           | H : context[p] |- _ => revert H
             end;
             pattern p; case_plug p; clear p.

Tactic Notation "Destruct_p" hyp(p) := ddestruct_p_base p; intros.

(**             Equality of plugs             *)

(* Equality of plugs is decidable             *)

Lemma eqdec_plug S T (p1 p2:plug S T) : sumbool (p1=p2) (p1 <> p2). (* notation issue : {s=t} + {s<>t} %type *)
Proof.
destruct p1; pattern p2; Destruct_p p2; try easy.
- rewrite H0 in H1. symmetry in H1; apply S_diff_S_T in H1; false.
- Inverts H1.
  rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus).
  right; intro G1; Inverts G1.
- Inverts H1 as H1.  apply S_diff_S_T in H1; false.
- Inverts H1 as H1. symmetry in H1; apply S_diff_S_T in H1; false.
- apply S_diff_S_T in H1; false.
- rewrite <- H0 in H2. apply S_diff_S_T in H2; false.
- rewrite <- H2 in H0. Inverts H0.
  symmetry in H3. apply S_diff_T_S in H3; false.
- Inverts H0. symmetry in H1. apply S_diff_S_T in H1; false.
- Inverts H1. rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus).
  right; intro G1; Inverts G1.
- symmetry in H1. apply S_diff_T_S in H1; false.
- Inverts H3. rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus).
  right; intro G1; Inverts G1.
- Inverts H1. rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus).
  right; intro G1; Inverts G1.
- Inverts H1. symmetry in H0. apply S_diff_S_T in H0; false.
- Inverts H2. symmetry in H0. apply S_diff_T_S in H0; false.
- Inverts H3. rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus).
  right; intro G1; Inverts G1.
- rewrite H0 in H2.
  assert (X:depth_bus S = depth_bus ((S#T)#B)) by (rewrite H2; easy).
  cbn in X. omega.
- Inverts H1 as G1 G2. apply S_diff_S_T in G1; false.
- Inverts H1 as G1 G2. symmetry in G1. apply S_diff_S_T in G1; false.
- Inverts H2. rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus).
  right; intro G1; Inverts G1.
- rewrite H2 in H0.
  assert (X:depth_bus S = depth_bus ((S#T)#B)) by (rewrite H0; easy).
  cbn in X. omega.
Qed.

(* syntactic equality of plugs (not checking types) *)
Fixpoint beq_plug S T U V (p1:plug S T) (p2:plug U V): bool :=
match p1,p2 with
| Pid _ , Pid _          => true
| Fork _ , Fork _        => true
| Swap _ _ , Swap _ _    => true
| Lsh _ _ _ , Lsh _ _ _  => true
| Rsh _ _ _ , Rsh _ _ _  => true
|  _  , _  => false
end.

(** Syntactic equality of gates and input bus implies equality of output buses *)
Lemma beq_plug_eq_out : forall S T U (p1:plug S T) (p2:plug S U),
                        beq_plug p1 p2 = true -> T=U.
intros. destruct p1; Destruct_p p2; Inverts H; try easy.
- induction S; Inverts H1.
- induction U; Inverts H1.
Qed.

(** Syntactic equality of gates and types implies equality of gates *)

Lemma beq_plug_imp_eq : forall S T (p1 p2:plug S T), beq_plug p1 p2 = true -> p1=p2.
Proof.
induction p1; introv H; Destruct_p p2; try easy.
- Inverts H2. symmetry in H0; apply S_diff_T_S in H0; false.
- Inverts H2.
  rewrite <- Eqdep_dec.eq_rect_eq_dec  in H by (decide equality; apply eqdec_bus).
  Inverts H.
- Inverts H2. apply S_diff_S_T in H1; false.
- Inverts H2. apply S_diff_T_S in H3; false.
- apply S_diff_S_T in H2; false.
- rewrite <- H1 in H3. apply S_diff_S_T in H3; false.
- Inverts H1. Inverts H3. apply S_diff_T_S in H4; false.
- Inverts H1. symmetry in H2. apply S_diff_S_T in H2; false.
- Inverts H2. rewrite <- Eqdep_dec.eq_rect_eq_dec  in H by (decide equality; apply eqdec_bus).
  Inverts H.
- symmetry in H3. apply S_diff_S_T in H3; false.
- Inverts H4. rewrite <- Eqdep_dec.eq_rect_eq_dec  in H by (decide equality; apply eqdec_bus).
  Inverts H.
- Inverts H2. rewrite <- Eqdep_dec.eq_rect_eq_dec  in H by (decide equality; apply eqdec_bus).
  Inverts H.
- Inverts H2. apply S_diff_T_S in H3; false.
- Inverts H3. symmetry in H1. apply S_diff_T_S in H1; false.
- Inverts H4. rewrite <- Eqdep_dec.eq_rect_eq_dec  in H by (decide equality; apply eqdec_bus).
  Inverts H.
- rewrite H1 in H3. assert (X:depth_bus S = depth_bus ((S#T)#B)) by (rewrite H3; easy).
  cbn in X. omega.
- Inverts H2. apply S_diff_S_T in H1; false.
- Inverts H2. symmetry in H1. apply S_diff_S_T in H1; false.
- Inverts H3. rewrite <- Eqdep_dec.eq_rect_eq_dec  in H by (decide equality; apply eqdec_bus).
  Inverts H.
- rewrite H3 in H1. assert (X:depth_bus S = depth_bus ((S#T)#B)) by (rewrite H1; easy).
  cbn in X. omega.
Qed.

Lemma beq_plug_reflx : forall S T (p:plug S T), beq_plug p p = true.
Proof.
destruct p; try easy.
- induction S; easy.
- induction S; easy.
Qed.

(* ####################################################### *)
(** **                  Circuits                           *)
(* ####################################################### *)

Inductive circuit : bus -> bus -> Set :=
| Cgate : forall S T, gate S T -> circuit S T
| Cplug : forall S T, plug S T -> circuit S T
| Cseq  : forall S T U, circuit S T -> circuit T U -> circuit S U
| Cpar  : forall S T U V, circuit S T -> circuit U V -> circuit (S#U) (T#V)
| Cloop : forall S T, bool -> circuit (S#§) (T#§) -> circuit S T.

(** A dependent destruction for circuits without axioms *)
(* the general destruction lemma for circuits *)

Lemma circuit_case :
  forall S T (P : circuit S T -> Type),
    (forall (g:gate S T), P (Cgate g)) ->
    (forall (g:plug S T), P (Cplug g)) ->
    (forall U (c1:circuit S U) (c2:circuit U T), P (Cseq c1 c2)) ->
    (forall S1 S2 T1 T2 (c1:circuit S1 T1) (c2:circuit S2 T2) (_pf : (S1#S2,T1#T2)=(S,T)),
            P (eq_rect (S1#S2,T1#T2) (fun s => circuit (fst s) (snd s)) (Cpar c1 c2)  (S,T) _pf)) ->
    (forall (b:bool) (c:circuit (S#§) (T#§)), P (Cloop b c)) ->
    (forall x, P x).
Proof.
introv ? ? ? H ?.
destruct x as [?|?|?|S T U V c1 c2|?]; try easy.
- specialize (H S U T V c1 c2 eq_refl).
  rewrite <- Eqdep_dec.eq_rect_eq_dec in H by (decide equality; apply eqdec_bus).
  easy.
Qed.

Ltac case_circuit c :=
     apply circuit_case; intros; try inversion _pf; try subst;
     try (rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus));
     try (
     match goal with
   | H : context[eq_rect] |- _ =>  rewrite <- Eqdep_dec.eq_rect_eq_dec in H  by (decide equality; apply eqdec_bus)
     end).

(* rewrite <- Eqdep_dec.eq_rect_eq_dec by (decide equality; apply eqdec_bus). *)

Ltac ddestruct_c_base c :=
     repeat  match goal with
           | H : context[c] |- _ => revert H
             end;
             pattern c; case_circuit c; clear c.

Tactic Notation "Destruct_c" hyp(c) := ddestruct_c_base c; intros.

Lemma eqdec_circuit S T (c1 c2:circuit S T) : sumbool (c1 = c2) (c1 <> c2). (* {s=t} + {s<>t} %type *)
Proof.
induction c1.
- destruct c2; try (solve [right; intro H; Inverts H]).
  destruct (eqdec_gate g g0).
  left. subst. easy.
  right. intro H. apply n. Inverts H. easy.
- destruct c2; try (solve [right; intro H; Inverts H]).
  destruct (eqdec_plug p p0).
  left. subst. easy.
  right. intro H. apply n. Inverts H. easy.
- destruct c2; try (solve [right; intro H; Inverts H]).
  destruct (eqdec_bus T T0).
  + subst. destruct (IHc1_1 c2_1); destruct (IHc1_2 c2_2); subst;
    try (right; intro H; apply n; Inverts H; easy).
    left. easy.
  + right. intro H. Inverts H. apply n. easy.
- Destruct_c c2; try (solve [right; intro H; Inverts H]).
  destruct (IHc1_1 c1); destruct (IHc1_2 c0); subst;
  try (right; intro H; apply n; Inverts H; easy). easy.
- destruct c2; try (solve [right; intro H; Inverts H]).
  destruct (bool_dec b b0); destruct (IHc1 c2); subst;
  try (right; intro H; apply n; Inverts H; easy).
  left; easy.
Defined.

(** syntactic equality of circuits (not checking types) *)
Fixpoint beq_circuit S T U V (c1:circuit S T) (c2:circuit U V): bool :=
match c1,c2 with
| Cgate g1, Cgate g2       => beq_gate g1 g2
| Cplug p1, Cplug p2       => beq_plug p1 p2
| Cseq d1 d2, Cseq e1 e2   => (beq_circuit d1 e1) && (beq_circuit d2 e2)
| Cpar d1 d2, Cpar e1 e2   => (beq_circuit d1 e1) && (beq_circuit d2 e2)
| Cloop b1 d1, Cloop b2 d2 => (eqb b1 b2) && (beq_circuit d1 d2)
|  _   , _                 => false
end.

(** Syntactic equality of circuits and input bus implies equality of output buses *)

Lemma beq_cir_eq_out : forall S T (c1:circuit S T) U (c2:circuit S U), beq_circuit c1 c2 = true -> T=U.
induction c1; introv H; Destruct_c c2; Inverts H.
- apply beq_gate_eq_out in H1. easy.
- apply beq_plug_eq_out in H1. easy.
- apply andb_prop in H1. destruct H1 as [H1 H2].
  apply IHc1_1 in H1. subst. apply IHc1_2 in H2. easy.
- apply andb_prop in H1. destruct H1 as [H1 H2].
  apply IHc1_1 in H1. subst. apply IHc1_2 in H2. subst. easy.
- apply andb_prop in H1. destruct H1 as [H1 H2].
  apply IHc1 in H2. subst. Inverts H2. easy.
Qed.

(** Syntactic equality of circuits and types implies equality of gates *)
Lemma beq_circuit_imp_eq : forall S T (x y:circuit S T), beq_circuit x y=true -> x=y.
Proof.
induction x; introv H; Destruct_c y; Inverts H.
- apply beq_gate_imp_eq in H1. subst. easy.
- apply beq_plug_imp_eq in H1. subst. easy.
- apply andb_prop in H1. destruct H1 as [H1 H2].
  destruct (eqdec_bus T U0).
  + subst. apply IHx1 in H1. apply IHx2 in H2. subst. easy.
  + apply beq_cir_eq_out in H1. false.
- apply andb_prop in H1. destruct H1 as [H1 H2].
  apply IHx1 in H1. apply IHx2 in H2. subst. easy.
- apply andb_prop in H1. destruct H1 as [H1 H2].
  apply IHx in H2. apply eqb_prop in H1.
  subst. easy.
Qed.

Lemma beq_circuit_reflx : forall S T (c:circuit S T), beq_circuit c c =true.
Proof.
induction c; cbn.
- apply beq_gate_reflx.
- apply beq_plug_reflx.
- rewrite IHc1. rewrite IHc2. easy.
- rewrite IHc1. rewrite IHc2. easy.
- rewrite IHc. rewrite eqb_reflx. easy.
Qed.

(* ####################################################### *)
(** **                  Notations                          *)
(* ####################################################### *)

Notation "'NOT'"       := (Cgate Not) (at level 40).
Notation "'AND'"       := (Cgate And) (at level 40).
Notation "'OR'"        := (Cgate Or) (at level 40).
Notation "'ID'"        := (Cplug (Pid _)) (at level 40).
Notation "'FORK'"      := (Cplug (Fork _)) (at level 40).
Notation "'SWAP'"      := (Cplug (Swap _ _)) (at level 40).
Notation "'LSH'"       := (Cplug (Lsh _ _ _)) (at level 40).
Notation "'RSH'"       := (Cplug (Rsh _ _ _)) (at level 40).
Notation "-| X , Y |-" := (Cpar X Y)   (at level 50).
Notation "-{ X }- C"   := (Cloop X C)   (at level 60, X ident).
Notation "X '-o-' Y"   := (Cseq X Y)   (at level 0).

(** **              Classes of circuits                *)

Inductive combinatorial : forall S T, circuit S T -> Prop :=
| Combgate: forall S T g, combinatorial (@Cgate S T g)
| Combplug: forall S T p, combinatorial (@Cplug S T p)
| Combseq : forall S T U c1 c2,
            combinatorial c1 -> combinatorial c2 -> combinatorial (@Cseq S T U c1 c2)
| Combpar : forall S T U V c1 c2,
            combinatorial c1 -> combinatorial c2 -> combinatorial (@Cpar S T U V c1 c2).
Hint Constructors combinatorial.

Fixpoint is_comb S T (c: circuit S T ): bool :=
match c with
| Cgate g    => true
| Cplug g    => true
| Cseq c1 c2 => andb (is_comb c1) (is_comb c2)
| Cpar c1 c2 => andb (is_comb c1) (is_comb c2)
| Cloop b c  => false
end.

Lemma comb_equiv_is_comb : forall S T (c:circuit S T), combinatorial c <-> is_comb c = true.
Proof.
split.
- introv H. induction H.
  + easy.
  + easy.
  + cbn. rewrite IHcombinatorial1. rewrite IHcombinatorial2. easy.
  + cbn. rewrite IHcombinatorial1. rewrite IHcombinatorial2. easy.
- introv H. induction c as [?|?|? ? ? ? IH1 ? IH2|? ? ? ? ? IH1 ? IH2|?].
  + constructor.
  + constructor.
  + cbn in H. apply andb_true_iff in H. destruct H as [H1 H2].
    apply IH1 in H1. apply IH2 in H2. constructor; easy.
  + cbn in H. apply andb_true_iff in H. destruct H as [H1 H2].
    apply IH1 in H1. apply IH2 in H2. constructor; easy.
  + Inverts H.
Qed.

Inductive wiring : forall S T, circuit S T -> Prop :=
| Pplug: forall S T p, wiring (@Cplug S T p)
| Pseq : forall S T U c1 c2,
            wiring c1 -> wiring c2 -> wiring (@Cseq S T U c1 c2)
| Ppar : forall S T U V c1 c2,
            wiring c1 -> wiring c2 -> wiring (@Cpar S T U V c1 c2).
Hint Constructors wiring.

Fixpoint is_wiring S T (c: circuit S T ): bool :=
match c with
| Cgate g    => false
| Cplug  g   => true
| Cseq c1 c2 => andb (is_wiring c1) (is_wiring c2)
| Cpar c1 c2 => andb (is_wiring c1) (is_wiring c2)
| Cloop b c  => false
end.

Lemma wiring_equiv_is_wiring : forall S T (c:circuit S T), wiring c <-> is_wiring c = true.
Proof.
split.
- introv H. induction H.
  + easy.
  + cbn. rewrite IHwiring1. rewrite IHwiring2. easy.
  + cbn. rewrite IHwiring1. rewrite IHwiring2. easy.
- introv H. induction c; Inverts H; constructor;
  apply andb_true_iff in H1; destruct H1; easy.
Qed.

Inductive sequential : forall S T, circuit S T -> Prop :=
| Seqseql : forall S T U c1 c2,
            sequential c1 -> sequential (@Cseq S T U c1 c2)
| Seqseqr : forall S T U c1 c2,
            sequential c2 -> sequential (@Cseq S T U c1 c2)
| Seqparl : forall S T U V c1 c2,
            sequential c1 -> sequential (@Cpar S T U V c1 c2)
| Seqparr : forall S T U V c1 c2,
            sequential c2 -> sequential (@Cpar S T U V c1 c2)
| Seqloop : forall S T b c, sequential (@Cloop S T b c).
Hint Constructors sequential.

Lemma dec_comb : forall S T (c:circuit S T), combinatorial c \/ ~combinatorial c.
Proof.
introv; induction c as [?|?| ? ? ? ? IH1 ? IH2 | ? ? ? ? ? IH1 ? IH2 | ? ? ? ? IH].
- left. constructor.
- left. constructor.
- destruct IH1; destruct IH2.
  + left. constructor; easy.
  + right. intro N. Inverts N. false.
  + right. intro N. Inverts N. false.
  + right. intro N. Inverts N. false.
- destruct IH1; destruct IH2.
  + left. constructor; easy.
  + right. intro N. Inverts N. false.
  + right. intro N. Inverts N. false.
  + right. intro N. Inverts N. false.
- right. intro N. Inverts N.
Qed.

Lemma plug_imp_comb : forall S T (c:circuit S T), wiring c -> combinatorial c.
Proof. introv H. induction H; easy. Qed.

Lemma not_comb_seq : forall S T U (c1:circuit S T) (c2:circuit T U),
                     ~ combinatorial (c1) -o- (c2) -> ~ combinatorial c1 \/ ~ combinatorial c2.
Proof.
introv H.
set (X1:= dec_comb c1). set (X2:= dec_comb c2).
destruct X1; destruct X2; easy.
Qed.

Lemma not_comb_par : forall S T U V (c1:circuit S T) (c2:circuit U V),
                     ~ combinatorial (-|c1,c2|-) -> ~ combinatorial c1 \/ ~ combinatorial c2.
Proof.
introv H.
set (X1:= dec_comb c1). set (X2:= dec_comb c2).
destruct X1; destruct X2; easy.
Qed.

Lemma seq_eq_notcomb : forall S T (c:circuit S T), sequential c <-> ~combinatorial c.
Proof.
split; introv H.
- induction H; introv C; Inverts C; false.
- induction c.
  + false; apply H. easy.
  + false; apply H. easy.
  + apply not_comb_seq in H. destruct H as [H|H].
    * apply IHc1 in H. apply Seqseql; easy.
    * apply IHc2 in H. apply Seqseqr; easy.
  +  apply not_comb_par in H. destruct H as [H|H].
    * apply IHc1 in H. apply Seqparl. easy.
    * apply IHc2 in H. apply Seqparr; easy.
  + easy.
Qed.

Inductive nofork_circuit : forall S T, circuit S T -> Prop :=
(*| NFC1 : forall S g, (g<>(@Fork S)) -> nofork_circuit (@Cgate S (S#S) g) *)
| NFC0 : nofork_circuit (NOT)
| NFC1 : nofork_circuit (AND)
| NFC2 : nofork_circuit (OR)
| NFC3 : forall S, nofork_circuit (Cplug (Pid S))
| NFC4 : forall S T, nofork_circuit (Cplug (Swap S T))
| NFC5 : forall S T U, nofork_circuit (Cplug (Lsh S T U))
| NFC6 : forall S T U, nofork_circuit (Cplug (Rsh S T U))
| NFC7 : forall S T U c1 c2, nofork_circuit c1 -> nofork_circuit c2 -> nofork_circuit (@Cseq S T U c1 c2)
| NFC8 : forall S T U V c1 c2,
         nofork_circuit c1 -> nofork_circuit c2 -> nofork_circuit (@Cpar S T U V c1 c2)
| NFC9 : forall S T c b,
         nofork_circuit c -> nofork_circuit (@Cloop S T b c).
Hint Constructors nofork_circuit.

(** **           Some useful subcircuits                *)

(**                     Plugs                           *)

(** shuffle : ((a,b),(c,d)) -> ((a,c),(b,d))  *)
Definition shuffle a b c d : circuit ((a#b)#(c#d)) ((a#c)#(b#d))
           := LSH-o--|ID,SWAP|--o--|ID,LSH|--o-RSH-o--|ID,SWAP|-.

(** DUPL : (a,b) -> ((a,b),b)                 *)
Definition DUPL a b : circuit (a#b) ((a#b)#b)
           :=-|ID,FORK|- -o- RSH.

(** DIST : ((a,b),c) -> ((a,c),(b,c))         *)
Definition DIST a b c : circuit ((a#b)#c) ((a#c)#(b#c))
           :=-|ID,FORK|- -o- LSH-o--|ID,RSH -o- SWAP|--o- RSH.

(** SWAP_LR : ((a,b),c) -> ((a,c),b)          *)
Definition SWAP_LR a b c : circuit ((a#b)#c) ((a#c)#b)
           :=LSH-o--|ID,SWAP|--o-RSH.

(** SWAP_LS : ((a,b),c) -> (a,(c,b))          *)
Definition SWAP_LS a b c : circuit ((a#b)#c) (a#(c#b))
           :=LSH-o--|ID,SWAP|-.

(** SWAP_RL : (a,(b,c)) -> (b,(a,c))          *)
Definition SWAP_RL a b c : circuit (a#(b#c)) (b#(a#c))
           :=RSH-o--|SWAP,ID|--o-LSH.

(** SWAP32 : (a,(b,c)) -> (c,(b,a))          *)
Definition SWAP32 a b c : circuit (a#(b#c)) (c#(b#a))
           :=RSH-o--|SWAP,ID|--o-SWAP.

(** Cicuits emmiting constant values (without glitches)  *)
Definition Out0 : circuit § §
           := FORK -o--|NOT,ID|--o-AND.
Definition Out1 : circuit § §
           := FORK -o--|NOT,ID|--o-OR.

(**      Multiplexer 2 to 1                              *)
(* Mux21 select XO X1 = X0 if select = 0
                      = X1 if select = 1                 *)
Definition Mux21: circuit (§#(§#§)) §
           :=  -|FORK,ID|--o-RSH-o--|LSH-o-SWAP,ID|--o-LSH-o--|-|NOT,ID|--o-AND,AND|--o-OR.

(** Simple sequentialy-organised memory cell  *)
Definition Celb (b:bool): circuit § § := -{b}-SWAP.

(** Memory cells initialized to false or true *)
Definition Celf : circuit § § := -{false}-SWAP.
Definition Celt : circuit § § := -{true}-SWAP.

(** Memory cell with enable signal: (data, enable)out- if enable=1 then re-write *)
Definition CelbE (b:bool): circuit (§ # §) §
           := -{b}-(-|SWAP,FORK|--o-RSH-o-SWAP-o--|ID,LSH-o--|ID,SWAP|--o-Mux21|-).

(** Comparator:: 1 when not equal      *)
Definition eqG: circuit (§ # §) §
           := -|FORK,FORK|--o-(shuffle § § § §)-o--|AND,-|NOT,NOT|--o-AND|--o-OR-o-NOT.

(* XOR : equivalent to eqG *)
Definition XOR: circuit (§ # §) §
           := -|FORK,FORK|--o-(shuffle § § § §)-o--|OR,AND-o-NOT|--o-AND.

(** Majority voter for 3 inputs *)
Definition Voter31 : circuit ((§#§)#§) §
           := -|FORK,FORK|--o-LSH-o- -|AND,LSH|-
              -o--|ID, -|ID,RSH|- |- -o- -|ID, -|ID,SWAP|- |-
              -o--|ID,RSH|- -o--|ID, -|AND,AND|- |-
              -o--|ID,OR|--o-OR.

(** Triplicated majority voters 3-1  *)
Definition Tvoter31 : circuit  ((§#§)#§) ((§#§)#§)
           := FORK -o--|FORK-o--|Voter31,Voter31|-,Voter31|-.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Finite arrays                                                           *
**************************************************************************)

(** UNDER CONSTRUCTION *)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibReflect
  LibRelation LibList LibInt LibOperation LibEpsilon
  LibSet LibMap.
Require Export LibBag.

(* todo: move *)

Parameter range : int -> int -> set int.

(* ********************************************************************** *)
(** * Construction of arrays based on maps *)

(* ---------------------------------------------------------------------- *)
(** ** Basic definitions *)

Record array_raw (A:Type) := {
  array_length : int;
  array_support : map int A }.

Record array_wf A (t:array_raw A) := {
  array_pos : array_length t >= 0;
  array_dom : dom (array_support t) = range 0 (array_length t) }.

Definition array (A:Type) := { t : array_raw A | array_wf t }.

Definition length A (t:array A) :=
  array_length (proj1_sig t).

Definition read_impl `{Inhab A} (t:array A) (i:int) : A :=
  (array_support (proj1_sig t))\(i).

Program Definition update_impl A (t:array A) (i:int) (v:A) : array A :=
  Build_array_raw (length t) ((array_support (proj1_sig t))\(i := v)).
Next Obligation.
  destruct t as [t [Wp Wd]]. constructor; unfold length; simpl.
  auto.
  skip. (* todo: dom udpate *)
Defined.

Definition binds_impl A (t:array A) (i:int) (v:A) :=
  binds (array_support (proj1_sig t)) i v.

Axiom make : forall A (n:int) (v:A), array A.

(* ---------------------------------------------------------------------- *)
(** ** Notation through typeclasses *)

Instance read_inst : forall `{Inhab A}, BagRead int A (array A).
  constructor. rapply (@read_impl A H). Defined.
Instance update_inst : forall A, BagUpdate int A (array A).
  constructor. rapply (@update_impl A). Defined.
Instance binds_inst : forall A, BagBinds int A (array A).
  constructor. rapply (@binds_impl A). Defined.

Global Opaque array read_inst update_inst binds_inst.

(* ---------------------------------------------------------------------- *)
(** ** Index for arrays *)

Instance array_index : forall A, BagIndex (array A) int.
Proof. intros. constructor. exact (fun t i => index (length t) i). Defined.

Lemma array_index_def : forall A (t:array A) i,
  index t i = index (length t) i.
Proof. auto. Qed.

Lemma array_index_bounds : forall A (t:array A) i,
  index t i = (0 <= i < length t).
Proof. auto. Qed.

Lemma array_index_prove : forall A (t:array A) i,
  0 <= i < length t -> index t i.
Proof. intros. rewrite~ array_index_def. Qed.

Lemma index_array_length : forall A (t : array A) n i,
  index n i -> n = length t -> index t i.
Proof. intros. subst. rewrite~ array_index_def. Qed.

Global Opaque array_index.

(* ********************************************************************** *)
(** * Properties of arrays *)

(* todo *)
Axiom length_update : forall A (t:array A) i v,
  length (t\(i:=v)) = length t.
(* Axiom length_update_prove : forall A (t:array A) i v n,
  length t = n -> length (t\(i:=v)) = n. *)
Axiom array_update_read_eq : forall `{Inhab A} (t:array A) (i:int) (v:A),
  index t i -> (t\(i:=v))\(i) = v.
Axiom array_update_read_neq : forall `{Inhab A} (t:array A) (i j:int) (v:A),
  index t j -> i<>j -> (t\(i:=v))\(j) = t\(j).
Axiom array_make_read : forall `{Inhab A} (i n:int) (v:A),
  index n i -> (make n v)\(i) = v.

Axiom index_update : forall `{Inhab A} (T:array A) i j (v:A),
  index T i -> index (T\(j:=v)) i.
Axiom index_make : forall `{Inhab A} n i (v:A),
  index n i -> index (make n v) i.
Axiom index_array_length_eq : forall A (t : array A) i,
  index (length t) i -> index t i.
Axiom length_make : forall A n (v:A),
  length (make n v) = n.

Hint Rewrite @array_make_read @length_update @array_update_read_eq @array_update_read_neq : rew_array.

Tactic Notation "rew_array" :=
  autorewrite with rew_array.
Tactic Notation "rew_array" "in" hyp(H) :=
  autorewrite with rew_array in H.
Tactic Notation "rew_array" "in" "*" :=
  autorewrite with rew_array in *.

Tactic Notation "rew_array" "~" :=
  rew_array; auto_tilde.
Tactic Notation "rew_array" "*" :=
  rew_array; auto_star.
Tactic Notation "rew_array" "~" "in" hyp(H) :=
  rew_array in H; auto_tilde.
Tactic Notation "rew_array" "*" "in" hyp(H) :=
  rew_array in H; auto_star.

(* todo : fix bug in rewriting order *)

Hint Rewrite @array_update_read_eq : rew_arr.

Tactic Notation "rew_arr" :=
  autorewrite with rew_arr.
Tactic Notation "rew_arr" "in" hyp(H) :=
  autorewrite with rew_arr in H.
Tactic Notation "rew_arr" "in" "*" :=
  autorewrite with rew_arr in *.

Tactic Notation "rew_arr" "~" :=
  rew_arr; auto_tilde.
Tactic Notation "rew_arr" "*" :=
  rew_arr; auto_star.
Tactic Notation "rew_arr" "~" "in" hyp(H) :=
  rew_arr in H; auto_tilde.
Tactic Notation "rew_arr" "*" "in" hyp(H) :=
  rew_arr in H; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Structural properties

Section Instances.
Variables (A:Type).

Transparent map empty_inst single_bind_inst binds_inst
 union_inst dom_inst disjoint_inst.

Global Instance map_union_empty_l : Union_empty_l (T:=map A B).
Proof.
  constructor. intros_all. simpl.
  unfold union_impl, empty_impl, map. simpl. extens~.
Qed.

Global Instance map_union_assoc : Union_assoc (T:=map A B).
Proof.
  constructor. intros M N P. simpl.
  unfold union_impl, map. extens.
  intros k. destruct~ (M k).
Qed.

End Instances.

*)

(* ********************************************************************** *)
(** * Fold *)

Parameter fold_left :
  forall A B (f:A->B->B) (t:array A) (b:B), B.

(* ********************************************************************** *)
(** * Count *)

Require Import LibWf.

Parameter count :
  forall A (f:A->Prop) (t:array A), int.

Parameter count_make : forall A (f:A->Prop) n v,
  count f (make n v) = (If f v then n else 0).

Parameter count_update : forall `{Inhab A} (f:A->Prop) (t:array A) i v,
  count f (t\(i:=v)) = count f t
    - (If f (t\(i)) then 1 else 0)
    + (If f v then 1 else 0).

Parameter count_bounds : forall `{Inhab A} (t:array A) (f:A->Prop),
  0 <= count f t <= length t.

Lemma array_count_upto : forall `{Inhab A} (P:A->Prop) (t:array A) n i v,
  ~ P (t\(i)) -> P v -> length t <= n ->
  upto n (count P (t\(i:=v))) (count P t).
Proof.
  introv Ni Pv Le. forwards K: (count_bounds (t\(i:=v)) P). split.
  rewrite length_update in K. math.
  lets M: (@count_update A _). rewrite M. clear M.
  do 2 (case_if; tryfalse). math.
Qed.


From ConCert.Extraction Require Import Common.
From MetaCoq.TypedExtraction Require Import Extraction.
From MetaCoq.TypedExtraction Require Import ResultMonad.
From MetaCoq.Template Require Import Ast.
From MetaCoq.Template Require Import monad_utils.
From Coq Require Import ZArith.
From Coq Require Import String.

Local Notation "'bs_to_s' s" := (bytestring.String.to_string s) (at level 200).
Local Notation "'s_to_bs' s" := (bytestring.String.of_string s) (at level 200).
Local Coercion bytestring.String.to_string : bytestring.String.t >-> string.

Example pos_syn_to_nat_5 :
  pos_syn_to_nat (EAst.tApp _xI (EAst.tApp _xO _xH)) = Some 5.
Proof. reflexivity. Qed.

Example N_syn_to_nat_0 :
  N_syn_to_nat _N0 = Some 0.
Proof. reflexivity. Qed.

Example N_syn_to_nat_5 :
  N_syn_to_nat (EAst.tApp _Npos (EAst.tApp _xI (EAst.tApp _xO _xH))) = Some 5.
Proof. reflexivity. Qed.

Open Scope string.

Example N_syn_to_nat_fail :
  N_syn_to_nat (EAst.tApp _Npos (EAst.tApp _xI (EAst.tVar (s_to_bs "")))) = None.
Proof. reflexivity. Qed.

Example Z_syn_to_Z_0 :
  Z_syn_to_Z _Z0 = Some 0%Z.
Proof. reflexivity. Qed.

Example Z_syn_to_Z_5 :
  Z_syn_to_Z (EAst.tApp _Zpos (EAst.tApp _xI (EAst.tApp _xO _xH))) = Some 5%Z.
Proof. reflexivity. Qed.

Example Z_syn_to_Z_minus_5 :
  Z_syn_to_Z (EAst.tApp _Zneg (EAst.tApp _xI (EAst.tApp _xO _xH))) = Some (-5)%Z.
Proof. reflexivity. Qed.

Example Z_syn_to_Z_fail :
  Z_syn_to_Z (EAst.tApp _Zpos (EAst.tApp _xI (EAst.tVar (s_to_bs "")))) = None.
Proof. reflexivity. Qed.

Import MCMonadNotation Core.
Open Scope monad_scope.

Definition result_err_bytestring A := result A bytestring.String.t.

Definition extract_ (p : program) : result_err_bytestring _ :=
  entry <- match snd p with
           | tConst kn _ => ret kn
           | _ => Err (s_to_bs "Expected program to be a tConst")
           end;;
  extract_template_env_within_coq
         (fst p)
         (Kernames.KernameSet.singleton entry)
         (fun k => false).

Definition extract_body {A} (def : A) : TemplateMonad _ :=
  p <- tmQuoteRec def ;;
  entry <- match snd p with
           | tConst kn _ => ret kn
           | _ => tmFail (s_to_bs "Expected program to be a tConst")
          end ;;
  res <- tmEval Common.lazy (extract_template_env_within_coq
               (fst p)
               (Kernames.KernameSet.singleton entry)
               (fun k => false));;
  match res with
  | Ok env => match Erasure.Ex.lookup_env env entry with
             | Some (Erasure.Ex.ConstantDecl (Erasure.Ex.Build_constant_body _ (Some b))) =>
                 tmDefinition (s_to_bs (snd entry ++ "_extracted")) b
             | Some _ => tmFail (s_to_bs "Not a constant or body is missing")
             | None => tmFail (s_to_bs "No constant in the extracted env")
             end
  | Err e => tmFail e
  end.

Open Scope N_scope.

(* TODO: Use QuickChick here?*)
(* NOTE: these numbers come from the Dexter contract, where the bug was discovered *)
Definition _997 : N := 997%N.

MetaCoq Run (extract_body _997).

Example N_syn_to_nat_997 :
  N_syn_to_nat _997_extracted = Some 997%nat.
Proof. reflexivity. Qed.

Definition _1000 : N := 1000%N.

MetaCoq Run (extract_body _1000).

Example N_syn_to_nat_1000 :
  N_syn_to_nat _1000_extracted = Some 1000%nat.
Proof. reflexivity. Qed.


(**
# 第9回 タクティックの定義と利用/停止性証明 (2014/06/08)

http://qnighy.github.io/coqex2014/

## 課題43 (種別:B / 締め切り : 2014/06/22)

ゴールがandの連なった形であるとき、これをandの形になっている限りsplitし続けるタクティックを
定義せよ。課題41と違い、and以外の形の場合はsplitしてはいけない。

*)

Ltac split_all :=
  match goal with
    | _ : _ |- _ /\ _
      => split; split_all
    | _ => idtac
  end.

(* 以下は動作確認用 *)

Lemma bar :
  forall P Q R S : Prop,
    R -> Q -> P -> S -> (P /\ R) /\ (S /\ Q).
Proof.
  intros P Q R S H0 H1 H2 H3.
  split_all.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
Qed.

Lemma baz :
  forall P Q R S T : Prop,
    R -> Q -> P -> T -> S -> P /\ Q /\ R /\ S /\ T.
Proof.
  intros P Q R S T H0 H1 H2 H3 H4.
  split_all.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
Qed.

Lemma quux :
  forall P Q : Type, P -> Q -> P * Q.
Proof.
  intros P Q H0 H1.
  split_all.
  split.
  - assumption.
  - assumption.
Qed.

(*
ヒント

match goal with ... end 構文を使いましょう。この構文の使い方についてはマニュアルの9章の文法
定義を追うのがよいかと思います。*)

(* END *)


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus lv3 (plus (Succ Zero) lv2))).
Admitted.
QuickChick conj18synthconj4.


(** * Soundness of LJT w.r.t. Kripke Semantics *)

Set Implicit Arguments.

Require Import decidable_In.
Require Import environments.
Require Import extralibrary.
Require Import sublist.
Require Import language_syntax.
Require Import variable_sets.
Require Import substitution.
Require Import fresh_csts.
Require Import relocation.
Require Import LJT_and_weakening.
Require Import kripke_semantics.

(** The soundness of [LJT] with respect to Kripke semantics
   is relatively simple.

   If we had included parameters (free variables), the soundness
   proof of [LJT] would be a simple simultaneous induction
   on the derivation, cf. with_FreeVar_soundness.v.

   However, because we use constants instead, the case
   [ProofForallR] requires more attention. *)

(** ** Some auxiliary predicates and operations *)

(** A predicate checking that a property holds for all elements
   of a list. *)

Inductive list_forall (A:Type)(P:A -> Type) : list A -> Type :=
| ForallNil  : list_forall P nil
| ForallCons : forall a l,
               P a -> list_forall P l -> list_forall P (cons a l).

Definition force_ctx K (w:worlds K) eta Ga :=
  list_forall (fun B : (formula nil) => w ||- B [eta]) Ga.

Lemma force_In_ctx : forall K (w:worlds K) eta Ga,
  force_ctx K w eta Ga ->
  forall A,
    A @ Ga ->
    w ||- A [eta].
Proof.
  induction 1 as [ | B]; simpl; intros A; [ intro Hnil; elim Hnil | intro Hcons ].
  destruct (fml_dec A B); subst; auto.
  apply IHX; auto with datatypes. intuition; contradict n; auto.
 Qed.

Lemma list_force_assoc_equiv : forall Ga K (w:worlds K) eta eta0,
  list_forall (fun B : (formula nil) => w ||- B [eta]) Ga ->
  list_forall (fun B : (formula nil) => w ||- B [eta0]) Ga.
Proof.
  induction 1;
    [ constructor
      | apply ForallCons;
        [apply force_assoc_equiv with eta; auto; solve_assoc
          | assumption
        ]
    ].
Qed.

(** Forcing is monotone wrt. the world relation. *)

Lemma mono_force_ctx : forall K (w w':worlds K),
  w <= w' ->
  forall eta (Ga:context),
    force_ctx K w eta Ga ->
    force_ctx K w' eta Ga.
Proof.
  induction 2 as [| B]; constructor; eauto using mono_force.
Qed.

(** ** Creation of a new Kripke model *)

Section Creation_new_Kripke.

(** This section reflects the fact that fresh constants are
   as good as fresh parameters.

   - Syntactically, this fact is represented by the renaming lemma.

   - At the semantic level, this corresponds to creating a new Kripke
     model from a given one such that the semantics remains
     nearly identical.

   - The following section is not necessary when we had introduced
     parameters. *)

  Variable K : Kripke.

(** Given an arbitrary association for constants, we construct
   a new Kripke model which differs only for a specific constant. *)

  Definition Kripke_new_csts (f : name -> domain K) : Kripke
    := @Build_Kripke (worlds K) (wle K) (wle_refl K) (wle_trans K)
    (domain K) f (funs K) (atoms K) (atoms_mon K).

(** [csts_up] creates a new association for constants using a specific
   value for a specific contant. *)

  Definition csts_up (f:name -> domain K) (n:name) (d:domain K) :
    name -> domain K
    := (fun m => if (eq_name m n) then d else f m).

(** If [c] is a fresh constant for a class of formulae, then
   the new Kripke model has the same interpretation as before
   w.r.t. the class.

   For technical reason, we need to exclude the case [c=0],
   Note its special role in the definition of forcing. *)

  Lemma fresh_csts_psem : forall m (t:term m) (c:name) (eta:assoc (domain K)),
    c # (oc_t t) ->
    sub_name (ov_t t) (dom eta) ->
    forall (d:domain K),
      psem K t eta = psem (Kripke_new_csts (csts_up (csts K) c d)) t eta.
  Proof.
    unfold csts_up; induction t; simpl; intros.
    - apply incl_cons_0 in H0.
      apply lookup_exists in H0; inversion H0 as [d' Hd'].
      rewrite Hd' in *; auto.
    - repeat case_name; intuition.
    - f_equal; [rewrite <-  IHt1 | rewrite <- IHt2]; auto with datatypes.
  Qed.

  Lemma fresh_csts_forceL : forall m (A:formula m) (c:name) (eta:assoc (domain K)),
    c # oc_f A ->
    sub_name (ov_f A) (dom eta) ->
    forall (w:worlds K) (d:domain K),
      force K w A eta ->
      force (Kripke_new_csts (csts_up (csts K) c d)) w A eta

    with fresh_csts_forceR : forall m (A:formula m) (c:name) (eta:assoc (domain K)),
      c # oc_f A ->
      sub_name (ov_f A) (dom eta) ->
      forall (w:worlds K) (d:domain K),
        force (Kripke_new_csts (csts_up (csts K) c d)) w A eta ->
        force K w A eta.
  Proof.
    - destruct A as [ [p t] | | ]; simpl; intros.
      + rewrite <- fresh_csts_psem; assumption.
      + apply fresh_csts_forceL; auto with datatypes.
        apply X; auto.
        apply fresh_csts_forceR with (c:=c) (d:=d); auto with datatypes.
      + assert (sub_name (ov_f A) (dom ((x,d0)::eta))).
        * apply incl_rm_2; auto.
        * apply fresh_csts_forceL; auto.
    - destruct A as [ [p t] | | ]; simpl; intros.
      + rewrite <- fresh_csts_psem in X; assumption.
      + generalize (incl_appL H0); intro.
        generalize (incl_appR H0); intro.
        apply fresh_csts_forceR with (c:=c) (d:=d); auto with datatypes.
        apply X; auto.
        apply fresh_csts_forceL; auto with datatypes.
      + assert (sub_name (ov_f A) (dom ((x, d0)::eta))).
        * apply incl_rm_2; auto.
        * apply fresh_csts_forceR with (c:=c) (d:=d0); eauto.
  Qed.

  Lemma fresh_csts_force_ctx : forall (Ga:context) (c:name),
    c # oc_c Ga ->
    forall (w:worlds K) (eta:assoc (domain K)) (d:domain K),
      force_ctx K w eta Ga ->
      force_ctx (Kripke_new_csts (csts_up (csts K) c d)) w eta Ga.
  Proof.
    induction Ga as [ | A]; simpl; intros;
      [ apply ForallNil
        | destruct_notIn; inversion X; apply ForallCons;
          [ apply fresh_csts_forceL
            | apply IHGa ]; auto ].
  Qed.

End Creation_new_Kripke.

(** ** Soundness *)

Theorem soundness : forall Ga A,
  Ga |- A ->
    forall K (w:worlds K),
      list_forall (fun B => w ||- B [nil]) Ga ->
      w ||- A [nil]

with soundness_stoup : forall Ga A C,
  Ga ;; A |- C ->
    forall K (w:worlds K),
      list_forall (fun B => w ||- B [nil]) Ga ->
      w ||- A [nil]
      -> w ||- C [nil].
Proof.
  (* soundness*)
  destruct 1; simpl; intros;
    [ apply soundness_stoup with (Ga:=Ga)(A:=A);
      eauto using force_In_ctx
      | apply soundness with (Ga:= B::Ga); auto;
        apply ForallCons; auto;
          apply mono_force_ctx with (w:=w); assumption
      | apply force_assoc_equiv with ((y,d)::nil);
        [ solve_assoc
          | simpl in n; destruct_notIn;
            apply fresh_csts_forceR with (c:=a)(d:=d); auto;
              set (K' := Kripke_new_csts K (csts_up K (csts K) a d));
                assert (d = psem K' (@Cst nil a) nil);
                  [ simpl; unfold csts_up; simpl; case_name; intuition congruence
                    | rewrite H2;
                      apply subst_force with (K:=K')(l:=nil); simpl; auto;
                        apply soundness with (K:=K')(Ga:=Ga); auto;
                          apply fresh_csts_force_ctx; auto;
                            apply mono_force_ctx with (w:=w); auto;
                              apply list_force_assoc_equiv with (eta:=eta); auto
                  ]
        ]
    ].

  (* soundness_stoup *)
  destruct 1; simpl; intros;
    [ assumption
      | apply soundness_stoup with (Ga:=Ga)(A:=C); auto;
        apply X0;
          [ apply wle_refl
            | apply soundness with Ga; auto
          ]
      |
    ].

  apply soundness_stoup with
    (Ga := Ga) (A := [nil ! (y,u) :: nil] B); auto.
      change (w ||- [ (nil \ y) ! (y, u) :: nil] B [nil]).
        apply force_assoc_equiv with nil.
        + solve_assoc.
        + apply force_subst; auto;
              apply force_assoc_equiv with (eta:= (y, psem K u nil) :: nil).
          * unfold assoc_equiv; intros; simpl in *; case_name; auto.
          * apply force_assoc_equiv with ((y, psem K u nil) :: nil);
            [ solve_assoc
            | apply X0; apply wle_refl
            ].
Qed.


(* *********************************************************************)
(*                                                                     *)
(*           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 "<< 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)
  ].


(*|
#############################
Transitivity of ``->`` in Coq
#############################

:Link: https://stackoverflow.com/q/55295029
|*)

(*|
Question
********

I'm trying to prove the transitivity of ``->`` in Coq's propositions:
|*)

Theorem implies_trans : forall P Q R : Prop,
    (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
Abort. (* .none *)

(*|
I wanted to destruct all propositions and simply handle **all 8
possibilities** with reflexivity. Apparently it's not that simple.
Here's what I tried:
|*)

Theorem implies_trans : forall P Q R : Prop,
    (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  intros P Q R H1 H2.
  Fail destruct P. (* .unfold .fails *) (** Hmmm ... this doesn't work *)
Admitted.

(*| Any help is very much appreciated, thanks! |*)

(*|
Answer
******

Coq's logic is not classical logic where propositions are true or
false. Instead, it's based in type theory and has an intuitionistic
flavor by default [1]_. In type theory, you should think of ``P -> Q``
being a function from "things of type ``P``" to "things of type ``Q``"
[2]_.

The usual way to prove a goal of type ``P -> Q`` is to use ``intro``
or ``intros`` to introduce a hypothesis of type ``P``, then use that
hypothesis to somehow produce an element of type ``Q``.

For example, we can prove that ``(P -> Q -> R) -> (Q -> P -> R)``. In
the "implication is a function" interpretation, this could be read as
saying that if we have a function that takes ``P`` and ``Q`` and
produces ``R``, then we can define a function that takes ``Q`` and
``P`` and produces ``R``. This is the same function, but with the
arguments swapped.
|*)

Definition ArgSwap_1 {P Q R: Prop}: (P -> Q -> R) -> (Q -> P -> R) :=
  fun f q p => f p q.

(*|
Using tactics, we can see the types of the individual elements.
|*)

Lemma ArgSwap_2 {P Q R: Prop}: (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intro f. intros q p. exact (f p q).
Qed.

(*|
After the ``intro``, we see that ``f: P -> Q -> R``, so ``f`` is our
function that takes ``P``\ s and ``Q``\ s and produces ``R``\ s. After
the ``intros`` (which introduces multiple terms), we see that ``q: Q``
and ``p: P``. The last line (before the ``Qed.``) simply applies the
function ``f`` to ``p`` and ``q`` to get something in ``R``.

For your problem, the ``intros`` introduces the propositions ``P``,
``Q`` and ``R``, as well as ``H1: P -> Q`` and ``H2: Q -> R``. We can
still introduce one more term of type ``P`` though, since the goal is
``P -> R``. Can you see how to use ``H1`` and ``H2`` and an element of
``P`` to produce an element of ``R``? Hint: you'll go through ``Q``.
Also, remember that ``H1`` and ``H2`` are functions.

----

.. [1] You could add the law of excluded middle as an axiom, which
       would allow the kind of case analysis you want, but I think it
       misses the point of Coq.
.. [2] If you're wondering, the elements of ``Prop`` are still types
       and have very similar behavior to elements of ``Set`` or
       ``Type``. The only difference is that ``Prop`` is
       "impredicative", which allows propositions to quantify over all
       propositions. For example ``forall P: Prop, P -> P`` is an
       element of ``Prop``, but ``forall A: Type, A -> A`` is an
       element of the next level up of ``Type`` (``Type`` is actually
       an infinite hierarchy).
|*)


(** This file tests a bunch of things. *)
From program_logic Require Import model saved_prop.

Module ModelTest. (* Make sure we got the notations right. *)
  Definition iResTest {Λ : language} {Σ : iFunctor}
    (w : iWld Λ Σ) (p : iPst Λ) (g : iGst Λ Σ) : iRes Λ Σ := Res w p g.
End ModelTest.

Module SavedPropTest.
  (* Test if we can really go "crazy higher order" *)
  Section sec.
    Definition F : cFunctor := ( ∙ -n> ∙ ).
    Definition Σ : gFunctors := #[ savedPropGF F ].
    Context {Λ : language}.
    Notation iProp := (iPropG Λ Σ).

    Local Instance : savedPropG Λ Σ F := _.

    Definition own_pred γ (φ : iProp -n> iProp) : iProp :=
      saved_prop_own γ φ.
  End sec.
End SavedPropTest.