From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial ssralg finset fingroup finalg.
From mathcomp Require Import matrix.
Require Import Reals Fourier.
From infotheo Require Import Reals_ext ssrR logb ssr_ext ssralg_ext Rbigop.

Local Open Scope reals_ext_scope.

(** Generalization of section [sum_dom_codom] in [infotheo.Rbigop] *)

Section sum_dom_codom_generalized.

Variable A B : finType. (* B <> R *)

Lemma sum_parti' (p : seq A) (X : A -> B) : forall F, uniq p ->
  \rsum_(i <- p) (F i) =
  \rsum_(r <- undup (map X p)) \big[Rplus/0]_(i <- p | X i == r) (F i).
Proof.
move Hn : (undup (map X (p))) => n.
move: n p X Hn.
elim => [p X HA F Hp | h t IH p X H F Hp].
- rewrite big_nil.
  move/undup_nil in HA.
  suff: p = [::] by move ->; rewrite big_nil.
  by apply size0nil; rewrite -(size_map X) HA.
- rewrite big_cons.
  have [preh [pret [H1 [H2 H3]]]] : exists preh pret,
    perm_eq p (preh ++ pret) /\ undup (map X preh) = [:: h] /\ undup (map X pret) = t.
    by apply undup_perm.
  apply trans_eq with (\big[Rplus/0]_(i <- preh ++ pret) F i).
    by apply: eq_big_perm.
  apply trans_eq with
   (\big[Rplus/0]_(i <- preh ++ pret | X i == h) F i +
   \rsum_(j <- t) \big[Rplus/0]_(i <- preh ++ pret | X i == j) F i); last first.
    f_equal.
    apply: eq_big_perm.
      by rewrite perm_eq_sym.
    apply eq_bigr => i _ /=.
    apply: eq_big_perm.
    by rewrite perm_eq_sym.
  have -> :
    \rsum_(j <- t) \big[Rplus/0]_(i <- (preh ++ pret) | X i == j) F i =
    \rsum_(j <- t) \big[Rplus/0]_(i <- pret | X i == j) F i.
    rewrite big_seq_cond.
    symmetry.
    rewrite big_seq_cond /=.
    apply eq_bigr => i Hi.
    rewrite big_cat /=.
    have -> : \big[Rplus/0]_(i0 <- preh | X i0 == i) F i0 = 0.
      transitivity (\big[Rplus/0]_(i0 <- preh | false) F i0).
      rewrite big_seq_cond.
      apply eq_bigl => /= j.
      apply/negP.
      case/andP; move=> Xj_i; move/eqP=> j_preh.
      subst i.
      have Xj_h : X j \in [:: h].
        have H4 : X j \in map X preh by apply/mapP; exists j.
        have H5 : X j \in undup (map X preh)  by rewrite mem_undup.
        by rewrite H2 in H5.
      have : uniq (h :: t).
        rewrite -H.
        apply undup_uniq.
        rewrite /= in_cons in_nil orbC /= in Xj_h.
        move/eqP : Xj_h => Xj_h.
        subst h.
        rewrite andbC /= in Hi.
        by rewrite /= Hi.
      by rewrite big_pred0.
      by rewrite add0R.
  rewrite -IH //; last first.
    have : uniq (preh ++ pret) by rewrite -(@perm_eq_uniq _ _ _ H1).
    rewrite cat_uniq.
    case/andP => _; by case/andP.
  have -> :  \big[Rplus/0]_(i <- (preh ++ pret) | X i == h) F i =
    \rsum_(i <- preh) F i.
    rewrite big_cat /=.
    have -> : \big[Rplus/0]_(i <- pret | X i == h) F i = 0.
      transitivity (\big[Rplus/0]_(i0 <- pret | false) F i0); last first.
        by rewrite big_pred0.
      rewrite big_seq_cond.
      apply eq_bigl => /= j.
      apply/negP.
      case/andP; move => j_pret; move/eqP => Xj_h.
      subst h.
      have Xj_t : X j \in t.
        have H4 : X j \in map X pret.
        apply/mapP; by exists j.
        have H5 : X j \in undup (map X pret).
        by rewrite mem_undup.
        by rewrite H3 in H5.
      have : uniq (X j :: t).
        rewrite -H.
        by apply undup_uniq.
      by rewrite /= Xj_t.
    rewrite addR0 big_seq_cond /=.
    symmetry.
    rewrite big_seq_cond /=.
    apply congr_big => //= x.
    case/orP : (orbN (x \in preh)) => Y.
    + rewrite Y /=.
      symmetry.
      have : X x \in [:: h].
        rewrite -H2 mem_undup.
        apply/mapP.
        by exists x.
      by rewrite in_cons /= in_nil orbC.
    + by rewrite (negbTE Y) andbC.
  by rewrite big_cat.
Qed.

Lemma sum_parti'_finType (X : A -> B) F :
   \rsum_(i in A) (F i) =
   \rsum_(r <- undup (map X (enum A))) \big[Rplus/0]_(i in A | X i == r) (F i).
Proof.
move: (@sum_parti' (enum A) X F) => /=.
rewrite enum_uniq.
move/(_ (refl_equal _)) => IH.
transitivity (\big[Rplus/0]_(i <- enum A) F i).
  apply congr_big => //.
  by rewrite enumT.
rewrite IH.
apply eq_bigr => i _.
apply congr_big => //.
by rewrite enumT.
Qed.

End sum_dom_codom_generalized.


Require Export Iron.Language.SystemF.Ty.
Require Export Iron.Language.SystemF.Ki.

(* Kind judgement assigns a kind to a type.

   With plain SystemF (not SystemF2) we only have value types.
   We could have made this a 2-place relation and omitted the
   KStar return kind, but doing it this way makes the form of the
   judgement more similar to the SystemF2 case.
 *)
Inductive KIND : kienv -> ty -> ki -> Prop :=
 | KICon
   :  forall ke c
   ,  KIND ke (TCon c) KStar

 | KIVar
   :  forall ke i k
   ,  get  i ke = Some k
   -> KIND ke (TVar i) k

 | KIForall
   :  forall ke t
   ,  KIND (ke :> KStar) t           KStar
   -> KIND ke            (TForall t) KStar

 | KIFun
   :  forall ke t1 t2
   ,  KIND ke t1 KStar
   -> KIND ke t2 KStar
   -> KIND ke (TFun t1 t2) KStar.

Hint Constructors KIND.

(********************************************************************)
(* A well kinded type is well formed. *)
Lemma kind_wfT
 :  forall ke t k
 ,  KIND ke t k
 -> wfT  ke t.
Proof.
 intros. gen ke k.
 induction t; intros; inverts H; simpl; eauto.
Qed.

(* If a type is well kinded in an empty environment,
   then that type is closed. *)
Lemma kind_empty_is_closed
 :  forall t k
 ,  KIND nil t k
 -> closedT t.
Proof.
 intros. unfold closedT. eapply kind_wfT. eauto.
Qed.

(* We can insert a new type into the environment at an arbitray point
   provided we lift existing references to types higher than this
   point across the new one. *)
Lemma liftTT_insert
 :  forall ke ix t k1 k2
 ,  KIND ke t k1
 -> KIND (insert ix k2 ke) (liftTT ix t) k1.
Proof.
 intros. gen ix ke k1.
 induction t; intros; simpl; inverts H; eauto.

 Case "TVar".
  lift_cases; intros; auto.

 Case "TForall".
  apply KIForall.
  rewrite insert_rewind.
  apply IHt. auto.
Qed.

(* Weakening the kind environment by pushing a new type onto the
   stack *)
Lemma liftTT_weaken
 :  forall ke t k1 k2
 ,  KIND  ke         t           k1
 -> KIND (ke :> k2) (liftTT 0 t) k1.
Proof.
 intros.
 assert (ke :> k2 = insert 0 k2 ke). simpl.
   destruct ke; auto.
 rewrite H0. apply liftTT_insert. auto.
Qed.


Require Import PointContinuousFunction.
Require Import QArith.QArith_base.
Require Import Sequence.
Require Import Psatz.

Definition fex1 (x:Q) := x.
Definition rex1       := 0.

Lemma fex1_works : forall x y, x==y -> fex1 x == fex1 y.
Proof.
intros.
unfold fex1.
auto.
Qed.

Lemma ex1 : PointContinuousFunction.
Proof.
  apply Build_PointContinuousFunction with (PContinf := fex1) (PContinr := rex1).
  unfold PointContinuousFunction_def.
  intros.

  remember (fun (q:Q) => q) as qseqa.

  exists (Seqa seq).

  unfold ConvergentSequence_def.

  intros.

  unfold fex1.

  assert( rex1 == Seqr seq ) by lra.

  rewrite H1.

  assert (H2 := Seq_spec seq).

  unfold ConvergentSequence_def in H2.

  assert (H3 := H2 q).
  assert (H4 := H3 H0).
  apply H4.

 Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* This needs step by step unfolding *)

Fixpoint T (n:nat) : Prop :=
  match n with
  | O => True
  | S p => n = n -> T p
  end.

Require Import Arith.

Goal T 3 -> T 1.
intro H.
apply H.

(* This needs unification on type *)

Goal forall n m : nat, S m = S n :>nat.
intros.
apply f_equal.

(* f_equal : forall (A B:Set) (f:A->B) (x y:A), x=y->(f x)=(f y) *)
(* and A cannot be deduced from the goal but only from the type of f, x or y *)


Require Import List Map Envs AllInRel Exp MoreList.
Require Import IL.
Require Import Liveness.Liveness LabelsDefined.

Set Implicit Arguments.

Definition one_or_empty_if k X `{OrderedType X} (s:set X) : set X
  := if [cardinal s >= k] then
      match choose s with
      | Some x => singleton x
      | None => ∅
      end
    else
      ∅.

Lemma one_or_empty_of_incl k X `{OrderedType X} (s:set X)
  : one_or_empty_if k s ⊆ s.
Proof.
  unfold one_or_empty_if. repeat cases; eauto with cset.
  exploit choose_1; eauto. cset_tac.
Qed.

Lemma one_or_empty_cardinal_ge k X `{OrderedType X} (s:set X)
  : k > 0 -> cardinal s >= k -> cardinal (one_or_empty_if k s) = 1.
Proof.
  unfold one_or_empty_if. repeat cases; eauto with cset.
  - intros; exfalso.
    exploit choose_2; eauto.
    exploit cardinal_1; eauto. omega.
  - intros; omega.
Qed.

Lemma one_or_empty_cardinal_lt k X `{OrderedType X} (s:set X)
  : cardinal s < k -> one_or_empty_if k s = ∅.
Proof.
  unfold one_or_empty_if. repeat cases; eauto with cset.
  - intros; exfalso. omega.
Qed.

Definition one_or_empty_if' k X `{OrderedType X} (s t:set X) : set X
  := if [cardinal s >= k] then
      match choose (s ∩ t) with
      | Some x => singleton x
      | None => match choose s with
               | Some x => singleton x
               | None => ∅
               end
      end
    else
      ∅.

Lemma one_or_empty_of_incl' k X `{OrderedType X} (s t:set X)
  : one_or_empty_if' k s t ⊆ s.
Proof.
  unfold one_or_empty_if'. repeat cases; eauto with cset.
  - exploit choose_1; eauto. cset_tac.
  - symmetry in Heq0. apply choose_1 in Heq0. cset_tac.
Qed.

