Require Export Types.
Require Import Logic.FunctionalExtensionality.

Module STLC.

Inductive ty : Type :=
  | TVar : id -> ty
  | TArrow : ty -> ty -> ty
  | TForall : id -> ty -> ty.

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tABS : id -> tm -> tm
  | tAPP : tm -> ty -> tm.

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).

Definition X := (Id 3).
Definition Y := (Id 4).
Definition Z := (Id 5).

Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_ABS : forall x t,
      value t ->
      value (tABS x t).

Hint Constructors value.

Fixpoint subst_tm (x : id) (s : tm) (t : tm) :=
  match t with
  | tvar x' => if beq_id x x' then s else t
  | tabs x' T t1 => tabs x' T (if beq_id x x' then t1
                               else subst_tm x s t1)
  | tapp t1 t2 => tapp (subst_tm x s t1) (subst_tm x s t2)
  | tABS x' t1 => tABS x' (if beq_id x x' then t1
                           else subst_tm x s t1)
  | tAPP t1 T => tAPP (subst_tm x s t1) T
  end.

Fixpoint subst_ty (x : id) (s : ty) (t : ty) :=
  match t with
  | TVar x' => if beq_id x x' then s else t
  | TArrow t1 t2 => TArrow (subst_ty x s t1) (subst_ty x s t2)
  | TForall x' t' =>
      TForall x (if beq_id x x' then t' else subst_ty x s t')
  end.

Fixpoint subst_ty_tm (x : id) (s : ty) (t : tm) :=
  match t with
  | tvar x' => t
  | tabs x' T t1 => tabs x' (subst_ty x s T) (subst_ty_tm x s t1)
  | tapp t1 t2 => tapp (subst_ty_tm x s t1) (subst_ty_tm x s t2)
  | tABS x' t1 => tABS x' (if beq_id x x' then t1
                           else subst_ty_tm x s t1)
  | tAPP t1 T => tAPP (subst_ty_tm x s t1) (subst_ty x s T)
  end.

Notation "'[' x ':=' s ']' t" := (subst_tm x s t) (at level 20).
Notation "'[[' x '::=' s ']]' t" := (subst_ty x s t) (at level 20).
Notation "'[[' x ':=' s ']]' t" := (subst_ty_tm x s t) (at level 20).

Reserved Notation "t1 '==>' t2" (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
      value v2 -> tapp (tabs x T t12) v2 ==> subst_tm x v2 t12
  | ST_App1 : forall t1 t1' t2,
      t1 ==> t1' ->
      tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
      value v1 ->
      t2 ==> t2' ->
      tapp v1 t2 ==> tapp v1 t2'
  | ST_AppABS : forall X v1 T,
      value v1 ->
      tAPP (tABS X v1) T ==> subst_ty_tm X T v1
  | ST_AppABS1 : forall t1 t1' T,
      t1 ==> t1' ->
      tAPP t1 T ==> tAPP t1' T
  | ST_ABS : forall X t1 t1',
      t1 ==> t1' ->
      tABS X t1 ==> tABS X t1'
  where "t1 '==>' t2" := (step t1 t2).

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

Notation idB :=
  (tABS X (tabs x (TVar X) (tvar x))).

Notation idBB :=
  (tABS X (tabs x (TArrow (TVar X) (TVar X)) (tvar x))).

Lemma step_example1' :
  (tABS X (tapp (tAPP idBB (TVar X)) (tAPP idB (TVar X)))) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_ABS.
    apply ST_App1.
    apply ST_AppABS.
    auto.
  eapply multi_step.
    simpl.
    apply ST_ABS.
    apply ST_App2.
    auto.
    apply ST_AppABS.
    auto.
  eapply multi_step.
    simpl.
    apply ST_ABS.
    apply ST_AppAbs.
    auto.
  apply multi_refl.
Qed.

Inductive binding :=
  | Empty : binding
  | TyVar : binding
  | TmVar : ty -> binding.

Definition context := id -> binding.
Definition empty : context := (fun _ => Empty).
Definition extend (G : context) (x : id) (b : binding) :=
  fun x' => if beq_id x x' then b else G x'.

Module PartialMap.

Lemma extend_eq : forall (ctxt: context) x T,
  (extend ctxt x T) x = T.
Proof.
  intros.
  destruct x0.
  unfold extend; unfold beq_id; simpl.
  rewrite <- beq_nat_refl.
  auto.
Qed.

Lemma extend_neq : forall (ctxt : context) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros.
  unfold extend. rewrite H. auto.
Qed.

Lemma extend_shadow : forall (ctxt: context) x T1 T2,
  (extend (extend ctxt x T1) x T2) = (extend ctxt x T2).
Proof.
  intros.
  extensionality x.
  unfold extend.
  destruct (beq_id x0 x); auto.
Qed.

Lemma extend_commute : forall (ctxt : context) x1 x2 T1 T2,
  x1 <> x2 ->
  (extend (extend ctxt x1 T1) x2 T2) = (extend (extend ctxt x2 T2) x1 T1).
Proof.
  intros.
  extensionality x.
  unfold extend.
  remember (beq_id x2 x) as x2x.
  remember (beq_id x1 x) as x1x.
  destruct x2x.
  destruct x1x; subst.
  + apply beq_id_eq in Heqx2x.
    apply beq_id_eq in Heqx1x.
    subst. exfalso.
    apply H. auto.
  + auto.
  + auto.
Qed.

End PartialMap.

Inductive wf_ty : context -> ty -> Prop :=
  | WF_Var : forall G X,
      G X = TyVar ->
      wf_ty G (TVar X)
  | WF_Arrow : forall G T1 T2,
      wf_ty G T1 ->
      wf_ty G T2 ->
      wf_ty G (TArrow T1 T2)
  | WF_Forall : forall G X T,
      wf_ty (extend G X TyVar) T ->
      wf_ty G (TForall X T).

Inductive wf_tm : context -> tm -> Prop :=
  | wf_var : forall G x T,
      G x = TmVar T ->
      wf_ty G T ->
      wf_tm G (tvar x)
  | wf_app : forall G t1 t2,
      wf_tm G t1 ->
      wf_tm G t2 ->
      wf_tm G (tapp t1 t2)
  | wf_abs : forall G x T t,
      wf_ty G T ->
      wf_tm (extend G x (TmVar T)) t ->
      wf_tm G (tabs x T t)
  | wf_ABS : forall G X t,
      wf_tm (extend G X TyVar) t ->
      wf_tm G (tABS X t)
  | wf_APP : forall G T t,
      wf_ty G T ->
      wf_tm G t ->
      wf_tm G (tAPP t T).

(*Inductive appears_free_in_ty : id -> ty -> Prop :=
  | afi_Var : forall x,
      appears_free_in_ty x (TVar x)
  | afi_Arrow1 : forall T1 T2,
      appears_free_in_ty x T1 ->
      appears_free_in_ty x (TArrow T1 T2)
  | afi_Arrow2 : forall T1 T2,
      appears_free_in_ty x T2 ->
      appears_free_in_ty x (TArrow T1 T2)
  | afi_Forall : forall x y T,
      y <> x  ->
      appears_free_in_ty x T ->
      appears_free_in_ty x (TForall y T).

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs1 : forall x y T11 t12,
      y <> x ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_abs2 : forall x y T11 t12,
      appears_free_in_ty x T11 ->
      appears_free_in x (tabs y T11 t12)
  | afi_APP1 : forall x t T,
      appears_free_in x t ->
      appears_free_in x (tAPP t T)
  | afi_APP2 : forall x t T,
      appears_free_in_ty x T ->
      appears_free_in x (tAPP t T)
  | afi_ABS : forall x X t,
      X <> x ->
      appears_free_in x t ->
      appears_free_in x (tABS X t).*)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs1 : forall x y T11 t12,
      y <> x ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_APP1 : forall x t T,
      appears_free_in x t ->
      appears_free_in x (tAPP t T)
  | afi_ABS : forall x X t,
      appears_free_in x t ->
      appears_free_in x (tABS X t).

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall G x T,
      G x = TmVar T ->
      has_type G (tvar x) T
  | T_Abs : forall x G T11 T12 t12,
      has_type (extend G x (TmVar T11)) t12 T12 ->
      has_type G (tabs x T11 t12) (TArrow T11 T12)
  | T_App : forall T11 T12 G t1 t2,
      has_type G t1 (TArrow T11 T12) ->
      has_type G t2 T11 ->
      has_type G (tapp t1 t2) T12
  | T_ABS : forall X G T body,
      has_type (extend G X TyVar) body T ->
      has_type G (tABS X body) (TForall X T)
  | T_APP : forall X G body T T',
      has_type G body (TForall X T) ->
      wf_ty G T' ->
      has_type G (tAPP body T') (subst_ty X T' T).

Require Import Logic.FunctionalExtensionality.
Lemma has_type_context_subst G1 G2 t T : (forall x, G1 x = G2 x) ->
  has_type G1 t T -> has_type G2 t T.
Proof.
  intros.
  assert (G1 = G2) by
    (extensionality x; auto).
  rewrite <- H1.
  auto.
Qed.

Example typing_example_2_full :
  has_type (extend empty X TyVar)
    (tabs x (TVar X)
       (tabs y (TArrow (TVar X) (TVar X))
          (tapp (tvar y) (tapp (tvar y) (tvar x)))))
    (TArrow (TVar X) (TArrow (TArrow (TVar X) (TVar X)) (TVar X))).
Proof with (compute; auto).
  apply T_Abs.
  apply T_Abs.
  eapply T_App.
  - apply T_Var...
  - eapply T_App.
    + apply T_Var...
    + apply T_Var...
Qed.

Theorem progress G t T :
  closed t -> has_type G t T ->
  value t \/ exists t', t ==> t'.
Proof with (try constructor; eauto).
  intros Hcl Ht.
  induction Ht; intros.
  - unfold closed in Hcl.
    exfalso.
    apply (Hcl x0).
    constructor.
  - left. constructor.
  - right.
    assert (closed t1).
      unfold closed.
      intros x0 appear.
      apply (Hcl x0)...
    assert (closed t2).
      unfold closed.
      intros x0 appear.
      apply (Hcl x0).
      apply afi_app2...
    apply IHHt1 in H.
    apply IHHt2 in H0.
    destruct H; [ destruct H0 | .. ].
    + inversion Ht1; subst.
      * solve by inversion 2.
      * exists ([x0 := t2] t12)...
      * solve by inversion 2.
      * solve by inversion 2.
    + destruct H0.
      exists (tapp t1 x0)...
    + destruct H as [t'].
      exists (tapp t' t2)...
  - assert (closed body).
      intros x H.
      apply (Hcl x).
      apply afi_ABS...
    apply IHHt in H.
    destruct H.
    * left...
    * right. destruct H.
      eexists...
  - assert (closed body).
      intros x H'.
      apply (Hcl x).
      apply afi_APP1...
    apply IHHt in H0; clear IHHt; destruct H0.
    * destruct H0.
      inversion Ht.
      right.
      eexists...
    * right.
      destruct H0.
      exists (tAPP x0 T')...
Qed.

(*Lemma has_type_in_context : forall G G0 t T,
  (forall x, G0 x = G x \/ G0 x = Empty) ->
  has_type G0 t T ->
  has_type G t T.
Proof.
  intros G G0 T t HG H.
  induction H.
  - destruct (HG x0).
    constructor. rewrite <- H0. auto.
    rewrite H in H0.
    inversion H0.
  - constructor.
    assert (has_type G t12 T12).
    apply IHhas_type.
      intros.
      remember (beq_id x1 x0) as xeq.
      destruct xeq.
      apply beq_id_eq in Heqxeq; subst.
admit.*)

Lemma substitution_preserves_typing t : forall G x U t' T,
     has_type (extend G x (TmVar U)) t T ->
     has_type empty t' U ->
     has_type G ([x:=t']t) T.
Proof.
  induction t; intros; remember empty as G0.
  - (*unfold subst_tm.
    remember (beq_id x0 i) as eqx.
    destruct eqx.
    + apply beq_id_eq in Heqeqx.
      inversion H.
      subst x0 x1 T0 G1.
      rewrite PartialMap.extend_eq in H3.
      inversion H3; subst U; clear H3.
      inversion H0.
      * subst G0; inversion H1.
      * subst.
      unfold G0 in H0.
  induction t.
  - unfold subst_tm.
    remember (beq_id x0 i) as Hx0.
    destruct Hx0.
    apply beq_id_eq in HeqHx0; subst.
    inversion H; subst.
    rewrite PartialMap.extend_eq in H3.
    inversion H3.
    rewrite <- H2.*)
    admit.
  - simpl.
    inversion H; subst.
    apply IHt1 with (t':=t') in H4; auto.
    apply IHt2 with (t':=t') in H6; auto.
    apply T_App with (T11:=T11); auto.
  - simpl. inversion H; subst.
    remember (beq_id x0 i) as eqx.
    destruct eqx.
    * apply T_Abs.
      apply beq_id_eq in Heqeqx; subst.
      rewrite PartialMap.extend_shadow in H6.
      auto.
    * apply T_Abs.
      inversion H; subst.
      apply IHt with (U:=U); auto.
      rewrite PartialMap.extend_commute in H6; auto.
  - simpl.
    inversion H; subst.
    constructor.
    remember (beq_id x0 i) as eqx.
    destruct eqx.
    apply IHt.

Qed.


(** Semántica y verificación 22-1

  Orden para binarios

  Script con las definiciones y las propiedades de
  orden en naturales binarios.
  Este árbol binarios será sobre el cual se definan los árboles de braun.
  Este script fue basado de los cursos de Favio Ezquiel
  Miranda Perea y modificado en ciertos aspectos.

  Edición por Luis Felipe Benítez Lluis

  Contenido:
    1 Definiciones de orden en binnat
    2 Propiedades de <BN en operadores U y D
    3 Axiomas de COPO estricto para <BN
    4 Propiedades de <BN con cero
    5 Propiedades de suc sin dependencias
    6 Propiedades trasformación de representaciones
    7 Mas propiedades de <BN con sucesor
    8 Propiedades de <=BN
    9 Propiedadese que combinan <BN y <=BN
    10 Axiomas de COPO para <BN
    11 Propiedades de orden <BN respecto a pred

    Para acceder rápidamente a la sección deseada
    buscar la cadena ">n" donde "n" es el número de
    sección. *)

Require Import Coq.Arith.PeanoNat.
From Proyecto02Base Require Import binnat.
From Coq Require Import Lia.

(** >1 Definiciones de orden en binnat *)
Inductive ltBN : BN -> BN -> Prop :=
 | ltBNZU : forall (a:BN), ltBN Z (U a)
 | ltBNZD : forall (a:BN), ltBN Z (D a)
 | ltBNUU : forall (a b:BN), ltBN a b -> ltBN (U a) (U b)
 | ltBNUDeq : forall (a :BN), ltBN (U a) (D a)
 | ltBNUD : forall (a b:BN), ltBN a b -> ltBN (U a) (D b)
 | ltBNDU : forall (a b:BN), ltBN a b -> ltBN (D a) (U b)
 | ltBNDD : forall (a b:BN), ltBN a b -> ltBN (D a) (D b).

Inductive lteqBN: BN -> BN -> Prop :=
 | lteqBNref: forall (a:BN), lteqBN a a
 | lteqBNl: forall (a b: BN), ltBN a b -> lteqBN a b.

Notation "a <BN b" := (ltBN a b) (at level 70).
Notation "a <BN b <BN c" := (ltBN a b /\ ltBN b c) (at level 70, b at next level).

Notation "a <=BN b" := (lteqBN a b) (at level 70).

(** >2 Propiedades de <BN en operadores U y D*)
Lemma lt_Ua_and_Da: forall a:BN, a<BN U a/\ a <BN D a.
Proof.
induction a.
- split; constructor.
- destruct IHa as [HU HD]. split; constructor; assumption.
- destruct IHa as [HU HD]. split; constructor; assumption.
Qed.
Lemma lt_Ua: forall a:BN , a<BN U a.
Proof.
intros.
pose proof lt_Ua_and_Da a.
destruct H.
assumption.
Qed.

Lemma lt_Da: forall a:BN , a<BN D a.
Proof.
intros.
pose proof lt_Ua_and_Da a.
destruct H.
assumption.
Qed.
Lemma lt_UaDa: forall a:BN, U a <BN D a.
Proof.
apply ltBNUDeq.
Qed.

Lemma lt_U: forall (a b:BN), a <BN b <-> (U a) <BN U b.
Proof.
intros.
split.
+ intro.
  apply ltBNUU.
  assumption.
+ intro.
  inversion H.
  assumption.
Qed.

Lemma lt_D: forall (a b:BN), a <BN b <-> (D a) <BN D b.
Proof.
intros. split.
+ intros. apply ltBNDD.
  assumption.
+ intros.
  inversion H.
  assumption.
Qed.

(** >3 Axiomas de COPO estricto para <BN*)
Lemma ltBN_arefl: forall (a:BN), ~ a <BN a.
Proof.
intros.
induction a.
unfold not.
intros.
inversion H.
contradict IHa.
inversion IHa.
trivial.
contradict IHa.
inversion IHa.
trivial.
Qed.

Create HintDb PNatDb.

Hint Resolve ltBN_arefl: PNatDb.

Lemma ltBN_asym: forall (a b:BN), a <BN b -> ~ b <BN a.
Proof.
intros.
induction H.
unfold not;intros.
inversion H.
unfold not;intros.
inversion H.
contradict IHltBN.
inversion IHltBN.
trivial.
unfold not;intros.
inversion H.
apply (ltBN_arefl a).
trivial.
(*exact (ltBN_arefl a H2).*)
unfold not;intros.
inversion H0.
intuition.
contradict IHltBN.
inversion IHltBN.
rewrite H2 in H.
trivial.
trivial.
contradict IHltBN.
inversion IHltBN.
trivial.
Qed.

Hint Resolve ltBN_asym: PNatDb.

Lemma ltBN_tr: forall (b c:BN), b <BN c -> forall (x:BN), x <BN b -> x <BN c.
Proof.
intro.
intro.
intro.
induction H.
- intros. inversion H.
- intros. inversion H.
- intros. destruct x.
  --  constructor.
  -- apply ltBNUU.
     apply IHltBN.
     inversion H0;subst;assumption.
  -- apply ltBNDU.
     apply IHltBN.
     inversion H0;subst;assumption.

  - intros. destruct x.
  --  constructor.
  -- apply ltBNUD.
     inversion H;subst;assumption.
  -- apply ltBNDD.
     inversion H;subst;assumption.

- intros. destruct x.
  --  constructor.
  -- apply ltBNUD.
     apply IHltBN.
     inversion H0;subst;assumption.
  -- apply ltBNDD.
     apply IHltBN.
     inversion H0;subst;assumption.

  - intros. destruct x.
  --  constructor.
  -- apply ltBNUU.
     inversion H0.
     assumption.
     apply IHltBN.
     assumption.
  -- apply ltBNDU.
     apply IHltBN.
     inversion H0;subst;assumption.

  - intros. destruct x.
  --  constructor.
  -- apply ltBNUD.
     inversion H0.
     assumption.
     apply IHltBN.
     assumption.
  -- apply ltBNDD.
     apply IHltBN.
     inversion H0;subst;assumption.
Qed.

Hint Resolve ltBN_tr: PNatDb.

Lemma ltBN_trans: forall (a b c:BN), a <BN b -> b <BN c -> a <BN c.
Proof.
intros.
eapply ltBN_tr.
eexact H0.
trivial.
Qed.

(** >4 Propiedades de <BN con cero*)
Lemma ltBN_ZUa: forall a:BN, Z <BN U a.
Proof.
induction a;try(constructor).
Qed.

Lemma ltBN_ZDa: forall a:BN, Z <BN D a.
Proof.
induction a;try(constructor).
Qed.

Lemma ltBN_UZDa: forall a:BN, U Z <BN D a.
Proof.
induction a;try(do 2 constructor).
Qed.
Lemma ltBN_Zsuca: forall a:BN,  Z <BN sucBN a.
Proof.
induction a;try(do 2 constructor).
Qed.

Lemma ltBN_aUZ: forall (a:BN), a <BN U Z -> a =Z.
Proof.
intros.
induction a.
reflexivity.
inversion H.
inversion H2.
inversion H.
inversion H2.
Qed.

Lemma ltBN_UaDZ: forall (a:BN),U a <BN D Z -> a =Z.
Proof.
induction a.
- reflexivity.
- intros. inversion H. subst. inversion H2.
- intros. inversion H. subst. inversion H2.
Qed.

Lemma ltBN_aDZ: forall (a:BN), a <BN D Z -> (a =Z \/ a= U Z).
Proof.
intros.
induction a.
- left. reflexivity.
- assert (a<BN D Z).
  -- eapply ltBN_trans. 2:{ apply H. } apply lt_Ua.
  -- destruct IHa.
  --- assumption.
  --- right. subst. reflexivity.
  --- apply ltBN_UaDZ in H. subst. discriminate H1.
-  assert (a<BN D Z).
  -- eapply ltBN_trans. 2:{ apply H. } apply lt_Da.
  -- destruct IHa.
  --- assumption.
  --- subst. contradict H. apply ltBN_arefl.
  --- inversion H. inversion H4.
Qed.

Lemma ltBM_UZDa: forall (a:BN), U Z <BN D a.
Proof.
induction a.
- constructor.
- do 2 constructor.
-  do 2 constructor.
Qed.

(** >5 Propiedades de suc sin dependencias*)
Lemma lts: forall (a:BN), a <BN (sucBN a).
Proof.
intros.
induction a.
constructor.
simpl.
constructor.
simpl.
constructor.
trivial.
Qed.

Lemma ltDUs: forall (a:BN), (D a) <BN (U (sucBN a)).
Proof.
intros.
induction a.
simpl.
constructor.
constructor.
simpl.
constructor.
constructor.
simpl.
constructor.
trivial.
Qed.

Lemma lt_suc: forall a:BN, a <BN sucBN a.
Proof.
induction a.
simpl. apply ltBN_ZUa.
simpl. apply ltBNUDeq.
simpl. apply ltDUs.
Qed.

(** >6 Propiedades trasformación de representaciones*)

Lemma le_ToN_order: forall (a b:BN),
  a <BN b -> toN a < toN b.
Proof.
intro.
induction a;intros.
-  inversion H. simpl.
    rewrite Nat.add_1_r. apply Nat.lt_0_succ.
   simpl. rewrite Nat.add_succ_r. apply Nat.lt_0_succ.
- simpl.
  inversion H.
  -- subst. simpl.
      apply IHa in H1.
      lia.
  -- subst. simpl.
      lia.
  -- subst. simpl.
     apply IHa in H1.
     lia.
- simpl. inversion H. subst.
  -- simpl. apply IHa in H1.
     lia.
  -- subst. simpl.
    apply IHa in H1.
     lia.
Qed.

Lemma le_ToBN_order: forall (b a: nat),
  a < b -> toBN a <BN toBN b.
Proof.
intro.
induction b;intros.
- simpl. inversion H.
- simpl.
  inversion H.
  --  apply lt_suc.
  -- simpl. inversion H1.
  --- subst. specialize (IHb a).
      pose proof Nat.lt_succ_diag_r a.
      apply IHb in H0.
      eapply ltBN_trans.
      + apply H0.
      + apply lt_suc.
  --- subst.
      assert (a < S m0).
      { eapply Nat.lt_le_trans.
        apply Nat.lt_succ_diag_r.
        assumption.
      }
      apply IHb in H0.
      eapply ltBN_trans.
      apply H0.
      apply lt_suc.
Qed.

Lemma le_ToN_order_equiv: forall (a b:BN),
  a <BN b <-> toN a < toN b.
Proof.
split.
apply le_ToN_order.
remember (toN a) as aa.
remember (toN b) as bb.
intros.
assert (toBN aa = a).
  { subst. apply inverse_op_2.  }
assert (toBN bb = b).
  { subst. apply inverse_op_2. }
rewrite <- H0.
rewrite <- H1.
apply le_ToBN_order.
assumption.
Qed.

Lemma le_ToBN_order_equiv: forall (b a: nat),
  a < b <-> toBN a <BN toBN b.
Proof.
split.
apply le_ToBN_order.
remember (toBN a) as aa.
remember (toBN b) as bb.
intros.
assert (toN aa = a).
  { subst. apply inverse_op_1.  }
assert (toN bb = b).
  { subst. apply inverse_op_1. }
rewrite <- H0.
rewrite <- H1.
apply le_ToN_order.
assumption.
Qed.

(** >7 Mas propiedades de <BN con sucesor*)

Lemma lt_UsaDb:forall (b a:BN), a<BN b -> U (sucBN a) <BN D b.
Proof.
intros.
apply <-le_ToN_order_equiv.
simpl.
apply le_ToN_order_equiv in H.
rewrite toN_sucBN.
lia.
Qed.

(** >E Rellenar este problema. Dificultad 3. Lia es una táctica para resolver
 problemas aritméticos simples.*)
Lemma lt_asuc_iff_UD: forall (a b:BN), a <BN  sucBN b <-> (U a) <BN D b.
Proof.

intros. split.
-
intros.
apply <-le_ToN_order_equiv.
simpl. apply le_ToN_order_equiv in H.
rewrite toN_sucBN in H.
lia.
- (*Concretar este caso*)
Admitted.

(** >E Rellenar este problema. Dificultad 3. Usar inducción sobre <BN y varias propiedades
        Dificultad 3*)
Lemma ltBN_suc_mono_r: forall (a b :BN), a<BN b -> sucBN a <BN sucBN b.
Proof.
Admitted.

(** >8 Propiedades de <=BN*)

Lemma lteqBN_Za: forall (a:BN), Z <=BN a.
Proof.
intros.
destruct a.
- constructor.
- constructor.
  apply ltBNZU.
- constructor.
  apply ltBNZD.
Qed.

Hint Resolve lts: PNatDb.

Lemma lteqs: forall (a:BN), a <=BN (sucBN a).
Proof.
intros.
induction a.
constructor.
constructor.
simpl.
constructor.
constructor.
simpl.
constructor.
constructor.
inversion IHa.
contradict H0.
apply notSucBN.
trivial.
Qed.

Hint Resolve lteqs: PNatDb.

Lemma ltaux1: forall (j:BN), Z <=BN (D j) -> Z <=BN j.
Proof.
intros.
apply lteqBN_Za.
Qed.

Lemma lteqBN_refl : forall (b:BN), b <=BN b.
Proof.
intros.
constructor.
Qed.

Lemma lteqBN_Z : forall (b:BN), Z <=BN b.
Proof.
intros.
destruct b.
constructor.
constructor;constructor.
constructor;constructor.
Qed.

Lemma lteqBN_U_U:forall (a b:BN), (U a) <=BN (U b) <-> a <=BN b.
Proof.
intros.
split.
{
intros.
inversion H.
constructor.
inversion H0.
constructor.
trivial.
}
intros.
inversion H.
- subst.
constructor.
- subst. do 2 constructor. assumption.
Qed.

Lemma lteqBN_D_D : forall (a b : BN), (D a) <=BN (D b)<-> a <=BN b.
Proof.
intros.
split.
{
intro.
inversion H.
constructor.
inversion H0.
constructor.
trivial.
}
intros.
inversion H.
-
subst.
constructor.
- subst. do 2 constructor.
assumption.
Qed.

Lemma lteqBN_U_D:forall (a b:BN), (U a) <=BN (D b) <-> a <=BN b.
Proof.
split.
{
intros.
inversion H.
inversion H0.
constructor.
constructor.
trivial.
}
intros.
inversion H.
- subst.  constructor.  constructor.
- subst. do 2 constructor. assumption.
Qed.

Lemma lteqBN_D_U:forall (a b:BN), (D a) <=BN (U b) -> a <=BN b.
Proof.
intros.
inversion H.
inversion H0.
constructor.
trivial.
Qed.

(** >9 Propiedadese que combinan <BN y <=BN*)
Hint Resolve ltBN_trans: PNatDb.
Lemma le_noteq_lt: forall (a b :BN), a <> b -> a <=BN b -> a <BN b.
Proof.
 intros.
 inversion H0.
 - subst. contradict H. reflexivity.
 - assumption.
Qed.

Lemma lt_lteqBN_trans: forall (a b c:BN), a <BN b -> b <=BN c -> a <BN c.
Proof.
intros.
inversion H0.
rewrite H2 in H.
trivial.
eapply ltBN_trans.
eexact H.
trivial.
Qed.

Hint Resolve lt_lteqBN_trans: PNatDb.

Lemma lteqBN_trans: forall (a b c:BN), a <=BN b -> b <=BN c -> a <=BN c.
Proof.
intros.
inversion H.
trivial.
inversion H0.
rewrite H5 in H.
trivial.
constructor.
eapply ltBN_trans.
eexact H1.
trivial.
Qed.
Hint Resolve ltDUs: PNatDb.
Hint Resolve lteqBN_trans: PNatDb.

Lemma not_lt: forall (a b:BN), b <=BN a -> ~ a <BN b.
Proof.
intros.
destruct H.
-  apply ltBN_arefl.
- apply ltBN_asym. assumption.
Qed.

Lemma lt1: forall (b a:BN), a <BN (sucBN b) -> a <=BN b.
Proof.
intro.
induction b.
- intros.
  simpl.
  inversion H.
  constructor.
  inversion H2.
  inversion H2.
- intros.
  inversion H.
  * apply lteqBN_Za.
  * constructor.
  * constructor.
    constructor.
    assumption.
  * constructor.
    constructor.
    assumption.
- intros.
  inversion H.
  * apply lteqBN_Za.
  * subst.
    apply IHb in H2.
    inversion H2.
    -- subst. constructor.
      inversion H2;apply ltBNUDeq.
    -- subst. constructor.
     constructor. assumption.
 * subst. apply IHb in H2.
    inversion H2.
    -- subst. constructor.
    -- subst. constructor.
     constructor. assumption.
Qed.

Hint Resolve lt1: PNatDb.

Lemma lt2: forall (b a:BN), a <=BN b -> a <BN (sucBN b).
Proof.
intro.
induction b.
- intros.
  inversion H.
  subst.
  constructor.
  subst.
  inversion H0.
- intros.
  inversion H.
  subst.
  constructor.
  subst.
  induction a.
  constructor.
  inversion H0.
  subst.
  simpl.
  constructor.
  assumption.
  simpl.
  constructor.
  inversion H0.
  assumption.
- intros.
  inversion H.
  apply lts.
  subst.
  inversion H0.
  constructor.
  simpl.
  constructor.
  apply lts.
  simpl.
  subst.
  constructor.
  apply IHb.
  constructor.
  assumption.
  simpl.
  constructor.
  apply IHb.
  constructor.
  assumption.
Qed.
Lemma le_ab_lt_asucb: forall (b a:BN), a <=BN b <-> a <BN (sucBN b).
Proof.
intros.
split.
apply lt2.
apply lt1.
Qed.

Hint Resolve lt2: PNatDb.

Lemma lt_suc_lteq: forall (a b:BN), a <BN b <-> (sucBN a) <=BN b.
Proof.
intros.
split.
+ intro. induction H.
- simpl. destruct a.
  -- constructor.
  -- simpl. constructor.
     apply ltBNUU.
     constructor.
  -- constructor.
     apply ltBNUU.
     constructor.
- destruct a;do 3 constructor.

- simpl.
  constructor.
  constructor.
  assumption.
- constructor.
- simpl.
  constructor.
  constructor.
  assumption.
- simpl.
  apply <-lteqBN_U_U.
  assumption.
- simpl.
  apply <-lteqBN_U_D.
  assumption.
+ intro.
pose proof (lts a).
eapply lt_lteqBN_trans.
apply H0.
assumption.
Qed.
Lemma sucBN_lt: forall (a b:BN), sucBN a <> b -> a <BN b -> (sucBN a) <BN b.
Proof.
intros.
apply lt_suc_lteq in H0.
apply le_noteq_lt;assumption.
Qed.

Lemma lteqBN_suc: forall (a b:BN), a <=BN b -> (sucBN a) <=BN (sucBN b).
Proof.
intros.
inversion H.
constructor.
apply lt_suc_lteq.
apply lt2.
trivial.
Qed.

(** >10 Axiomas de COPO para <BN*)

Theorem not_lt_suc: forall (a:BN), ~ exists (b:BN), a <BN b /\ b <BN (sucBN a).
Proof.
intros.
intro.
induction a.
+ destruct H.
  destruct H.
  - apply ltBN_aUZ in H0.
  rewrite H0 in H.
  inversion H.
+ apply IHa.
  destruct H.
  destruct H.
  simpl in H0.
  induction x.
  inversion H.
  - apply lt_U in H.
    inversion H0.
    -- subst.
        contradict H.
        apply ltBN_arefl.
    -- subst.
       contradict H3.
       apply ltBN_asym.
       assumption.
  - inversion H0. subst.
    inversion H. subst.
    contradict H3.
    apply ltBN_arefl.
    subst. contradict H4.
    apply ltBN_asym.
    assumption.
+ apply IHa.
  destruct H.
  destruct H.
  apply le_ab_lt_asucb in H0.
  exfalso.
  apply (ltBN_arefl (D a)).
  eapply  lt_lteqBN_trans.
  apply H.
  assumption.
Qed.

(** >E Concretar los casos faltantes este problema. Dificultad 4. Hint: los casos se parecen. *)
Lemma lt_trichotomy: forall (a b:BN), a <BN b \/ a=b \/ b <BN a.
Proof.
induction a, b.
- right. left. reflexivity.
- left. constructor.
- left. constructor.
- right. right. constructor.
- specialize IHa with b.
  destruct IHa.
  left. constructor. assumption.
  destruct H. right. left. rewrite H. reflexivity.
  right. right. constructor. assumption.
Admitted.

Lemma bbalCond_eqs: forall (s t:BN), t <=BN s -> s <=BN sucBN t -> s = t \/ s = sucBN t.
Proof.
intros.
inversion H.
intuition.
inversion H0.
intuition.
exfalso.
eapply not_lt_suc.
exists s.
split.
exact H1.
assumption.
Qed.

(** >11 Propiedades de orden <BN respecto a pred *)

Lemma ltpred : forall (a:BN), a <> Z -> (predBN a) <BN a.
Proof.
intros.
induction a.
- contradict H. reflexivity.
- simpl. destruct a.
  + constructor.
  + apply ltBNDU.
    apply IHa.
    apply not_eq_sym.
    apply ZnotU.
  + apply ltBNDU.
    apply IHa.
    apply not_eq_sym.
    apply ZnotD.
- simpl. apply ltBNUDeq.
Qed.

Hint Resolve ltpred: PNatDb.

Lemma lteqBN_suc_pred : forall (a b:BN),
  a <> Z -> a <=BN (sucBN b) -> (predBN a) <=BN b.
Proof.
intros.
assert ((predBN a) <BN a).
apply ltpred.
trivial.
assert (predBN a <BN sucBN b).
eapply lt_lteqBN_trans.
eexact H1.
trivial.
apply lt1.
trivial.
Qed.

Hint Resolve lteqBN_suc_pred: PNatDb.


Variable A: Type.
Variable empty: A.
Variable x z : A.

Inductive ls1: A -> Prop :=
  | ls1_empty: ls1 empty
  | ls1_x : ls1 x
  | ls1_xy: ls1 x ->  A -> ls1 x.

Inductive ls2: A -> Prop :=
  | ls2_empty: ls2 empty
  | ls2_x : ls2 x
  | ls2_xy: ls2 x -> ls2 x -> ls2 x.

Lemma uno: forall (y : A), ls1 y <-> ls2 y.
Proof.
  intro.
  split.
  (* ida *)
  intro.
  induction H.
  constructor.
  constructor.
  trivial.
  (*vuelta *)
  intros.
  induction H.
  constructor.
  constructor.
  trivial.
Qed.


(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import ZArith Zwf Psatz QArith.
Open Scope Z_scope.

Lemma Zabs_square : forall x,  (Zabs  x)^2 = x^2.
Proof.
 intros ; case (Zabs_dec x) ; intros ; psatz Z 2.
Qed.
Hint Resolve Zabs_pos Zabs_square.

Lemma integer_statement :  ~exists n, exists p, n^2 = 2*p^2 /\ n <> 0.
Proof.
intros [n [p [Heq Hnz]]]; pose (n' := Zabs n); pose (p':=Zabs p).
assert (facts : 0 <= Zabs n /\ 0 <= Zabs p /\ Zabs n^2=n^2
         /\ Zabs p^2 = p^2) by auto.
assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by
  (destruct facts as [Hf1 [Hf2 [Hf3 Hf4]]]; unfold n', p' ; psatz Z 2).
generalize p' H; elim n' using (well_founded_ind (Zwf_well_founded 0)); clear.
intros n IHn p [Hn [Hp Heq]].
assert (Hzwf : Zwf 0 (2*p-n) n) by (unfold Zwf; psatz Z 2).
assert (Hdecr : 0 < 2*p-n /\ 0 <= n-p /\ (2*p-n)^2=2*(n-p)^2) by psatz Z 2.
apply (IHn (2*p-n) Hzwf (n-p) Hdecr).
Qed.

Open Scope Q_scope.

Lemma QnumZpower : forall x : Q, Qnum (x ^ 2)%Q = ((Qnum x) ^ 2) %Z.
Proof.
  intros.
  destruct x.
  cbv beta  iota zeta delta - [Zmult].
  ring.
Qed.

Lemma QdenZpower : forall x : Q, ' Qden (x ^ 2)%Q = ('(Qden x) ^ 2) %Z.
Proof.
  intros.
  destruct x.
  simpl.
  unfold Zpower_pos.
  simpl.
  rewrite Pmult_1_r.
  reflexivity.
Qed.

Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1.
Proof.
 unfold Qeq; intros [x p]; revert p; simpl (Qden (2#1)); rewrite Zmult_1_r.
 intros HQeq.
 assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by
   (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto).
 assert (Hnx : (Qnum x <> 0)%Z)
 by (intros Hx; simpl in HQeq; rewrite Hx in HQeq; discriminate HQeq).
 apply integer_statement; exists (Qnum x); exists (' Qden x); auto.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 12: Hoare Logic: Verifying Imperative Programs
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

(** * Syntax and semantics of a simple imperative language *)

(* Here's some appropriate syntax for expressions (side-effect-free) of a simple
 * imperative language with a mutable memory. *)
Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Mult (e1 e2 : exp).

(* Those were the expressions of numeric type.  Here are the Boolean
 * expressions. *)
Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp).

Definition heap := fmap nat nat.
Definition valuation := fmap var nat.
Definition assertion := heap -> valuation -> Prop.

(* Here's the syntax of side-effecting commands, where we attach an assertion to
 * every "while" loop, for reasons that should become clear later.  The
 * assertion is ignored in the operational semantics! *)
Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)

(* And one more, which we'll use to characterize program correctness more
 * simply: *)
| Assert (a : assertion).

(* Shorthand notation for looking up in a finite map, returning zero if the key
 * is not found *)
Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

(* Start of expression semantics: meaning of expressions *)
Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x => v $! x
  | Read e1 => h $! eval e1 h v
  | Plus e1 e2 => eval e1 h v + eval e2 h v
  | Minus e1 e2 => eval e1 h v - eval e2 h v
  | Mult e1 e2 => eval e1 h v * eval e2 h v
  end.

(* Meaning of Boolean expressions *)
Fixpoint beval (b : bexp) (h : heap) (v : valuation) : bool :=
  match b with
  | Equal e1 e2 => if eval e1 h v ==n eval e2 h v then true else false
  | Less e1 e2 => if eval e2 h v <=? eval e1 h v then false else true
  end.

(* A big-step operational semantics for commands *)
Inductive exec : heap -> valuation -> cmd -> heap -> valuation -> Prop :=
| ExSkip : forall h v,
  exec h v Skip h v
| ExAssign : forall h v x e,
  exec h v (Assign x e) h (v $+ (x, eval e h v))
| ExWrite : forall h v e1 e2,
  exec h v (Write e1 e2) (h $+ (eval e1 h v, eval e2 h v)) v
| ExSeq : forall h1 v1 c1 h2 v2 c2 h3 v3,
  exec h1 v1 c1 h2 v2
  -> exec h2 v2 c2 h3 v3
  -> exec h1 v1 (Seq c1 c2) h3 v3
| ExIfTrue : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = true
  -> exec h1 v1 c1 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExIfFalse : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = false
  -> exec h1 v1 c2 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExWhileFalse : forall I h v b c,
  beval b h v = false
  -> exec h v (While_ I b c) h v
| ExWhileTrue : forall I h1 v1 b c h2 v2 h3 v3,
  beval b h1 v1 = true
  -> exec h1 v1 c h2 v2
  -> exec h2 v2 (While_ I b c) h3 v3
  -> exec h1 v1 (While_ I b c) h3 v3

(* Assertions execute only when they are true.  They provide a way to embed
 * proof obligations within programs. *)
| ExAssert : forall h v (a : assertion),
  a h v
  -> exec h v (Assert a) h v.

(** * Hoare logic *)

(* Here's an inductive predicate capturing a class of *proved* specifications
 * for commands.  The intuition is that, when [hoare_triple P c Q], we know
 * that, when we start [c] in a state satisfying [P], if [c] finishes, its final
 * state satisfies [Q]. *)

Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
| HtSkip : forall P, hoare_triple P Skip P
| HtAssign : forall (P : assertion) x e,
  hoare_triple P (Assign x e) (fun h v => exists v', P h v' /\ v = v' $+ (x, eval e h v'))
| HtWrite : forall (P : assertion) (e1 e2 : exp),
  hoare_triple P (Write e1 e2) (fun h v => exists h', P h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v))
| HtSeq : forall (P Q R : assertion) c1 c2,
  hoare_triple P c1 Q
  -> hoare_triple Q c2 R
  -> hoare_triple P (Seq c1 c2) R
| HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
  hoare_triple (fun h v => P h v /\ beval b h v = true) c1 Q1
  -> hoare_triple (fun h v => P h v /\ beval b h v = false) c2 Q2
  -> hoare_triple P (If_ b c1 c2) (fun h v => Q1 h v \/ Q2 h v)
| HtWhile : forall (I P : assertion) b c,
  (forall h v, P h v -> I h v)
  -> hoare_triple (fun h v => I h v /\ beval b h v = true) c I
  -> hoare_triple P (While_ I b c) (fun h v => I h v /\ beval b h v = false)
| HtAssert : forall P I : assertion,
  (forall h v, P h v -> I h v)
  -> hoare_triple P (Assert I) P
| HtConsequence : forall (P Q P' Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, P' h v -> P h v)
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P' c Q'.

(* Let's prove that the intuitive description given above really applies to this
 * predicate.  First, a lemma, which is difficult to summarize intuitively!
 * More or less precisely this obligation shows up in the main proof below. *)
Lemma hoare_triple_big_step_while: forall (I : assertion) b c,
  (forall h v h' v', exec h v c h' v'
                     -> I h v
                     -> beval b h v = true
                     -> I h' v')
  -> forall h v h' v', exec h v (While_ I b c) h' v'
                       -> I h v
                       -> I h' v' /\ beval b h' v' = false.
Proof.
  induct 2; eauto.
Qed.

(* That main theorem statement literally translates our intuitive description of
 * [hoare_triple] from above. *)
Theorem hoare_triple_big_step : forall pre c post,
    hoare_triple pre c post
    -> forall h v h' v', exec h v c h' v'
                         -> pre h v
                         -> post h' v'.
Proof.
  induct 1; eauto; invert 1; eauto.

  simplify.
  eapply hoare_triple_big_step_while; eauto.
Qed.

(* BEGIN syntax macros that won't be explained *)
Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Notation "*[ e ]" := (Read e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Mult : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" := (If_ b then_ else_) (at level 75, b at level 0).
Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75).
Notation "'assert' {{ I }}" := (Assert I) (at level 75).
Delimit Scope cmd_scope with cmd.

Infix "+" := plus : reset_scope.
Infix "-" := minus : reset_scope.
Infix "*" := mult : reset_scope.
Infix "=" := eq : reset_scope.
Infix "<" := lt : reset_scope.
Delimit Scope reset_scope with reset.
Open Scope reset_scope.
(* END macros *)

(* We should draw some attention to the next notation, which defines special
 * lambdas for writing assertions. *)
Notation "h & v ~> e" := (fun h v => e%reset) (at level 85, v at level 0).

(* And here's the classic notation for Hoare triples. *)
Notation "{{ P }} c {{ Q }}" := (hoare_triple P c%cmd Q) (at level 90, c at next level).

(* Special case of consequence: keeping the precondition; only changing the
 * postcondition. *)
Lemma HtStrengthenPost : forall (P Q Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P c Q'.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

(* Finally, three tactic definitions that we won't explain.  The overall tactic
 * [ht] tries to prove Hoare triples, essentially by rote application of the
 * rules.  Some other obligations are generated, generally of implications
 * between assertions, and [ht] also makes a best effort to solve those. *)

Ltac ht1 := apply HtSkip || apply HtAssign || apply HtWrite || eapply HtSeq
            || eapply HtIf || eapply HtWhile || eapply HtAssert
            || eapply HtStrengthenPost.

Ltac t := cbv beta; propositional; subst;
          repeat match goal with
                 | [ H : ex _ |- _ ] => invert H; propositional; subst
                 end;
          simplify;
          repeat match goal with
                 | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
                 | [ H : ?E = ?E |- _ ] => clear H
                 end; simplify; propositional; auto; try equality; try linear_arithmetic.

Ltac ht := simplify; repeat ht1; t.

(** * Some examples of verified programs *)

(** ** Swapping the values in two variables *)

(* First, let's prove it with more manual applications of the Hoare-logic
 * rules. *)
Theorem swap_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    "tmp" <- "x";;
    "x" <- "y";;
    "y" <- "tmp"
  {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
Proof.
  simplify.
  eapply HtSeq.
  apply HtAssign.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  apply HtAssign.
  simplify.
  t.
Qed.

(* We can also automate the proof easily. *)
Theorem swap_ok_snazzy : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    "tmp" <- "x";;
    "x" <- "y";;
    "y" <- "tmp"
  {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
Proof.
  ht.
Qed.

(** ** Computing the maximum of two variables *)

Theorem max_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    when "x" < "y" then
      "m" <- "y"
    else
      "m" <- "x"
    done
  {{_&v ~> v $! "m" = max a b}}.
Proof.
  simplify.
  eapply HtStrengthenPost.
  apply HtIf.
  apply HtAssign.
  apply HtAssign.
  simplify.
  t.
Qed.

Theorem max_ok_snazzy : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    when "x" < "y" then
      "m" <- "y"
    else
      "m" <- "x"
    done
  {{_&v ~> v $! "m" = max a b}}.
Proof.
  ht.
Qed.

(** ** Iterative factorial *)

(* These two rewrite rules capture the definition of functional [fact], in
 * exactly the form useful in our Hoare-logic proof. *)
Lemma fact_base : forall n,
  n = 0
  -> fact n = 1.
Proof.
  simplify; subst; auto.
Qed.

Hint Rewrite <- minus_n_O.

Lemma fact_rec : forall n,
  n > 0
  -> fact n = n * fact (n - 1).
Proof.
  simplify; cases n; simplify; linear_arithmetic.
Qed.

Hint Rewrite fact_base fact_rec using linear_arithmetic.

(* Note the careful choice of loop invariant below.  It may look familiar from
 * earlier chapters' proofs! *)
Theorem fact_ok : forall n,
  {{_&v ~> v $! "n" = n}}
    "acc" <- 1;;
    {{_&v ~> v $! "acc" * fact (v $! "n") = fact n}}
    while 0 < "n" loop
      "acc" <- "acc" * "n";;
      "n" <- "n" - 1
    done
  {{_&v ~> v $! "acc" = fact n}}.
Proof.
  simplify.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  eapply HtWhile.
  simplify.
  t.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  apply HtAssign.
  simplify.
  t.
  ring [H0].
  (* This variant of [ring] suggests a hypothesis to use in the proof. *)
  simplify.
  t.
Qed.

Theorem fact_ok_snazzy : forall n,
  {{_&v ~> v $! "n" = n}}
    "acc" <- 1;;
    {{_&v ~> v $! "acc" * fact (v $! "n") = fact n}}
    while 0 < "n" loop
      "acc" <- "acc" * "n";;
      "n" <- "n" - 1
    done
  {{_&v ~> v $! "acc" = fact n}}.
Proof.
  ht.
  ring [H0].
Qed.

(** ** Selection sort *)

(* This is our one example of a program reading/writing memory, which holds the
 * representation of an array that we want to sort in-place. *)

(* One simple lemma turns out to be helpful to guide [eauto] properly. *)
Lemma leq_f : forall A (m : fmap A nat) x y,
  x = y
  -> m $! x <= m $! y.
Proof.
  ht.
Qed.

Hint Resolve leq_f.
Hint Extern 1 (@eq nat _ _) => linear_arithmetic.
Hint Extern 1 (_ < _) => linear_arithmetic.
Hint Extern 1 (_ <= _) => linear_arithmetic.
(* We also register [linear_arithmetic] as a step to try during proof search. *)

(* These invariants are fairly hairy, but probably the best way to understand
 * them is just to spend a while reading them.  They generally talk about
 * sortedness of subsets of the array.  See the final postcondition for how we
 * interpret a part of memory as an array.  Also note that we only prove here
 * that the final array is sorted, *not* that it's a permutation of the original
 * array!  (Exercise for the reader?  I'm not sure how much work it would
 * take.) *)
Theorem selectionSort_ok :
  {{_&_ ~> True}}
    "i" <- 0;;
    {{h&v ~> v $! "i" <= v $! "n"
        /\ (forall i j, i < j < v $! "i" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j))
        /\ (forall i j, i < v $! "i" -> v $! "i" <= j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)) }}
    while "i" < "n" loop
      "j" <- "i"+1;;
      "best" <- "i";;
      {{h&v ~> v $! "i" < v $! "j" <= v $! "n"
         /\ v $! "i" <= v $! "best" < v $! "n"
         /\ (forall k, v $! "i" <= k < v $! "j" -> h $! (v $! "a" + v $! "best") <= h $! (v $! "a" + k))
         /\ (forall i j, i < j < v $! "i" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j))
         /\ (forall i j, i < v $! "i" -> v $! "i" <= j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)) }}
      while "j" < "n" loop
        when *["a" + "j"] < *["a" + "best"] then
          "best" <- "j"
        else
          Skip
        done;;
        "j" <- "j" + 1
      done;;
      "tmp" <- *["a" + "best"];;
      *["a" + "best"] <- *["a" + "i"];;
      *["a" + "i"] <- "tmp";;
      "i" <- "i" + 1
    done
  {{h&v ~> forall i j, i < j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)}}.
Proof.
  ht; repeat match goal with
             | [ |- context[_ $+ (?a + ?x, _) $! (?a + ?y)] ] =>
               cases (x ==n y); ht
             end.

  cases (k ==n x0 $! "j"); ht.
  specialize (H k); ht.

  cases (k ==n x $! "j"); ht.
Qed.

(** * An alternative correctness theorem for Hoare logic, with small-step semantics *)

(* In case you were worried that this chapter is too far removed from the
 * pattern of program reasoning we've seen recur again and again, help is here!
 * We can also characterize Hoare triples in terms of invariants of transition
 * systems.  To start with, here's a small-step semantics for our running
 * language. *)
Inductive step : heap * valuation * cmd -> heap * valuation * cmd -> Prop :=
| StAssign : forall h v x e,
  step (h, v, Assign x e) (h, v $+ (x, eval e h v), Skip)
| StWrite : forall h v e1 e2,
  step (h, v, Write e1 e2) (h $+ (eval e1 h v, eval e2 h v), v, Skip)
| StStepSkip : forall h v c,
  step (h, v, Seq Skip c) (h, v, c)
| StStepRec : forall h1 v1 c1 h2 v2 c1' c2,
  step (h1, v1, c1) (h2, v2, c1')
  -> step (h1, v1, Seq c1 c2) (h2, v2, Seq c1' c2)
| StIfTrue : forall h v b c1 c2,
  beval b h v = true
  -> step (h, v, If_ b c1 c2) (h, v, c1)
| StIfFalse : forall h v b c1 c2,
  beval b h v = false
  -> step (h, v, If_ b c1 c2) (h, v, c2)
| StWhileFalse : forall I h v b c,
  beval b h v = false
  -> step (h, v, While_ I b c) (h, v, Skip)
| StWhileTrue : forall I h v b c,
  beval b h v = true
  -> step (h, v, While_ I b c) (h, v, Seq c (While_ I b c))
| StAssert : forall h v (a : assertion),
  a h v
  -> step (h, v, Assert a) (h, v, Skip).

Hint Constructors step.

Definition trsys_of (st : heap * valuation * cmd) := {|
  Initial := {st};
  Step := step
|}.

(* We'll characterize *unstuckness* in roughly the same way as we did for
 * lambda-calculus type soundness: the program is done (reached [Skip]) or can
 * take a step. *)
Definition unstuck (st : heap * valuation * cmd) :=
  snd st = Skip
  \/ exists st', step st st'.

(* A convenient property of Hoare triples: they rule out stuckness, regardless
 * of the specs we choose, so long as the precondition accurately describes the
 * real execution state!  Note that the only real possibility for stuckness in
 * the semantics is via [Assert], which is why we included it.  We reduce
 * arbitrary correctness checks, on intermediate program states, to stuckness or
 * lack thereof in program execution. *)
Lemma hoare_triple_unstuck : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v, P h v
                 -> unstuck (h, v, c).
Proof.
  induct 1; unfold unstuck; simplify; propositional; eauto.

  apply IHhoare_triple1 in H1.
  unfold unstuck in H1; simplify; first_order; subst; eauto.
  cases x.
  cases p.
  eauto.

  cases (beval b h v); eauto.

  cases (beval b h v); eauto.

  apply H0 in H2.
  apply IHhoare_triple in H2.
  unfold unstuck in H2; simplify; first_order.
Qed.

(* Another basic property: [Skip] has no effect on program state, and the set of
 * derivable specs for [Skip] reflects that fact. *)
Lemma hoare_triple_Skip : forall P Q,
  {{P}} Skip {{Q}}
  -> forall h v, P h v -> Q h v.
Proof.
  induct 1; auto.
Qed.

(* Finally, our main inductive proof: small steps preserve the existence of
 * Hoare triples.  We even give the concrete specification for the new command
 * [c'] that was stepped to.  It keeps the old postcondition, and we give it a
 * very specific precondition saying "the state is exactly this." *)
Lemma hoare_triple_step : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v h' v' c',
      step (h, v, c) (h', v', c')
      -> P h v
      -> {{h''&v'' ~> h'' = h' /\ v'' = v'}} c' {{Q}}.
Proof.
  induct 1.

  invert 1.

  invert 1; ht; eauto.

  invert 1; ht; eauto.

  invert 1; simplify.

  eapply HtConsequence; eauto.
  propositional; subst.
  eapply hoare_triple_Skip; eauto.

  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto; equality.
  eapply HtConsequence; eauto; equality.

  invert 1; simplify.
  eapply HtConsequence with (P := h'' & v'' ~> h'' = h' /\ v'' = v').
  apply HtSkip.
  auto.
  simplify; propositional; subst; eauto.

  econstructor.
  eapply HtConsequence; eauto.
  simplify; propositional; subst; eauto.
  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto.
  econstructor.
  simplify; propositional; subst; eauto.

  simplify.
  eapply HtConsequence.
  eapply IHhoare_triple; eauto.
  simplify; propositional; subst; eauto.
  auto.
Qed.

(* Oh, what a coincidence! ;-)  As with type-safety proofs, we find that the
 * reasonably intuitive properties we just proved are precisely the hard parts
 * of a standard proof by invariant strengthening and invariant induction. *)
Theorem hoare_triple_invariant : forall P c Q h v,
  {{P}} c {{Q}}
  -> P h v
  -> invariantFor (trsys_of (h, v, c)) unstuck.
Proof.
  simplify.
  apply invariant_weaken with (invariant1 := fun st => {{h&v ~> h = fst (fst st)
                                                           /\ v = snd (fst st)}}
                                                         snd st
                                                       {{_&_ ~> True}}).

  apply invariant_induction; simplify.

  propositional; subst; simplify.
  eapply HtConsequence; eauto.
  equality.

  cases s.
  cases s'.
  cases p.
  cases p0.
  simplify.
  eapply hoare_triple_step; eauto.
  simplify; auto.

  simplify.
  cases s.
  cases p.
  simplify.
  eapply hoare_triple_unstuck; eauto.
  simplify; auto.
Qed.

(* A very simple example, just to show all this in action *)
Definition forever := (
  "i" <- 1;;
  "n" <- 1;;
  {{h&v ~> v $! "i" > 0}}
  while 0 < "i" loop
    "i" <- "i" * 2;;
    "n" <- "n" + "i";;
    assert {{h&v ~> v $! "n" >= 1}}
  done;;

  assert {{_&_ ~> False}}
  (* Note that this last assertion implies that the program never terminates! *)
)%cmd.

Theorem forever_ok : {{_&_ ~> True}} forever {{_&_ ~> False}}.
Proof.
  ht.
Qed.

Theorem forever_invariant : invariantFor (trsys_of ($0, $0, forever)) unstuck.
Proof.
  eapply hoare_triple_invariant.
  apply forever_ok.
  simplify; trivial.
Qed.


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

(*
  Decision Procedure(s):
    Two-counter Minsky Program Machine Halting (MPM2_HALT) [1, Chapter 11.1]
*)

(*
  Literature:
    [1] Minsky, Marvin Lee. Computation. Englewood Cliffs: Prentice-Hall, 1967. (Chapter 11.1)
*)

Require Import List ssrfun.

(* a configuration consists of a state and two counter values *)
Definition Config : Set := nat * (nat * nat).

(* accessors for state, value1, value2 of configurations *)
Definition state (x: Config) : nat := fst x.
Arguments state !x /.
Definition value1 (x: Config) : nat := fst (snd x).
Arguments value1 !x /.
Definition value2 (x: Config) : nat := snd (snd x).
Arguments value2 !x /.

(* the instruction zero true maps
      a configuration (p, (v1, v2)) to (1+p, (v1, 0))
    the instruction zero false maps
      a configuration (p, (v1, v2)) (1+p, (0, v2))
    the instruction inc true maps
      a configuration (p, (v1, v2)) to (1+p, (v1, 1+v2))
    the instruction inc false maps
      a configuration (p, (v1, v2)) (1+p, (1+v1, v2))
    an instruction dec true q maps
      a configuration (p, (v1, 0)) to (q, (v1, 0))
      a configuration (p, (v1, 1+v2)) to (1+p, (v1, v2))
    an instruction dec false q maps
      a configuration (p, (0, v2)) to (q, (0, v2))
      a configuration (p, (1+v1, v2)) to (1+p, (v1, v2)) *)
Inductive Instruction : Set :=
  | halt : Instruction
  | zero : bool -> Instruction
  | inc : bool -> Instruction
  | dec : bool -> nat -> Instruction.

(* a two counter machine is a list of instructions *)
Definition Mpm2 : Set := list Instruction.

(* partial two counter Minsky machine step function *)
Definition step (M: Mpm2) (x: Config) : option Config :=
  match nth_error M (state x) with
  | None => None (* halting configuration *)
  | Some halt => None (* halting instruction *)
  | Some (zero b) => (* set counter to zero, goto next state*)
    Some (1 + (state x), ((if b then (value1 x) else 0), (if b then 0 else (value2 x))))
  | Some (inc b) => (* increase counter, goto next state*)
    Some (1 + (state x), ((if b then 0 else 1) + (value1 x), (if b then 1 else 0) + (value2 x)))
  | Some (dec b y) => (* decrease counter, goto next state; if unsuccessful goto state y *)
    Some (
      if b then
        match value2 x with
        | 0 => (y, (value1 x, 0))
        | S n => (1 + (state x), (value1 x, n))
        end
      else
        match value1 x with
        | 0 => (y, (0, value2 x))
        | S n => (1 + (state x), (n, value2 x))
        end)
  end.

Definition steps (M: Mpm2) (n: nat) (x: Config) : option Config :=
  Nat.iter n (obind (step M)) (Some x).

(* does M eventually terminate starting from the configuration x? *)
Definition terminating (M: Mpm2) (x: Config) :=
  exists n, steps M n x = None.

(* Two-counter Minsky Program Machine Halting Problem:
   Given a two-counter Minsky program machine M and a configucation c,
   does a run in M starting from c eventually terminate? *)
Definition MPM2_HALT : Mpm2 * Config -> Prop :=
  fun '(M, c) => terminating M c.

Require Import List PeanoNat Lia Operators_Properties.
Import ListNotations.
Require Import ssreflect ssrbool ssrfun.
Require Import Undecidability.CounterMachines.Util.Facts.

Set Default Goal Selector "!".
Set Default Proof Using "Type".

Section Construction.
Variable M : Mpm2.

#[local] Notation step := (step M).
#[local] Notation steps := (steps M).
#[local] Notation terminating := (terminating M).
#[local] Notation l := (length M).

(* after k steps values change at most by k (or are reset and at most k) *)
Lemma steps_bound {k p a b p' a' b'} : steps k (p, (a, b)) = Some (p', (a', b')) ->
  a' <= k + a /\ b' <= k + b /\ (a' <= k \/ a <= k + a') /\ (b' <= k \/ b <= k + b').
Proof.
  elim: k p' a' b'.
  { move=> p' a' b' /= []. lia. }
  move=> k + p' a' b' /=.
  case: (steps k (p, (a, b))) => [[p'' [a'' b'']]|]; last done.
  move=> /(_ p'' a'' b'' ltac:(done)) IH.
  rewrite /= /(step _).
  case: (nth_error M (state (p'', (a'', b'')))); last done.
  case.
  - done.
  - case; case; lia.
  - case; case; lia.
  - case => q /=.
    + move: b'' IH => [|b''] ? []; lia.
    + move: a'' IH => [|a''] ? []; lia.
Qed.

Definition reaches (x y: Config) := exists k, steps k x = Some y.
Definition reaches_plus (x y: Config) := exists k, 0 < k /\ steps k x = Some y.
Definition non_terminating x := forall k, steps k x <> None.

Lemma reaches_plus_reaches {x y z} : reaches_plus x y -> reaches y z -> reaches_plus x z.
Proof.
  move=> [k [? Hk]] [k' Hk']. exists (k+k'). split; first by lia.
  move: Hk. by rewrite /steps iter_plus => ->.
Qed.

Lemma reaches_reaches_plus {x y z} : reaches x y -> reaches_plus y z -> reaches_plus x z.
Proof.
  move=> [k Hk] [k' [? Hk']]. exists (k+k'). split; first by lia.
  move: Hk. by rewrite /steps iter_plus => ->.
Qed.

Lemma reaches_plus_incl {x y} : reaches_plus x y -> reaches x y.
Proof. move=> [k [? Hk]]. by exists k. Qed.

Lemma reaches_terminating {x y} : reaches x y -> terminating y -> terminating x.
Proof.
  move=> [k Hk] [k' Hk']. exists (k+k').
  move: Hk. by rewrite /steps iter_plus => ->.
Qed.

Lemma steps_k_monotone {k x} k' : steps k x = None -> k <= k' -> steps k' x = None.
Proof.
  move=> + ?. have ->: k' = (k' - k) + k by lia.
  elim: (k' - k); first done.
  by move=> ? IH /IH /= ->.
Qed.

Lemma steps_plus {k x k' y} :
steps k x = Some y -> steps (k + k') x = steps k' y.
Proof. rewrite /steps iter_plus. by move=> ->. Qed.

Lemma reaches_non_terminating {x y} : reaches x y -> non_terminating y -> non_terminating x.
Proof.
  move=> [k Hk] Hy k'.
  have [|->] : k' <= k \/ k' = k + (k' - k) by lia.
  - by move: Hk => + /steps_k_monotone H /H => ->.
  - rewrite (steps_plus Hk). by apply: Hy.
Qed.

Lemma reaches_non_terminating' {x y} : reaches x y -> non_terminating x -> non_terminating y.
Proof.
  move=> [k' Hk'] Hx k Hk.
  apply: (Hx (k' + k)).
  by rewrite (steps_plus Hk').
Qed.

Lemma reaches_plus_state_bound {x y} : reaches_plus x y -> state x < l.
Proof.
  move=> [k [? Hk]].
  suff: not (l <= state x) by lia.
  move=> /nth_error_None Hx.
  move: Hk. have ->: k = S (k - 1) by lia.
  by rewrite /= obind_oiter /step Hx oiter_None.
Qed.

Lemma reaches_plus_trans {x y z} : reaches_plus x y -> reaches_plus y z -> reaches_plus x z.
Proof. by move=> /reaches_plus_incl /reaches_reaches_plus H /H. Qed.

Lemma reaches_trans {x y z} : reaches x y -> reaches y z -> reaches x z.
Proof. move=> [k Hk] [k' Hk']. exists (k+k'). by rewrite (steps_plus Hk). Qed.

(* a configuration (p, (a, b))
  is either halting or uniformly transitions into a configuration with one zero counter *)
Lemma next_waypoint p a b :
  terminating (p, (a, b)) +
  { '(p', a') | forall n, exists k, 0 < k <= l - p /\ steps k (p, (n+a, b)) = Some (p', (n+a', 0)) } +
  { '(p', b') | forall n, exists k, 0 < k <= l - p /\ steps k (p, (a, n+b)) = Some (p', (0, n+b')) }.
Proof.
  move Hn: (l - p) => n. elim: n p Hn a b.
  { move=> p ? a b. left. left. exists 1. rewrite /= /step.
    by have ->: nth_error M (state (p, (a, b))) = None
      by (rewrite nth_error_None /=; lia). }
  move=> n IH p ? a b.
  case Hi: (nth_error M (state (p, (a, b)))) => [i|]; first last.
  { left. left. exists 1. by rewrite /= /step Hi. }
  move: i Hi => /= [].
  - move=> Hi. left. left. exists 1. by rewrite /= /step Hi.
  - case.
    + move=> Hi. left. right. exists (S p, a).
      move=> n'. exists 1. split; first by lia.
      by rewrite /= /step /= Hi.
    + move=> Hi. right. exists (S p, b).
      move=> n'. exists 1. split; first by lia.
      by rewrite /= /step /= Hi.
  - case.
    + move=> Hi.
      have [[|[[p' a'] HSp]]|[[p' b'] HSp]] := IH (S p) ltac:(lia) a (S b).
      * move=> /reaches_terminating HSp. left. left.
        apply: HSp. exists 1. by rewrite /= /step Hi.
      * left. right. exists (p', a').
        move=> n'.
        have [k [? <-]] := (HSp n').
        exists (1+k). split; first by lia.
        apply: steps_plus. by rewrite /= /step Hi.
      * right. exists (p', b').
        move=> n'.
        have [k [? <-]] := (HSp n').
        exists (1+k). split; first by lia.
        apply: steps_plus. by rewrite /= /step Hi Nat.add_succ_r.
    + move=> Hi.
      have [[|[[p' a'] HSp]]|[[p' b'] HSp]] := IH (S p) ltac:(lia) (S a) b.
      * move=> /reaches_terminating HSp. left. left.
        apply: HSp. exists 1. by rewrite /= /step Hi.
      * left. right. exists (p', a').
        move=> n'.
        have [k [? <-]] := (HSp n').
        exists (1+k). split; first by lia.
        apply: steps_plus. by rewrite /= /step Hi Nat.add_succ_r.
      * right. exists (p', b').
        move=> n'.
        have [k [? <-]] := (HSp n').
        exists (1+k). split; first by lia.
        apply: steps_plus. by rewrite /= /step Hi.
  - case=> q Hi.
    + move: b => [|b].
      { left. right. exists (q, a) => n'. exists 1.
        split; first by lia. by rewrite /= /step Hi. }
      have [[|[[p' a'] HSp]]|[[p' b'] HSp]] := IH (S p) ltac:(lia) a b.
      * move=> /reaches_terminating HSp. left. left.
        apply: HSp. exists 1. by rewrite /= /step Hi.
      * left. right. exists (p', a').
        move=> n'.
        have [k [? <-]] := (HSp n').
        exists (1+k). split; first by lia.
        apply: steps_plus. by rewrite /= /step Hi.
      * right. exists (p', b').
        move=> n'.
        have [k [? <-]] := (HSp n').
        exists (1+k). split; first by lia.
        apply: steps_plus. by rewrite /= /step Hi Nat.add_succ_r.
    + move: a => [|a].
      { right. exists (q, b) => n'. exists 1.
        split; first by lia. by rewrite /= /step Hi. }
      have [[|[[p' a'] HSp]]|[[p' b'] HSp]] := IH (S p) ltac:(lia) a b.
      * move=> /reaches_terminating HSp. left. left.
        apply: HSp. exists 1. by rewrite /= /step Hi.
      * left. right. exists (p', a').
        move=> n'.
        have [k [? <-]] := (HSp n').
        exists (1+k). split; first by lia.
        apply: steps_plus. by rewrite /= /step Hi Nat.add_succ_r.
      * right. exists (p', b').
        move=> n'.
        have [k [? <-]] := (HSp n').
        exists (1+k). split; first by lia.
        apply: steps_plus. by rewrite /= /step Hi.
Qed.

(* terminate or reach uniformly next config or reach small config *)
Corollary next_waypoint_a p a :
  terminating (p, (a, 0)) +
  { '(p', a') | forall n, reaches_plus (p, (n+a, 0)) (p', (n+a', 0)) } +
  { '(p', (a', b')) | reaches (p, (a, 0)) (p', (a', b')) /\ a' <= l /\ b' <= l }.
Proof.
  have [[?|[[p' a'] Hp]]|[[p' b'] Hp]] := next_waypoint p a 0.
  - left. by left.
  - left. right. exists (p', a') => n.
    have [k [? Hk]] := Hp n. exists k.
    split; [lia|done].
  - right. exists (p', (0, b')).
    have [k [? Hk]] := Hp 0.
    have ? := steps_bound Hk.
    split; [by exists k|lia].
Qed.

(* terminate or reach uniformly next config or reach small config *)
Corollary next_waypoint_b p b :
  terminating (p, (0, b)) +
  { '(p', b') | forall n, reaches_plus (p, (0, n+b)) (p', (0, n+b')) } +
  { '(p', (a', b')) | reaches (p, (0, b)) (p', (a', b')) /\ a' <= l /\ b' <= l }.
Proof.
  have [[?|[[p' a'] Hp]]|[[p' b'] Hp]] := next_waypoint p 0 b.
  - left. by left.
  - right. exists (p', (a', 0)).
    have [k [? Hk]] := Hp 0.
    have ? := steps_bound Hk.
    split; [by exists k|lia].
  - left. right. exists (p', b') => n.
    have [k [? Hk]] := Hp n. exists k.
    split; [lia|done].
Qed.

Lemma loop_a {p a a' b} :
  a <= a' ->
  (forall n : nat, reaches_plus (p, (n + a, b)) (p, (n + a', b))) ->
  non_terminating (p, (a, b)).
Proof.
  move=> ? Hp k.
  suff: forall m, steps k (p, (m + a, b)) <> None by move=> /(_ 0).
  elim: k; first done.
  move=> k IH m.
  have [k' [? Hk']] := Hp m.
  move=> /(steps_k_monotone (k' + k)) /(_ ltac:(lia)).
  move: Hk' => /steps_plus ->.
  have ->: m + a' = (m + a' - a) + a by lia.
  by apply: IH.
Qed.

Lemma loop_b {p a b b'} :
  b <= b' ->
  (forall n : nat, reaches_plus (p, (a, n + b)) (p, (a, n + b'))) ->
  non_terminating (p, (a, b)).
Proof.
  move=> ? Hp k.
  suff: forall m, steps k (p, (a, m + b)) <> None by move=> /(_ 0).
  elim: k; first done.
  move=> k IH m.
  have [k' [? Hk']] := Hp m.
  move=> /(steps_k_monotone (k' + k)) /(_ ltac:(lia)).
  move: Hk' => /steps_plus ->.
  have ->: m + b' = (m + b' - b) + b by lia.
  by apply: IH.
Qed.

Lemma reaches_plus_self_loop x : reaches_plus x x -> non_terminating x.
Proof.
  move=> [k [? Hk]]. elim; first done.
  move=> k' Hk'.
  move=> /(steps_k_monotone (k + k')) /(_ ltac:(lia)).
  by rewrite (steps_plus Hk).
Qed.

Definition update {X : Type} (f : nat -> X) n x :=
  fun m => if Nat.eq_dec m n is left _ then x else f m.

Inductive R : (nat -> option nat) -> (nat -> option nat) -> Prop :=
  | R_None f p c : p < l -> f p = None -> R (update f p (Some c)) f
  | R_Some c' f p c : p < l -> f p = Some c' -> c < c' -> R (update f p (Some c)) f.

Lemma wf_R : well_founded R.
Proof.
  pose F := (fun (f : nat -> option nat) =>
    list_sum (map (fun p => if f p is None then 1 else 0) (seq 0 l))).
  pose G := (fun (f : nat -> option nat) =>
    list_sum (map (fun p => if f p is Some c then c else 0) (seq 0 l))).
  elim /(measure_ind F). elim /(measure_ind G).
  move=> f IHG IHF. constructor => g Hgf.
  case: Hgf IHG IHF.
  - move=> {}f p c ? Hf IHG IHF.
    apply: IHF. rewrite /F.
    have /list_sum_map_lt : In p (seq 0 l) by (apply /in_seq; lia).
    apply.
    + move=> p''. case Hp'': (f p'') => [c''|].
      * rewrite /update Hp''. by case: (Nat.eq_dec p'' p).
      * rewrite /update Hp''. case: (Nat.eq_dec p'' p); lia.
    + rewrite /update Hf. case: (Nat.eq_dec p p); lia.
  - move=> c' {}f p c Hl Hf ? IHG IHF.
    apply: IHG; first last.
    { move=> h Hh. apply: IHF.
      suff: F (update f p (Some c)) <= F f by lia.
      apply: list_sum_map_le.
      move=> p''. case Hp'': (f p'') => [c''|].
      - rewrite /update Hp''. by case: (Nat.eq_dec p'' p).
      - rewrite /update Hp''. case: (Nat.eq_dec p'' p); lia. }
    rewrite /G.
    have : In p (seq 0 l) by (apply /in_seq; lia).
    move=> /list_sum_map_lt. apply.
    + move=> p''. case Hp'': (f p'') => [c''|].
      * rewrite /update. case: (Nat.eq_dec p'' p).
        ** move=> ?. subst. move: Hf Hp'' => -> []. lia.
        ** rewrite Hp''. lia.
      * rewrite /update. case: (Nat.eq_dec p'' p).
        ** move=> ?. subst. by move: Hf Hp'' => ->.
        ** rewrite Hp''. lia.
    + rewrite /update Hf. by case: (Nat.eq_dec p p).
Qed.

Lemma big_wf_a p a (f : nat -> option nat) :
  (forall p' a', f p' = Some a' -> forall n, reaches_plus (p', (n+a', 0)) (p, (n+a, 0))) ->
  terminating (p, (a, 0)) +
  non_terminating (p, (a, 0)) +
  { '(p', (a', b')) | reaches (p, (a, 0)) (p', (a', b')) /\ a' <= l /\ b' <= l }.
Proof.
  elim /(well_founded_induction_type wf_R) : f p a.
  move=> f IH p a Hf.
  have [[Hp|[[p' a'] Hp]]|[[p' [a' b']] [Hp ?]]] := next_waypoint_a p a.
  - left. by left.
  - have /= ? := reaches_plus_state_bound (Hp 0).
    set P := (_ + _ + _)%type.
    have HR : R (update f p (Some a)) f -> P.
    { move=> /IH /(_ p' a') /=. case; [|case|].
      - move=> p''' a'''. rewrite /update.
        case: (Nat.eq_dec p''' p).
        { by move=> -> [<-]. }
        move=> ? /Hf Hp''' n.
        by apply: (reaches_plus_trans (Hp''' n) (Hp n)).
      - move=> /reaches_terminating Hp'. left. left.
        by apply /Hp' /reaches_plus_incl /(Hp 0).
      - move=> /reaches_non_terminating Hp'. left. right.
        by apply /Hp' /reaches_plus_incl /(Hp 0).
      - move=> [[p''' [a''' b''']]] [Hp'] ?. right.
        exists (p''', (a''', b''')). split; last done.
        by apply: (reaches_trans (reaches_plus_incl (Hp 0))). }
    case H'p: (f p) => [a''|].
    + case E: (a''-a) => [|?].
      { left. right. move: H'p => /Hf{Hf} H'p.
        apply: (reaches_non_terminating' (reaches_plus_incl (H'p 0))).
        apply: (loop_a _ H'p). lia. }
      apply /HR /(R_Some a''); [done|done|lia].
    + by apply /HR /R_None.
  - right. by exists (p', (a', b')).
Qed.

Lemma big_wf_b p b (f : nat -> option nat) :
  (forall p' b', f p' = Some b' -> forall n, reaches_plus (p', (0, n+b')) (p, (0, n+b))) ->
  terminating (p, (0, b)) +
  non_terminating (p, (0, b)) +
  { '(p', (a', b')) | reaches (p, (0, b)) (p', (a', b')) /\ a' <= l /\ b' <= l }.
Proof.
  elim /(well_founded_induction_type wf_R) : f p b.
  move=> f IH p b Hf.
  have [[Hp|[[p' b'] Hp]]|[[p' [a' b']] [Hp ?]]] := next_waypoint_b p b.
  - left. by left.
  - have /= ? := reaches_plus_state_bound (Hp 0).
    set P := (_ + _ + _)%type.
    have HR : R (update f p (Some b)) f -> P.
    { move=> /IH /(_ p' b') /=. case; [|case|].
      - move=> p''' b'''. rewrite /update.
        case: (Nat.eq_dec p''' p).
        { by move=> -> [<-]. }
        move=> ? /Hf Hp''' n.
        by apply: (reaches_plus_trans (Hp''' n) (Hp n)).
      - move=> /reaches_terminating Hp'. left. left.
        by apply /Hp' /reaches_plus_incl /(Hp 0).
      - move=> /reaches_non_terminating Hp'. left. right.
        by apply /Hp' /reaches_plus_incl /(Hp 0).
      - move=> [[p''' [a''' b''']]] [Hp'] ?. right.
        exists (p''', (a''', b''')). split; last done.
        by apply: (reaches_trans (reaches_plus_incl (Hp 0))). }
    case H'p: (f p) => [b''|].
    + case E: (b''-b) => [|?].
      { left. right. move: H'p => /Hf{Hf} H'p.
        apply: (reaches_non_terminating' (reaches_plus_incl (H'p 0))).
        apply: (loop_b _ H'p). lia. }
      apply /HR /(R_Some b''); [done|done|lia].
    + by apply /HR /R_None.
  - right. by exists (p', (a', b')).
Qed.

(* from any config can decide termination or get to next small waypoint *)
Lemma next_small_waypoint p a b :
  terminating (p, (a, b)) +
  non_terminating (p, (a, b)) +
  { '(p', (a', b')) | reaches_plus (p, (a, b)) (p', (a', b')) /\ a' <= l /\ b' <= l }.
Proof.
  have [[?|[[p' a'] Hp]]|[[p' b'] Hp]] := next_waypoint p a b.
  - left. by left.
  - have [[|]|] := big_wf_a p' a' (fun _ => None) ltac:(done).
    * move=> /reaches_terminating Hp'. left. left.
      apply: Hp'. have [k [? Hk]] := Hp 0. by exists k.
    * move=> /reaches_non_terminating Hp'. left. right.
      apply: Hp'. have [k [? Hk]] := Hp 0. by exists k.
    * move=> [[p'' [a'' b'']]] [Hp'] ?. right.
      exists (p'', (a'', b'')). split; last done.
      apply: (reaches_plus_reaches _ Hp').
      have [k [? Hk]] := Hp 0. exists k. split; [lia|done].
  - have [[|]|] := big_wf_b p' b' (fun _ => None) ltac:(done).
    * move=> /reaches_terminating Hp'. left. left.
      apply: Hp'. have [k [? Hk]] := Hp 0. by exists k.
    * move=> /reaches_non_terminating Hp'. left. right.
      apply: Hp'. have [k [? Hk]] := Hp 0. by exists k.
    * move=> [[p'' [a'' b'']]] [Hp'] ?. right.
      exists (p'', (a'', b'')). split; last done.
      apply: (reaches_plus_reaches _ Hp').
      have [k [? Hk]] := Hp 0. exists k. split; [lia|done].
Qed.

Lemma small_decider p a b L : a <= l -> b <= l ->
  Forall (fun '(p', (a', b')) => reaches_plus (p', (a', b')) (p, (a, b)) /\ p' < l /\ a' <= l /\ b' <= l ) L ->
  NoDup L ->
  terminating (p, (a, b)) + non_terminating (p, (a, b)).
Proof.
  move Hn: ((l*(l+1)*(l+1)+1) - length L) => n.
  elim: n L Hn p a b.
  { move=> L ? ????? H1L /NoDup_incl_length H2L.
    have : incl L (list_prod (seq 0 l) (list_prod (seq 0 (l+1)) (seq 0 (l+1)))).
    { move=> [p [a b]].
      move: H1L => /Forall_forall H1L /H1L ?.
      apply /in_prod; [|apply /in_prod]; apply /in_seq; lia. }
    move=> /H2L. rewrite ?prod_length ?seq_length. lia. }
  move=> n IH L ? p a b ? ? H1L H2L.
  have [[|]|[[p' [a' b']] [Hp ?]]] := next_small_waypoint p a b; [tauto|tauto|].
  have := In_dec _ (p, (a, b)) L. case.
  { do ? decide equality. }
  - move=> H'p. right. apply: reaches_plus_self_loop.
    by move: H1L H'p => /Forall_forall H /H [].
  - move=> H'p.
    have := (IH ((p, (a, b)) :: L) _ p' a' b'). case.
    + move=> /=. lia.
    + lia.
    + lia.
    + constructor.
      * split; first done.
        move: Hp => /reaches_plus_state_bound /=. lia.
      * apply: Forall_impl H1L.
        move=> [p'' [a'' b'']] [? ?]. split; last done.
        by apply: (reaches_plus_reaches _ (reaches_plus_incl Hp)).
    + by constructor.
    + move=> /reaches_terminating H. left. by apply /H /reaches_plus_incl.
    + move=> /reaches_non_terminating H. right. by apply /H /reaches_plus_incl.
Qed.

(* informative decision statement for halting for Mpm2 *)
Lemma decision x : terminating x + non_terminating x.
Proof.
  move: x => [p [a b]].
  have [[|]|] := next_small_waypoint p a b; [tauto|tauto|].
  move=> [[p' [a' b']]] [/reaches_plus_incl Hp'] [Ha' Hb'].
  have := small_decider p' a' b' [] Ha' Hb' ltac:(by constructor) ltac:(by constructor).
  case.
  - move: Hp' => /reaches_terminating H /H ?. by left.
  - move: Hp' => /reaches_non_terminating H /H ?. by right.
Qed.

End Construction.

Require Import Undecidability.Synthetic.Definitions.

(* decision procedure for the halting problem for Minsky Program Machines with two counters *)
Definition decide : Mpm2 * Config -> bool :=
  fun '(M, c) =>
    match decision M c with
    | inl _ => true
    | inr _ => false
    end.

(* decision procedure correctness *)
Lemma decide_spec : decider decide MPM2_HALT.
Proof.
  rewrite /decider /reflects /decide => - [M c].
  case: (decision M c).
  - tauto.
  - move=> H. split; [by move=> [k /H] | done].
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (y : natural) (lf2 : natural) : natural := plus y Zero.


Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.
Require Export Bool.
Definition Var:= string.
Check "x".

Inductive Natural :=
| errnat : Natural
| num : nat -> Natural.

Inductive Boolean :=
| errbool : Boolean
| boolean : bool -> Boolean.

Coercion num: nat >-> Natural.
Coercion boolean: bool >-> Boolean.

Inductive Data :=
| undecl : Data
| assign : Data
| default : Data
| nat_type : Natural -> Data
| bool_type : Boolean -> Data.

Scheme Equality for Data.

Definition Env := string -> Data.

Inductive AExp :=
| avar : string -> AExp
| anum : Natural -> AExp
| aplus : AExp -> AExp -> AExp
| amul : AExp -> AExp -> AExp
| amin : AExp -> AExp -> AExp
| amod : AExp -> AExp -> AExp
| adiv : AExp -> AExp -> AExp.

(*Notatii folosite pentru expresii aritmetice*)
Notation "A +' B" := (aplus A B) (at level 48).
Notation "A -' B" := (amin A B) (at level 48).
Notation "A /' B" := (adiv A B) (at level 46).
Notation "A *' B" := (amul A B) (at level 46).
Notation "A %' B" := (amod A B) (at level 47).

Coercion anum: Natural >-> AExp.
Coercion avar: string >-> AExp.

Check "x".

Inductive BExp :=
| true
| false
| bequal : AExp -> AExp -> BExp
| blessthan : AExp -> AExp -> BExp
| bnot : BExp -> BExp
| band : BExp -> BExp -> BExp
| bor : BExp -> BExp -> BExp
| bxor : BExp -> BExp -> BExp. (*sintaxa pentru xor*)

(*Notatii folosite pentru expresii booleane*)
Notation "A <=' B" := (blessthan A B) (at level 53).
Notation "! A" := (bnot A) (at level 52).
Notation "A &&' B" := (band A B) (at level 53).
Notation "A ||' B" := (bor A B) (at level 54).
Notation "A \\ B " := (bxor A B) (at level 54).
Notation "A ==' B" := (bequal A B) (at level 53).

Inductive Instructiune :=
| decl_nat : string -> Instructiune
| atribuire_nat : string -> AExp -> Instructiune
| decl_bool : string -> Instructiune
| atribuire_bool : string -> BExp -> Instructiune
| incrementare : string -> AExp -> Instructiune (*sintaxa incrementare*)
| decrementare : string -> AExp -> Instructiune (*sintaxa decrementare*)
| secventa : Instructiune -> Instructiune -> Instructiune
| while : BExp -> Instructiune -> Instructiune
| ifthen : BExp -> Instructiune -> Instructiune
| ifthenelse : BExp -> Instructiune -> Instructiune -> Instructiune
| comment : string -> Instructiune (*sintaxa pentru comentarii*)
| break : Instructiune (*sintaxa pentru break*)
| body_functie : string -> Instructiune -> Instructiune. (*pentru functii*)

(*Notatii folosite pentru instructiuni*)

Notation "break()' " := (break) (at level 50).
Notation "S1 ;; S2" := (secventa S1 S2) (at level 90).
Notation "<nat> X" := (decl_nat X) (at level 60).
Notation "<bool> X" := (decl_bool X) (at level 60).
Notation "X =n A" := (atribuire_nat X A) (at level 60).
Notation "X =b A" := (atribuire_bool X A) (at level 60).
Notation "X ++" := (incrementare X 1) (at level 60).
Notation "X --" := (decrementare X 1) (at level 60).
Notation "'fors' ( A , B , C ) { S }" := (A ;; while B ( S ;; C )) (at level 97).
Notation " // A // " := (comment A) (at level 99).
Notation "f( X ) {{ S }} " := (body_functie X S) (at level 90).
Notation " A ? B ~ C" := (ifthenelse A B C) (at level 65). (*sintaxa operator "?"*)
Notation "'switch'  'case' ( A ) ( B ) ( 'case' ( C )  ( D ) 'default' ( E ))" := (ifthenelse A B (ifthenelse C D E)) (at level 66).
(*sintaxa instructiune switch*)
(* switch(x)
  case 1: x++
  case 2: x--
  default: x=0
ar putea fi scrisa cu ajutorul a doua ifthenelse-uri:
if (x==1) then x++
  else if (x==2) then x--
        else x=0*)

(*Verificari*)
Check <nat> "a".
Check "x" =n 12.
Check "b" =b true.
Check "x"++.

Definition for_check :=
<nat> "i" ;;
fors ( "i" =n 1 , "i" <=' 10 , "i" =n "i" +' 1 ) {<nat> "x"}.
Check for_check.

Definition op_conditional_check :=
<nat> "x" ;;
("x"=='3) ? ("x"++) ~ ("x"--).
Check op_conditional_check.

Definition switch_check :=
switch
 case ("x" ==' 1)  ( "x"++ )
( case ("x" =='2)  ( "x"-- )
     default ( "x" =n 0 )).
Check switch_check.

Definition functie_check :=
f("nume_functie") {{ <nat> "x" ;; "x" =n 3 }}.
Check functie_check.

Definition while_check :=
while ("i" <=' 6)
        ("sum" =n "sum" +' "i" ;;
           "i" =n "i" +' 1).
Check while_check.

Definition limbaj1 :=
<nat> "a" ;;
<nat> "b" ;;
<nat> "c" ;; // "exemplu de comentariu" // ;;
"c" =n "a" +' "b" ;;
"c" ++ ;;
break()' ;;
<nat> "i" ;;
<nat> "p" ;;
ifthenelse ("p" <=' "i") ("p" =n 5)
         ("p" =n 4).

Compute limbaj1.

(*Erori*)

Definition div_zero (n1 n2 : Natural) : Natural :=
match n1, n2 with
| errnat, _ => errnat
| _, errnat => errnat
| _, num 0 => errnat
| num m1, num m2 => num (Nat.div m1 m2)
end.

Definition subst_fst_gt_scnd (n1 n2 : Natural) : Natural :=
match n1, n2 with
| errnat, _ => errnat
| _, errnat => errnat
| num m1, num m2 => if Nat.ltb m1 m2
                    then errnat
                    else num (m1 - m2)
end.


(************************************************************************)
(*         *   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)         *)
(************************************************************************)
(************************************************************************)

(** Contributed by Laurent Théry (INRIA);
    Adapted to Coq V8 by the Coq Development Team *)

Require Import Bool BinPos BinNat PeanoNat Nnat.
Declare ML Module "ascii_syntax_plugin".

(** * Definition of ascii characters *)

(** Definition of ascii character as a 8 bits constructor *)

Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool).

Delimit Scope char_scope with char.
Bind Scope char_scope with ascii.

Definition zero := Ascii false false false false false false false false.

Definition one := Ascii true false false false false false false false.

Definition shift (c : bool) (a : ascii) :=
  match a with
    | Ascii a1 a2 a3 a4 a5 a6 a7 a8 => Ascii c a1 a2 a3 a4 a5 a6 a7
  end.

(** Definition of a decidable function that is effective *)

Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}.
Proof.
  decide equality; apply bool_dec.
Defined.

Local Open Scope lazy_bool_scope.

Definition eqb (a b : ascii) : bool :=
 match a, b with
 | Ascii a0 a1 a2 a3 a4 a5 a6 a7,
   Ascii b0 b1 b2 b3 b4 b5 b6 b7 =>
    Bool.eqb a0 b0 &&& Bool.eqb a1 b1 &&& Bool.eqb a2 b2 &&& Bool.eqb a3 b3
    &&& Bool.eqb a4 b4 &&& Bool.eqb a5 b5 &&& Bool.eqb a6 b6 &&& Bool.eqb a7 b7
 end.

Infix "=?" := eqb : char_scope.

Lemma eqb_spec (a b : ascii) : reflect (a = b) (a =? b)%char.
Proof.
 destruct a, b; simpl.
 do 8 (case Bool.eqb_spec; [ intros -> | constructor; now intros [= ] ]).
 now constructor.
Qed.

Local Ltac t_eqb :=
  repeat first [ congruence
               | progress subst
               | apply conj
               | match goal with
                 | [ |- context[eqb ?x ?y] ] => destruct (eqb_spec x y)
                 end
               | intro ].
Lemma eqb_refl x : (x =? x)%char = true. Proof. t_eqb. Qed.
Lemma eqb_sym x y : (x =? y)%char = (y =? x)%char. Proof. t_eqb. Qed.
Lemma eqb_eq n m : (n =? m)%char = true <-> n = m. Proof. t_eqb. Qed.
Lemma eqb_neq x y : (x =? y)%char = false <-> x <> y. Proof. t_eqb. Qed.
Lemma eqb_compat: Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) eqb.
Proof. t_eqb. Qed.

(** * Conversion between natural numbers modulo 256 and ascii characters *)

(** Auxiliary function that turns a positive into an ascii by
   looking at the last 8 bits, ie z mod 2^8 *)

Definition ascii_of_pos : positive -> ascii :=
 let loop := fix loop n p :=
   match n with
     | O => zero
     | S n' =>
       match p with
         | xH => one
         | xI p' => shift true (loop n' p')
         | xO p' => shift false (loop n' p')
       end
   end
 in loop 8.

(** Conversion from [N] to [ascii] *)

Definition ascii_of_N (n : N) :=
  match n with
    | N0 => zero
    | Npos p => ascii_of_pos p
  end.

(** Same for [nat] *)

Definition ascii_of_nat (a : nat) := ascii_of_N (N.of_nat a).

(** The opposite functions *)

Local Open Scope list_scope.

Fixpoint N_of_digits (l:list bool) : N :=
 match l with
  | nil => 0
  | b :: l' => (if b then 1 else 0) + 2*(N_of_digits l')
 end%N.

Definition N_of_ascii (a : ascii) : N :=
 let (a0,a1,a2,a3,a4,a5,a6,a7) := a in
 N_of_digits (a0::a1::a2::a3::a4::a5::a6::a7::nil).

Definition nat_of_ascii (a : ascii) : nat := N.to_nat (N_of_ascii a).

(** Proofs that we have indeed opposite function (below 256) *)

Theorem ascii_N_embedding :
  forall a : ascii, ascii_of_N (N_of_ascii a) = a.
Proof.
  destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity.
Qed.

Theorem N_ascii_embedding :
  forall n:N, (n < 256)%N -> N_of_ascii (ascii_of_N n) = n.
Proof.
destruct n.
reflexivity.
do 8 (destruct p; [ | | intros; vm_compute; reflexivity ]);
 intro H; vm_compute in H; destruct p; discriminate.
Qed.

Theorem ascii_nat_embedding :
  forall a : ascii, ascii_of_nat (nat_of_ascii a) = a.
Proof.
  destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity.
Qed.

Theorem nat_ascii_embedding :
  forall n : nat, n < 256 -> nat_of_ascii (ascii_of_nat n) = n.
Proof.
 intros. unfold nat_of_ascii, ascii_of_nat.
 rewrite N_ascii_embedding.
 apply Nat2N.id.
 unfold N.lt.
 change 256%N with (N.of_nat 256).
 rewrite <- Nat2N.inj_compare.
 now apply Nat.compare_lt_iff.
Qed.

(** * Concrete syntax *)

(**
  Ascii characters can be represented in scope char_scope as follows:
  - ["c"]   represents itself if c is a character of code < 128,
  - [""""]  is an exception: it represents the ascii character 34
            (double quote),
  - ["nnn"] represents the ascii character of decimal code nnn.

  For instance, both ["065"] and ["A"] denote the character `uppercase
  A', and both ["034"] and [""""] denote the character `double quote'.

  Notice that the ascii characters of code >= 128 do not denote
  stand-alone utf8 characters so that only the notation "nnn" is
  available for them (unless your terminal is able to represent them,
  which is typically not the case in coqide).
*)

Local Open Scope char_scope.

Example Space := " ".
Example DoubleQuote := """".
Example Beep := "007".


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
From Coq Require Import Relations Relation_Operators.
Export Relations Relation_Operators.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Notation "[* R ]" :=
  (clos_refl_trans_1n _ R) (at level 5, no associativity) : type_scope.
Notation "[= R ]" := [* fun x y => R x y \/ R y x ]
  (at level 5, no associativity) : type_scope.

Notation inclusion R R' := (forall t1 t2, R t1 t2 -> R' t1 t2).
Notation same_relation R R' := (forall t1 t2, R t1 t2 <-> R' t1 t2).
Notation wconfluent R :=
  (forall t1 t2 t3, R t1 t2 -> R t1 t3 ->
                    exists2 t4, [*R%type] t2 t4 & [*R%type] t3 t4).
Notation confluent R :=
  (forall t1 t2 t3, R t1 t2 -> R t1 t3 ->
                    exists2 t4, R%type t2 t4 & R%type t3 t4).
Notation church_rosser R :=
  (forall t1 t2, [= R] t1 t2 ->
                 exists2 t3, [*R%type] t1 t3 & [*R%type] t2 t3).

Hint Resolve rt1n_refl.

Lemma rtc_trans A R : transitive A [*R].
Proof. by move => t1 t2 t3; rewrite -!clos_rt_rt1n_iff; apply rt_trans. Qed.

Lemma rtc_step A (R : relation A) : inclusion R [*R].
Proof. by move => x y H; apply rt1n_trans with y. Qed.

Lemma rtc_map A (R R' : relation A) : inclusion R R' -> inclusion [*R] [*R'].
Proof.
move => H t t'; elim/clos_refl_trans_1n_ind: t t' / => // t1 t2 T3 H0 H1 H2.
apply rt1n_trans with t2; auto.
Qed.

Lemma rtc_map' A B (R : relation A) (R' : relation B) (f : A -> B) :
  inclusion R (fun x y => R' (f x) (f y)) ->
  inclusion [*R] (fun x y => [*R'] (f x) (f y)).
Proof.
move => H t t'; elim/clos_refl_trans_1n_ind: t t' / => //= x y z H0 H1 H2.
apply rt1n_trans with (f y); auto.
Qed.

Lemma rtc_nest_elim A (R : relation A) : same_relation [*[*R]] [*R].
Proof.
move => t1 t2; split.
- by elim/clos_refl_trans_1n_ind: t1 t2 / => // t1 t2 t3 H _ H0;
     apply rtc_trans with t2.
- apply clos_rt1n_step.
Qed.

Lemma rtc_semi_confluent' A (R R' : relation A) :
  (forall t1 t2 t3, R t1 t2 -> R' t1 t3 -> exists2 t4, R' t2 t4 & [*R] t3 t4) ->
  (forall t1 t2 t3, [*R] t1 t2 -> R' t1 t3 ->
    exists2 t4, R' t2 t4 & [*R] t3 t4).
Proof.
move => H t1 t2 t3 H0; elim/clos_refl_trans_1n_ind: t1 t2 / H0 t3.
- by move => t1 t3 H0; exists t3.
- move => t1 t1' t2 H0 H1 IH t3 H2.
  case: (H t1 t1' t3 H0 H2) => {H H0 H2} t3' H H0.
  case: (IH t3' H) => {IH H} t4 H H2.
  by exists t4 => //; apply rtc_trans with t3'.
Qed.

Lemma rtc_semi_confluent A (R R' : relation A) :
  (forall t1 t2 t3, R t1 t2 -> R' t1 t3 -> exists2 t4, R' t2 t4 & R t3 t4) ->
  (forall t1 t2 t3, [*R] t1 t2 -> R' t1 t3 ->
    exists2 t4, R' t2 t4 & [*R] t3 t4).
Proof.
move => H; apply rtc_semi_confluent' => t1 t2 t3 H0 H1.
by case: (H _ _ _ H0 H1) => t4 H2 H3; exists t4 => //; apply rtc_step.
Qed.

Lemma rtc_confluent A (R : relation A) : confluent R -> confluent [*R].
Proof.
move => H; apply rtc_semi_confluent => t1 t2 t3 H0 H1.
by case: (rtc_semi_confluent H H1 H0) => t4 H2 H3; exists t4.
Qed.

Lemma rtc_confluent' A (R R' : relation A) :
  inclusion R R' -> inclusion R' [*R] -> confluent R' -> confluent [*R].
Proof.
move => H H0 H1 t1 t2 t3 H2 H3.
case: (rtc_confluent H1 (rtc_map H H2) (rtc_map H H3)) => t4 H4 H5.
by exists t4; apply rtc_nest_elim; apply (rtc_map H0).
Qed.

Lemma equiv_refl A (R : relation A) : reflexive A [= R].
Proof. by []. Qed.

Lemma equiv_trans A (R : relation A) : transitive A [= R].
Proof. apply rtc_trans. Qed.

Lemma equiv_sym A (R : relation A) : symmetric A [= R].
Proof.
move => x y; elim/clos_refl_trans_1n_ind: x y / => //= x y z H _ H0.
by apply equiv_trans with y => //; apply rtc_step; case: H; auto.
Qed.

Lemma equiv_includes_rtc A (R : relation A) : inclusion [* R] [= R].
Proof.
move => x y; elim/clos_refl_trans_1n_ind: x y / => //= x y z H _ H0.
by apply rt1n_trans with y => //; left.
Qed.

Lemma confluent_CR A (R : relation A) : confluent [* R] <-> church_rosser R.
Proof.
split; last by move => H x y z Hy Hz; apply H, equiv_trans with x;
               [apply equiv_sym, equiv_includes_rtc | apply equiv_includes_rtc].
move => H x y; elim/clos_refl_trans_1n_ind: x y /; first by move => x; exists x.
move => x y z [] H0 H1 [c H2 H3].
- by exists c => //; apply rt1n_trans with y.
- by case: (H _ _ _ (rtc_step H0) H2) => c' H4 H5;
    exists c' => //; apply rtc_trans with c.
Qed.

Section Z.

Variable (A : Type) (R : relation A) (comp : A -> A).
Variable (Z : forall x y, R x y -> [*R] y (comp x) /\ [*R] (comp x) (comp y)).

Lemma Z_confluent : confluent [*R].
Proof.
have Z1 x y : R x y -> [*R] y (comp x) by firstorder.
have Z2 x y : R x y -> [*R] (comp x) (comp y) by firstorder.
apply rtc_semi_confluent' => t1 t2 t3 H H0; exists (comp t3).
- apply rtc_trans with (comp t1); first apply Z1 => //.
  apply rtc_nest_elim; move: t1 t3 H0 {H}; apply rtc_map', Z2.
- case: H0.
  + by apply rt1n_trans with t2 => //; apply Z1.
  + move => {t3} t1' t3 H0 H1;
      elim/clos_refl_trans_1n_ind: t1' t3 / H1 t1 H0 {H}; eauto => t1' t1 H.
    by apply rtc_trans with (comp t1); [apply Z1 | apply Z2].
Qed.

End Z.

Lemma rtc_preservation A (P : A -> Prop) (R : relation A) :
  (forall x y, R x y -> P x -> P y) -> forall x y, [*R] x y -> P x -> P y.
Proof.
move => H x y; elim/clos_refl_trans_1n_ind: x y / => //= x y z H0 _ H1 H2.
exact (H1 (H x y H0 H2)).
Qed.

Lemma Acc_ind' (A : Type) (R : relation A) (P : A -> Prop) :
  (forall x, (forall y, R y x -> P y) -> P x) -> forall x, Acc R x -> P x.
Proof. move => H x H0; elim/Acc_ind: x / H0 H => x _ IH H; apply H; auto. Qed.

Lemma acc_preservation A B (RA : relation A) (RB : relation B) (f : A -> B) a :
  (forall x y, RA x y -> RB (f x) (f y)) -> Acc RB (f a) -> Acc RA a.
Proof.
move => H H0; move: {1 2}(f a) H0 (erefl (f a)) => b H0.
elim/Acc_ind': b / H0 a => b H0 a H1; subst b.
by constructor => a' H1; apply (fun x => H0 _ x _ erefl), H.
Qed.

Lemma Acc_ind2
  (A B : Type) (RA : relation A) (RB : relation B) (P : A -> B -> Prop) :
  (forall x y, (forall x', RA x' x -> P x' y) ->
               (forall y', RB y' y -> P x y') -> P x y) ->
  forall x y, Acc RA x -> Acc RB y -> P x y.
Proof.
move => H x y Hx Hy;
  elim/Acc_ind: x / Hx y Hy => x Hx IHx y Hy; elim/Acc_ind: y / Hy => y Hy IHy.
by apply H => [x' | y'] H2; [apply IHx | apply IHy].
Qed.

Lemma Acc_wconfluent A (R : relation A) :
  (forall x, Acc (fun a => R^~ a) x) -> wconfluent R -> confluent [*R].
Proof.
move => Hacc Hwconfluent x; elim/Acc_ind': x / (Hacc x) => x IH y z Hy Hz.
inversion Hy; subst; first by exists z.
inversion Hz; subst; first by exists y.
move: {Hy Hz} y0 y1 H H0 H1 H2 => y' z' Hy Hy0 Hz Hz0.
case: (Hwconfluent _ _ _ Hy Hz) => x' Hy1 Hz1.
case: (IH _ Hy _ _ Hy0 Hy1) => y'' Hy2 Hy3.
case: (IH _ Hz _ _ Hz0 Hz1) => z'' Hz2 Hz3.
case: (IH _ Hy _ _ (rtc_trans Hy0 Hy2) (rtc_trans Hy1 Hz3)) => x'' Hy4 Hz4.
by exists x''; [apply (rtc_trans Hy2 Hy4) | apply (rtc_trans Hz2 Hz4)].
Qed.