Require Import Coq.Arith.Compare_dec.

Require Import
        Essentials.Facts_Tactics
        Essentials.Notations
        Essentials.Types
        Essentials.Omega.
Require Import Metrics.Mappings Metrics.Cauchy.
Require Import Metrics.Complete_UltraMetric.
Require Import
        Categories.Category.Main
        Categories.Functor.Main
        Categories.Archetypal.Discr.Discr
        Categories.Archetypal.PreOrder_Cat.OmegaCat
        Categories.Limits.Limit
.
Require Import MCat.MCat.

Local Open Scope order_scope.
Local Open Scope metric_scope.
Local Open Scope lattice_scope.

Section IncreasingCauchyTower.
  Context {L : MLattice} {M : MCat L}.

  (**
Intuitively, an increasing cauchy tower is a diagram:

#

              f₀        f₁
            ————→     ————→      ......>
       A₀          A₁        A₂  ......
            ←————     ←————      <......
              g₀        g₁

#
Such that fₙ makes gₙ a split epi for all n ∈ N, i.e., gₙ ∘ fₙ = id_Aₙ.
Furthermore, the distance between fₙ ∘ gₙ and id_Aₙ₊₁ decreases as n grows, i.e.,

#

       ∀ ε, ∃ N, ∀ n, N ≤ n → δ(fₙ ∘ gₙ, id_Aₙ₊₁) ⊏ ε

#
.
*)
  Record IncreasingCauchyTower : Type :=
    {
      ICT_Objs :> nat → M;
      ICT_fs : ∀ n, (ICT_Objs n –≻ ICT_Objs (S n))%morphism;
      ICT_gs : ∀ n, (ICT_Objs (S n) –≻ ICT_Objs n)%morphism;
      ICT_gs_split_epi : ∀ n, ((ICT_gs n) ∘ (ICT_fs n) = id)%morphism;
      ICT_approach_id :
        ∀ (ε : ApprType L),
          {N : nat | ∀ n, N ≤ n → δ(((ICT_fs n) ∘ (ICT_gs n))%morphism, id (ICT_Objs (S n))) ⊏ (projT1 ε)}
    }.

  Section ICT_Func_Limit.
    Context (ICT : IncreasingCauchyTower).

    (** The functor from ω → M that maps h : m ≤ n to gₘ ∘ ... ∘ gₙ₋₂ ∘ gₙ₋₁ from Aₙ → Aₘ. *)
    Definition ICT_Func :=
      OmegaCat_Op_Func (ICT_Objs ICT) (ICT_gs ICT).

    (** The functor from ω → M that maps h : m ≤ n to fₙ ∘ ... ∘ fₘ₊₂ ∘ fₘ₊₁ from Aₘ → Aₙ. *)
    Definition ICT_inv_Func :=
      OmegaCat_Func (ICT_Objs ICT) (ICT_fs ICT).

    (** conversion of gₙ to (ICT_Func _a) (le_S _ _ (le_n n) : n ≤ S n) *)
    Lemma ICT_gs_ICT_Func n :
      ICT_gs ICT n = (ICT_Func _a (Tle_S _ _ (Tle_n n)))%morphism.
    Proof.
      cbn.
      cbn_rewrite (MC_id_unit_left M); trivial.
    Qed.

    (** conversion of fₙ to (ICT_inv_Func _a) (le_S _ _ (le_n n) : n ≤ S n) *)
    Lemma ICT_fs_ICT_inv_Func n :
      ICT_fs ICT n = (ICT_inv_Func _a (Tle_S _ _ (Tle_n n)))%morphism.
    Proof.
      cbn.
      cbn_rewrite (MC_id_unit_right M); trivial.
    Qed.

    (** A simple tactic to solve equality of OmegaCat_Func *)
    Ltac solve_simpl_omega_func_eq :=
      match goal with
      |  [|- (?F _a ?x)%morphism = (?G _a ?y)%morphism] =>
         cutrewrite (x = y); [trivial|apply Tle_is_HProp]; fail
      | [|- OmegaCat.FA_fx _ ?f _ _ ?x = OmegaCat.FA_fx _ ?f _ _ ?y] =>
        cutrewrite (x = y); [trivial|apply Tle_is_HProp]; fail
      end.

    Local Hint Extern 1 => solve_simpl_omega_func_eq.

    Lemma ICT_inv_Func_ICT_Func_id a b (g : (a ≤ b)%omegacat) :
      (MC_compose M) ((ICT_inv_Func _a)%morphism g, (ICT_Func _a)%morphism g) = MC_id M.
    Proof.
      cbn in *.
      induction g as [|m t IHt].
      + cbn; apply MC_id_unit_left.
      + cbn in *.
        rewrite MC_assoc_sym.
        rewrite (MC_assoc _ _ _ _ _ _ (ICT_gs ICT m)).
        cbn_rewrite ICT_gs_split_epi.
        rewrite MC_id_unit_right.
        apply IHt.
    Qed.

    (** A fundamental property of increasing cauchy towers:
Given (g : a ≤ b) (h : c ≤ b) (i : a ≤ c),

(ICT_Func _a h)  ∘ (ICT_inv_Func _a g) = (ICT_inv_Func _a i)

*)
    Lemma ICT_inv_Func_ICT_Func_1
          a b c
          (g : (a ≤ b)%omegacat)
          (h : (c ≤ b)%omegacat)
          (i : (a ≤ c)%omegacat) :
      (MC_compose M) ((ICT_inv_Func _a)%morphism g, (ICT_Func _a)%morphism h) =
      (ICT_inv_Func _a)%morphism i.
    Proof.
      replace g with (Tle_trans _ _ _ i h) by (apply Tle_is_HProp).
      cbn.
      cbn_rewrite (@F_compose _ _ ICT_inv_Func).
      rewrite MC_assoc_sym.
      cbn_rewrite ICT_inv_Func_ICT_Func_id.
      apply MC_id_unit_left.
    Qed.

    (** A fundamental property of increasing cauchy towers:
Given (g : a ≤ b) (h : c ≤ b) (i : c ≤ a),

(ICT_Func _a h)  ∘ (ICT_inv_Func _a g) = (ICT_Func _a i)

*)
    Lemma ICT_inv_Func_ICT_Func_2
          a b c
          (g : (a ≤ b)%omegacat)
          (h : (c ≤ b)%omegacat)
          (i : (c ≤ a)%omegacat) :
      (MC_compose M) ((ICT_inv_Func _a)%morphism g, (ICT_Func _a)%morphism h) =
      (ICT_Func _a)%morphism i.
    Proof.
      replace h with (Tle_trans _ _ _ i g) by (apply Tle_is_HProp).
      cbn.
      cbn_rewrite (@F_compose _ _ ICT_Func).
      rewrite MC_assoc.
      cbn_rewrite ICT_inv_Func_ICT_Func_id.
      apply MC_id_unit_right.
    Qed.

    Local Arguments OmegaCat_Op_Func : simpl never.
    Local Arguments OmegaCat_Func : simpl never.

    (**
This is a function used to create an auxiliary cone to ICT_Func
with apex Aₘ. In practice, Aux_cone_fun is id if m = n. It is
gₘ ∘ ... ∘ gₙ₋₁ ∘ gₙ if n < m and fₙ ∘ ... ∘ fₘ₊₁ ∘ fₘ.
*)
    Definition Aux_cone_fun m n
      : MC_Hom M (ICT_Objs ICT m) (ICT_Objs ICT n)
      :=
      match gt_eq_gt_dec n m with
      | inleft H =>
        match H with
        | left h => (ICT_Func _a)%morphism (Tle_trans _ _ _ (Tle_S _ _ (Tle_n n)) (le_Tle h))
        | right W =>
          match W in _ = y return
                ((ICT y) –≻ (ICT n))%morphism
          with
          | eq_refl => id
          end
        end
      | inright h => (ICT_inv_Func _a)%morphism (Tle_trans _ _ _ (Tle_S _ _ (Tle_n m)) (le_Tle h))
      end.

    Lemma Aux_cone_fun_S m x :
      Aux_cone_fun m x = (MC_compose M) (ICT_fs ICT m, Aux_cone_fun (S m) x).
    Proof.
      unfold Aux_cone_fun.
      (destruct gt_eq_gt_dec as [H|H]; [destruct H as [H|H]|]);
        (destruct gt_eq_gt_dec as [H'|H']; [destruct H' as [H'|H']|]);
        try omega;
        ElimEq;
        repeat rewrite ICT_fs_ICT_inv_Func; repeat rewrite ICT_gs_ICT_Func; cbn
      .
      + erewrite ICT_inv_Func_ICT_Func_2; trivial.
      + change (@MC_id _ M (ICT_Objs ICT x)) with (ICT_Func _a (Tle_n x))%morphism.
        erewrite ICT_inv_Func_ICT_Func_2; trivial.
      + change (@MC_id _ M (ICT_Objs ICT x)) with (ICT_Func _a (Tle_n x))%morphism.
        dependent destruction H'.
        erewrite ICT_inv_Func_ICT_Func_1; trivial.
      + cbn_rewrite <- (@F_compose _ _ ICT_inv_Func); auto.
    Qed.

    (** This is an auxiliary cone to ICT_Func with apex Aₘ. *)
    Program Definition Aux_cone (m : nat) : Cone ICT_Func :=
      {|
        cone_apex := Func_From_SingletonCat (ICT m);
        cone_edge :=
          {|
            Trans := Aux_cone_fun m
          |}
      |}.

    Next Obligation.
    Proof.
      unfold Aux_cone_fun.
      cbn.
      repeat (try destruct gt_eq_gt_dec;
              try match goal with
                    [H : {_} + {_} |- _] => destruct H
                  end; ElimEq);
        try (assert (h' := Tle_le h); omega; clear h'; fail);
        repeat rewrite (MC_id_unit_right M);
        repeat rewrite ICT_gs_ICT_Func;
        repeat rewrite ICT_fs_ICT_inv_Func;
        repeat cbn_rewrite <- (@F_compose _ _ ICT_Func);
        repeat cbn_rewrite <- (@F_compose _ _ ICT_inv_Func);
        try
          (change (@MC_id _ M (ICT_Objs ICT c)) with (ICT_Func _a (Tle_n c))%morphism; auto).
      + set (W := ICT_inv_Func_ICT_Func_2); cbn in W; erewrite W; auto.
      + erewrite ICT_inv_Func_ICT_Func_2; auto.
      + erewrite ICT_inv_Func_ICT_Func_1; auto.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply Aux_cone_obligation_1.
    Qed.

    (** A simplified version of Trans_com of Cones into ICT_Func. *)
    Lemma Cone_Trans_com_simplified
          (Cn : Cone ICT_Func)
          {c c' : nat}
          (h : (c' ≤ c)%omegacat)
      :
        Trans Cn c' =
      (MC_compose M) (Trans Cn c, (ICT_Func _a)%morphism h).
    Proof.
      etransitivity; [|apply (Trans_com Cn h)].
      cbn; rewrite From_Term_Cat.
      symmetry; apply MC_id_unit_right.
    Qed.

    (** A simplified version of Trans_com of CoCones into ICT_inv_Func. *)
    Lemma CoCone_Trans_com_simplified
          (Cn : CoCone ICT_inv_Func)
          {c c' : nat}
          (h : (c' ≤ c)%omegacat)
      :
        Trans Cn c' =
      (MC_compose M) ((ICT_inv_Func _a)%morphism h, Trans Cn c).
    Proof.
      etransitivity; [|apply (Trans_com Cn h)].
      cbn; rewrite From_Term_Cat.
      symmetry; apply MC_id_unit_left.
    Qed.

    Section CoCone_Interacting_With_and_related.

      Context (Cn : Cone ICT_Func).

      (** This is the type of cocones with the same apex as the provided cone.
Furthermore, Trans Cn n ∘ Trans CCn n = id_Aₙ. Where CCn is the cocone of
this definition.
       *)
      Program Record CoCone_Interacting_With :=
        {
          CCIW_injs :> ∀ n, (ICT n –≻ Cn)%morphism;
          CCIW_injs_form_cocone :
            ∀ (c c' : (ω%omegacat ^op)%category) (h : (c –≻ c')%morphism),
              (
                (CCIW_injs c')
                  ∘ (
                    (
                      (Func_From_SingletonCat Cn ^op)
                        ∘ (Functor_To_1_Cat ω%omegacat ^op)
                    )
                      _a
                  ) h
              )%morphism
              = (MC_compose M (((ICT_inv_Func ^op) _a) h, CCIW_injs c))%morphism;
          CCIW_CoCone : CoCone ICT_inv_Func :=
            {|
              cone_apex := (Func_From_SingletonCat Cn)^op;
              cone_edge :=
                {|
                  Trans := CCIW_injs;
                  Trans_com := CCIW_injs_form_cocone;
                  Trans_com_sym := fun _ _ _ => eq_sym (CCIW_injs_form_cocone _ _ _)
                |}
            |};
          CCIW_split_epi : ∀ n, ((Trans Cn n) ∘ (CCIW_injs n) = id)%morphism
        }.

      (** A cocone CCn related to a cone Cn is a cocone interacting with it such that the
distance between composition of injections of CCn with projections of Cn approach the
identity morphism of Cn (Cn's apex). *)
      Program Record CoCone_Related_To : Type :=
        {
          TRCC_CoCone :> CoCone_Interacting_With;
          TRCC_approach_id :
            ∀ (ε : ApprType L),
              {N : nat | ∀ n, N ≤ n → δ(((TRCC_CoCone n) ∘ (Trans Cn n))%morphism, id Cn) ⊏ (projT1 ε)}
        }.

      Context (CCn : CoCone_Interacting_With).

      (** Composition of a cone projection and a cocone injection of an interacting cocone. *)
      Lemma Cone_Interacting_CoCone_Aux_cone_fun_n_m n m
        :
          (MC_compose M)
            (Trans (CCIW_CoCone CCn) n, Trans Cn m) =
          Aux_cone_fun n m.
      Proof.
        repeat unfold Aux_cone_fun.
        repeat (try destruct gt_eq_gt_dec;
                try match goal with
                      [H : {_} + {_} |- _] => destruct H
                    end; ElimEq);
          try omega; cbn.
        + rewrite (Cone_Trans_com_simplified Cn (Tle_trans _ _ _ (Tle_S _ _ (Tle_n m)) (le_Tle g))).
          rewrite (MC_assoc M).
          cbn_rewrite (CCIW_split_epi CCn).
          apply MC_id_unit_right.
        + apply CCIW_split_epi.
        + cbn_rewrite (CoCone_Trans_com_simplified (CCIW_CoCone CCn) (Tle_trans _ _ _ (Tle_S _ _ (Tle_n n)) (le_Tle g))).
          rewrite (MC_assoc_sym M).
          cbn_rewrite (CCIW_split_epi CCn).
          apply MC_id_unit_left.
      Qed.

      (** Composition of a projection with Aux_cone_fun is just another projection. *)
      Lemma Aux_cone_fun_m_n_o_Cone_n_eq_Cone_m n m (h : m ≤ n) :
        (MC_compose M)
          (Trans Cn n, Aux_cone_fun n m) = Trans Cn m.
      Proof.
        set (W := @Trans_com _ _ _ _ Cn n m).
        cbn in W.
        rewrite From_Term_Cat in W; cbn in W.
        rewrite MC_id_unit_right in W.
        unfold Aux_cone_fun.
        destruct gt_eq_gt_dec as [[H|H]|H]; try omega.
        + symmetry; apply W.
        + destruct H; cbn.
          apply MC_id_unit_left.
      Qed.

      Context (Cn' : Cone ICT_Func).

      (** The sequence of projections Cn composed with injections (of a cocone interacting with Cn')
forms a cauchy sequence. *)
      Program Definition proj_n_o_inj_n_cauchy
        :
          Cauchy_Sequence (MC_Hom M (Cn' : M) (Cn : M)) :=
        {|
          CHS_seq :=
            fun n =>
              (MC_compose M)
                (Trans Cn' n,
                 Trans (CCIW_CoCone CCn) n)
        |}.

      Next Obligation.
      Proof.
        apply Cauchy_condition_simpl.
        clear.
        intros ε.
        destruct (ICT_approach_id ICT ε) as [N H1].
        exists N.
        intros n H2.
        set (W := @Trans_com _ _ _ _ Cn' _ _ (Tle_S _ _ (Tle_n n)));
          cbn in W; rewrite From_Term_Cat in W; cbn in W;
          rewrite MC_id_unit_right in W; rewrite W; clear W.
        cbn_rewrite ( CoCone_Trans_com_simplified (CCIW_CoCone CCn) (Tle_S _ _ (Tle_n n))).
        rewrite MC_assoc.
        rewrite (MC_assoc_sym M _ _ _ _ _ ((ICT_Func _a)%morphism (Tle_S n n (Tle_n n)))).
        rewrite
          <- (MC_id_unit_right _ _ _ (Trans (CCIW_CoCone CCn) (S n))) at 2.
        rewrite MC_assoc_sym.
        eapply LE_LT_Trans; [apply NE_non_expansive|].
        cbn.
        rewrite UM_eq_zero_dist.
        rewrite lub_sym.
        rewrite lub_bot.
        eapply LE_LT_Trans; [apply NE_non_expansive|].
        cbn.
        rewrite UM_eq_zero_dist.
        rewrite lub_bot.
        rewrite <- ICT_gs_ICT_Func.
        rewrite <- ICT_fs_ICT_inv_Func.
        apply H1; trivial.
      Qed.

    End CoCone_Interacting_With_and_related.

    Program Definition limit_proj_n_o_inj_n_cauchy_forms_Cone_morph_from_Cn_to_Con_NT
            (Cn : Cone ICT_Func)
            (CCn : CoCone_Interacting_With Cn)
            (Cn' : Cone ICT_Func)
      :
        (Cn' –≻ Cn)%nattrans
      :=
        {|
          Trans :=
            fun h =>
              match h as u return (MC_Hom M ((Cn' _o)%object u) ((Cn _o)%object u)) with
              | tt =>
                (CUM_complete _ (proj_n_o_inj_n_cauchy Cn CCn Cn') : MC_Hom M (Cn' : M) (Cn : M))
              end
        |}.

    Next Obligation.
      repeat match goal with [H : unit|- _] => destruct H end.
      repeat rewrite From_Term_Cat; cbn.
      rewrite MC_id_unit_left, MC_id_unit_right.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply limit_proj_n_o_inj_n_cauchy_forms_Cone_morph_from_Cn_to_Con_NT_obligation_1.
    Qed.

    (** The limit of the sequence of projections of a cone Cn composed with injections
(of a cocone interacting with Cn') forms a cone morphism from Cn' to Cn. *)
    Program Definition limit_proj_n_o_inj_n_cauchy_forms_Cone_morph_from_Cn_to_Con
            (Cn : Cone ICT_Func)
            (CCn : CoCone_Interacting_With Cn)
            (Cn' : Cone ICT_Func)
      :
        LoKan_Cone_Morph Cn' Cn :=
      {|
        cone_morph :=
          limit_proj_n_o_inj_n_cauchy_forms_Cone_morph_from_Cn_to_Con_NT Cn CCn Cn'
      |}.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      extensionality m.
      cbn.
      rewrite From_Term_Cat; cbn.
      rewrite MC_id_unit_left.
      set (z := CUM_complete (MC_Hom M (Cn' : M) (Cn : M)) (proj_n_o_inj_n_cauchy _ _ _)).
      rewrite (Limit_of_SubSeq_equal z m (Limit_of_SubSeq z m)).
      change (MC_compose M ((Limit_of_SubSeq z m) : MC_Hom _ _ _, Trans Cn m)) with
      (Lim (@NonExpansive_Continuous _ _ _ (Limit_of_SubSeq z m) _ (NonExpansive_Compose_right _ (Trans Cn m)))).
      match goal with
        [|- _ = Lim ?A] =>
        rewrite (Eq_Seq_Eq_Limits _ _ A (Limit_of_ConstSeq (Trans Cn' m)))
      end.
      {
        rewrite Limit_of_ConstSeq_equal.
        trivial.
      }
      {
        clear.
        extensionality n.
        cbn.
        rewrite MC_assoc_sym.
        match goal with
          [|- NE_fun (MC_compose M) (_, ?A) = _] =>
          cutrewrite (A = (Aux_cone_fun (m + n) m));
            [apply Aux_cone_fun_m_n_o_Cone_n_eq_Cone_m; trivial|
             apply Cone_Interacting_CoCone_Aux_cone_fun_n_m]
        end.
        abstract omega.
      }
    Qed.

  End ICT_Func_Limit.

End IncreasingCauchyTower.

Arguments IncreasingCauchyTower {_} _.
Arguments CoCone_Interacting_With {_ _ _} _.
Arguments CoCone_Related_To {_ _ _} _.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 6: Model Checking
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap TransitionSystems.

Set Implicit Arguments.

(* Coming up with invariants ourselves can be tedious!  Let's investigate how we
 * can automate the choice of invariants, for systems with only finitely many
 * reachable states.  This style is known as model checking.  First, let's think
 * more deliberately about how to grow a candidate invariant by adding new cases
 * that we missed.  Here's what it means for one invariant to retain all cases of
 * another. *)
Definition oneStepClosure_current {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st, invariant1 st
             -> invariant2 st.

(* And here's what it means to add all new states reachable from the original
 * set. *)
Definition oneStepClosure_new {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st st', invariant1 st
                 -> sys.(Step) st st'
                 -> invariant2 st'.

(* Putting together the two conditions, we have a closure operator, for
 * enriching a candidate invariant with all new states reachable from it in a
 * single step. *)
Definition oneStepClosure {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  oneStepClosure_current sys invariant1 invariant2
  /\ oneStepClosure_new sys invariant1 invariant2.

(* Here's a simple restatement of [oneStepClosure] as a theorem with two
 * premises. *)
Theorem prove_oneStepClosure : forall state (sys : trsys state) (inv1 inv2 : state -> Prop),
  (forall st, inv1 st -> inv2 st)
  -> (forall st st', inv1 st -> sys.(Step) st st' -> inv2 st')
  -> oneStepClosure sys inv1 inv2.
Proof.
  unfold oneStepClosure.
  propositional.
Qed.

(* Now imagine the following general procedure to find an invariant.  Start with
 * the initial states as the candidate invariant.  Now take the one-step
 * closure, adding all states reachable in one step.  Then take it again, and
 * again, until the invariant is "big enough."  What is the formal meaning of
 * this termination condition?  We are done if one-step closure brings us back
 * to the original set.  (Of course, we must also retain all the initial
 * states.) *)
Theorem oneStepClosure_done : forall state (sys : trsys state) (invariant : state -> Prop),
  (forall st, sys.(Initial) st -> invariant st)
  -> oneStepClosure sys invariant invariant
  -> invariantFor sys invariant.
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new.
  propositional.
  apply invariant_induction.
  assumption.
  simplify.
  eapply H2.
  eassumption.
  assumption.
Qed.

(* Now we define an inductive relation, capturing repeated closure until
 * convergence. *)
Inductive multiStepClosure {state} (sys : trsys state)
  : (state -> Prop) -> (state -> Prop) -> Prop :=

(* We might be done, if one-step closure has no effect. *)
| MscDone : forall inv,
    oneStepClosure sys inv inv
    -> multiStepClosure sys inv inv

(* Or we might need to run another one-step closure and recurse. *)
| MscStep : forall inv inv' inv'',
    oneStepClosure sys inv inv'
    -> multiStepClosure sys inv' inv''
    -> multiStepClosure sys inv inv''.

(* Now, with the help of a lemma, we prove that multi-step closure is a sound
 * way to find an invariant for any transition system.  Note that we really do
 * not have that silver bullet here, because, for many systems, multi-step
 * closure does not terminate!  However, if it does, we get a correct
 * invariant. *)

Lemma multiStepClosure_ok' : forall state (sys : trsys state) (inv inv' : state -> Prop),
  multiStepClosure sys inv inv'
  -> (forall st, sys.(Initial) st -> inv st)
  -> invariantFor sys inv'.
Proof.
  induct 1; simplify.

  apply oneStepClosure_done.
  assumption.
  assumption.

  apply IHmultiStepClosure.
  simplify.
  unfold oneStepClosure, oneStepClosure_current in *.
  propositional.
  apply H3.
  apply H1.
  assumption.
Qed.

Theorem multiStepClosure_ok : forall state (sys : trsys state) (inv : state -> Prop),
  multiStepClosure sys sys.(Initial) inv
  -> invariantFor sys inv.
Proof.
  simplify.
  eapply multiStepClosure_ok'.
  eassumption.
  propositional.
Qed.

(* OK, great.  We know how to find invariants if we can evaluate one-step
 * closure efficiently.  Here's one case that is particularly easy to evaluate,
 * starting from the empty set as the invariant.  We use a function [constant]
 * from the FRAP library, for sets of finite size.  In general, we write
 * [constant [x1; ..., xN]] for the set [{x1, ..., xN}], and in fact the latter
 * notation is available, too. *)
Theorem oneStepClosure_empty : forall state (sys : trsys state),
  oneStepClosure sys (constant nil) (constant nil).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; propositional.
Qed.

(* In general, for finite sets, we'll compute one-step closure by closing
 * separately over each element of the set.  This theorem implements one step of
 * that process, where we learn that [inv1] accurately captures where we might
 * get from state [st] in one step.  States [sts] are those left over to
 * consider. *)
Theorem oneStepClosure_split : forall state (sys : trsys state) st sts (inv1 inv2 : state -> Prop),
  (forall st', sys.(Step) st st' -> inv1 st')
  -> oneStepClosure sys (constant sts) inv2
  -> oneStepClosure sys (constant (st :: sts)) ({st} \cup inv1 \cup inv2).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; propositional.

  invert H0.

  left.
  (* [left] and [right]: prove a disjunction by proving the left or right case,
   *   respectively.  Note that here, we are using the fact that set union
   *   [\cup] is defined in terms of disjunction. *)
  left.
  simplify.
  propositional.

  right.
  apply H1.
  assumption.

  simplify.
  propositional.

  right.
  left.
  apply H.
  equality.

  right.
  right.
  eapply H2.
  eassumption.
  assumption.
Qed.

(* A trivial fact about union and singleton sets. *)
Theorem singleton_in : forall {A} (x : A) rest,
  ({x} \cup rest) x.
Proof.
  simplify.
  left.
  simplify.
  equality.
Qed.

(* OK, back to our example from last chapter, of factorial as a transition
 * system.  Here's a good overall correctness condition, which we didn't bother
 * to state before. *)
Definition fact_correct (original_input : nat) (st : fact_state) : Prop :=
  match st with
  | AnswerIs ans => fact original_input = ans
  | WithAccumulator _ _ => True
  end.

(* Let's also restate the initial-states set using a singleton set. *)
Theorem fact_init_is : forall original_input,
  fact_init original_input = {WithAccumulator original_input 1}.
Proof.
  simplify.
  apply sets_equal; simplify.
  (* Note the use of a theorem [sets_equal], saying that sets are equal if they
   * have the same elements. *)
  propositional.

  invert H.
  equality.

  rewrite <- H0.
  constructor.
Qed.

(* Now we will prove that factorial is correct, for the input 2, without needing
 * to write out an inductive invariant ourselves.  Note that it's important that
 * we choose a small, constant input, so that the reachable state space is
 * finite and tractable. *)
Theorem factorial_ok_2 :
  invariantFor (factorial_sys 2) (fact_correct 2).
Proof.
  simplify.
  eapply invariant_weaken.
  (* We begin like in last chapter, by strengthening to an inductive
   * invariant. *)

  apply multiStepClosure_ok.
  (* The difference is that we will use multi-step closure to find the invariant
   * automatically.  Note that the invariant appears as an existential variable,
   * whose name begins with a question mark. *)
  simplify.
  rewrite fact_init_is.
  (* It's important to phrase the current candidate invariant explicitly as a
   * finite set, before continuing.  Otherwise, it won't be obvious how to take
   * the one-step closure. *)

  (* Compute which states are reachable after one step. *)
  eapply MscStep.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  (* Compute which states are reachable after two steps. *)
  eapply MscStep.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  (* Compute which states are reachable after three steps. *)
  eapply MscStep.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  (* Now the candidate invariatn is closed under single steps.  Let's prove
   * it. *)
  apply MscDone.
  apply prove_oneStepClosure; simplify.
  propositional.
  propositional; invert H0; try equality.
  invert H; equality.
  invert H1; equality.

  (* Finally, we prove that our new invariant implies the simpler, noninductive
   * one that we started with. *)
  simplify.
  propositional; subst; simplify; propositional.
  (* [subst]: remove all hypotheses like [x = e] for variables [x], simply
   *   replacing all uses of [x] by [e]. *)
Qed.

(* That process was so rote that we can automate it all, in a generic way that
 * will work for most transition systems that have finitely many reachable
 * states.  Here is a definition of some tactics to do the work.
 * BEGIN CODE THAT WILL NOT BE EXPLAINED IN DETAIL! *)

Hint Rewrite fact_init_is.

Ltac model_check_done :=
  apply MscDone; apply prove_oneStepClosure; simplify; propositional; subst;
  repeat match goal with
         | [ H : _ |- _ ] => invert H
         end; simplify; equality.

Theorem singleton_in_other : forall {A} (x : A) (s1 s2 : set A),
  s2 x
  -> (s1 \cup s2) x.
Proof.
  simplify.
  right.
  right.
  assumption.
Qed.

Ltac singletoner :=
  repeat match goal with
         | [ |- _ ?S ] => idtac S; apply singleton_in
         | [ |- (_ \cup _) _ ] => apply singleton_in_other
         end.

Ltac model_check_step0 :=
  eapply MscStep; [
    repeat ((apply oneStepClosure_empty; simplify)
            || (apply oneStepClosure_split; [ simplify;
                                              repeat match goal with
                                                     | [ H : _ |- _ ] => invert H; try congruence
                                                     end; solve [ singletoner ] | ]))
  | simplify ].

Ltac model_check_step :=
  match goal with
  | [ |- multiStepClosure _ ?inv1 _ ] =>
    model_check_step0;
    match goal with
    | [ |- multiStepClosure _ ?inv2 _ ] =>
      (assert (inv1 = inv2) by compare_sets; fail 3)
      || idtac
    end
  end.

Ltac model_check_steps1 := model_check_step || model_check_done.
Ltac model_check_steps := repeat model_check_steps1.

Ltac model_check_finish := simplify; propositional; subst; simplify; equality.

Ltac model_check_infer :=
  apply multiStepClosure_ok; simplify; model_check_steps.

Ltac model_check_find_invariant :=
  simplify; eapply invariant_weaken; [ model_check_infer | ]; cbv beta in *.

Ltac model_check := model_check_find_invariant; model_check_finish.

(* END CODE THAT WILL NOT BE EXPLAINED IN DETAIL! *)

(* Now watch this.  We can check various instances of factorial
 * automatically. *)

Theorem factorial_ok_2_snazzy :
  invariantFor (factorial_sys 2) (fact_correct 2).
Proof.
  model_check.
Qed.

Theorem factorial_ok_3 :
  invariantFor (factorial_sys 3) (fact_correct 3).
Proof.
  model_check.
Qed.

Theorem factorial_ok_5 :
  invariantFor (factorial_sys 5) (fact_correct 5).
Proof.
  model_check.
Qed.

(* Let's see that last one broken into two steps, so that we get a look at the
 * inferred invariant. *)
Theorem factorial_ok_5_again :
  invariantFor (factorial_sys 5) (fact_correct 5).
Proof.
  model_check_find_invariant.
  model_check_finish.
Qed.

(** * Abstraction *)

(* It's lovely when we happen to be analyzing a system with a finite state
 * space, but usually we aren't that lucky.  For instance, imagine that we are
 * using a programming language with infinite-precision integers, and we want to
 * check this program:
 * <<
   int global = 0;

   thread() {
     int local;

     while (true) {
       local = global;
       global = local + 2;
     }
   }
   >>
 * The program loops indefinitely, adding 2 to a global variable.  We want to
 * prove that "global" always holds an even value.  Here's how we can formalize
 * evenness inductively. *)

Inductive isEven : nat -> Prop :=
| EvenO : isEven 0
| EvenSS : forall n, isEven n -> isEven (S (S n)).

(* And now we define a transition system for the program, in a process that
 * should be routine by now.  We use last chapter's concept of a multithreaded
 * transition system. *)

Inductive add2_thread :=
| Read
| Write (local : nat).

Inductive add2_init : threaded_state nat add2_thread -> Prop :=
| Add2Init : add2_init {| Shared := 0; Private := Read |}.

Inductive add2_step : threaded_state nat add2_thread -> threaded_state nat add2_thread -> Prop :=
| StepRead : forall global,
    add2_step {| Shared := global; Private := Read |}
              {| Shared := global; Private := Write global |}
| StepWrite : forall global local,
    add2_step {| Shared := global; Private := Write local |}
              {| Shared := S (S local); Private := Read |}.

Definition add2_sys1 := {|
  Initial := add2_init;
  Step := add2_step
|}.

Definition add2_sys := parallel add2_sys1 add2_sys1.

(* Here is the invariant we want to prove. *)
Definition add2_correct (st : threaded_state nat (add2_thread * add2_thread)) :=
  isEven st.(Shared).

(* We can't model-check [add2_sys] directly, because it can reach infinitely
 * many states.  Even if we worked with fixed-precision integers, say with 64
 * bits, the state space would be impractically large to explore directly.
 * Instead, we will *abstract* this system into another one that retains its
 * essential properties.  In particular, we want to find another transition
 * system that *simulates* this one, in the sense made precise by this
 * definition, where [sys1] will be [add2_sys] for this example. *)
Inductive simulates state1 state2 (R : state1 -> state2 -> Prop)
  (* [R] is a relation connecting the states of the two systems. *)
  (sys1 : trsys state1) (sys2 : trsys state2) : Prop :=
| Simulates :
  (* Every initial state of [sys1] has some matching initial state of [sys2]. *)
  (forall st1, sys1.(Initial) st1
               -> exists st2, R st1 st2
                              /\ sys2.(Initial) st2)

  (* Starting from a pair of related states, every step in [sys1] can be matched
   * in [sys2], to destinations that are also related. *)
  -> (forall st1 st2, R st1 st2
                      -> forall st1', sys1.(Step) st1 st1'
                                      -> exists st2', R st1' st2'
                                                      /\ sys2.(Step) st2 st2')

  -> simulates R sys1 sys2.

(* Given an invariant for [sys2], we now have a generic way of defining an
 * invariant for [sys1], by composing with [R]. *)
Inductive invariantViaSimulation state1 state2 (R : state1 -> state2 -> Prop)
  (inv2 : state2 -> Prop)
  : state1 -> Prop :=
| InvariantViaSimulation : forall st1 st2, R st1 st2
  -> inv2 st2
  -> invariantViaSimulation R inv2 st1.

(* By way of a lemma, let's prove that, given a simulation, any
 * invariant-via-simulation really is an invariant for the original system. *)
Lemma invariant_simulates' : forall state1 state2 (R : state1 -> state2 -> Prop)
  (sys1 : trsys state1) (sys2 : trsys state2),
  (forall st1 st2, R st1 st2
                   -> forall st1', sys1.(Step) st1 st1'
                                   ->  exists st2', R st1' st2'
                                                    /\ sys2.(Step) st2 st2')
  -> forall st1 st1', sys1.(Step)^* st1 st1'
                      -> forall st2, R st1 st2
                                     -> exists st2', R st1' st2'
                                                     /\ sys2.(Step)^* st2 st2'.
Proof.
  induct 2.

  simplify.
  exists st2.
  (* [exists E]: prove [exists x, P(x)] by proving [P(E)]. *)
  propositional.
  constructor.

  simplify.
  eapply H in H2.
  first_order.
  (* [first_order]: simplify first-order logic structure.  Be forewarned: this
   *   one is especially likely to run forever! *)
  apply IHtrc in H2.
  first_order.
  exists x1.
  propositional.
  econstructor.
  eassumption.
  assumption.
  assumption.
Qed.

Theorem invariant_simulates : forall state1 state2 (R : state1 -> state2 -> Prop)
  (sys1 : trsys state1) (sys2 : trsys state2) (inv2 : state2 -> Prop),
  simulates R sys1 sys2
  -> invariantFor sys2 inv2
  -> invariantFor sys1 (invariantViaSimulation R inv2).
Proof.
  simplify.
  invert H.
  unfold invariantFor; simplify.
  apply H1 in H.
  first_order.
  apply invariant_simulates' with (sys2 := sys2) (R := R) (st2 := x) in H3; try assumption.
  first_order.
  unfold invariantFor in H0.
  apply H0 with (s' := x0) in H4; try assumption.
  econstructor.
  eassumption.
  assumption.
Qed.

(* OK, that's a general theory for abstracting a system with another one that
 * simulates it.  What abstraction will work for our example of the two threads
 * and the counter?  Here's another program that has replaced integers with
 * Booleans, where the Boolean is true iff the matching integer is even.
 * <<
    bool global = true;

    thread() {
      bool local;

      while (true) {
        local = global;
        global = local;
      }
    }
   >>
 * We can formalize this program as a transition system, too. *)

Inductive add2_bthread :=
| BRead
| BWrite (local : bool).

Inductive add2_binit : threaded_state bool add2_bthread -> Prop :=
| Add2BInit : add2_binit {| Shared := true; Private := BRead |}.

Inductive add2_bstep : threaded_state bool add2_bthread -> threaded_state bool add2_bthread -> Prop :=
| StepBRead : forall global,
    add2_bstep {| Shared := global; Private := BRead |}
               {| Shared := global; Private := BWrite global |}
| StepBWrite : forall global local,
    add2_bstep {| Shared := global; Private := BWrite local |}
               {| Shared := local; Private := BRead |}.

Definition add2_bsys1 := {|
  Initial := add2_binit;
  Step := add2_bstep
|}.

Definition add2_bsys := parallel add2_bsys1 add2_bsys1.

(* This invariant formalizes the connection between local states of threads, in
 * the original and abstracted systems. *)
Inductive R_private1 : add2_thread -> add2_bthread -> Prop :=
| RpRead : R_private1 Read BRead
| RpWrite : forall n b, (b = true <-> isEven n)
                        -> R_private1 (Write n) (BWrite b).

(* We lift [R_private1] to a relation over whole states. *)
Inductive add2_R : threaded_state nat (add2_thread * add2_thread)
                   -> threaded_state bool (add2_bthread * add2_bthread)
                   -> Prop :=
| Add2_R : forall n b th1 th2 th1' th2',
  (b = true <-> isEven n)
  -> R_private1 th1 th1'
  -> R_private1 th2 th2'
  -> add2_R {| Shared := n; Private := (th1, th2) |}
            {| Shared := b; Private := (th1', th2') |}.

(* Let's also recharacterize the initial states via a singleton set. *)
Theorem add2_init_is :
  parallel1 add2_binit add2_binit = { {| Shared := true; Private := (BRead, BRead) |} }.
Proof.
  simplify.
  apply sets_equal; simplify.
  propositional.

  invert H.
  invert H2.
  invert H4.
  equality.

  invert H0.
  constructor.
  constructor.
  constructor.
Qed.

(* We ask Coq to remember this lemma as a hint, which will be used by the
 * model-checking tactics that we refrain from explaining in detail. *)
Hint Rewrite add2_init_is.

(* Now, let's verify the original system. *)
Theorem add2_ok :
  invariantFor add2_sys add2_correct.
Proof.
  (* First step: strengthen the invariant.  We leave an underscore for the
   * unknown invariant, to be found by model checking. *)
  eapply invariant_weaken with (invariant1 := invariantViaSimulation add2_R _).

  (* One way to find an invariant-by-simulation is to find an invariant for the
   * abstracted system, as this step asks to do. *)
  apply invariant_simulates with (sys2 := add2_bsys).

  (* Now we must prove that the simulation via [add2_R] is valid, which is
   * routine. *)
  constructor; simplify.

  invert H.
  invert H0.
  invert H1.
  exists {| Shared := true; Private := (BRead, BRead) |}; simplify.
  propositional.
  constructor.
  propositional.
  constructor.
  constructor.
  constructor.

  invert H.
  invert H0; simplify.

  invert H7.

  invert H2.
  exists {| Shared := b; Private := (BWrite b, th2') |}.
  propositional.
  constructor.
  propositional.
  constructor.
  propositional.
  assumption.
  constructor.
  constructor.

  invert H2.
  exists {| Shared := b0; Private := (BRead, th2') |}.
  propositional.
  constructor.
  propositional.
  constructor.
  assumption.
  invert H0.
  propositional.
  constructor.
  assumption.
  constructor.
  constructor.

  invert H7.

  invert H3.
  exists {| Shared := b; Private := (th1', BWrite b) |}.
  propositional.
  constructor.
  propositional.
  assumption.
  constructor.
  propositional.
  constructor.
  constructor.

  invert H3.
  exists {| Shared := b0; Private := (th1', BRead) |}.
  propositional.
  constructor.
  propositional.
  constructor.
  assumption.
  invert H0.
  propositional.
  assumption.
  constructor.
  constructor.
  constructor.

  (* OK, we're glad to have that over with!  Such a process could also be
   * automated, but we won't bother doing so here.  However, we are now in a
   * good state, where our model checker can find the invariant
   * automatically. *)
  model_check_infer.
  (* It finds exactly four reachable states.  We finish by showing that they all
   * obey the original invariant. *)

  invert 1.
  invert H0.
  simplify.
  unfold add2_correct.
  simplify.
  propositional; subst.

  invert H.
  propositional.

  invert H1.
  propositional.

  invert H.
  propositional.

  invert H1.
  propositional.
Qed.

(** * Another abstraction example *)

(* Let's try a fancier example of abstraction.  Here's a simple integer
 * function.
 * <<
    f(int n) {
      int i, j;

      i = 0;
      j = 0;
      while (n > 0) {
        i = i + n;
        j = j + n;
        n = n - 1;
      }
    }
   >>
 * We might want to prove that "i" and "j" are always equal at the end.
 * First, we formalize the transition system. *)

Inductive pc :=
| i_gets_0
| j_gets_0
| Loop
| i_add_n
| j_add_n
| n_sub_1
| Done.

Record vars := {
  N : nat;
  I : nat;
  J : nat
}.

Record state := {
  Pc : pc;
  Vars : vars
}.

Inductive initial : state -> Prop :=
| Init : forall vs, initial {| Pc := i_gets_0; Vars := vs |}.

Inductive step : state -> state -> Prop :=
| Step_i_gets_0 : forall n i j,
  step {| Pc := i_gets_0; Vars := {| N := n;
                                     I := i;
                                     J := j |} |}
       {| Pc := j_gets_0; Vars := {| N := n;
                                     I := 0;
                                     J := j |} |}
| Step_j_gets_0 : forall n i j,
  step {| Pc := j_gets_0; Vars := {| N := n;
                                     I := i;
                                     J := j |} |}
       {| Pc := Loop; Vars := {| N := n;
                                 I := i;
                                 J := 0 |} |}
| Step_Loop_done : forall i j,
  step {| Pc := Loop; Vars := {| N := 0;
                                 I := i;
                                 J := j |} |}
       {| Pc := Done; Vars := {| N := 0;
                                 I := i;
                                 J := j |} |}
| Step_Loop_enter : forall n i j,
  step {| Pc := Loop; Vars := {| N := S n;
                                 I := i;
                                 J := j |} |}
       {| Pc := i_add_n; Vars := {| N := S n;
                                    I := i;
                                    J := j |} |}
| Step_i_add_n : forall n i j,
  step {| Pc := i_add_n; Vars := {| N := n;
                                    I := i;
                                    J := j |} |}
       {| Pc := j_add_n; Vars := {| N := n;
                                    I := i + n;
                                    J := j |} |}
| Step_j_add_n : forall n i j,
  step {| Pc := j_add_n; Vars := {| N := n;
                                    I := i;
                                    J := j |} |}
       {| Pc := n_sub_1; Vars := {| N := n;
                                    I := i;
                                    J := j + n |} |}
| Step_n_sub_1 : forall n i j,
  step {| Pc := n_sub_1; Vars := {| N := n;
                                    I := i;
                                    J := j |} |}
       {| Pc := Loop; Vars := {| N := n - 1;
                                 I := i;
                                 J := j |} |}.

Definition loopy_sys := {|
  Initial := initial;
  Step := step
|}.

Definition loopy_correct (st : state) :=
  st.(Pc) = Done -> st.(Vars).(I) = st.(Vars).(J).

(* Which abstraction will give us a finite-state system?  Unlike with factorial,
 * here we are more ambitious, seeking an abstraction that will be finite-state
 * even when considering all possible parameter values "n".  Let's try this
 * simple abstract version of variable state. *)
Inductive absvars :=
| Unknown
  (* We don't know anything about the values of the variables. *)
| i_is_0
  (* We know [i == 0]. *)
| i_eq_j
  (* We know [i == j]. *)
| i_eq_j_plus_n.
  (* We know [i == j + n]. *)

(* To get our abstract states, we keep the same program counters and just change
 * out the variable state. *)
Record absstate := {
  APc : pc;
  AVars : absvars
}.

(* Here's the rather boring new abstract step relation.  Note the clever state
 * transformations, in terms of our new abstraction. *)
Inductive absstep : absstate -> absstate -> Prop :=
| AStep_i_gets_0 : forall vs,
  absstep {| APc := i_gets_0; AVars := vs |}
          {| APc := j_gets_0; AVars := i_is_0 |}
| AStep_j_gets_0_i_is_0 :
  absstep {| APc := j_gets_0; AVars := i_is_0 |}
          {| APc := Loop; AVars := i_eq_j |}
| AStep_j_gets_0_Other : forall vs,
  vs <> i_is_0
  -> absstep {| APc := j_gets_0; AVars := vs |}
             {| APc := Loop; AVars := Unknown |}
| AStep_Loop_done : forall vs,
  absstep {| APc := Loop; AVars := vs |}
          {| APc := Done; AVars := vs |}
| AStep_Loop_enter : forall vs,
  absstep {| APc := Loop; AVars := vs |}
          {| APc := i_add_n; AVars := vs |}
| AStep_i_add_n_i_eq_j :
  absstep {| APc := i_add_n; AVars := i_eq_j |}
          {| APc := j_add_n; AVars := i_eq_j_plus_n |}
| AStep_i_add_n_Other : forall vs,
  vs <> i_eq_j
  -> absstep {| APc := i_add_n; AVars := vs |}
             {| APc := j_add_n; AVars := Unknown |}
| AStep_j_add_n_i_eq_j_plus_n :
  absstep {| APc := j_add_n; AVars := i_eq_j_plus_n |}
          {| APc := n_sub_1; AVars := i_eq_j |}
| AStep_j_add_n_i_Other : forall vs,
  vs <> i_eq_j_plus_n
  -> absstep {| APc := j_add_n; AVars := vs |}
             {| APc := n_sub_1; AVars := Unknown |}
| AStep_n_sub_1_bad :
  absstep {| APc := n_sub_1; AVars := i_eq_j_plus_n |}
          {| APc := Loop; AVars := Unknown |}
| AStep_n_sub_1_good : forall vs,
  vs <> i_eq_j_plus_n
  -> absstep {| APc := n_sub_1; AVars := vs |}
             {| APc := Loop; AVars := vs |}.

Definition absloopy_sys := {|
  Initial := { {| APc := i_gets_0; AVars := Unknown |} };
  Step := absstep
|}.

(* Now we need our simulation relation.  First, we define one just at the level
 * of local-variable state.  It formalizes our intuition about those values. *)
Inductive Rvars : vars -> absvars -> Prop :=
| Rv_Unknown : forall vs, Rvars vs Unknown
| Rv_i_is_0 : forall vs, vs.(I) = 0 -> Rvars vs i_is_0
| Rv_i_eq_j : forall vs, vs.(I) = vs.(J) -> Rvars vs i_eq_j
| Rv_i_eq_j_plus_n : forall vs, vs.(I) = vs.(J) + vs.(N) -> Rvars vs i_eq_j_plus_n.

(* We lift to full states in the obvious way. *)
Inductive R : state -> absstate -> Prop :=
| Rcon : forall pc vs avs, Rvars vs avs -> R {| Pc := pc; Vars := vs |}
                                             {| APc := pc; AVars := avs |}.

(* Now we are ready to prove the original system correct. *)
Theorem loopy_ok :
  invariantFor loopy_sys loopy_correct.
Proof.
  eapply invariant_weaken with (invariant1 := invariantViaSimulation R _).
  apply invariant_simulates with (sys2 := absloopy_sys).

  (* Here comes another boring simulation proof. *)
  constructor; simplify.

  invert H.
  exists {| APc := i_gets_0; AVars := Unknown |}.
  propositional.
  constructor.
  constructor.

  invert H0.

  invert H.
  exists {| APc := j_gets_0; AVars := i_is_0 |}.
  propositional; repeat constructor.

  invert H.
  invert H3.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := i_eq_j |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.

  exists {| APc := Done; AVars := st2.(AVars) |}.
  invert H; simplify; propositional; repeat constructor; equality.

  exists {| APc := i_add_n; AVars := st2.(AVars) |}.
  invert H; simplify; propositional; repeat constructor; equality.

  invert H.
  invert H3.
  exists {| APc := j_add_n; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := j_add_n; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := j_add_n; AVars := i_eq_j_plus_n |}; repeat constructor; simplify; equality.
  exists {| APc := j_add_n; AVars := Unknown |}; repeat constructor; equality.

  invert H.
  invert H3.
  exists {| APc := n_sub_1; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := n_sub_1; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := n_sub_1; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := n_sub_1; AVars := i_eq_j |}; repeat constructor; simplify; equality.

  invert H.
  invert H3.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := i_is_0 |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := i_eq_j |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.

  (* Finally, we can call the model checker to find an invariant of the abstract
   * system. *)
  model_check_infer.
  (* We get 7 neat little states, one per program counter.  Next, we prove that
   * each of them implies the original invariant. *)

  invert 1. (* Note that this [1] means "first premise below the double
             * line." *)
  invert H0.
  unfold loopy_correct.
  simplify.
  propositional; subst.

  (* Most of the hypotheses we invert are contradictory, implying that distinct
   * program counters are equal. *)

  invert H2.

  invert H1.

  invert H2.

  invert H1.
  invert H.
  assumption.

  invert H2.

  invert H1.

  invert H2.
Qed.

(** * Modularity *)

(* Throughout the book, we'll come again and again to our two main weapons in
 * soundly modeling complex transition systems with simpler ones.  We just
 * learned about *abstraction*, to replace a full system with a simpler one.
 * The other key one is *modularity*, to replace a system with several others.
 * Let's study one example that helps with model checking, allowing us to check
 * programs with arbitrarily many threads running the same code, while still
 * finding an invariant automatically by brute-force enumeration. *)

(* The key to this particular technique is instrumenting a step relation to
 * consider *interference*, or the actions that other threads might take, in
 * between steps of the thread that we focus on.  This relation is parameterized
 * on an invariant [inv] that the other threads guarantee to preserve on the
 * shared state.  That is, the other threads may mess with the shared state
 * arbitrarily between our own steps, *but* they guarantee that every value they
 * set for it satisfies [inv]. *)
Inductive stepWithInterference shared private (inv : shared -> Prop)
          (step : threaded_state shared private -> threaded_state shared private -> Prop)
          : threaded_state shared private -> threaded_state shared private -> Prop :=

(* First kind of step: this thread runs in the normal way. *)
| StepSelf : forall st st',
  step st st'
  -> stepWithInterference inv step st st'

(* Second kind of step: other threads change shared state to some new value
 * satisfying [inv]. *)
| StepEnvironment : forall sh pr sh',
  inv sh'
  -> stepWithInterference inv step
                          {| Shared := sh; Private := pr |}
                          {| Shared := sh'; Private := pr |}.

(* Via this relation, we have an operator to build a new transition system from
 * an old one, given [inv]. *)
Definition withInterference shared private (inv : shared -> Prop)
           (sys : trsys (threaded_state shared private))
  : trsys (threaded_state shared private) := {|
  Initial := sys.(Initial);
  Step := stepWithInterference inv sys.(Step)
|}.

(* Tired of simulation proofs yet?  Then you'll love this theorem, which shows
 * a free simulation for any use of [withInterference]!  We even get to pick the
 * trivial simulation relation, state equality. *)
Theorem withInterference_abstracts : forall shared private (inv : shared -> Prop)
                                           (sys : trsys (threaded_state shared private)),
  simulates (fun st st' => st = st') sys (withInterference inv sys).
Proof.
  simplify.
  constructor; simplify.

  exists st1; propositional.

  exists st1'; propositional.
  constructor.
  equality.
Qed.

(* That proof was pretty straightforward, because we could construct the
 * simulation using only the first rule of [stepWithInterference], ignoring the
 * possibility for steps by other threads.  We go next for a theorem with an
 * intimidating statement and a much more interesting proof, whose details we
 * nonetheless won't comment on in text.  It may make sense to skip past the
 * next two lemma statements to the main theorem [withInterference_parallel]. *)
Lemma withInterference_parallel1 : forall shared private1 private2
                                          (invs : shared -> Prop)
                                          (sys1 : trsys (threaded_state shared private1))
                                          (sys2 : trsys (threaded_state shared private2))
                                          st st',
  (withInterference invs (parallel sys1 sys2)).(Step)^* st st'
  -> forall st1 st2,
      (forall st1', (withInterference invs sys1).(Step)^* st1 st1' -> invs st1'.(Shared))
      -> (forall st2', (withInterference invs sys2).(Step)^* st2 st2' -> invs st2'.(Shared))
      -> (withInterference invs sys1).(Step)^* st1
                                            {| Shared := st.(Shared);
                                               Private := fst st.(Private) |}
      -> (withInterference invs sys2).(Step)^* st2
                                            {| Shared := st.(Shared);
                                               Private := snd st.(Private) |}
      -> (withInterference invs sys1).(Step)^* st1
                                            {| Shared := st'.(Shared);
                                               Private := fst st'.(Private) |}.
Proof.
  induct 1; simplify.

  assumption.

  invert H; simplify.
  invert H5; simplify.

  apply IHtrc with (st2 := {| Shared := sh'; Private := pr2 |}).
  simplify.
  apply H1.
  assumption.
  simplify.
  eapply H2.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H1 with (st1' := {| Shared := sh'; Private := pr1' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  assumption.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  constructor.

  apply IHtrc with (st2 := {| Shared := sh'; Private := pr2' |}).
  assumption.
  simplify.
  apply H2.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  constructor.
  eassumption.
  eassumption.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H2 with (st2' := {| Shared := sh'; Private := pr2' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  constructor.
  constructor.

  apply IHtrc with (st2 := {| Shared := sh'; Private := snd pr |}).
  assumption.
  simplify.
  eapply H2.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  assumption.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  constructor.
  constructor.
Qed.

Lemma withInterference_parallel2 : forall shared private1 private2
                                          (invs : shared -> Prop)
                                          (sys1 : trsys (threaded_state shared private1))
                                          (sys2 : trsys (threaded_state shared private2))
                                          st st',
  (withInterference invs (parallel sys1 sys2)).(Step)^* st st'
  -> forall st1 st2,
      (forall st1', (withInterference invs sys1).(Step)^* st1 st1' -> invs st1'.(Shared))
      -> (forall st2', (withInterference invs sys2).(Step)^* st2 st2' -> invs st2'.(Shared))
      -> (withInterference invs sys1).(Step)^* st1
                                            {| Shared := st.(Shared);
                                               Private := fst st.(Private) |}
      -> (withInterference invs sys2).(Step)^* st2
                                            {| Shared := st.(Shared);
                                               Private := snd st.(Private) |}
      -> (withInterference invs sys2).(Step)^* st2
                                            {| Shared := st'.(Shared);
                                               Private := snd st'.(Private) |}.
Proof.
  induct 1; simplify.

  assumption.

  invert H; simplify.
  invert H5; simplify.

  apply IHtrc with (st1 := {| Shared := sh'; Private := pr1' |}).
  simplify.
  apply H1.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  assumption.
  assumption.
  constructor.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H1 with (st1' := {| Shared := sh'; Private := pr1' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  constructor.

  apply IHtrc with (st1 := {| Shared := sh'; Private := pr1 |}).
  simplify.
  apply H1.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H2 with (st2' := {| Shared := sh'; Private := pr2' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  constructor.
  eassumption.
  constructor.
  assumption.
  assumption.
  constructor.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  constructor.
  eassumption.
  constructor.

  apply IHtrc with (st1 := {| Shared := sh'; Private := fst pr |}).
  simplify.
  eapply H1.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  assumption.
  assumption.
  constructor.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  constructor.
Qed.

(* OK, we made it to the main theorem.  It helps us find an invariant for a
 * [parallel] system to which we have applied the [withInterference]
 * construction.  Crucially, we may check the invariant for each constituent
 * thread *separately*, avoiding the combinatorial state-space explosion that
 * would come from analyzing the combined system directly.  This is the essence
 * of modularity! *)
Theorem withInterference_parallel : forall shared private1 private2
                                           (invs : shared -> Prop)
                                           (sys1 : trsys (threaded_state shared private1))
                                           (sys2 : trsys (threaded_state shared private2)),
    invariantFor (withInterference invs sys1)
                 (fun st => invs st.(Shared))
    -> invariantFor (withInterference invs sys2)
                    (fun st => invs st.(Shared))
    -> invariantFor (withInterference invs (parallel sys1 sys2))
                    (fun st => invs st.(Shared)).
Proof.
  unfold invariantFor.
  simplify.
  invert H1.

  (* [assert P]: first prove proposition [P], then continue with it as a new
   *   hypothesis. *)
  assert ((withInterference invs sys1).(Step)^*
             {| Shared := sh; Private := pr1 |}
             {| Shared := s'.(Shared); Private := fst s'.(Private) |}).
  apply withInterference_parallel1 with (sys2 := sys2)
                                          (st := {| Shared := sh; Private := (pr1, pr2) |})
                                          (st2 := {| Shared := sh; Private := pr2 |});
    simplify; propositional.
  apply H in H1; propositional.
  apply H0 in H1; propositional.
  constructor.
  constructor.

  assert ((withInterference invs sys2).(Step)^*
             {| Shared := sh; Private := pr2 |}
             {| Shared := s'.(Shared); Private := snd s'.(Private) |}).
  apply withInterference_parallel2 with (sys1 := sys1)
                                          (st := {| Shared := sh; Private := (pr1, pr2) |})
                                          (st1 := {| Shared := sh; Private := pr1 |});
    simplify; propositional.
  apply H in H5; propositional.
  apply H0 in H5; propositional.
  constructor.
  constructor.

  apply H in H1; try assumption.
Qed.

(* Let's apply this principle on a concrete example.  Consider a program with
 * many threads running calls to this function.
 * <<
    int global = 0;

    f() {
      int local = 0;

      while (true) {
        local = global;
        local = 3 + local;
        local = 7 + local;
        global = local;
      }
    }
   >>
 * Here's the usual formalization as a transition system. *)

Inductive twoadd_pc := ReadIt | Add3 | Add7 | WriteIt.

Definition twoadd_initial := { {| Shared := 0; Private := (ReadIt, 0) |} }.

Inductive twoadd_step : threaded_state nat (twoadd_pc * nat)
                        -> threaded_state nat (twoadd_pc * nat) -> Prop :=
| Step_ReadIt : forall g l,
  twoadd_step {| Shared := g; Private := (ReadIt, l) |}
              {| Shared := g; Private := (Add3, g) |}
| Step_Add3 : forall g l,
  twoadd_step {| Shared := g; Private := (Add3, l) |}
              {| Shared := g; Private := (Add7, 3 + l) |}
| Step_Add7 : forall g l,
  twoadd_step {| Shared := g; Private := (Add7, l) |}
              {| Shared := g; Private := (WriteIt, 7 + l) |}
| Step_WriteIt : forall g l,
  twoadd_step {| Shared := g; Private := (WriteIt, l) |}
              {| Shared := l; Private := (ReadIt, l) |}.

Definition twoadd_sys := {|
  Initial := twoadd_initial;
  Step := twoadd_step
|}.

(* Invariant to prove: the global variable is always even, again. *)
Definition twoadd_correct private (st : threaded_state nat private) :=
  isEven st.(Shared).

(* Here's an abstract version of the system where, much like before, we model
 * integers as Booleans, recording whether they are even or not. *)

Definition twoadd_ainitial := { {| Shared := true; Private := (ReadIt, true) |} }.

Inductive twoadd_astep : threaded_state bool (twoadd_pc * bool)
                        -> threaded_state bool (twoadd_pc * bool) -> Prop :=
| AStep_ReadIt : forall g l,
  twoadd_astep {| Shared := g; Private := (ReadIt, l) |}
               {| Shared := g; Private := (Add3, g) |}
| AStep_Add3 : forall g l,
  twoadd_astep {| Shared := g; Private := (Add3, l) |}
               {| Shared := g; Private := (Add7, negb l) |}
| AStep_Add7 : forall g l,
  twoadd_astep {| Shared := g; Private := (Add7, l) |}
               {| Shared := g; Private := (WriteIt, negb l) |}
| AStep_WriteIt : forall g l,
  twoadd_astep {| Shared := g; Private := (WriteIt, l) |}
               {| Shared := l; Private := (ReadIt, l) |}
| AStep_Someone_Made_It_Even : forall g pr,
  twoadd_astep {| Shared := g; Private := pr |}
               {| Shared := true; Private := pr |}.

Definition twoadd_asys := {|
  Initial := twoadd_ainitial;
  Step := twoadd_astep
|}.

(* Here's a simulation relation at the level of integers and their Boolean
 * counterparts. *)
Definition even_R (n : nat) (b : bool) :=
  isEven n <-> b = true.

(* A few unsurprising properties hold of [even_R]. *)

Lemma even_R_0 : even_R 0 true.
Proof.
  unfold even_R; propositional.
  constructor.
Qed.

Lemma even_R_forward : forall n, isEven n -> even_R n true.
Proof.
  unfold even_R; propositional.
Qed.

Lemma even_R_backward : forall n, even_R n true -> isEven n.
Proof.
  unfold even_R; propositional.
Qed.

Lemma even_R_add2 : forall n b,
  even_R n b
  -> even_R (S (S n)) b.
Proof.
  unfold even_R; propositional.
  invert H; propositional.
  constructor; assumption.
Qed.

(* The cases for evenness of an integer and its successor *)
Lemma isEven_decide : forall n,
  (isEven n /\ ~isEven (S n)) \/ (~isEven n /\ isEven (S n)).
Proof.
  induct n; simplify; propositional.

  left; propositional.
  constructor.
  invert H.

  right; propositional.
  constructor; assumption.

  left; propositional.
  invert H.
  propositional.
Qed.

Lemma even_R_add1 : forall n b,
  even_R n b
  -> even_R (S n) (negb b).
Proof.
  unfold even_R; simplify.
  assert ((isEven n /\ ~isEven (S n)) \/ (~isEven n /\ isEven (S n))).
  apply isEven_decide.
  cases b; simplify; propositional.
  equality.
  equality.
Qed.

(* Here's the top-level simulation relation for our choice of abstraction. *)
Inductive twoadd_R : threaded_state nat (twoadd_pc * nat)
                     -> threaded_state bool (twoadd_pc * bool) -> Prop :=
| Twoadd_R : forall pc gn ln gb lb,
  even_R gn gb
  -> even_R ln lb
  -> twoadd_R {| Shared := gn; Private := (pc, ln) |}
              {| Shared := gb; Private := (pc, lb) |}.

(* Step 1 of main proof: model-check an individual thread. *)
Lemma twoadd_ok :
  invariantFor (withInterference isEven twoadd_sys)
               (fun st => isEven (Shared st)).
Proof.
  eapply invariant_weaken.
  apply invariant_simulates with (sys2 := twoadd_asys) (R := twoadd_R).

  (* Boring simulation proof begins here. *)
  constructor; simplify.

  invert H.
  exists {| Shared := true; Private := (ReadIt, true) |}; propositional.
  constructor; propositional.
  apply even_R_0.
  apply even_R_0.
  constructor.
  equality.
  simplify.
  propositional.

  invert H0.
  invert H1.

  invert H.
  exists {| Shared := gb; Private := (Add3, gb) |}; propositional.
  constructor; propositional.
  constructor.

  invert H.
  exists {| Shared := gb; Private := (Add7, negb lb) |}; propositional.
  constructor; propositional.
  apply even_R_add2.
  apply even_R_add1.
  assumption.
  constructor.

  invert H.
  exists {| Shared := gb; Private := (WriteIt, negb lb) |}; propositional.
  constructor; propositional.
  repeat apply even_R_add2.
  apply even_R_add1.
  assumption.
  constructor.

  invert H.
  exists {| Shared := lb; Private := (ReadIt, lb) |}; propositional.
  constructor; propositional.
  constructor.

  invert H.
  exists {| Shared := true; Private := (pc0, lb) |}; propositional.
  constructor; propositional.
  apply even_R_forward.
  assumption.
  constructor.

  (* Now find an invariant automatically. *)
  model_check_infer.

  (* Now prove that the invariant implies the correctness condition. *)
  invert 1.
  invert H0.
  simplify.
  propositional.

  invert H0.
  apply even_R_backward.
  assumption.

  invert H1.
  apply even_R_backward.
  assumption.

  invert H0.
  apply even_R_backward.
  assumption.

  invert H1.
  apply even_R_backward.
  assumption.
Qed.

(* Step 2: lift that result to the two-thread system, with no new model
 * checking. *)
Theorem twoadd2_ok :
  invariantFor (parallel twoadd_sys twoadd_sys) (twoadd_correct (private := _)).
Proof.
  eapply invariant_weaken.
  eapply invariant_simulates.
  apply withInterference_abstracts.
  apply withInterference_parallel.
  apply twoadd_ok.
  apply twoadd_ok.

  unfold twoadd_correct.
  invert 1.
  assumption.
Qed.

(* In fact, this modularity technique is so powerful that we now get correctness
 * for any number of threads, "for free"!  Here's a tactic definition, which we
 * won't explain, but which is able to derive correctness for any number of
 * threads, just by repeating use of [withInterference_parallel] and
 * [twoadd_ok]. *)
Ltac twoadd := eapply invariant_weaken; [ eapply invariant_simulates; [
                                          apply withInterference_abstracts
                                          | repeat (apply withInterference_parallel
                                                    || apply twoadd_ok) ]
                                        | unfold twoadd_correct; invert 1; assumption ].

(* For instance, let's verify the three-thread version. *)
Theorem twoadd3_ok :
  invariantFor (parallel twoadd_sys (parallel twoadd_sys twoadd_sys)) (twoadd_correct (private := _)).
Proof.
  twoadd.
Qed.

(* To save us time defining versions with many threads, here's a recursive
 * function, creating exponentially many threads with respect to its
 * parameter. *)
Fixpoint manyadds_state (n : nat) : Type :=
  match n with
  | O => twoadd_pc * nat
  | S n' => manyadds_state n' * manyadds_state n'
  end%type.

Fixpoint manyadds (n : nat) : trsys (threaded_state nat (manyadds_state n)) :=
  match n with
  | O => twoadd_sys
  | S n' => parallel (manyadds n') (manyadds n')
  end.

(* Here are some examples of the systems we produce. *)
Eval simpl in manyadds 0.
Eval simpl in manyadds 1.
Eval simpl in manyadds 2.
Eval simpl in manyadds 3.

Theorem twoadd4_ok :
  invariantFor (manyadds 4) (twoadd_correct (private := _)).
Proof.
  twoadd.
Qed.

Theorem twoadd6_ok :
  invariantFor (manyadds 6) (twoadd_correct (private := _)).
Proof.
  twoadd.
Qed.


(** * Types: Type Systems *)

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of the simplest
    imaginable language, to introduce the basic ideas of types and
    typing rules and the fundamental theorems about type systems:
    _type preservation_ and _progress_.  In chapter [Stlc] we'll move
    on to the _simply typed lambda-calculus_, which lives at the core
    of every modern functional programming language (including
    Coq!). *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Arith.Arith.
From PLF Require Import Maps.
From PLF Require Import Imp.
From PLF Require Import Smallstep.

Hint Constructors multi : core.

(* ################################################################# *)
(** * Typed Arithmetic Expressions *)

(** To motivate the discussion of type systems, let's begin as
    usual with a tiny toy language.  We want it to have the potential
    for programs to go wrong because of runtime type errors, so we
    need something a tiny bit more complex than the language of
    constants and addition that we used in chapter [Smallstep]: a
    single kind of data (e.g., numbers) is too simple, but just two
    kinds (numbers and booleans) gives us enough material to tell an
    interesting story.

    The language definition is completely routine. *)

(* ================================================================= *)
(** ** Syntax *)

(** Here is the syntax, informally:

    t ::= tru
        | fls
        | test t then t else t
        | zro
        | scc t
        | prd t
        | iszro t

    And here it is formally: *)

Inductive tm : Type :=
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm
  | zro : tm
  | scc : tm -> tm
  | prd : tm -> tm
  | iszro : tm -> tm.

(** (Since it is so simple, we will not bother introducing custom
    concrete syntax for this language.) *)

(** _Values_ are [tru], [fls], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_tru : bvalue tru
  | bv_fls : bvalue fls.

Inductive nvalue : tm -> Prop :=
  | nv_zro : nvalue zro
  | nv_scc : forall t, nvalue t -> nvalue (scc t).

Definition value (t : tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue : core.
Hint Unfold value : core.

(* ================================================================= *)
(** ** Operational Semantics *)

(** Here is the single-step relation, first informally...

                   -------------------------------                  (ST_TestTru)
                   test tru then t1 else t2 --> t1

                   -------------------------------                  (ST_TestFls)
                   test fls then t1 else t2 --> t2

                               t1 --> t1'
            ----------------------------------------------------       (ST_Test)
            test t1 then t2 else t3 --> test t1' then t2 else t3

                             t1 --> t1'
                         ------------------                             (ST_Scc)
                         scc t1 --> scc t1'

                           ---------------                           (ST_PrdZro)
                           prd zro --> zro

                         numeric value v
                        -------------------                          (ST_PrdScc)
                        prd (scc v) --> v

                              t1 --> t1'
                         ------------------                             (ST_Prd)
                         prd t1 --> prd t1'

                          -----------------                        (ST_IszroZro)
                          iszro zro --> tru

                         numeric value v
                      ---------------------                       (ST_IszroScc)
                      iszro (scc v) --> fls

                            t1 --> t1'
                       ----------------------                         (ST_Iszro)
                       iszro t1 --> iszro t1'
*)

(** ... and then formally: *)

Reserved Notation "t '-->' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_TestTru : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFls : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)
  | ST_Scc : forall t1 t1',
      t1 --> t1' ->
      (scc t1) --> (scc t1')
  | ST_PrdZro :
      (prd zro) --> zro
  | ST_PrdScc : forall v,
      nvalue v ->
      (prd (scc v)) --> v
  | ST_Prd : forall t1 t1',
      t1 --> t1' ->
      (prd t1) --> (prd t1')
  | ST_IszroZro :
      (iszro zro) --> tru
  | ST_IszroScc : forall v,
       nvalue v ->
      (iszro (scc v)) --> fls
  | ST_Iszro : forall t1 t1',
      t1 --> t1' ->
      (iszro t1) --> (iszro t1')

where "t '-->' t'" := (step t t').

Hint Constructors step : core.

(** Notice that the [step] relation doesn't care about whether the
    expression being stepped makes global sense -- it just checks that
    the operation in the _next_ reduction step is being applied to the
    right kinds of operands.  For example, the term [scc tru] cannot
    take a step, but the almost as obviously nonsensical term

       scc (test tru then tru else tru)

    can take a step (once, before becoming stuck). *)

(* ================================================================= *)
(** ** Normal Forms and Values *)

(** The first interesting thing to notice about this [step] relation
    is that the strong progress theorem from the [Smallstep]
    chapter fails here.  That is, there are terms that are normal
    forms (they can't take a step) but not values (they are not
    included in our definition of possible "results of reduction").
    Such terms are said to be _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t : tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck : core.

(** **** Exercise: 2 stars, standard (some_term_is_stuck) *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** However, although values and normal forms are _not_ the same in
    this language, the set of values is a subset of the set of normal
    forms.  This is important because it shows we did not accidentally
    define things so that some value could still take a step. *)

(** **** Exercise: 3 stars, standard (value_is_nf) *)
Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  (* FILL IN HERE *) Admitted.

(** (Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways.)

    [] *)

(** **** Exercise: 3 stars, standard, optional (step_deterministic)

    Use [value_is_nf] to show that the [step] relation is also
    deterministic. *)

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Typing *)

(** The next critical observation is that, although this
    language has stuck terms, they are always nonsensical, mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | Bool : ty
  | Nat : ty.

(** In informal notation, the typing relation is often written
    [|- t \in T] and pronounced "[t] has type [T]."  The [|-] symbol
    is called a "turnstile."  Below, we're going to see richer typing
    relations where one or more additional "context" arguments are
    written to the left of the turnstile.  For the moment, the context
    is always empty.

                           ---------------                     (T_Tru)
                           |- tru \in Bool

                          ---------------                      (T_Fls)
                          |- fls \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------     (T_Test)
                    |- test t1 then t2 else t3 \in T

                             --------------                    (T_Zro)
                             |- zro \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Scc)
                          |- scc t1 \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Prd)
                          |- prd t1 \in Nat

                            |- t1 \in Nat
                        --------------------                 (T_IsZro)
                        |- iszro t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_Tru :
       |- tru \in Bool
  | T_Fls :
       |- fls \in Bool
  | T_Test : forall t1 t2 t3 T,
       |- t1 \in Bool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- test t1 t2 t3 \in T
  | T_Zro :
       |- zro \in Nat
  | T_Scc : forall t1,
       |- t1 \in Nat ->
       |- scc t1 \in Nat
  | T_Prd : forall t1,
       |- t1 \in Nat ->
       |- prd t1 \in Nat
  | T_Iszro : forall t1,
       |- t1 \in Nat ->
       |- iszro t1 \in Bool

where "'|-' t '\in' T" := (has_type t T).

Hint Constructors has_type : core.

Example has_type_1 :
  |- test fls zro (scc zro) \in Nat.
Proof.
  apply T_Test.
  - apply T_Fls.
  - apply T_Zro.
  - apply T_Scc. apply T_Zro.
Qed.

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not consider
    what happens when the term is reduced -- in particular, it does
    not calculate the type of its normal form. *)

Example has_type_not :
  ~ ( |- test fls zro tru \in Bool ).
Proof.
  intros Contra. solve_by_inverts 2.  Qed.

(** **** Exercise: 1 star, standard, optional (scc_hastype_nat__hastype_nat) *)
Example scc_hastype_nat__hastype_nat : forall t,
  |- scc t \in Nat ->
  |- t \in Nat.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Canonical forms *)

(** The following two lemmas capture the fundamental property that the
    definitions of boolean and numeric values agree with the typing
    relation. *)

Lemma bool_canonical : forall t,
  |- t \in Bool -> value t -> bvalue t.
Proof.
  intros t HT [Hb | Hn].
  - assumption.
  - destruct Hn as [ | Hs].
    + inversion HT.
    + inversion HT.
Qed.

Lemma nat_canonical : forall t,
  |- t \in Nat -> value t -> nvalue t.
Proof.
  intros t HT [Hb | Hn].
  - inversion Hb; subst; inversion HT.
  - assumption.
Qed.

(* ================================================================= *)
(** ** Progress *)

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are not stuck -- or conversely, if a
    term is well typed, then either it is a value or it can take at
    least one step.  We call this _progress_. *)

(** **** Exercise: 3 stars, standard (finish_progress) *)
Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t --> t'.

(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the parts we've given of the informal proof in the
    following exercise before starting -- this will save you a lot of
    time.) *)
Proof.
  intros t T HT.
  induction HT; auto.
  (* The cases that were obviously values, like T_Tru and
     T_Fls, are eliminated immediately by auto *)
  - (* T_Test *)
    right. destruct IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    destruct H.
      * exists t2. auto.
      * exists t3. auto.
    + (* t1 can take a step *)
      destruct H as [t1' H1].
      exists (test t1' t2 t3). auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_progress_informal)

    Complete the corresponding informal proof: *)

(** _Theorem_: If [|- t \in T], then either [t] is a value or else
    [t --> t'] for some [t']. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

    - If the last rule in the derivation is [T_Test], then [t = test t1
      then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
      \in T].  By the IH, either [t1] is a value or else [t1] can step
      to some [t1'].

      - If [t1] is a value, then by the canonical forms lemmas
        and the fact that [|- t1 \in Bool] we have that [t1]
        is a [bvalue] -- i.e., it is either [tru] or [fls].
        If [t1 = tru], then [t] steps to [t2] by [ST_TestTru],
        while if [t1 = fls], then [t] steps to [t3] by
        [ST_TestFls].  Either way, [t] can step, which is what
        we wanted to show.

      - If [t1] itself can take a step, then, by [ST_Test], so can
        [t].

    - (* FILL IN HERE *)
 *)
(* Do not modify the following line: *)
Definition manual_grade_for_finish_progress_informal : option (nat*string) := None.
(** [] *)

(** This theorem is more interesting than the strong progress theorem
    that we saw in the [Smallstep] chapter, where _all_ normal forms
    were values.  Here a term can be stuck, but only if it is ill
    typed. *)

(* ================================================================= *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is a well-typed term (of the same type). *)

(** **** Exercise: 2 stars, standard (finish_preservation) *)
Theorem preservation : forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.

(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)

Proof.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try solve_by_invert.
    - (* T_Test *) inversion HE; subst; clear HE.
      + (* ST_TESTTru *) assumption.
      + (* ST_TestFls *) assumption.
      + (* ST_Test *) apply T_Test; try assumption.
        apply IHHT1; assumption.
    (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_preservation_informal)

    Complete the following informal proof: *)

(** _Theorem_: If [|- t \in T] and [t --> t'], then [|- t' \in T]. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

    - If the last rule in the derivation is [T_Test], then [t = test t1
      then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
      \in T].

      Inspecting the rules for the small-step reduction relation and
      remembering that [t] has the form [test ...], we see that the
      only ones that could have been used to prove [t --> t'] are
      [ST_TestTru], [ST_TestFls], or [ST_Test].

      - If the last rule was [ST_TestTru], then [t' = t2].  But we
        know that [|- t2 \in T], so we are done.

      - If the last rule was [ST_TestFls], then [t' = t3].  But we
        know that [|- t3 \in T], so we are done.

      - If the last rule was [ST_Test], then [t' = test t1' then t2
        else t3], where [t1 --> t1'].  We know [|- t1 \in Bool] so,
        by the IH, [|- t1' \in Bool].  The [T_Test] rule then gives us
        [|- test t1' then t2 else t3 \in T], as required.

    - (* FILL IN HERE *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_finish_preservation_informal : option (nat*string) := None.
(** [] *)

(** **** Exercise: 3 stars, standard (preservation_alternate_proof)

    Now prove the same property again by induction on the
    _evaluation_ derivation instead of on the typing derivation.
    Begin by carefully reading and thinking about the first few
    lines of the above proofs to make sure you understand what
    each one is doing.  The set-up for this proof is similar, but
    not exactly the same. *)

Theorem preservation' : forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The preservation theorem is often called _subject reduction_,
    because it tells us what happens when the "subject" of the typing
    relation is reduced.  This terminology comes from thinking of
    typing statements as sentences, where the term is the subject and
    the type is the predicate. *)

(* ================================================================= *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we see that a
    well-typed term can never reach a stuck state.  *)

Definition multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
  |- t \in T ->
  t -->* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  - apply progress in HT. destruct HT; auto.
  - apply IHP.
    + apply preservation with (t := x); auto.
    + unfold stuck. split; auto.
Qed.

(* ================================================================= *)
(** ** Additional Exercises *)

(** **** Exercise: 2 stars, standard, especially useful (subject_expansion)

    Having seen the subject reduction property, one might
    wonder whether the opposity property -- subject _expansion_ --
    also holds.  That is, is it always the case that, if [t --> t']
    and [|- t' \in T], then [|- t \in T]?  If so, prove it.  If
    not, give a counter-example.  (You do not need to prove your
    counter-example in Coq, but feel free to do so.)

    (* FILL IN HERE *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_subject_expansion : option (nat*string) := None.
(** [] *)

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

    Suppose that we add this new rule to the typing relation:

      | T_SccBool : forall t,
           |- t \in Bool ->
           |- scc t \in Bool

   Which of the following properties remain true in the presence of
   this rule?  For each one, write either "remains true" or
   else "becomes false." If a property becomes false, give a
   counterexample.
      - Determinism of [step]
            (* FILL IN HERE *)
      - Progress
            (* FILL IN HERE *)
      - Preservation
            (* FILL IN HERE *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_variation1 : option (nat*string) := None.
(** [] *)

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

    Suppose, instead, that we add this new rule to the [step] relation:

      | ST_Funny1 : forall t2 t3,
           (test tru t2 t3) --> t3

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
            (* FILL IN HERE *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_variation2 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (variation3)

    Suppose instead that we add this rule:

      | ST_Funny2 : forall t1 t2 t2' t3,
           t2 --> t2' ->
           (test t1 t2 t3) --> (test t1 t2' t3)

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
            (* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 2 stars, standard, optional (variation4)

    Suppose instead that we add this rule:

      | ST_Funny3 :
          (prd fls) --> (prd (prd fls))

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 2 stars, standard, optional (variation5)

    Suppose instead that we add this rule:

      | T_Funny4 :
            |- zro \in Bool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 2 stars, standard, optional (variation6)

    Suppose instead that we add this rule:

      | T_Funny5 :
            |- prd zro \in Bool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 3 stars, standard, optional (more_variations)

    Make up some exercises of your own along the same lines as
    the ones above.  Try to find ways of selectively breaking
    properties -- i.e., ways of changing the definitions that
    break just one of the properties and leave the others alone.
*)
(* FILL IN HERE

    [] *)

(** **** Exercise: 1 star, standard (remove_prdzro)

    The reduction rule [ST_PrdZro] is a bit counter-intuitive: we
    might feel that it makes more sense for the predecessor of [zro] to
    be undefined, rather than being defined to be [zro].  Can we
    achieve this simply by removing the rule from the definition of
    [step]?  Would doing so create any problems elsewhere?

(* FILL IN HERE *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_remove_predzro : option (nat*string) := None.
(** [] *)

(** **** Exercise: 4 stars, advanced (prog_pres_bigstep)

    Suppose our evaluation relation is defined in the big-step style.
    State appropriate analogs of the progress and preservation
    properties. (You do not need to prove them.)

    Can you see any limitations of either of your properties?  Do they
    allow for nonterminating programs?  Why might we prefer the
    small-step semantics for stating preservation and progress?

(* FILL IN HERE *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_prog_pres_bigstep : option (nat*string) := None.
(** [] *)

(* 2021-08-11 15:11 *)


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.

(* Why3 assumption *)
Fixpoint length {a:Type} {a_WT:WhyType a} (l:(list a)) {struct l}: Z :=
  match l with
  | Init.Datatypes.nil => 0%Z
  | (Init.Datatypes.cons _ r) => (1%Z + (length r))%Z
  end.

Lemma length_std :
  forall {a:Type} {a_WT:WhyType a} (l:list a),
  length l = Z_of_nat (List.length l).
Proof.
intros a a_WT l.
induction l.
easy.
change (1 + length l = Z_of_nat (S (List.length l)))%Z.
now rewrite inj_S, Zplus_comm, IHl.
Qed.

(* Why3 goal *)
Lemma Length_nonnegative : forall {a:Type} {a_WT:WhyType a},
  forall (l:(list a)), (0%Z <= (length l))%Z.
Proof.
intros a a_WT l.
rewrite length_std.
apply Zle_0_nat.
Qed.

(* Why3 goal *)
Lemma Length_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = Init.Datatypes.nil).
Proof.
intros a a_WT [|h t] ; split ; try easy.
unfold length. fold length.
intros H.
exfalso.
generalize (Length_nonnegative t).
omega.
Qed.


(*|
########################################################################################
Why does nesting the induction tactic also nest the inductive hypotheses under a lambda?
########################################################################################

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

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

Require Import Coq.Arith.PeanoNat. (* .none *)
Theorem mult_comm : forall m n : nat, m * n = n * m.
Proof.
  intros. induction n.
  - simpl. rewrite (Nat.mul_0_r m). reflexivity.
  - simpl. rewrite <- IHn. induction m.
    + simpl. reflexivity.
    + simpl.

(*| The above is from the Software Foundation's second chapter. |*)

      Show. (* .unfold .messages *)

(*|
I am really confused as to what ``IHm`` is supposed to be here. The
way I understand it, Coq tactics get compiled under the hood to some
functional program, but I am really not sure what is going on here. I
am pretty sure that this is not I intended it to do.

What I wanted to do is something like the following Idris program.

.. code-block:: idris

    add_comm : {a,b : Nat} -> a + b = b + a
    add_assoc : {a,b,c : Nat} -> (a + b) + c = a + (b + c)

    total
    mult_comm : {m,n : Nat} -> (m * n) = n * m
    mult_comm {m = Z} {n = Z} = Refl
    mult_comm {m = Z} {n = (S k)} = mult_comm {m=Z} {n=k}
    mult_comm {m = (S k)} {n = Z} = mult_comm {m=k} {n=Z}
    mult_comm {m = (S k)} {n = (S j)} =
        let prf1 = mult_comm {m=k} {n=S j}
            prf2 = mult_comm {m=S k} {n=j}
            prf3 = mult_comm {m=k} {n=j}
            prf_add_comm = add_comm {a=k} {b=j}
            prf_add_assoc = add_assoc {a=k} {b=j} {c=j*k}
            prf_add_assoc' = add_assoc {a=j} {b=k} {c=j*k}
        in
            rewrite prf1 in
            rewrite sym prf2 in
            rewrite prf3 in
            rewrite sym prf_add_assoc in
            rewrite sym prf_add_assoc' in
            rewrite (add_comm {a=k} {b=j}) in
            Refl

More specifically, I need ``prf1``, ``prf2`` and ``prf3`` which I get
using recursive calls to ``mult_comm``. In Coq the two of the proofs
are stuck in a lambda and I am not sure how that happened. I see that
Coq's ``induction`` tactic is not doing what I think it should be
doing.

In addition to the explanation of the above, let me also ask is there
more introductory material to Coq than Software Foundations just in
case I get stuck like this again on some tactic? Note that I know how
to solve this in Coq as I've found the solution online.

I've tried tackling the SF book unsuccessfully back in 2016 as an
introduction to dependently typed programming and now with the benefit
of hindsight, I see that Little Typer and the Idris book are much
better in that regard.
|*)

(*|
Answer
******

When you call the ``induction`` tactic, Coq uses heuristics to
determine the predicate ``P : nat -> Prop`` that you want to prove by
induction. Before calling ``induction`` for the second time, the proof
state looks like this:
|*)
      Undo 6. (* .none *) Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
What happened is that Coq decided to include the premise ``IHn`` in
the induction predicate, which was inferred to be

.. code-block:: coq

    P m := m * n = n * m -> m * S n = m + m * n

which is exactly what you had in your induction hypothesis. In this
case, you could argue that it was silly for Coq to use the premise,
but there are cases where dropping it would result in an unprovable
goal. For instance, consider the following proof attempt:
|*)

Lemma double_inj : forall n m, n + n = m + m -> n = m.
Proof.
  intros n m H.
  induction n as [|n IH].
  (* ... *)
Abort. (* .none *)

(*|
If ``H`` were dropped after calling ``induction``, you would have to
prove ``forall n m, n = m``, which clearly does not hold.

This example is one of the reasons why it is often a bad idea to call
``induction`` multiple times in a single Coq proof. As we suggest in
that exercise in Software Foundations, it is better to prove an
auxiliary lemma, since you can be explicit about the induction
predicate. For this example, there are other options as well. You
could, for instance, call ``clear IHn`` to drop the ``IHn`` premise,
which would lead Coq to the correct predicate. The ssreflect proof
language, which now ships with Coq, has a different tactic for
performing induction called ``elim``, which allows you to be more
explicit in the choice of the predicate.

I agree with your final comment, but I should add that it is not the
goal of Software Foundations to be an introduction to dependently
typed programming. Though Coq supports this paradigm, it is generally
cumbersome to write such programs directly, and much easier to use
tactics to prove lemmas about simply typed programs. For instance,
your proof of ``mult_comm`` is accepted by Idris because its
termination checker is smart enough to recognize all recursive calls
as decreasing, even though they are not decreasing with respect to a
fixed argument (in the second clause, ``n`` decreases, whereas in the
third ``m`` does). This is not possible in Coq, and you must split the
definition into multiple recursive functions, one for each argument,
or use well-founded induction on pairs of natural numbers, which would
be overkill for this example.

Adam Chlipala has another Coq textbook called `CPDT
<http://adam.chlipala.net/cpdt/>`__ that you might want to check out.
However, I don't think you will find a comprehensive description of
Coq's tactics there, either. Like ``induction``, many tactics rely on
heuristics and are hard to explain in detail.

On a final note, Matthieu Sozeau has developed a package called
`Equations <https://github.com/mattam82/Coq-Equations>`__ that makes
dependently typed programming in Coq much closer to Idris or Agda. If
you find this style of proving more intuitive, you could try to use
it.
|*)


Require Import
  HoTT.Classes.orders.naturals
  HoTT.Classes.implementations.peano_naturals.
Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.theory.naturals.

Generalizable Variables N.

Section contents.
Context `{Funext} `{Univalence}.
Context `{Naturals N}.
(* Add Ring N : (rings.stdlib_semiring_theory N). *)

(* NatDistance instances are all equivalent, because their behavior is fully
 determined by the specification. *)
Lemma nat_distance_unique {a b : NatDistance N}
  : forall x y, @nat_distance _ _ a x y = @nat_distance _ _ b x y.
Proof.
intros. unfold nat_distance.
destruct (@nat_distance_sig _ _ a x y) as [[z1 E1]|[z1 E1]],
(@nat_distance_sig _ _ b x y) as [[z2 E2]|[z2 E2]];simpl.
- apply (left_cancellation plus x). path_via y.
- rewrite <-(rings.plus_0_r y),<-E2,<-rings.plus_assoc in E1.
  apply (left_cancellation plus y) in E1. apply naturals.zero_sum in E1.
  destruct E1;path_via 0.
- rewrite <-(rings.plus_0_r x),<-E2,<-rings.plus_assoc in E1.
  apply (left_cancellation plus x) in E1. apply naturals.zero_sum in E1.
  destruct E1;path_via 0.
- apply (left_cancellation plus y);path_via x.
Qed.

End contents.

(* An existing instance of [CutMinus]
   allows to create an instance of [NatDistance] *)
Global Instance natdistance_cut_minus `{Naturals N} `{!TrivialApart N}
   {cm} `{!CutMinusSpec N cm} `{forall x y, Decidable (x ≤ y)} : NatDistance N.
Proof.
red. intros. destruct (decide_rel (<=) x y) as [E|E].
- left. exists (y ∸ x).
  rewrite rings.plus_comm;apply cut_minus_le;trivial.
- right. exists (x ∸ y).
  rewrite rings.plus_comm;apply cut_minus_le, orders.le_flip;trivial.
Defined.

(* Using the preceding instance we can make an instance
   for arbitrary models of the naturals
   by translation into [nat] on which we already have a [CutMinus] instance. *)
Global Instance natdistance_default `{Naturals N} : NatDistance N | 10.
Proof.
intros x y.
destruct (nat_distance_sig (naturals_to_semiring N nat x)
  (naturals_to_semiring N nat y)) as [[n E]|[n E]].
- left. exists (naturals_to_semiring nat N n).
  rewrite <-(naturals.to_semiring_involutive N nat y), <-E.
  rewrite (rings.preserves_plus (A:=nat)), (naturals.to_semiring_involutive _ _).
  split.
- right. exists (naturals_to_semiring nat N n).
  rewrite <-(naturals.to_semiring_involutive N nat x), <-E.
  rewrite (rings.preserves_plus (A:=nat)), (naturals.to_semiring_involutive _ _).
  split.
Defined.