Lemma one_or_empty_cardinal_ge' k X `{OrderedType X} (s t:set X)
  : k > 0 -> cardinal s >= k -> cardinal (one_or_empty_if' k s t) = 1.
Proof.
  unfold one_or_empty_if'. repeat cases; eauto with cset.
  - intros; exfalso.
    exploit choose_2; eauto.
    exploit cardinal_1; eauto. omega.
  - intros; omega.
Qed.

Lemma one_or_empty_cardinal_lt' k X `{OrderedType X} (s t:set X)
  : cardinal s < k -> one_or_empty_if' k s t = ∅.
Proof.
  unfold one_or_empty_if'. repeat cases; eauto with cset.
  - intros; exfalso. omega.
  - intros; exfalso. omega.
Qed.


Require Import Coq.Arith.EqNat.
Require Import Coq.Init.Nat.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.

Require Import Hapsl.Ascii.Class.
Require Import Hapsl.Bool.Bool.
Require Import Hapsl.String.Equality.

Import StringEqualityNotations.

(* Returns true if a string contains a substring, otherwise returns false. *)
Fixpoint contains (h n : string) : bool :=
  match h with
  | String c s =>
      if length h <? length n then
        false
      else if (substring 0 (length n) h) ==_s n then
        true
      else
        contains s n
  | EmptyString => eqb (length n) 0
  end.

(* Counts the number of characters in a string that satisfy a function. *)
Fixpoint string_count (s : string) (f : ascii->bool) : nat :=
  match s with
  | EmptyString => 0
  | String c s => (nat_of_bool (f c)) + (string_count s f)
  end.

(* Returns the number of lower case letters in a string. *)
Definition string_count_lower (s : string) : nat :=
  string_count s is_lower.

(* Returns the number of upper case letters in a string. *)
Definition string_count_upper (s : string) : nat :=
  string_count s is_upper.

(* Returns the number of digits in a string. *)
Definition string_count_digit (s : string) : nat :=
  string_count s is_digit.

(* Returns the number of other characters in a string (that is, not upper case
   letter, lower case letter or digit). *)
Definition string_count_other (s : string) : nat :=
  string_count s is_other.

(* Returns true if any of the characters in a string satisfy a function,
   otherwise returns false. *)
Fixpoint string_contains (s : string) (f : string->nat) : bool :=
  ltb 0 (f s).

(* Returns true if any of the characters in a string are lower case letters,
   otherwise returns false. *)
Definition string_contains_lower (s : string) : bool :=
  string_contains s string_count_lower.

(* Returns true if any of the characters in a string are upper case letters,
   otherwise returns false. *)
Definition string_contains_upper (s : string) : bool :=
  string_contains s string_count_upper.

(* Returns true if any of the characters in a string are digits, otherwise
   returns false. *)
Definition string_contains_digit (s : string) : bool :=
  string_contains s string_count_digit.

(* Returns true if any of the characters in a string are neither lower case
   letters, upper case letters or digits. Otherwise returns false. *)
Definition string_contains_other (s : string) : bool :=
  string_contains s string_count_other.

(* Returns a number from 0-4 representing the number of character classes in a
   string (lower case letters, upper case letters, digits and others). *)
Definition string_count_character_classes (s : string) : nat :=
  (nat_of_bool (string_contains_lower s))
    + (nat_of_bool (string_contains_upper s))
    + (nat_of_bool (string_contains_digit s))
    + (nat_of_bool (string_contains_other s)).

(* Returns true if a string is a rotated version of another, otherwise false. *)
Definition string_is_rotated (a b : string) : bool :=
  contains (append a a) b.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

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

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

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

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

Lemma lem: forall m n, Succ (plus m n) = plus m (Succ n).
Proof.
intros. simpl. induction m.
  - simpl. rewrite IHm. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : natural), eq (plus x (Succ x)) (Succ (plus x x)).
Proof.
induction x.
  - simpl. rewrite IHx. f_equal.
    rewrite lem.
lfind.
Admitted.


(* -*- mode: coq; mode: visual-line -*-  *)

(** * Decidable propositions *)

Require Import HoTT.Basics HoTT.Types.
Require Import TruncType HProp UnivalenceImpliesFunext.
Require Import HoTT.Truncations.
Import TrM.

Local Open Scope path_scope.

(** ** Definitions *)

(** A decidable proposition is, morally speaking, an hprop that is decidable.  However, we only require that it be an hprop under the additional assumption of [Funext]; this enables decidable propositions to usually be used without [Funext] hypotheses. *)

Record DProp :=
  { dprop_type : Type ;
    ishprop_dprop : Funext -> IsHProp dprop_type ;
    dec_dprop : Decidable dprop_type
  }.

(** A fancier definition, which would have the property that negation is judgmentally involutive, would be

<<
Record DProp :=
  { dprop_holds : Type ;
    ishprop_holds : Funext -> IsHProp dprop_holds ;
    dprop_denies : Type ;
    ishprop_denies : Funext -> IsHProp dprop_denies ;
    holds_or_denies : dprop_holds + dprop_denies ;
    denies_or_holds : dprop_denies + dprop_holds ;
    not_holds_and_denies : dprop_holds -> dprop_denies -> Empty
  }.
>>

At some point we may want to go that route, but it would be more work.  In particualar, [Instance]s of [Decidable] wouldn't be automatically computed for us, and the characterization of the homotopy type of [DProp] itself would be a lot harder. *)

Coercion dprop_type : DProp >-> Sortclass.
Global Existing Instance ishprop_dprop.
Global Existing Instance dec_dprop.

(** Sometimes, however, we have decidable props that are hprops without funext, and we want to remember that. *)

Record DHProp :=
  { dhprop_hprop : hProp ;
    dec_dhprop : Decidable dhprop_hprop
  }.

Coercion dhprop_hprop : DHProp >-> hProp.
Global Existing Instance dec_dhprop.

Definition dhprop_to_dprop : DHProp -> DProp
  := fun P => Build_DProp P (fun _ => _) _.

Coercion dhprop_to_dprop : DHProp >-> DProp.

(** In particular, [True] and [False] are always hprops. *)

Definition True : DHProp
  := Build_DHProp Unit_hp (inl tt).

Definition False : DHProp
  := Build_DHProp False_hp (inr idmap).

(** Decidable props can be coerced to [Bool]. *)

Definition dprop_to_bool (P : DProp) : Bool
  := if dec P then true else false.

Coercion dprop_to_bool : DProp >-> Bool.

(** And back again, but we don't declare that as a coercion. *)

Definition bool_to_dhprop (b : Bool) : DHProp
  := if b then True else False.

(** ** The type of decidable props *)
Definition issig_dprop
  : { X : Type & { _ : Funext -> IsHProp X & Decidable X } } <~> DProp.
Proof.
  issig.
Defined.

Definition equiv_path_dprop `{Funext} (P Q : DProp)
: (P = Q :> Type) <~> (P = Q :> DProp).
Proof.
  destruct P as [P hP dP]. destruct Q as [Q hQ dQ].
  refine (((equiv_ap' issig_dprop^-1 _ _)^-1)
            oE _); cbn.
  refine ((equiv_ap' (equiv_sigma_assoc' _ _)^-1
                     ((P;hP);dP) ((Q;hQ);dQ))
            oE _).
  refine (equiv_path_sigma_hprop _ _ oE _); cbn.
  { intros [X hX]; exact _. }
  refine (equiv_path_sigma_hprop (P;hP) (Q;hQ)).
Defined.

Definition path_dprop `{Funext} {P Q : DProp}
: (P = Q :> Type) -> (P = Q :> DProp)
  := equiv_path_dprop P Q.

Global Instance ishset_dprop `{Univalence} : IsHSet DProp.
Proof.
  intros P Q.
  refine (trunc_equiv' _ (n := -1) (equiv_path_dprop P Q)).
Defined.

Global Instance isequiv_dprop_to_bool `{Univalence}
: IsEquiv dprop_to_bool.
Proof.
  refine (isequiv_adjointify dprop_to_bool bool_to_dhprop _ _).
  - intros []; reflexivity.
  - intros P; unfold dprop_to_bool.
    destruct (dec P); symmetry; apply path_dprop, path_universe_uncurried.
    + apply if_hprop_then_equiv_Unit; [ exact _ | assumption ].
    + apply if_not_hprop_then_equiv_Empty; [ exact _ | assumption ].
Defined.

Definition equiv_dprop_to_bool `{Univalence}
: DProp <~> Bool
  := Build_Equiv _ _ dprop_to_bool _.

(** ** Operations *)

(** We define the logical operations on decidable hprops to be the operations on ordinary hprops, with decidability carrying over.  For the operations which preserve hprops without funext, we define separate versions that act on [DHProp]. *)

Definition dand (b1 b2 : DProp) : DProp
  := Build_DProp (b1 * b2) _ _.

Definition dhand (b1 b2 : DHProp) : DHProp
  := Build_DHProp (BuildhProp (b1 * b2)) _.

Definition dor (b1 b2 : DProp) : DProp
  := Build_DProp (hor b1 b2) _ _.

Definition dhor (b1 b2 : DHProp) : DHProp
  := Build_DHProp (BuildhProp (hor b1 b2)) _.

Definition dneg (b : DProp) : DProp
  := Build_DProp (~b) _ _.

Definition dimpl (b1 b2 : DProp) : DProp
  := Build_DProp (b1 -> b2) _ _.

Declare Scope dprop_scope.
Delimit Scope dprop_scope with dprop.
Bind Scope dprop_scope with DProp.
Declare Scope dhprop_scope.
Delimit Scope dhprop_scope with dhprop.
Bind Scope dhprop_scope with DHProp.

Infix "&&" := dand : dprop_scope.
Infix "&&" := dhand : dhprop_scope.
Infix "||" := dor : dprop_scope.
Infix "||" := dhor : dhprop_scope.
Infix "->" := dimpl : dprop_scope.
Notation "!! P" := (dneg P) : dprop_scope.

Local Open Scope dprop_scope.

(** ** Computation *)

(** In order to be able to "compute" with [DProp]s like booleans, we define a couple of typeclasses. *)

Class IsTrue (P : DProp) :=
  dprop_istrue : P.

Class IsFalse (P : DProp) :=
  dprop_isfalse : ~ P.

(** Note that we are not using [Typeclasses Strict Resolution] for [IsTrue] and [IsFalse]; this enables us to write simply [dprop_istrue] as a proof of some true dprop, and Coq will infer from context what the dprop is that we're proving. *)

Global Instance true_istrue : IsTrue True := tt.

Global Instance false_isfalse : IsFalse False := idmap.

Global Instance dand_true_true {P Q} `{IsTrue P} `{IsTrue Q}
: IsTrue (P && Q).
Proof.
  exact (dprop_istrue, dprop_istrue).
Defined.

Global Instance dand_false_l {P Q} `{IsFalse P}
: IsFalse (P && Q).
Proof.
  intros [p q].
  exact (dprop_isfalse p).
Defined.

Global Instance dand_false_r {P Q} `{IsFalse Q}
: IsFalse (P && Q).
Proof.
  intros [p q].
  exact (dprop_isfalse q).
Defined.

Global Instance dhand_true_true {P Q : DHProp} `{IsTrue P} `{IsTrue Q}
: IsTrue (P && Q)%dhprop.
Proof.
  (** We have to give [P] as an explicit argument here.  This is apparently because with two [IsTrue] instances in the context, when we write simply [dprop_istrue], Coq guesses one of them during typeclass resolution, and isn't willing to backtrack once it realizes that that choice fails to be what's needed to solve the goal.  Coq currently seems to consistently guess [Q] rather than [P], so that we don't have to give the argument [Q] to the second call to [dprop_istrue]; but rather than depend on such behavior, we give both arguments explicitly.  (The problem doesn't arise with [dand_true_true] because in that case, unification, which fires before typeclass search, is able to guess that the argument must be [P].) *)
  exact (@dprop_istrue P _, @dprop_istrue Q _).
Defined.

Global Instance dhand_false_l {P Q : DHProp} `{IsFalse P}
: IsFalse (P && Q)%dhprop.
Proof.
  intros [p q].
  exact (dprop_isfalse p).
Defined.

Global Instance dhand_false_r {P Q : DHProp} `{IsFalse Q}
: IsFalse (P && Q)%dhprop.
Proof.
  intros [p q].
  exact (dprop_isfalse q).
Defined.

Global Instance dor_true_l {P Q} `{IsTrue P}
: IsTrue (P || Q).
Proof.
  exact (tr (inl Q dprop_istrue)).
Defined.

Global Instance dor_true_r {P Q} `{IsTrue Q}
: IsTrue (P || Q).
Proof.
  exact (tr (inr P dprop_istrue)).
Defined.

Global Instance dor_false_false {P Q} `{IsFalse P} `{IsFalse Q}
: IsFalse (P || Q).
Proof.
  intros pq. strip_truncations. destruct pq as [p|q].
  - exact (dprop_isfalse p).
  - exact (dprop_isfalse q).
Defined.

Global Instance dhor_true_l {P Q : DHProp} `{IsTrue P}
: IsTrue (P || Q)%dhprop.
Proof.
  exact (tr (inl Q dprop_istrue)).
Defined.

Global Instance dhor_true_r {P Q : DHProp} `{IsTrue Q}
: IsTrue (P || Q)%dhprop.
Proof.
  exact (tr (inr P dprop_istrue)).
Defined.

Global Instance dhor_false_false {P Q : DHProp} `{IsFalse P} `{IsFalse Q}
: IsFalse (P || Q)%dhprop.
Proof.
  intros pq. strip_truncations. destruct pq as [p|q].
  (** See comment in the proof of [dhand_true_true]. *)
  - exact (@dprop_isfalse P _ p).
  - exact (@dprop_isfalse Q _ q).
Defined.

Global Instance dneg_true {P} `{IsTrue P}
: IsFalse (!! P).
Proof.
  intros np; exact (np dprop_istrue).
Defined.

Global Instance dneg_false {P} `{IsFalse P}
: IsTrue (!! P).
Proof.
  exact dprop_isfalse.
Defined.

Global Instance dimpl_true_r {P Q} `{IsTrue Q}
: IsTrue (P -> Q).
Proof.
  intros p. exact dprop_istrue.
Defined.

Global Instance dimpl_false_l {P Q} `{IsFalse P}
: IsTrue (P -> Q).
Proof.
  intros p. elim (dprop_isfalse p).
Defined.

Global Instance dimpl_true_false {P Q} `{IsTrue P} `{IsFalse Q}
: IsFalse (P -> Q).
Proof.
  intros f. exact (dprop_isfalse (f dprop_istrue)).
Defined.


Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.Algebra.Hierarchy.

Section Monoid.
  Context {T eq op id} {monoid:@monoid T eq op id}.
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Infix "*" := op.
  Local Infix "=" := eq : eq_scope.
  Local Open Scope eq_scope.

  Lemma cancel_right z iz (Hinv:op z iz = id) :
    forall x y, x * z = y * z <-> x = y.
  Proof using Type*.
    split; intros.
    { assert (op (op x z) iz = op (op y z) iz) as Hcut by (rewrite_hyp ->!*; reflexivity).
      rewrite <-associative in Hcut.
      rewrite <-!associative, !Hinv, !right_identity in Hcut; exact Hcut. }
    { rewrite_hyp ->!*. reflexivity. }
  Qed.

  Lemma cancel_left z iz (Hinv:op iz z = id) :
    forall x y, z * x = z * y <-> x = y.
  Proof using Type*.
    split; intros.
    { assert (op iz (op z x) = op iz (op z y)) as Hcut by (rewrite_hyp ->!*; reflexivity).
      rewrite !associative, !Hinv, !left_identity in Hcut; exact Hcut. }
    { rewrite_hyp ->!*; reflexivity. }
  Qed.

  Lemma inv_inv x ix iix : ix*x = id -> iix*ix = id -> iix = x.
  Proof using Type*.
    intros Hi Hii.
    assert (H:op iix id = op iix (op ix x)) by (rewrite Hi; reflexivity).
    rewrite associative, Hii, left_identity, right_identity in H; exact H.
  Qed.

  Lemma inv_op x y ix iy : ix*x = id -> iy*y = id -> (iy*ix)*(x*y) =id.
  Proof using Type*.
    intros Hx Hy.
    cut (iy * (ix*x) * y = id); try intro H.
    { rewrite <-!associative; rewrite <-!associative in H; exact H. }
    rewrite Hx, right_identity, Hy. reflexivity.
  Qed.

End Monoid.

Section Homomorphism.
  Context {T  EQ OP ID} {monoidT:  @monoid T  EQ OP ID }.
  Context {T' eq op id} {monoidT': @monoid T' eq op id }.
  Context {phi:T->T'}.
  Local Infix "=" := eq. Local Infix "=" := eq : type_scope.
  Class is_homomorphism :=
    {
      homomorphism : forall a b,  phi (OP a b) = op (phi a) (phi b);

      is_homomorphism_phi_proper : Proper (respectful EQ eq) phi
    }.
  Global Existing Instance is_homomorphism_phi_proper.
End Homomorphism.

Section HomomorphismComposition.
  Context {G EQ OP ID} {monoidG:@monoid G EQ OP ID}.
  Context {H eq op id} {monoidH:@monoid H eq op id}.
  Context {K eqK opK idK} {monoidK:@monoid K eqK opK idK}.
  Context {phi:G->H} {phi':H->K}
          {Hphi:@is_homomorphism G EQ OP H eq op phi}
          {Hphi':@is_homomorphism H eq op K eqK opK phi'}.
  Lemma is_homomorphism_compose
        {phi'':G->K}
        (Hphi'' : forall x, eqK (phi' (phi x)) (phi'' x))
    : @is_homomorphism G EQ OP K eqK opK phi''.
  Proof using Hphi Hphi' monoidK.
    split; repeat intro; rewrite <- !Hphi''.
    { rewrite !homomorphism; reflexivity. }
    { apply Hphi', Hphi; assumption. }
  Qed.

  Global Instance is_homomorphism_compose_refl
    : @is_homomorphism G EQ OP K eqK opK (fun x => phi' (phi x))
    := is_homomorphism_compose (fun x => reflexivity _).
End HomomorphismComposition.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  Reduction from:
    (Alternative) Minsky Machine Halting with n Registers (MMA_HALTING n)
  to:
    Multi-tape Turing Machine Halting with n Tapes (HaltTM n)

  Argument:
    Read-only Turing machines with n tapes are n-counter machines [1].

  Literature
  [1] Marvin Minsky. Recursive unsolvability of Post’s problem of "tag" and
      other topics in theory of Turing machines. Annals of Mathematics, pages 437–455, 1961.
*)

From Undecidability.TM Require TM Util.TM_facts.
Import TM.
From Undecidability.MinskyMachines Require Import MM MMA.mma_defs.

From Undecidability.Shared.Libs.DLW
  Require Import Vec.pos Vec.vec Code.sss Code.subcode.

Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypesDef.
Require Import Undecidability.Shared.Libs.PSL.EqDec.

Require Import List Vector Lia PeanoNat Compare_dec.
Import ListNotations.
Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Module Argument.
Section HaltTM_MMA_HALTING.

Context {n : nat} (M : list (mm_instr (Fin.t n))).

#[local] Notation maxState := (S (length M)).

Definition Σ : finType := finType_CS bool.

Definition state' : finType := finType_CS (Fin.t maxState).

Definition toState (p : nat) : state' :=
  if le_lt_dec maxState p is right H then Fin.of_nat_lt H else Fin.F1.

Definition trans' : state' * Vector.t (option Σ) n -> state' * Vector.t (option Σ * move) n :=
  fun '(p, bs) =>
    match sval (Fin.to_nat p) with
    | 0 => (p, TM_facts.nop_action)
    | S m' =>
        match nth_error M m' with
        | None => (p, TM_facts.nop_action)
        | Some (mm_inc i) =>
            let b := if (vec_pos bs i) is Some true then true else false in
            (toState (S (S m')), vec_change TM_facts.nop_action i (Some b, Rmove))
        | Some (mm_dec i q) =>
            match vec_pos bs i with
            | Some true => (toState (S (S m')), TM_facts.nop_action)
            | _ => (toState q, vec_change TM_facts.nop_action i (None, Lmove))
            end
        end
    end.

Definition halt' (q : Fin.t maxState) := Fin.eqb (@Fin.F1 (length M)) q.

Definition P : TM Σ n :=
  {| state := state'; trans := trans'; start := toState 1; halt := halt' |}.

Inductive encodes_counter : nat -> tape Σ -> Prop :=
  | encodes_counter_mid_0 m : encodes_counter 0 (midtape [] true (repeat false m))
  | encodes_counter_mid_S m c : encodes_counter (S c) (midtape (repeat false c ++ [true]) false (repeat false m))
  | encodes_counter_right_1 : encodes_counter 1 (rightof true [])
  | encodes_counter_right_S c : encodes_counter (S (S c)) (rightof false (repeat false c ++ [true])).

#[local] Notation encodes_counters cs ts := (Vector.Forall2 encodes_counter cs ts).

Definition encode_counter (c : nat) : tape Σ :=
  if c is S m then midtape (repeat false m ++ [true]) false [] else midtape [] true [].

Definition encode_counters {n} (cs : Vector.t nat n) : Vector.t (tape Σ) n :=
  Vector.map encode_counter cs.

Lemma read_instr {p instr} : (p, [instr]) <sc (1, M) ->
  exists q, sval (Fin.to_nat (toState p)) = S q /\ nth_error M q = Some instr /\ p = S q.
Proof.
  rewrite /toState. case: (le_lt_dec maxState p).
  { move=> ? [?] [?] [/(f_equal (@length _))].
    rewrite app_length /=. by lia. }
  move=> Hp [l] [r] [HM H'p]. exists (length l).
  by rewrite Fin.to_nat_of_nat /= HM nth_error_app2 ?Nat.sub_diag.
Qed.

Lemma doAct_nop_1 (t : tape Σ) : TM_facts.doAct t (None, Nmove) = t.
Proof. by case: t. Qed.

Lemma read_current_char {m} {cs : vec nat m} {ts i k} :
  encodes_counters cs ts -> vec_pos cs i = k ->
  match k with
  | 0 => vec_pos (TM_facts.current_chars ts) i = Some true
  | S _ =>
      vec_pos (TM_facts.current_chars ts) i = Some false \/
      vec_pos (TM_facts.current_chars ts) i = None
  end.
Proof.
  move=> H. elim: H i. { move=> i. by case: (pos_O_inv i). }
  move=> {}m c t {}cs {}ts Hct Hcsts IH i.
  have [->|[i' ->]] := pos_S_inv i.
  - case: Hct => /= *; subst k; by intuition done.
  - by apply: IH.
Qed.

#[local] Create HintDb counters.
Hint Extern 1 (encodes_counter _ _) => by [
  apply: encodes_counter_mid_0|apply: (encodes_counter_mid_0 0)|apply: (encodes_counter_mid_0 (S _))|
  apply: encodes_counter_mid_S|apply: (encodes_counter_mid_S 0)|apply: (encodes_counter_mid_S (S _))|
  apply: encodes_counter_right_1|apply: encodes_counter_right_S] : counters.

Lemma simulation_step {instr p1 cs1 p2 cs2 ts1} :
  (p1, [instr]) <sc (1, M) ->
  mma_sss instr (p1, cs1) (p2, cs2) ->
  encodes_counters cs1 ts1 ->
  exists ts2,
    TM_facts.step (M := P) (TM_facts.mk_mconfig (toState p1) ts1) = TM_facts.mk_mconfig (toState p2) ts2 /\
    encodes_counters cs2 ts2.
Proof.
  rewrite /TM_facts.step /= /trans'.
  move=> /read_instr [q [-> [-> ->]]].
  move E1: (S q, cs1) => p1cs1. move E2: (p2, cs2) => p2cs2 H.
  case: H E1 E2.
  - move=> ? i ? [<- <-] [-> ->] Hcs1ts1.
    eexists. split; first done.
    elim: Hcs1ts1 i. { move=> i. by case: (pos_O_inv i). }
    move=> m c t cs ts Hct Hcsts IH i.
    have [->|[i' ->]] := pos_S_inv i.
    + move=> /=. constructor; last by rewrite TM_facts.doAct_nop.
      rewrite /TM_facts.doAct. case: Hct => [[|?]|[|?] ?| |>].
      all: by eauto with counters nocore.
    + by constructor; [rewrite doAct_nop_1|apply: IH].
  - move=> ? i p' v Hcs1i [<- ?] [-> ->] Hcs1ts1. subst v.
    rewrite (read_current_char Hcs1ts1 Hcs1i).
    eexists. by split; [done|rewrite TM_facts.doAct_nop].
  - move=> ? i p' v k Hcs1i [_ ?] [-> ->] Hcs1ts1. subst v.
    move=> [:H].
    have [->|->] := (read_current_char Hcs1ts1 Hcs1i);
      eexists; split; [done|abstract: H|done|by apply: H].
    elim: Hcs1ts1 i Hcs1i. { move=> i. by case: (pos_O_inv i). }
    move=> m c t cs ts Hct Hcsts IH i.
    have [->|[i' ->]] := pos_S_inv i.
    + move=> /= Hc. constructor; last by rewrite TM_facts.doAct_nop.
      rewrite /TM_facts.doAct. case: Hct Hc => [//|? [|?]| |[|?]] [<-].
      all: by eauto with counters nocore.
    + move=> ?. by constructor; [rewrite doAct_nop_1|apply: IH].
Qed.

#[local] Notation "P // s ↓" := (sss_terminates (@mma_sss _) P s).

Lemma in_out_code_halt (p : nat) :
  if halt' (toState p) then out_code p (1, M) else in_code p (1, M).
Proof.
  rewrite /halt' /toState.
  case: (le_lt_dec maxState p). { move=> ? /=. rewrite Nat.eqb_refl. by lia. }
  move: p => [|p] ? /=; rewrite ?Nat.eqb_refl; by lia.
Qed.

Lemma encodes_countersI (cs : Vector.t nat n) : encodes_counters cs (encode_counters cs).
Proof.
  elim: cs; first by constructor.
  move=> [|c] m cs IH; by eauto using @Forall2 with counters nocore.
Qed.

Lemma simulation st1 : (1, M) // st1 ↓ ->
  exists p ts,
    TM.eval P (toState (fst st1)) (encode_counters (snd st1)) p ts.
Proof.
  move=> Hst1.
  move: (encode_counters (snd st1)) (encodes_countersI (snd st1)).
  elim /sss_terminates_ind: Hst1.
  - by apply: mma_sss_fun.
  - move=> [p1 cs1].
    case Hp1: (halt' (toState p1)) (in_out_code_halt p1).
    + move=> *. do 2 eexists. by apply: eval_halt.
    + by move=> /in_out_code /[apply].
  - move=> [p1 cs1] IH ts Hts.
    case Hp1: (halt' (toState p1)) (in_out_code_halt p1).
    { do 2 eexists. by apply: eval_halt. }
    move=> /in_code_subcode [instr] HQ.
    have [[p2 cs2] H'p1p2] := mma_sss_total instr (p1, cs1).
    have /IH {}IH : sss_progress (mma_sss (n:=n)) (p1, [instr]) (p1, cs1) (p2, cs2).
    { exists 1. split; [done|]. apply: in_sss_steps_S; [|apply: in_sss_steps_0].
      exists p1, [], instr, [], cs1. by rewrite /= Nat.add_0_r. }
    have [ts' [H''p1p2]] := simulation_step HQ H'p1p2 Hts.
    move=> /(IH HQ) /= [p''] [ts''] /TM_facts.TM_eval_iff [k Hk].
    exists p'', ts''. apply /TM_facts.TM_eval_iff. exists (S k).
    by rewrite /= Hp1 H''p1p2.
Qed.

Lemma inverse_simulation p cs p' ts' :
  TM.eval P (toState p) (encode_counters cs) p' ts' -> (1, M) // (p, cs) ↓.
Proof.
  move: (encode_counters _) (encodes_countersI cs) => ts Hcsts.
  move=> /TM_facts.TM_eval_iff [k].
  have HM : forall p cs, out_code p (1, M) -> (1, M) // (p, cs) ↓.
  { move=> ???. eexists (_, _). split; [|by eassumption].
    exists 0. by apply: sss_steps_0. }
  elim: k p cs p' ts' ts Hcsts.
  - move=> p > ? /=.
    by move: (halt' (toState p)) (in_out_code_halt p) => [/HM|].
  - move=> k IH p1 cs1 p' ts' ts Hcsts /=.
    case: (halt' (toState p1)) (in_out_code_halt p1). { by move=> /HM. }
    move=> /in_code_subcode [instr] HQ.
    have [[p2 cs2] H'p1p2] := mma_sss_total instr (p1, cs1).
    have [ts'' [-> /IH /[apply]]] := simulation_step HQ H'p1p2 Hcsts.
    apply: subcode_sss_terminates_instr; by eassumption.
Qed.

End HaltTM_MMA_HALTING.
End Argument.

Require Import Undecidability.Synthetic.Definitions.

Theorem reduction {n} : @MMA_HALTING n ⪯ HaltTM n.
Proof.
  exists (fun '(M, cs) =>
    existT2 _ _ (finType_CS bool) (Argument.P M) (Argument.encode_counters cs)).
  move=> [M cs]. split.
  - by apply: Argument.simulation.
  - by move=> [p'] [ts] /Argument.inverse_simulation.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export QArith.
Require Export Qreduction.

Hint Resolve Qlt_le_weak : qarith.

Definition Qabs (x:Q) := let (n,d):=x in (Z.abs n#d).

Lemma Qabs_case : forall (x:Q) (P : Q -> Type), (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P (Qabs x).
Proof.
intros x P H1 H2.
destruct x as [[|xn|xn] xd];
[apply H1|apply H1|apply H2];
abstract (compute; discriminate).
Defined.

Add Morphism Qabs with signature Qeq ==> Qeq as Qabs_wd.
intros [xn xd] [yn yd] H.
simpl.
unfold Qeq in *.
simpl in *.
change (Zpos yd)%Z with (Z.abs (Zpos yd)).
change (Zpos xd)%Z with (Z.abs (Zpos xd)).
repeat rewrite <- Z.abs_mul.
congruence.
Qed.

Lemma Qabs_pos : forall x, 0 <= x -> Qabs x == x.
Proof.
intros x H.
apply Qabs_case.
reflexivity.
intros H0.
setoid_replace x with 0.
reflexivity.
apply Qle_antisym; assumption.
Qed.

Lemma Qabs_neg : forall x, x <= 0 -> Qabs x == - x.
Proof.
intros x H.
apply Qabs_case.
intros H0.
setoid_replace x with 0.
reflexivity.
apply Qle_antisym; assumption.
reflexivity.
Qed.

Lemma Qabs_nonneg : forall x, 0 <= (Qabs x).
intros x.
apply Qabs_case.
auto.
apply (Qopp_le_compat x 0).
Qed.

Lemma Zabs_Qabs : forall n d, (Z.abs n#d)==Qabs (n#d).
Proof.
intros [|n|n]; reflexivity.
Qed.

Lemma Qabs_opp : forall x, Qabs (-x) == Qabs x.
Proof.
intros x.
do 2 apply Qabs_case; try (intros; ring);
(intros H0 H1;
setoid_replace x with 0;[reflexivity|];
apply Qle_antisym);try assumption;
rewrite Qle_minus_iff in *;
ring_simplify;
ring_simplify in H1;
assumption.
Qed.

Lemma Qabs_triangle : forall x y, Qabs (x+y) <= Qabs x + Qabs y.
Proof.
intros [xn xd] [yn yd].
unfold Qplus.
unfold Qle.
simpl.
apply Z.mul_le_mono_nonneg_r;auto with *.
change (Zpos yd)%Z with (Z.abs (Zpos yd)).
change (Zpos xd)%Z with (Z.abs (Zpos xd)).
repeat rewrite <- Z.abs_mul.
apply Z.abs_triangle.
Qed.

Lemma Qabs_Qmult : forall a b, Qabs (a*b) == (Qabs a)*(Qabs b).
Proof.
intros [an ad] [bn bd].
simpl.
rewrite Z.abs_mul.
reflexivity.
Qed.

Lemma Qabs_Qinv : forall q, Qabs (/ q) == / (Qabs q).
Proof.
  intros [n d]; simpl.
  unfold Qinv.
  case_eq n; intros; simpl in *; apply Qeq_refl.
Qed.

Lemma Qabs_Qminus x y: Qabs (x - y) = Qabs (y - x).
Proof.
 unfold Qminus, Qopp. simpl.
 rewrite Pos.mul_comm, <- Z.abs_opp.
 do 2 f_equal. ring.
Qed.

Lemma Qle_Qabs : forall a, a <= Qabs a.
Proof.
intros a.
apply Qabs_case; auto with *.
intros H.
apply Qle_trans with 0; try assumption.
change 0 with (-0).
apply Qopp_le_compat.
assumption.
Qed.

Lemma Qabs_triangle_reverse : forall x y, Qabs x - Qabs y <= Qabs (x - y).
Proof.
intros x y.
rewrite Qle_minus_iff.
setoid_replace (Qabs (x - y) + - (Qabs x - Qabs y)) with ((Qabs (x - y) + Qabs y) + - Qabs x) by ring.
rewrite <- Qle_minus_iff.
setoid_replace (Qabs x) with (Qabs (x-y+y)).
apply Qabs_triangle.
apply Qabs_wd.
ring.
Qed.

Lemma Qabs_Qle_condition x y: Qabs x <= y <-> -y <= x <= y.
Proof.
 split.
  split.
   rewrite <- (Qopp_opp x).
   apply Qopp_le_compat.
   apply Qle_trans with (Qabs (-x)).
   apply Qle_Qabs.
   now rewrite Qabs_opp.
  apply Qle_trans with (Qabs x); auto using Qle_Qabs.
 intros (H,H').
 apply Qabs_case; trivial.
 intros. rewrite <- (Qopp_opp y). now apply Qopp_le_compat.
Qed.

Lemma Qabs_diff_Qle_condition x y r: Qabs (x - y) <= r <-> x - r <= y <= x + r.
Proof.
 intros. unfold Qminus.
 rewrite Qabs_Qle_condition.
 rewrite <- (Qplus_le_l (-r) (x+-y) (y+r)).
 rewrite <- (Qplus_le_l (x+-y) r (y-r)).
 setoid_replace (-r + (y + r)) with y by ring.
 setoid_replace (r + (y - r)) with y by ring.
 setoid_replace (x + - y + (y + r)) with (x + r) by ring.
 setoid_replace (x + - y + (y - r)) with (x - r) by ring.
 intuition.
Qed.


Require Export P04.

(** **** Problem #10 : 1 star, optional (fst_swap_is_snd) *)
Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros p. destruct p as [n m]. reflexivity.
Qed.


Require Import Coq.Program.Tactics.
Require Import CT.Algebra.Magma.
Require Import ProofIrrelevance.

Set Primitive Projections.

Record Semigroup {T : Type} :=
  { magma :> @Magma T;
    semigroup_assoc : forall x y z, magma.(mu) x (magma.(mu) y z) = magma.(mu) (magma.(mu) x y) z
  }.

(* Possibly separate this out at some point. *)

(** * Semigroup homomorphisms.

...are exactly the same as magma homomorphisms.
*)
Definition SemigroupHomomorphism {A B} (M : @Semigroup A) (N : @Semigroup B) :=
  @MagmaHomomorphism A B M N.

(** * Composition of maps. *)
Program Definition semigroup_hom_composition
        {T U V : Type}
        {A : @Semigroup T}
        {B : @Semigroup U}
        {C : @Semigroup V}
        (map1 : SemigroupHomomorphism A B)
        (map2 : SemigroupHomomorphism B C) :
  SemigroupHomomorphism A C
  := magma_hom_composition map1 map2.

(** * Equality of maps, assuming proof irrelevance. *)
Program Definition semigroup_hom_eq
        {A B : Type}
        {F : @Semigroup A}
        {G : @Semigroup B}
        (N M : SemigroupHomomorphism F G) :
    @magma_hom A B F G N = @magma_hom A B F G M ->
    N = M
  := magma_hom_eq A B F G N M.

(** * Associativity of composition of maps. *)
Program Definition semigroup_hom_composition_assoc
        {T : Type}
        {A B C D : @Semigroup T}
        (f : SemigroupHomomorphism A B)
        (g : SemigroupHomomorphism B C)
        (h : SemigroupHomomorphism C D) :
  semigroup_hom_composition f (semigroup_hom_composition g h) =
  semigroup_hom_composition (semigroup_hom_composition f g) h
  := magma_hom_composition_assoc f g h.

(** * Identity map. *)
Program Definition semigroup_hom_id
        {A : Type}
        {M : @Semigroup A} :
  SemigroupHomomorphism M M :=
  magma_hom_id.


(** * Real: Аксиоматизация вещественных чисел в Coq *)

Require Reals.
Require Psatz.
Require Ring.
Require Field.

(* ################################################################# *)
(** * Аксиоматизация множества R *)

(** Вещественные числа можно определить с помощью фундаментальных
    последовательностей или с помощью дедекиндовых сечений. Эти
    представления математически точны, их можно записать в Coq,
    реализацию можно найти в библиотеке Coq Repository at Nijmegen (CoRN).
    Однако это сложные представления и с ними сложно работать.

    Стандартная библиотека Coq предлагает другой подход: аксиоматический. *)

Module OurR.

Parameter R : Set.

Delimit Scope R_scope with R.
Local Open Scope R_scope.

(** Мы начнем с объявления двух важных вещественных чисел: нуля и единицы. *)
Parameter R0 : R.
Parameter R1 : R.

(** И объявим способы получить другие вещественные числа: *)
Parameter Rplus : R -> R -> R.
Parameter Rmult : R -> R -> R.
Parameter Ropp : R -> R.
Parameter Rinv : R -> R.

Infix "+" := Rplus : R_scope.
Infix "*" := Rmult : R_scope.
Notation "- x" := (Ropp x) : R_scope.
Notation "/ x" := (Rinv x) : R_scope.

(** Другие базовые операции определены с помощью уже объявленных: *)

Definition Rminus (r1 r2:R) : R := r1 + - r2.
Definition Rdiv (r1 r2:R) : R := r1 * / r2.

Infix "-" := Rminus : R_scope.
Infix "/" := Rdiv : R_scope.

(** Мы хотим иметь возможность конвертировать натуральные числа в элементы
    множества R, чтобы можно было писать числа 0, 1, 2, 3... *)

Fixpoint INR (n : nat) : R :=
  match n with
  | O    => R0
  | 1    => R1
  | S n' => R1 + INR n'
  end.

(** Стандартная библиотека определяет коэрсию из Z, которая
    немного полезнее, но хуже читается. *)

(** _Коэрсия_ предлагает Coq'у попробовать применить данную функцию
   в тех ситуациях, когда типы не совпадают. Например, сейчас [Rplus 4 5]
   выдаст type error. *)

Fail Check (4 + 5).

Coercion INR : nat >-> R.

Check 4 + 5.
Compute (4 + 5).

(* ################################################################# *)
(** * Аксиомы поля *)

(** Посмотрим на самую суть библиотеки вещественных чисел - на аксиомы: *)

Axiom R1_neq_R0 : INR 1 <> INR 0.

(** Аксиомы сложения *)

Axiom Rplus_comm : forall r1 r2 : R, r1 + r2 = r2 + r1.

Axiom Rplus_assoc : forall r1 r2 r3 : R, r1 + r2 + r3 = r1 + (r2 + r3).

Axiom Rplus_opp_r : forall r : R, r + - r = 0.

Axiom Rplus_0_l : forall r : R, 0 + r = r.

(** Конечно, не все свойства вещественных чисел определяются как аксиомы: некоторые можно
   доказать. *)

Lemma Rplus_0_r : forall r : R, r + 0 = r.
Proof.
  (* WORKED IN CLASS *)
  intros r.
  rewrite Rplus_comm.
  apply Rplus_0_l.
Qed.

Lemma Rplus_opp_l : forall r, -r + r = 0.
Proof.
  (* WORKED IN CLASS *)
  intros r.
  rewrite Rplus_comm.
  apply Rplus_opp_r.
Qed.

Lemma Ropp_0 : -0 = 0.
Proof.
  rewrite <- (Rplus_0_l (-0)).
  rewrite Rplus_opp_r.
  reflexivity.
Qed.

Lemma Rplus_cancel_l : forall r1 r2 r3, r1 + r2 = r1 + r3 -> r2 = r3.
Proof.
  intros r1 r2 r3 H.
  rewrite <- Rplus_0_l.
  rewrite <- (Rplus_opp_l r1).
  rewrite Rplus_assoc.
  rewrite <- H.
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_l.
  reflexivity.
Qed.

Lemma R0_unique : forall r1 r2, r1 + r2 = r1 -> r2 = 0.
Proof.
  intros r1 r2 H.
  rewrite <- Rplus_0_r in H.
  eapply Rplus_cancel_l.
  apply H.
Qed.

(** Аксиомы умножения *)

Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1.

Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3).

Axiom Rinv_l : forall r:R, r <> 0 -> / r * r = 1.

Axiom Rmult_1_l : forall r:R, 1 * r = r.

Axiom Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) = r1 * r2 + r1 * r3.

Lemma Rmult_0_r : forall r, r * 0 = 0.
Proof.
  (* WORKED IN CLASS *)
  intros r.
  apply (R0_unique (r * 0)).
  rewrite <- Rmult_plus_distr_l.
  rewrite Rplus_0_l.
  reflexivity.
Qed.

Lemma Rmult_plus_distr_r : forall r1 r2 r3:R, (r1 + r2) * r3 = r1 * r3 + r2 * r3.
Proof.
  (* WORKED IN CLASS *)
  intros r1 r2 r3.
  rewrite Rmult_comm.
  rewrite Rmult_plus_distr_l.
  rewrite 2 (Rmult_comm r3).
  reflexivity.
Qed.

Lemma Rinv_r : forall r:R, r <> 0 -> r * / r = 1.
Proof.
  (* WORKED IN CLASS *)
  intros. rewrite Rmult_comm.
  apply Rinv_l.
  assumption.
Qed.

(* ================================================================= *)
(** ** Тактики Ring и Field *)

(** Теперь, когда у нас есть основные леммы, мы можем сказать Coq'у, что R образует
    алгебраическое _кольцо_ и _поле_. *)

Export Ring.
Export Field.

Lemma R_Ring_Theory : ring_theory R0 R1 Rplus Rmult Rminus Ropp eq.
Proof.
  constructor.
  (* сложение *)
  (* 0 - нейтральный слева *) apply Rplus_0_l.
  (* коммутативность *) apply Rplus_comm.
  (* ассоциативность *) intros; rewrite Rplus_assoc; easy.
  (* умножение *)
  (* 1 - нейтральный слева *) apply Rmult_1_l.
  (* коммутативность *) apply Rmult_comm.
  (* ассоциативность *) intros; rewrite Rmult_assoc; easy.
  (* дистрибутивность *) apply Rmult_plus_distr_r.
  (* sub = opp *) reflexivity.
  (* существование обратного по сложению *) apply Rplus_opp_r.
Defined.

Add Ring RRing : R_Ring_Theory.

Lemma R_Field_Theory : field_theory R0 R1 Rplus Rmult Rminus Ropp Rdiv Rinv eq.
Proof.
  constructor.
  (* аксиомы кольца *) apply R_Ring_Theory.
  (* 0 <> 1 *) apply R1_neq_R0.
  (* div = inv *) reflexivity.
  (* существование обратного по умножению *) apply Rinv_l.
Defined.

Add Field RField : R_Field_Theory.

(** Посмотрим, на что способны эти тактики: *)

Example ring_test1 : forall (x : R), x + x = 2 * x. Proof. intros. simpl. ring. Qed.
Example ring_test2 : forall (x y z: R), x * y + z  = z + y * x. Proof. intros. ring. Qed.

Example field_test1 : forall (x y : R), x <> 0 -> x * y / x = y.
Proof. intros. Fail ring. field. assumption. Qed.

(* ################################################################# *)
(** * Порядок *)

(** Мы введем обычный порядок на вещественных числах, снова с помощью аксиом. *)

Parameter Rlt : R -> R -> Prop.

Infix "<" := Rlt : R_scope.

Definition Rgt (r1 r2:R) : Prop := r2 < r1.
Definition Rle (r1 r2:R) : Prop := r1 < r2 \/ r1 = r2.
Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2.

Infix "<=" := Rle : R_scope.
Infix ">=" := Rge : R_scope.
Infix ">" := Rgt : R_scope.

Axiom total_order_T : forall r1 r2 : R, {r1 < r2} + {r1 = r2} + {r1 > r2}.

Axiom Rlt_asym : forall r1 r2 : R, r1 < r2 -> ~ r2 < r1.

Axiom Rlt_trans : forall r1 r2 r3 : R, r1 < r2 -> r2 < r3 -> r1 < r3.

Axiom Rplus_lt_compat_l : forall r r1 r2 : R, r1 < r2 -> r + r1 < r + r2.

Axiom Rmult_lt_compat_l : forall r r1 r2 : R, 0 < r -> r1 < r2 -> r * r1 < r * r2.

(* ################################################################# *)
(** * Полнота *)

(** Конечно, не любое поле является полем вещественных чисел:
    даже рациональные числа (строгое подмножество вещественных) образуют
    поле. Последнее, что нужно для полного определения вещественных чисел, -
    аксиома _полноты_ (completeness). Эта аксиома утверждает, что любое
    непустое ограниченное подмножество вещественных чисел имеет наименьшую
    верхнюю границу (верхнюю грань, супремум), которая сама является
    вещественным числом.

    Как обычно, множества мы будем записывать как функции типа [R -> Prop],
    которые по данному вещественному числу указывают, является ли оно элементом
    множества. *)

Definition is_upper_bound (E:R -> Prop) (m:R) := forall x:R, E x -> x <= m.

Definition bound (E:R -> Prop) := exists m : R, is_upper_bound E m.

Definition is_lub (E:R -> Prop) (m:R) :=
  is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b).

Axiom
  completeness :
    forall E:R -> Prop,
      bound E -> (exists x : R, E x) -> { m:R | is_lub E m }.

(* ================================================================= *)
(** ** Как определять иррациональные числа *)

(** Взглянем на то, как на практике можно использовать аксиому полноты. Только
    прежде нам понадобится определить одну дополнительную лемму, которую мы _можем_,
    но это сложнее, чем кажется на первый взгляд. *)

Lemma Rlt_0_1 : 0 < 1. Admitted.

(** Мы хотим определить квадратный корень из 2. Квадратный корень из 2 -
    наименьшая верхняя грань для предиката [x * x < 2] (или [x * x <= 2]).
    Воспользуемся аксиомой полноты, чтобы показать, что эта наименьшая верхняя
    граница существует. *)

Definition lt_sqrt2 (x : R) := x * x < 2.

(** Сначала нужно показать, что у этого предиката есть верхняя граница.
    Один разумный пример такой верхней границы - число 2 (числа 3/2 или 5
    тоже подойдут). *)

Lemma upper_bound_2_sqrt_2 : is_upper_bound lt_sqrt2 2.
Proof.
  unfold is_upper_bound, lt_sqrt2; simpl.
  intros x H.
  left.
  destruct (total_order_T x 1) as [[L | E] | G].
  - rewrite <- (Rplus_0_r x).
    eapply Rlt_trans.
    apply Rplus_lt_compat_l.
    apply Rlt_0_1.
    rewrite Rplus_comm.
    apply Rplus_lt_compat_l.
    assumption.
  - rewrite E.
    rewrite <- (Rplus_0_r 1).
    apply Rplus_lt_compat_l.
    apply Rlt_0_1.
  - assert (x * 1 < x * x).
    apply Rmult_lt_compat_l.
    eapply Rlt_trans.
    apply Rlt_0_1.
    apply G.
    apply G.
    rewrite Rmult_comm, Rmult_1_l in H0.
    eapply Rlt_trans.
    apply H0.
    apply H.
Qed.

Lemma bound_sqrt2 : bound lt_sqrt2.
Proof. exists 2. apply upper_bound_2_sqrt_2. Qed.

(** We also need to show that some number satisfies this predicate:
    0, 1 and -1 are all reasonable candidates. *)

Lemma ex_lt_sqrt2 : exists x, lt_sqrt2 x.
Proof.
  exists 1. unfold lt_sqrt2.
  rewrite Rmult_1_l.
  rewrite <- (Rplus_0_r 1); simpl.
  apply Rplus_lt_compat_l.
  apply Rlt_0_1.
Qed.

(** We can now plug these proofs into our completeness axiom/function,
    getting out a real number that is the least upper bound of
    [lt_sqrt2] -- that is, the square root of 2. *)

Definition sqrt2 := completeness lt_sqrt2 bound_sqrt2 ex_lt_sqrt2.

Print sqrt2.
(** In subsequent chapters we will make use of real numbers like
    √2, π and e, which are defined in the Coq real number library
    using the completeness axiom. **)

End OurR.

(** Let's take a look at our upper bound proof using Coq's own
    real numbers and definitions. Here we will benefit from
    Coq's automation tactics. *)

Export Reals.
Export Psatz.

Open Scope R_scope.

Definition lt_sqrt2 (x : R) := x * x < 2.

Lemma upper_bound_2_sqrt_2 : is_upper_bound lt_sqrt2 2.
Proof.
  unfold is_upper_bound, lt_sqrt2; simpl.
  intros x H.
  destruct (total_order_T x 1) as [[L | E] | G]; try lra.
  assert (x * 1 <= x * x).
  { apply Rmult_le_compat_l; lra. }
  lra.
Qed.

(** [lra] stands for Linear Real Arithmetic and is broadly useful in
    proving real number (in)equalities *)

Notation "√ x" := (sqrt x) (at level 0).

Lemma pow2_sqrt : forall x:R, 0 <= x -> (√ x) ^ 2 = x.
Proof. intros; simpl; rewrite Rmult_1_r, sqrt_def; auto. Qed.

Lemma pow2_sqrt2 : (√ 2) ^ 2 = 2.
Proof. apply pow2_sqrt. lra. Qed.

Lemma pown_sqrt : forall (x : R) (n : nat),
  0 <= x -> √ x ^ (S (S n)) = (x * √ x ^ n)%R.
Proof.
  intros. simpl. rewrite <- Rmult_assoc. rewrite sqrt_sqrt; auto.
Qed.

Lemma sqrt_neq_0_compat : forall r : R, 0 < r -> (√ r)%R <> 0.
Proof. intros. specialize (sqrt_lt_R0 r). lra. Qed.

Lemma sqrt_inv : forall (r : R), 0 < r -> √ (/ r) = (/ √ r)%R.
Proof.
  intros.
  replace (/r)%R with (1/r)%R by lra.
  rewrite sqrt_div_alt, sqrt_1 by lra.
  lra.
Qed.

Lemma sqrt2_inv : √ (/ 2) = (/ √ 2)%R.
Proof.
  apply sqrt_inv; lra.
Qed.

(* Sun Jan 19 21:29:28 CST 2020 *)


Require Export Finite.

(* Grammar of a PTS *)

Parameter sort : Set.

Inductive term : nat -> Set :=
  var :> forall n, fin n -> term n |
  srt : forall n, sort -> term n |
  app : forall n, term n -> term n -> term n |
  pi : forall n, term n -> term (S n) -> term n |
  lda : forall n, term n -> term (S n) -> term n.
Implicit Arguments var [n].
Implicit Arguments srt [n].
Implicit Arguments app [n].
Implicit Arguments pi [n].
Implicit Arguments lda [n].

(* Destructors for the types term n *)
(* These functions are only needed to prove the injectivity results below *)

Definition antivar n (M : term n) :=
match M in (term n) return (option (fin n)) with
| var n x   => Some x
| srt _ _   => None
| app _ _ _ => None
| pi  _ _ _ => None
| lda _ _ _ => None
end.
Implicit Arguments antivar [n].

Definition appleft n (M : term n) :=
match M in (term n) return (term n) with
| var n x   => x
| srt n s   => srt s
| app n P _ => P
| pi  n A B => pi A B
| lda n A P => lda A P
end.
Implicit Arguments appleft [n].

Definition appright n (M : term n) :=
match M in (term n) return (term n) with
| var n x   => x
| srt n s   => srt s
| app n _ Q => Q
| pi  n A B => pi A B
| lda n A P => lda A P
end.
Implicit Arguments appright [n].

Definition quantleft n (M : term n) :=
match M in (term n) return (term n) with
| var n x   => x
| srt n s   => srt s
| app n P Q => app P Q
| pi  n A B => A
| lda n A P => A
end.
Implicit Arguments quantleft [n].

Definition quantright n (M : term n) :=
match M in (term n) return (term (S n)) with
| var n x   => bot
| srt n s   => bot
| app n P Q => bot
| pi  n A B => B
| lda n A P => P
end.
Implicit Arguments quantright [n].

(* Well-definition and injectivity results for the constructors for term *)

Lemma var_wd : forall n (x y : fin n), x = y -> var x = var y.
Proof.
intro n.
apply f_equal.
Qed.

Lemma var_inj : forall n (x y : fin n), var x = var y -> x = y.
Proof.
intros.
apply Some_inj.
change (Some x) with (antivar x).
change (Some y) with (antivar y).
apply f_equal with (term n).
assumption.
Qed.

Lemma srt_wd : forall n s t, s = t -> srt (n := n) s = srt t.
Proof.
intro n.
apply f_equal.
Qed.

Lemma srt_inj : forall n s t, srt (n := n) s = srt t -> s = t.
Proof.
injection 1.
auto.
Qed.

Lemma app_wd : forall n (M M' N N' : term n), M = M' -> N = N' -> app M N = app M' N'.
Proof.
intro n.
apply f_equal2.
Qed.

Lemma app_injl : forall n (M M' N N' : term n), app M N = app M' N' -> M = M'.
Proof.
intros n M M' N N'.
change M at 2 with (appleft (app M N)).
change M' at 2 with (appleft (app M' N')).
apply f_equal.
Qed.

Lemma app_injr : forall n (M M' N N' : term n), app M N = app M' N' -> N = N'.
Proof.
intros n M M' N N'.
change N at 2 with (appright (app M N)).
change N' at 2 with (appright (app M' N')).
apply f_equal.
Qed.

Lemma pi_wd : forall n (A A' : term n) (B B' : term (S n)), A = A' -> B = B' -> pi A B = pi A' B'.
Proof.
intro n.
apply f_equal2.
Qed.

Lemma pi_injl : forall n (A A' : term n) (B B' : term (S n)), pi A B = pi A' B' -> A = A'.
Proof.
intros n A A' B B'.
change A at 2 with (quantleft (pi A B)).
change A' at 2 with (quantleft (pi A' B')).
apply f_equal.
Qed.

Lemma pi_injr : forall n (A A' : term n) (B B' : term (S n)), pi A B = pi A' B' -> B = B'.
Proof.
intros n A A' B B'.
change B at 2 with (quantright (pi A B)).
change B' at 2 with (quantright (pi A' B')).
apply f_equal.
Qed.

Lemma lda_wd : forall n (A A' : term n) (M M' : term (S n)), A = A' -> M = M' -> lda A M = lda A' M'.
Proof.
intro n.
apply f_equal2.
Qed.

Lemma lda_injl : forall n (A A' : term n) (M M' : term (S n)), lda A M = lda A' M' -> A = A'.
Proof.
intros n A A' M M'.
change A at 2 with (quantleft (lda A M)).
change A' at 2 with (quantleft (lda A' M')).
apply f_equal.
Qed.

Lemma lda_injr : forall n (A A' : term n) (M M' : term (S n)), lda A M = lda A' M' -> M = M'.
Proof.
intros n A A' M M'.
change M at 2 with (quantright (lda A M)).
change M' at 2 with (quantright (lda A' M')).
apply f_equal.
Qed.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Init.Nat.
From Coq Require Import Lia.
From Coq Require Import Lists.List. Import ListNotations.
From PLF Require Import Maps.
From PLF Require Import Imp.

Inductive tm : Type :=
  | C : nat -> tm (* Constant *)
  | P : tm -> tm -> tm. (* Plus *)

Reserved Notation " t '==>' n " (at level 50, left associativity).

Inductive eval : tm -> nat -> Prop :=
  | E_Const : forall n,
    C n ==> n
  | E_Plust : forall t1 t2 v1 v2,
    t1 ==> v1 ->
    t2 ==> v2 ->
    P t1 t2 ==> (v1 + v2)

  where " t '==>' n " := (eval t n).

Module SimpleArith1.

Reserved Notation " t '-->' t' " (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall v1 v2,
      P (C v1) (C v2) --> C (v1 + v2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      t2 --> t2' ->
      P (C v1) t2 --> P (C v1) t2'

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

Example test_step_1 :
  P
    (P (C 1) (C 3))
    (P (C 2) (C 4))
  -->
  P
    (C 4)
    (P (C 2) (C 4)).
Proof.
  apply ST_Plus1. apply ST_PlusConstConst.
Qed.

Example test_step_2 :
  P
    (C 0)
    (P
      (C 2)
      (P (C 1) (C 3)))
  -->
  P
    (C 0)
    (P
      (C 2)
      (C 4)).
Proof.
  repeat apply ST_Plus2. apply ST_PlusConstConst.
Qed.

End SimpleArith1.

Definition relation (X : Type) := X -> X -> Prop.

Definition deterministic {X : Type} (R : relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Module SimpleArith2.
Import SimpleArith1.

Theorem deterministic_step : deterministic step.
Proof.
  unfold deterministic. intros.
  generalize dependent y2.
  induction H; intros.
  - inversion H0; subst; auto.
    + inversion H3.
    + inversion H3.
  - inversion H0; subst.
    + inversion H.
    + apply IHstep in H4. subst. auto.
    + inversion H.
  - inversion H0. subst.
    + inversion H.
    + inversion H4.
    + subst. apply IHstep in H4. subst. auto.
Qed.

End SimpleArith2.

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
  end end.

Module SimpleArith3.
Import SimpleArith1.

Ltac solve_by_invert :=
  solve_by_inverts 1.

Theorem step_deterministic_alt: deterministic step.
Proof.
  intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros y2 Hy2;
    inversion Hy2; subst; try solve_by_invert.
  - (* ST_PlusConstConst *) reflexivity.
  - (* ST_Plus1 *)
    apply IHHy1 in H2. rewrite H2. reflexivity.
  - (* ST_Plus2 *)
    apply IHHy1 in H2. rewrite H2. reflexivity.
Qed.

End SimpleArith3.

Inductive value : tm -> Prop :=
  | v_const: forall n, value (C n).

Reserved Notation " t '-->' t' " (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall v1 v2,
          P (C v1) (C v2)
      --> C (v1 + v2)
  | ST_Plus1 : forall t1 t1' t2,
        t1 --> t1' ->
        P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
        value v1 -> (* <--- n.b. *)
        t2 --> t2' ->
        P v1 t2 --> P v1 t2'

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

Theorem step_deterministic :
  deterministic step.
Proof.
  unfold deterministic. intros. generalize dependent y2.
  induction H; intros; inversion H0; subst; auto.
  - inversion H3.
  - inversion H4.
  - inversion H.
  - apply IHstep in H4. subst. auto.
  - inversion H3. subst. inversion H.
  (* t1 is already the final state. *)
  - inversion H. subst. inversion H1; subst.
    + inversion H5.
    + apply IHstep in H6. rewrite H6. auto.
  - inversion H. subst. inversion H1; subst.
    + inversion H6.
    + apply IHstep in H7. rewrite H7. auto.
  - inversion H. subst. inversion H1; subst.
    + inversion H7.
    + apply IHstep in H8. rewrite H8. auto.
Qed.

(* This important property is called strong progress,
because every term either is a value or can "make progress"
by stepping to some other term. *)
Theorem strong_progress : forall t,
  value t \/ (exists t', t --> t').
Proof.
  induction t.
  - left. constructor.
  - right. destruct IHt1.
    + destruct IHt2.
      * inversion H. inversion H0. exists (C (n + n0)).
        constructor.
      * destruct H0. exists (P t1 x). constructor; auto.
    + destruct IHt2; destruct H; exists (P x t2); constructor; auto.
Qed.

Definition normal_form {X : Type}
              (R : relation X) (t : X) : Prop :=
  ~ exists t', R t t'.

Lemma value_is_nf : forall v,
  value v -> normal_form step v.
Proof.
  unfold normal_form, not. intros.
  inversion H. subst.
  destruct H0. inversion H0.
Qed.

Lemma nf_is_value : forall t,
  normal_form step t -> value t.
Proof.
  unfold normal_form, not. intros.
  specialize strong_progress with t. intros.
  destruct H0. auto. apply H in H0. inversion H0.
Qed.

Corollary nf_same_as_value : forall t,
  normal_form step t <-> value t.
Proof. split. apply nf_is_value. apply value_is_nf. Qed.

Module Temp1.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n)
  | v_funny : forall t1 v2,
                value (P t1 (C v2)). (* <--- *)
Reserved Notation " t '-->' t' " (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall v1 v2,
      P (C v1) (C v2) --> C (v1 + v2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      P v1 t2 --> P v1 t2'

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

Lemma value_not_same_as_normal_form :
  exists v, value v /\ ~ normal_form step v.
Proof.
  exists(P (C 0) (C 0)). split.
  - constructor.
  - unfold normal_form, not. intros. apply H.
    exists (C (0 + 0)). constructor.
Qed.

End Temp1.

Module Temp2.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n). (* Original definition *)
Reserved Notation " t '-->' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_Funny : forall n,
      C n --> P (C n) (C 0) (* <--- NEW *)
  | ST_PlusConstConst : forall v1 v2,
      P (C v1) (C v2) --> C (v1 + v2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      P v1 t2 --> P v1 t2'

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

Lemma value_not_same_as_normal_form :
  exists v, value v /\ ~ normal_form step v.
Proof.
  exists (C 0). split.
  - constructor.
  - unfold normal_form, not. intros. apply H.
    exists (P (C 0) (C 0)). apply ST_Funny.
Qed.

End Temp2.

Module Temp3.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n).

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

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall v1 v2,
      P (C v1) (C v2) --> C (v1 + v2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2

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

(* (Note that ST_Plus2 is missing.) *)

Lemma value_not_same_as_normal_form :
  exists t, ~ value t /\ normal_form step t.
Proof.
  exists (P (C 0) (P (C 0) (C 0))). split.
  - unfold not. intros. inversion H.
  - unfold normal_form, not. intros. destruct H.
    inversion H. subst. inversion H3.
Qed.

End Temp3.

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation " t '-->*' t' " := (multi step t t') (at level 40).

(* Converts from -->* to --> *)
Theorem multi_R : forall (X : Type) (R : relation X) (x y : X),
  R x y -> (multi R) x y.
Proof.
  intros. apply multi_step with y. apply H. constructor.
Qed.

Theorem multi_trans :
  forall (X : Type) (R : relation X) (x y z : X),
      multi R x y ->
      multi R y z ->
      multi R x z.
Proof.
  intros.
  induction H.
  - auto.
  - apply multi_step with y. auto. apply IHmulti. auto.
Qed.

Definition step_normal_form := normal_form step.

Definition normal_form_of (t t' : tm) :=
  (t -->* t' /\ step_normal_form t').

Theorem normal_forms_unique:
  deterministic normal_form_of.
Proof.
  unfold deterministic. unfold normal_form_of.
  intros x y1 y2 P1 P2.
  destruct P1 as [P11 P12].
  destruct P2 as [P21 P22].
  induction P11.
  - inversion P21; subst.
    + trivial.
    + unfold step_normal_form in *. unfold normal_form in *. unfold not in *.
      exfalso. apply P12. exists y. auto.
  - inversion P21; subst.
    + apply IHP11. trivial.
      exfalso. unfold step_normal_form in *. unfold normal_form in *. unfold not in *.
      apply P22. exists y. trivial.
    + apply IHP11. trivial.
      assert (G : y = y0).
      * apply (step_deterministic _ _ _ H H0).
      * subst. auto.
Qed.

Definition normalizing {X : Type} (R : relation X) :=
  forall t, exists t',
    (multi R) t t' /\ normal_form R t'.

Lemma multistep_congr_1 :forall t1 t1' t2,
  t1 -->* t1' ->
  P t1 t2 -->* P t1' t2.
Proof.
  intros.
  induction H.
  - constructor.
  - apply multi_step with (P y t2).
    + apply ST_Plus1. auto.
    + auto.
Qed.

Lemma multistep_congr_2 : forall v1 t2 t2',
     value v1 ->
     t2 -->* t2' ->
     P v1 t2 -->* P v1 t2'.
Proof.
  intros.
  induction H0.
  - constructor.
  - apply multi_step with (P v1 y).
    apply ST_Plus2; auto.
    auto.
Qed.

Theorem step_normalizing :
  normalizing step.
Proof.
  unfold normalizing. intros. induction t.
  - exists (C n). split.
    + constructor.
    + unfold normal_form, not. intros.
      destruct H. inversion H.
  - destruct IHt1. destruct IHt2.
    destruct H, H0.
    apply nf_same_as_value in H1, H2.
    destruct H1, H2.
    exists (C (n + n0)). split.
    + apply multi_trans with (P (C n) t2).
      * apply multistep_congr_1. auto.
      * apply multi_trans with (P (C n) (C n0)).
        -- apply multistep_congr_2. constructor. auto.
        -- apply multi_R. constructor.
    + unfold normal_form. unfold not. intros. destruct H1.
      inversion H1.
Qed.

(* Should be obvious. *)
Theorem eval__multistep : forall t n,
  t ==> n -> t -->* C n.
Proof.
  intros. induction H.
  - constructor.
  - induction t1.
    + induction t2.
      * inversion IHeval1; inversion IHeval2; subst.
        -- apply multi_R. constructor.
        -- apply multi_trans with (P (C v1) (C v2)).
           apply multistep_congr_2. constructor. auto.
           apply multi_R. constructor.
        -- apply multi_trans with (P (C v1) (C v2)).
           apply multistep_congr_1. auto.
           apply multi_R. constructor.
        -- apply multi_trans with (P (C n) (C v2)).
           apply multistep_congr_2. constructor. auto.
           apply multi_trans with (P (C v1) (C v2)).
           apply multistep_congr_1. auto.
           apply multi_R. constructor.
      * assert (G: P (C n) (P t2_1 t2_2) -->* P (C n) (C v2)).
        -- apply multistep_congr_2. constructor. auto.
        -- apply multi_trans with (P (C v1) (C v2)).
           apply multi_trans with (P (C n) (C v2)).
           apply G. apply multistep_congr_1. auto. apply multi_R. constructor.
    + assert (G: P (P t1_1 t1_2) t2 -->* P (C v1) t2).
      * apply multistep_congr_1. auto.
      * apply multi_trans with (P (C v1) t2).
        -- auto.
        -- apply multi_trans with (P (C v1) (C v2)).
           apply multistep_congr_2. constructor. auto.
           apply multi_R. constructor.
Qed.

Lemma step__eval : forall t t' n,
     t --> t' ->
     t' ==> n ->
     t ==> n.
Proof.
  intros t t' n Hs. generalize dependent n.
  induction Hs; intros.
  - inversion H. constructor; constructor.
  - inversion H. subst. apply IHHs in H2.
    constructor; auto.
  - inversion H0. subst. apply IHHs in H5.
    constructor; auto.
Qed.

Theorem multistep__eval : forall t t',
  normal_form_of t t' -> exists n, t' = C n /\ t ==> n.
Proof.
  induction t; intros; unfold normal_form_of in *; destruct H.
  - exists n. split.
    + inversion H; subst; auto; try inversion H1.
    + constructor.
  - assert (G : exists n1, t1 ==> n1).
    + (* We have to craft forall t' : tm, t1 -->* t' /\ step_normal_form t' *)
      (* Accidentally, we have step_normal_form -> normalizing ->
         t1 -->* t' /\ step_normal_form t'. *)

      destruct (step_normalizing t1).
      Check step_normalizing.
      Check normalizing.
      apply IHt1 in H1. destruct H1. exists x0. destruct H1. auto.
    + assert (G' : exists n2, t2 ==> n2).
      (* step is normalizing, so this must be true. *)
      * destruct (step_normalizing t2).
        apply IHt2 in H1. destruct H1. exists x0. destruct H1. auto.
      * destruct G, G'. exists (x + x0).
        split. apply eval__multistep in H1, H2.

        (* Transitivities. *)
        assert (S: P t1 t2 -->* P (C x) t2).
        apply multistep_congr_1. auto.

        assert (S': P (C x) t2 -->* P (C x) (C x0)).
        apply multistep_congr_2. constructor. auto.

        assert (S'': P (t1) (t2) -->* P(C x) (C x0)).
        apply multi_trans with (P (C x) t2); auto.

        assert (S''': P (t1) (t2) -->* C (x + x0)).
        eapply multi_trans. eauto. apply multi_R. constructor.

        assert (S'''': t' = C (x + x0)).
        (* H: P t1 t2 -->* t'
           H0: step_normal_form t' *)
        apply (normal_forms_unique (P t1 t2)).
        unfold normal_form_of. split; auto.
        unfold normal_form_of. split; auto.
        unfold step_normal_form, normal_form. unfold not. intros.
        destruct H3. inversion H3. auto.

        constructor; auto.
Qed.

Fixpoint evalF (t : tm) : nat :=
  match t with
  | C n => n
  | P t1 t2 => evalF t1 + evalF t2
  end.

Theorem evalF_eval : forall t n,
  evalF t = n <-> t ==> n.
Proof.
  induction t; split; intros.
  - induction H. simpl. constructor.
  - inversion H. subst. trivial.
  - simpl in H. rewrite <- H.
    constructor.
    + apply IHt1. trivial.
    + apply IHt2. trivial.
  - simpl. inversion H. subst.
    apply IHt1 in H2. apply IHt2 in H4. subst. trivial.
Qed.

Inductive aval : aexp -> Prop :=
  | av_num : forall n, aval (ANum n).

Reserved Notation " a '/' st '-->a' a' "
                  (at level 40, st at level 39).
Inductive astep (st : state) : aexp -> aexp -> Prop :=
  | AS_Id : forall (i : string),
      i / st -->a (st i)
  | AS_Plus1 : forall a1 a1' a2,
      a1 / st -->a a1' ->
      <{ a1 + a2 }> / st -->a <{ a1' + a2 }>
  | AS_Plus2 : forall v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      <{ v1 + a2 }> / st -->a <{ v1 + a2' }>
  | AS_Plus : forall (v1 v2 : nat),
      <{ v1 + v2 }> / st -->a (v1 + v2)
  | AS_Minus1 : forall a1 a1' a2,
      a1 / st -->a a1' ->
      <{ a1 - a2 }> / st -->a <{ a1' - a2 }>
  | AS_Minus2 : forall v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      <{ v1 - a2 }> / st -->a <{ v1 - a2' }>
  | AS_Minus : forall (v1 v2 : nat),
      <{ v1 - v2 }> / st -->a (v1 - v2)
  | AS_Mult1 : forall a1 a1' a2,
      a1 / st -->a a1' ->
      <{ a1 * a2 }> / st -->a <{ a1' * a2 }>
  | AS_Mult2 : forall v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      <{ v1 * a2 }> / st -->a <{ v1 * a2' }>
  | AS_Mult : forall (v1 v2 : nat),
      <{ v1 * v2 }> / st -->a (v1 * v2)

    where " a '/' st '-->a' a' " := (astep st a a').

Reserved Notation " b '/' st '-->b' b' "
                  (at level 40, st at level 39).

Inductive bstep (st : state) : bexp -> bexp -> Prop :=
| BS_Eq1 : forall a1 a1' a2,
    a1 / st -->a a1' ->
    <{ a1 = a2 }> / st -->b <{ a1' = a2 }>
| BS_Eq2 : forall v1 a2 a2',
    aval v1 ->
    a2 / st -->a a2' ->
    <{ v1 = a2 }> / st -->b <{ v1 = a2' }>
| BS_Eq : forall (v1 v2 : nat),
    <{ v1 = v2 }> / st -->b
    (if (v1 =? v2) then <{ true }> else <{ false }>)
| BS_LtEq1 : forall a1 a1' a2,
    a1 / st -->a a1' ->
    <{ a1 <= a2 }> / st -->b <{ a1' <= a2 }>
| BS_LtEq2 : forall v1 a2 a2',
    aval v1 ->
    a2 / st -->a a2' ->
    <{ v1 <= a2 }> / st -->b <{ v1 <= a2' }>
| BS_LtEq : forall (v1 v2 : nat),
    <{ v1 <= v2 }> / st -->b
    (if (v1 <=? v2) then <{ true }> else <{ false }>)
| BS_NotStep : forall b1 b1',
    b1 / st -->b b1' ->
    <{ ~ b1 }> / st -->b <{ ~ b1' }>
| BS_NotTrue : <{ ~ true }> / st -->b <{ false }>
| BS_NotFalse : <{ ~ false }> / st -->b <{ true }>
| BS_AndStep : forall b1 b1' b2,
    b1 / st -->b b1' ->
    <{ b1 && b2 }> / st -->b <{ b1' && b2 }>
| BS_AndTrueStep : forall b2 b2',
    b2 / st -->b b2' ->
    <{ true && b2 }> / st -->b <{ true && b2' }>
| BS_AndFalse : forall b2,
    <{ false && b2 }> / st -->b <{ false }>
| BS_AndTrueTrue : <{ true && true }> / st -->b <{ true }>
| BS_AndTrueFalse : <{ true && false }> / st -->b <{ false }>

where " b '/' st '-->b' b' " := (bstep st b b').

Reserved Notation " t '/' st '-->' t' '/' st' "
                  (at level 40, st at level 39, t' at level 39).
Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AsgnStep : forall st i a1 a1',
      a1 / st -->a a1' ->
      <{ i := a1 }> / st --> <{ i := a1' }> / st
  | CS_Asgn : forall st i (n : nat),
      <{ i := n }> / st --> <{ skip }> / (i !-> n ; st)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st --> c1' / st' ->
      <{ c1 ; c2 }> / st --> <{ c1' ; c2 }> / st'
  | CS_SeqFinish : forall st c2,
      <{ skip ; c2 }> / st --> c2 / st
  | CS_IfStep : forall st b1 b1' c1 c2,
      b1 / st -->b b1' ->
      <{ if b1 then c1 else c2 end }> / st
      -->
      <{ if b1' then c1 else c2 end }> / st
  | CS_IfTrue : forall st c1 c2,
      <{ if true then c1 else c2 end }> / st --> c1 / st
  | CS_IfFalse : forall st c1 c2,
      <{ if false then c1 else c2 end }> / st --> c2 / st
  | CS_While : forall st b1 c1,
      <{ while b1 do c1 end }> / st
      -->
      <{ if b1 then c1; while b1 do c1 end else skip end }> / st

  where " t '/' st '-->' t' '/' st' " := (cstep (t,st) (t',st')).

Module CImp.
Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CPar : com -> com -> com. (* <--- NEW *)

Notation "x || y" :=
         (CPar x y)
           (in custom com at level 90, right associativity).
Notation "'skip'" :=
         CSkip (in custom com at level 0).
Notation "x := y" :=
         (CAsgn x y)
            (in custom com at level 0, x constr at level 0,
             y at level 85, no associativity).
Notation "x ; y" :=
         (CSeq x y)
           (in custom com at level 90, right associativity).
Notation "'if' x 'then' y 'else' z 'end'" :=
         (CIf x y z)
           (in custom com at level 89, x at level 99,
            y at level 99, z at level 99).
Notation "'while' x 'do' y 'end'" :=
         (CWhile x y)
            (in custom com at level 89, x at level 99, y at level 99).

Inductive cstep : (com * state) -> (com * state) -> Prop :=
    (* Old part: *)
  | CS_AsgnStep : forall st i a1 a1',
      a1 / st -->a a1' ->
      <{ i := a1 }> / st --> <{ i := a1' }> / st
  | CS_Asgn : forall st i (n : nat),
      <{ i := n }> / st --> <{ skip }> / (i !-> n ; st)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st --> c1' / st' ->
      <{ c1 ; c2 }> / st --> <{ c1' ; c2 }> / st'
  | CS_SeqFinish : forall st c2,
      <{ skip ; c2 }> / st --> c2 / st
  | CS_IfStep : forall st b1 b1' c1 c2,
      b1 / st -->b b1' ->
      <{ if b1 then c1 else c2 end }> / st
      -->
      <{ if b1' then c1 else c2 end }> / st
  | CS_IfTrue : forall st c1 c2,
      <{ if true then c1 else c2 end }> / st --> c1 / st
  | CS_IfFalse : forall st c1 c2,
      <{ if false then c1 else c2 end }> / st --> c2 / st
  | CS_While : forall st b1 c1,
      <{ while b1 do c1 end }> / st
      -->
      <{ if b1 then c1; while b1 do c1 end else skip end }> / st
    (* New part: *)
  | CS_Par1 : forall st c1 c1' c2 st',
      c1 / st --> c1' / st' ->
      <{ c1 || c2 }> / st --> <{ c1' || c2 }> / st'
  | CS_Par2 : forall st c1 c2 c2' st',
      c2 / st --> c2' / st' ->
      <{ c1 || c2 }> / st --> <{ c1 || c2' }> / st'
  | CS_ParDone : forall st,
      <{ skip || skip }> / st --> <{ skip }> / st

  where " t '/' st '-->' t' '/' st' " := (cstep (t,st) (t',st')).
Definition cmultistep := multi cstep.

Notation " t '/' st '-->*' t' '/' st' " :=
   (multi cstep (t,st) (t',st'))
   (at level 40, st at level 39, t' at level 39).

Definition par_loop : com :=
  <{
      Y := 1
    ||
      while (Y = 0) do X := X + 1 end
   }>.

Theorem par_loop_example_0:
  exists st',
    par_loop / empty_st -->* <{ skip }> / st' /\
    st' X = 0.
Proof.
  unfold par_loop.
  eexists. split.
  - eapply multi_step. apply CS_Par1. apply CS_Asgn.
    eapply multi_step. apply CS_Par2. apply CS_While.
    eapply multi_step. apply CS_Par2. apply CS_IfStep.
      apply BS_Eq1. apply AS_Id.
    eapply multi_step. apply CS_Par2. apply CS_IfStep.
      apply BS_Eq.
    eapply multi_step. apply CS_Par2. apply CS_IfFalse.
    eapply multi_step. apply CS_ParDone.
    eapply multi_refl.
  - auto.
Qed.

Example par_loop_example_2:
  exists st',
       par_loop / empty_st -->* <{skip}> / st'
    /\ st' X = 2.
Proof.
  eexists. intros. split.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfTrue.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AsgnStep. apply AS_Plus1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AsgnStep. apply AS_Plus.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_Asgn.
  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfTrue.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AsgnStep. apply AS_Plus1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AsgnStep. apply AS_Plus.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_Asgn.
  eapply multi_step. apply CS_Par1. apply CS_Asgn.
  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  eapply multi_refl.
  reflexivity.
Qed.

Lemma par_body_n__Sn : forall n st,
  st X = n /\ st Y = 0 ->
  par_loop / st -->* par_loop / (X !-> S n ; st).
Proof.
  intros. destruct H.
  unfold par_loop.

  eapply multi_step. apply CS_Par2. apply CS_While.

  eapply multi_step. apply CS_Par2. apply CS_IfStep.
  constructor. constructor.

  eapply multi_step. apply CS_Par2. apply CS_IfStep.
  rewrite H0. apply BS_Eq.

  eapply multi_step. apply CS_Par2. apply CS_IfTrue.

  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
  apply CS_AsgnStep. constructor. constructor.

  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
  apply CS_AsgnStep. apply AS_Plus.

  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
  apply CS_Asgn.

  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.

  replace (S n) with (n + 1). rewrite H.
  constructor. apply Nat.add_1_r.
Qed.

Lemma par_body_n : forall n st,
  st X = 0 /\ st Y = 0 ->
  exists st', par_loop / st -->* par_loop / st' /\ st' X = n /\ st' Y = 0.
Proof.
(* it looks like mistake, we need n > 0 *)
Admitted.

Theorem par_loop_any_X:
  forall n, exists st',
    par_loop / empty_st -->* <{skip}> / st'
    /\ st' X = n.
Proof.
  intros n.
  destruct (par_body_n n empty_st).
    split; reflexivity.
  rename x into st.
  inversion H as [H' [HX HY] ]; clear H.
  exists (Y !-> 1 ; st). split.
  eapply multi_trans with (par_loop,st). apply H'.
  eapply multi_step. apply CS_Par1. apply CS_Asgn.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id. rewrite t_update_eq.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  apply multi_refl.
  rewrite t_update_neq. assumption. intro X; inversion X.
Qed.


(* Inductive False := . *)

Module MLCoq.

SearchAbout (_ + _).
Print bool.
Print conj.
Print and_ind.
Print nat_ind.
Print plus_n_Sm.
Print plus_Sn_m.

Set Printing All.

Print IF_then_else.

Inductive and' (A B:Prop) : Prop :=
  conj' : forall (x : A), forall (y : B), and' A B.

Print and'_ind.
Inductive ex1 (A : Type) (P : forall (x : A), Prop) : Prop :=
  ex_intro1 : forall x : A, forall (y : (P x)), ex1 A P.

Set Implicit Arguments.

Inductive ex2 (A : Type) (P : forall (x : A), Prop) : Prop :=
  ex_intro2 : forall (x : A), forall (y : (P x)), ex2 P.

Inductive ex3 (A : Type) (P : forall (x : A), Prop) : Prop :=
  ex_intro3 : forall (x : A), forall (y : (P x)), ex3 (A:=A) P.

Inductive ex4 (A : Type) (P : forall (x : A), Prop) : Prop :=
  ex_intro4 : forall (x : A), forall (y : (P x)), @ ex4 A P.

Check conj.
Check conj'.

Print conj.

Print nat.
Print nat_ind.

Print False_ind.
Print Nat.add.
Print and_ind.

Print True.
Print True_ind.

Definition False_ind :=
fun (P : Prop) (f : False) => match f return P with
                              end .

Definition add_ind' :=
  fix add (n m : nat) : nat := match n with
                                        | 0 => m
                                        | S p => S (add p m)
                                        end .

Print nat.
Definition nat_ind' :=
fun (P : nat -> Prop) (f : P 0) (f0 : forall n : nat, P n -> P (S n)) =>
fix F (n : nat) := match n with
                         | 0 => f
                         | S n0 => f0 n0 (F n0)
                         end .

Print eq.
Print eq_ind.

Lemma AddZero : forall n, n + 0 = n.
Proof.
  intros.
  induction n. simpl. apply eq_refl.
  simpl. rewrite IHn.
  apply eq_refl.
Qed.

Set Printing All.
Print AddZero.
Check AddZero.

Print eq_refl.
Print eq_ind.

Lemma AndComm : forall A B, A /\ B -> B /\ A .
Proof.
  intros.
  destruct H. split; auto.
Qed.

Set Printing All.
Print AndComm.
Print not.

Definition AndComm' :=
fun (A B : Prop) (H : and A B) =>
match H return (and B A) with
| conj H0 H1 => @conj B A H1 H0
end  .

(* ask brandon if way to get term out of proof *)

Lemma AndComm'' : forall A B : Prop, A /\ B -> B /\ A .
Proof.
  exact AndComm'.
Qed.

Print AndComm'.

Print nat_ind.
Print or.

Definition test :=
  fun (A : Prop) =>
    match A with
    | False => True
    end .

Print test.

Definition and_rect' := forall (A B : Prop) (P : Type), (A -> B -> P) -> and A B -> P.
Definition and_ind := forall A B P : Prop, (A -> B -> P) -> and A B -> P .
Definition and_rec := forall (A B : Prop) (P : Set), (A -> B -> P) -> and A B -> P .

Lemma AndCom : forall A B, A /\ B -> B /\ A.
Proof.
  intros A B H.
  destruct H.
  constructor. apply H0. apply H.
Qed.

Print AndCom.

Definition AndCom' :=
fun (A B : Prop) (H : A /\ B) => match H with
                                 | conj H0 H1 => conj H1 H0
                                 end.

Print All.

End MLCoq.

(* Require Import dpdgraph.dpdgraph. *)
(* Print FileDependGraph MLCoq. *)

(* Print MLCoq.AndCom'. *)