Require Import Omega.
Require Import Bool.

Require Import mxx.
Require Import typesystem.

Definition obj_dec : forall (o1 o2 : obj), {o1 = o2} + {o1 <> o2}.
Proof.
decide equality.
apply eq_nat_dec.
Defined.

Definition class_dec : forall (c1 c2 : class), {c1 = c2} + {c1 <> c2}.
Proof.
decide equality.
Defined.

Definition cobj_dec : obj -> option class := fix f o :=
  match o with
  | KStar | KOne => Some CKind
  | KProd k1 k2 =>
      match f k1, f k2 with
        | Some CKind, Some CKind => Some CKind
        | _, _ => None
      end
  | KRes k p =>
      match f k, f p with
        | Some CKind, Some CProp => Some CKind
        | _, _ => None
      end
  | TVar _ | TOne | TVoid | TBot | TTop | TUnit => Some CType
  | TMu t | TFst t | TSnd t =>
      match f t with
        | Some CType => Some CType
        | _ => None
      end
  | TArr t s | TProd t s | TSum t s | TPair t s =>
      match f t, f s with
        | Some CType, Some CType => Some CType
        | _, _ => None
      end
  | TFor k t | TPi k t =>
      match f k, f t with
        | Some CKind, Some CType => Some CType
        | _, _ => None
      end
  | PTrue => Some CProp
  | PAnd p1 p2 =>
      match f p1, f p2 with
        | Some CProp, Some CProp => Some CProp
        | _, _ => None
      end
  | PCoer H t s =>
      match f H, f t, f s with
        | Some CTEnv, Some CType, Some CType => Some CProp
        | _, _, _ => None
      end
  | PExi k =>
      match f k with
        | Some CKind => Some CProp
        | _ => None
      end
  | PFor k p =>
      match f k, f p with
        | Some CKind, Some CProp => Some CProp
        | _, _ => None
      end
  | HNil => Some CTEnv
  | HCons H k =>
      match f H, f k with
        | Some CTEnv, Some CKind => Some CTEnv
        | _, _ => None
      end
  | YNil => Some CPEnv
  | YCons Y p =>
      match f Y, f p with
        | Some CPEnv, Some CProp => Some CPEnv
        | _, _ => None
      end
  | GNil => Some CAEnv
  | GCons G t =>
      match f G, f t with
        | Some CAEnv, Some CType => Some CAEnv
        | _, _ => None
      end
  end.

Lemma cobj_dec_cobj : forall o c, cobj_dec o = Some c <-> cobj o c.
Proof.
intros; split; intros H.
(* -> *)
  generalize c H; clear c H.
  induction o; simpl; intros c H; repeat
  match goal with
    | H : Some _ = Some _ |- _ => inversion H; clear H; subst
    | H : match ?x with _ => _ end = _ |- _ =>
        destruct x; try solve [inversion H]
  end; auto using cobj.
(* <- *)
  induction H; simpl; repeat
  match goal with
    | H : ?x = ?y |- match ?x with _ => _ end = _ =>
        rewrite H
  end; auto.
Qed.

Definition get_cobj : forall o, option (sigT (cobj o)).
Proof.
intros o.
remember (cobj_dec o) as e.
destruct e as [c|]; [apply Some|exact None].
apply (existT _ c).
apply cobj_dec_cobj.
apply eq_sym; assumption.
Defined.

Definition Hnth_dec : tenv -> nat -> option kind := fix f H a :=
  match a with
    | O =>
      match H with
        | HCons _ k => Some k
        | HNil => Some KOne
        | _ => None
      end
    | S a =>
      match H with
        | HCons H _ => f H a
        | HNil => Some KOne
        | _ => None
      end
  end.

Lemma Hnth_dec_Hnth : forall H a k, Hnth_dec H a = Some k <-> Hnth H a k.
Proof.
intros; split; intros Ha.
(* -> *)
  generalize H k Ha; clear H k Ha.
  induction a; simpl; intros H k Ha;
  destruct H; simpl in Ha; repeat
  match goal with
    | H : Some _ = Some _ |- _ => inversion H; clear H; subst
    | H : None = Some _ |- _ => solve [inversion H]
  end; auto using Hnth.
(* <- *)
  induction Ha; simpl; auto.
  destruct n; reflexivity.
Qed.

Definition get_Hnth : forall H a, option (sigT (Hnth H a)).
Proof.
intros H a.
remember (Hnth_dec H a) as e.
destruct e as [k|]; [apply Some|exact None].
apply (existT _ k).
apply Hnth_dec_Hnth.
apply eq_sym; assumption.
Defined.

Definition Gnth_dec : aenv -> nat -> option type := fix f G x :=
  match x with
    | O =>
      match G with
        | GCons _ t => Some t
        | GNil => Some TTop
        | _ => None
      end
    | S x =>
      match G with
        | GCons G _ => f G x
        | GNil => Some TTop
        | _ => None
      end
  end.

Lemma Gnth_dec_Gnth : forall G x t, Gnth_dec G x = Some t <-> Gnth G x t.
Proof.
intros; split; intros Hx.
(* -> *)
  generalize G t Hx; clear G t Hx.
  induction x; simpl; intros G t Hx;
  destruct G; simpl in Hx; repeat
  match goal with
    | H : Some _ = Some _ |- _ => inversion H; clear H; subst
    | H : None = Some _ |- _ => solve [inversion H]
  end; auto using Gnth.
(* <- *)
  induction Hx; simpl; auto.
  destruct n; reflexivity.
Qed.

Definition get_Gnth : forall G x, option (sigT (Gnth G x)).
Proof.
intros G x.
remember (Gnth_dec G x) as e.
destruct e as [t|]; [apply Some|exact None].
apply (existT _ t).
apply Gnth_dec_Gnth.
apply eq_sym; assumption.
Defined.

Definition is_free := fix f a o :=
  (match o with
  | KStar | KOne => true
  | KProd k1 k2 => f a k1 && f a k2
  | KRes k p => f a k && f (1 + a) p
  | TVar b => negb (beq_nat a b)
  | TOne | TVoid | TBot | TTop | TUnit => true
  | TMu t => f (1 + a) t
  | TFst t | TSnd t => f a t
  | TArr t s | TProd t s | TSum t s | TPair t s => f a t && f a s
  | TFor k t | TPi k t => f a k && f (1 + a) t
  | PTrue => true
  | PAnd p1 p2 => f a p1 && f a p2
  | PCoer H t s => f a H && f (Hlength H + a) t && f a s
  | PExi k => f a k
  | PFor k p => f a k && f (1 + a) p
  | HNil => true
  | HCons H k => f a H && f (Hlength H + a) k
  | YNil => true
  | YCons Y p => f a Y && f a p
  | GNil => true
  | GCons G t => f a G && f a t
  end)%bool.

Lemma is_free_sound : forall a o, is_free a o = true -> exists o', o = shift a o'.
Proof.
intros a o.
generalize a; clear a.
induction o; intros a Heq; inversion Heq; clear Heq; subst;
repeat match goal with
  | H : ?x && ?y = true |- _ => destruct (proj1 (andb_true_iff x y) H); clear H
  | IH : forall a, is_free a ?o = true -> _ , H : is_free ?a ?o = true |- _ =>
    destruct (IH a H); clear IH; subst o
end.
exists KStar; reflexivity.
exists KOne; reflexivity.
exists (KProd x0 x); reflexivity.
exists (KRes x0 x); reflexivity.
{ apply eq_sym, negb_sym, beq_nat_false_iff in H0.
  destruct (lt_eq_lt_dec a x) as [[?|?]|?]; [|exfalso; omega|].
  - destruct x; [inversion l|].
    exists (TVar x); simpl; subst_lift_var.
  - exists (TVar x); simpl; subst_lift_var. }
exists (TArr x0 x); reflexivity.
exists TOne; reflexivity.
exists (TProd x0 x); reflexivity.
exists TVoid; reflexivity.
exists (TSum x0 x); reflexivity.
exists (TFor x0 x); reflexivity.
exists (TPi x0 x); reflexivity.
exists (TMu x); reflexivity.
exists TBot; reflexivity.
exists TTop; reflexivity.
exists TUnit; reflexivity.
exists (TPair x0 x); reflexivity.
exists (TFst x); reflexivity.
exists (TSnd x); reflexivity.
exists PTrue; reflexivity.
exists (PAnd x0 x); reflexivity.
exists (PCoer x0 x x1); simpl; unfold shift; rewrite Hlength_lift; reflexivity.
exists (PExi x); reflexivity.
exists (PFor x0 x); reflexivity.
exists HNil; reflexivity.
exists (HCons x0 x); simpl; unfold shift; rewrite Hlength_lift; reflexivity.
exists YNil; reflexivity.
exists (YCons x0 x); reflexivity.
exists GNil; reflexivity.
exists (GCons x0 x); reflexivity.
Qed.

Definition jrec_dec : nat -> type -> recsort -> bool := fix f a t rec :=
  (match t with
  | TVar b => is_free a t ||
      match rec with
        | NE => true
        | WF => false
      end
  | TBot | TTop => true
  | TArr t s | TProd t s | TSum t s => f a t NE && f a s NE
  | TMu t => f (1 + a) t rec && f 0 t WF
  | TFor k t => is_free a k && f (1 + a) t rec
  | TPi k t => is_free a k && f (1 + a) t NE
  | _ => false
  end)%bool.

Lemma jrec_dec_jrec : forall a t rec, jrec_dec a t rec = true -> jrec a t rec.
Proof.
intros a t.
generalize a; clear a.
induction t; intros a rec Heq; inversion Heq; clear Heq; subst;
repeat match goal with
  | H : ?x && ?y = true |- _ => destruct (proj1 (andb_true_iff x y) H); clear H
end.
{ remember (negb (beq_nat a x)) as e; apply eq_sym in Heqe.
  destruct e.
  { destruct (is_free_sound a (TVar x) Heqe) as [w ?].
    destruct rec; [|apply RECne]; apply RECwf with w; auto. }
  destruct rec; inversion H0; clear H0.
  apply eq_sym, negb_sym, beq_nat_true_iff in Heqe; subst.
  apply RECVar. }
destruct rec; [|apply RECne]; apply RECArr; auto.
destruct rec; [|apply RECne]; apply RECProd; auto.
destruct rec; [|apply RECne]; apply RECSum; auto.
destruct (is_free_sound _ _ H) as [w ?]; apply RECFor with w; auto.
destruct rec; [|apply RECne]; destruct (is_free_sound _ _ H) as [w ?]; apply RECPi with w; auto.
apply RECMu; auto.
destruct rec; [|apply RECne]; apply RECwf with TBot; auto.
destruct rec; [|apply RECne]; apply RECwf with TTop; auto.
Qed.

Definition get_jrec a t rec : option (jrec a t rec) :=
  match jrec_dec a t rec return _ with
    | true => fun Heq => Some (jrec_dec_jrec a t rec Heq)
    | false => fun _ => None
  end eq_refl.

(* Definition rmin r1 r2 := *)
(*   match r1, r2 with *)
(*     | NE, _ | _, NE => NE *)
(*     | _, _ => WF *)
(*   end. *)

(* Definition rinc (r : recsort) := WF. *)

(* Definition jrec_dec : nat -> type -> option recsort := fix f a t := *)
(*   match t with *)
(*     | TVar b => if beq_nat a b then Some NE else Some CST *)
(*     | TArr t s | TProd t s | TSum t s => *)
(*         match f a t, f a s with *)
(*           | Some r1, Some r2 => Some (rinc (rmin r1 r2)) *)
(*           | _, _ => None *)
(*         end *)
(*     | TFor k t => *)
(*         match f a k, f (1 + a) t with *)
(*           | Some CST, Some rec => Some rec *)
(*           | _, _ => None *)
(*         end *)
(*     | TPi k t => *)
(*         match f a k, f (1 + a) t with *)
(*           | Some CST, Some r => Some (rinc r) *)
(*           | _, _ => None *)
(*         end *)
(*     | TMu t => *)
(*         match f 0 t, f (1 + a) t with *)
(*           | Some WF, Some rec => Some rec *)
(*           | _, _ => None *)
(*         end *)
(*     | _ => None *)
(*   end. *)

(* Definition le_recsort r1 r2 := *)
(*   match r1, r2 with *)
(*     | CST, _ => True *)
(*     | WF, CST => False *)
(*     | WF, _ => True *)
(*     | NE, NE => True *)
(*     | NE, _ => False *)
(*   end. *)
(* Hint Unfold le_recsort. *)

(* Lemma jrec_le : forall a t r1 r2, le_recsort r1 r2 -> jrec a t r1 -> jrec a t r2. *)
(* Proof. *)
(* intros; destruct r1; destruct r2; auto using RECne, RECwf; inversion H. *)
(* Qed. *)

(* Lemma jrec_NE : forall a t r, jrec a t r -> jrec a t NE. *)
(* Proof. *)
(* intros; apply (jrec_le a t r NE); auto. *)
(* destruct r; auto. *)
(* Qed. *)

(* Lemma jrec_dec_dir : forall t a rec, jrec_dec a t = Some rec -> jrec a t rec. *)
(* Proof. *)
(* induction t; simpl; intros a rec H; repeat *)
(* match goal with *)
(*   | |- jrec _ (TVar _) _ => fail 1 *)
(*   | |- jrec _ (TMu _) _ => fail 1 *)
(*   | H : None = Some _ |- _ => inversion H *)
(*   | H : Some _ = Some _ |- _ => inversion H; clear H; subst *)
(*   | H1 : match jrec_dec ?a ?t with _ => _ end = _ *)
(*   , H2 : forall _ _, jrec_dec _ ?t = _ -> _ |- _ => *)
(*       pose proof (H2 a); clear H2; *)
(*       destruct (jrec_dec a t); try solve [inversion H] *)
(*   | H : forall rec, Some ?r = Some rec -> _ |- _ => *)
(*       pose proof (H r eq_refl); clear H *)
(*   | H : match ?x with _ => _ end = _ |- _ => *)
(*       destruct x; try solve [inversion H] *)
(* end. *)
(* (* 7: TVar *) *)
(*   remember (beq_nat a x) as y. *)
(*   destruct y; inversion H; clear H; subst. *)
(*   (* +1: a = x *) *)
(*     pose proof (beq_nat_true a x (eq_sym Heqy)); subst. *)
(*     apply RECVar. *)
(*   (* +0: a <> x *) *)
(*     pose proof (beq_nat_false a x (eq_sym Heqy)). *)
(*     destruct (le_gt_dec a x). *)
(*     (* +1: a < x *) *)
(*       destruct x as [|x]; [exfalso; omega|]. *)
(*       apply RECcst with (TVar x); simpl. *)
(*       subst_lift_var. *)
(*     (* +0: a > x *) *)
(*       apply RECcst with (TVar x); simpl. *)
(*       subst_lift_var. *)
(* (* 6: TArr *) apply RECArr; eapply jrec_NE; eassumption. *)
(* (* 5: TProd *) apply RECProd; eapply jrec_NE; eassumption. *)
(* (* 4: TSum *) apply RECSum; eapply jrec_NE; eassumption. *)
(* (* 3: TFor *) apply RECFor; auto. *)
(* (* 2: TPi *) apply RECPi; [|eapply jrec_NE]; eassumption. *)
(* (* 1: TMu *) *)
(*   pose proof (IHt 0). *)
(*   pose proof (IHt (1 + a) rec); clear IHt. *)
(*   simpl in H1. *)
(*   destruct (jrec_dec 0 t); try solve [inversion H]. *)
(*   destruct r; try solve [inversion H]. *)
(*   destruct (jrec_dec (S a) t); try solve [inversion H]. *)
(*   apply RECMu; auto. *)
(* Qed. *)

(* Lemma jrec_dec_rev : forall t a r2, jrec a t r2 -> *)
(*   exists r1, (forall r, jrec a t r -> le_recsort r1 r) /\ jrec_dec a t = Some r1. *)
(* Proof. *)
(* intros. *)
(* induction H; simpl in *; repeat *)
(* match goal with *)
(*   | H : exists _, _ /\ _ |- _ => destruct H as [? [? ?]] *)
(*   | H : ?x = ?y |- _ => rewrite H *)
(* end. *)
(* (* 10: RECVar *) *)
(*   rewrite <- beq_nat_refl. *)
(*   exists NE; split; auto. *)
(*   intros. *)
(*   destruct r; simpl in H; auto. *)
(*   (* +1: *) *)
(*     inversion H; clear H; subst. *)
(*     destruct s; inversion H0; clear H0. *)
(*     exfalso; destruct (le_gt_dec a x); omega. *)
(*   (* +0: *) *)
(*     inversion H; clear H; subst. *)
(*     inversion H0; clear H0; subst. *)
(*     destruct s; inversion H; clear H. *)
(*     exfalso; destruct (le_gt_dec a x); omega. *)
(* (* 9: RECArr *) *)
(*   exists WF; split; auto. *)
(*   intros. *)
(*   destruct r *)
(* (* 8: RECProd *) exists WF; auto. *)
(* (* 7: RECSum *) exists WF; auto. *)
(* (* 6: RECFor *) *)
(*   exists x. *)
(*   split; auto. *)
(*   destruct x0; auto; inversion H3. *)
(* (* 5: RECPi *) *)
(*   exists WF. *)
(*   split; auto. *)
(*   destruct x0; auto; inversion H3. *)
(* (* 4: RECMu *) *)
(*   destruct x0; inversion H3. *)
(*   exists x. *)
(*   split; auto. *)
(* Qed. *)

(* Definition jeq_norm := fix f o := *)
(*   match o with *)
(*   | KStar => KStar *)
(*   | KOne => KOne *)
(*   | KProd k1 k2 => KProd (f k1) (f k2) *)
(*   | KRes k p => KRes (f k) (f p) *)
(*   | TVar a => TVar a *)
(*   | TArr t s => TArr (f t) (f s) *)
(*   | TProd t s => TProd (f t) (f s) *)
(*   | TSum t s => TSum (f t) (f s) *)
(*   | TFor k t => TFor (f k) (f t) *)
(*   | TPi k t => TPi (f k) (f t) *)
(*   | TMu t => TMu (f t) *)
(*   | TBot => TBot *)
(*   | TTop => TTop *)
(*   | TUnit => TUnit *)
(*   | TPair t s => TPair (f t) (f s) *)
(*   | TFst t => *)
(*       match f t with *)
(*         | TPair t s => t *)
(*         | t => TFst t *)
(*       end *)
(*   | TSnd t => *)
(*       match f t with *)
(*         | TPair t s => s *)
(*         | t => TSnd t *)
(*       end *)
(*   | TPack t => TPack (f t) *)
(*   | TUnpack t => *)
(*       match f t with *)
(*         | TPack t => t *)
(*         | t => TUnpack t *)
(*       end *)
(*   | PTrue => PTrue *)
(*   | PAnd p1 p2 => PAnd (f p1) (f p2) *)
(*   | PCoer H t s => PCoer (f H) (f t) (f s) *)
(*   | PExi k => PExi (f k) *)
(*   | PFor k p => PFor (f k) (f p) *)
(*   | HNil => HNil *)
(*   | HCons H k => HCons (f H) (f k) *)
(*   | YNil => YNil *)
(*   | YCons Y p => YCons (f Y) (f p) *)
(*   | GNil => GNil *)
(*   | GCons G t => GCons (f G) (f t) *)
(*   end. *)


(** * HoareAsLogic: Hoare Logic as a Logic *)

(** The presentation of Hoare logic in chapter [Hoare] could be
    described as "model-theoretic": the proof rules for each of the
    constructors were presented as _theorems_ about the evaluation
    behavior of programs, and proofs of program correctness (validity
    of Hoare triples) were constructed by combining these theorems
    directly in Coq.

    Another way of presenting Hoare logic is to define a completely
    separate proof system -- a set of axioms and inference rules that
    talk about commands, Hoare triples, etc. -- and then say that a
    proof of a Hoare triple is a valid derivation in _that_ logic.  We
    can do this by giving an inductive definition of _valid
    derivations_ in this new logic.

    This chapter is optional.  Before reading it, you'll want to read
    the [ProofObjects] chapter in _Logical
    Foundations_ (_Software Foundations_, volume 1). *)

From PLF Require Import Maps.
From PLF Require Import Imp.
Hint Constructors ceval : core.
From PLF Require Import Hoare.

(* ################################################################# *)
(** * Hoare Logic and Model Theory *)

(** In [Hoare] we introduced Hoare triples, which contain a
    precondition, command, and postcondition.  For example (and for
    the moment deliberately avoiding the notation we previously
    introduced),

      Pre:  X = 0
      Com:  X ::= X + 1
      Post: X = 1

    is a Hoare triple, as is

      Pre:  X = 0
      Com:  skip
      Post: X = 1

    But there's an important difference between those two triples: the
    former expresses a truth about how Imp programs execute, whereas
    the latter does not.

    To capture that difference, we introduced a definition
    [hoare_triple] that described when a triple expresses such a
    truth.  Let's repeat that definition, but this time we'll call it
    [valid]: *)

Definition valid (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st',
     st =[ c ]=> st'  ->
     P st  ->
     Q st'.

(** This notion of _validity_ is based on the underlying model of how
    Imp programs execute.  That model itself is based on states.  So,

      Pre:  X = 0
      Com:  X ::= X + 1
      Post: X = 1

    is _valid_, because starting from any state in which [X] is [0],
    and executing [X ::= X + 1], we are guaranteed to reach a state in
    which [X] is [1]. But,

      Pre:  X = 0
      Com:  skip
      Post: X = 1

    is _invalid_, because starting from any state in which [X] is [0],
    we are guaranteed not to change the state, so [X] cannot be [1].
*)

(** So far, we have punned between the syntax of a Hoare triple,
    written [{{P}} c {{Q}}], and its validity, as expressed by
    [valid].  In essence, we have said that the semantic meaning of
    that syntax is the proposition returned by [valid].  This way of
    giving semantic meaning to something syntactic is part of the
    branch of mathematical logic known as _model theory_.  *)

(** Our approach to Hoare logic through model theory led us to
    state proof rules in terms of that same state-based model, and to
    prove program correctness in it, too.  But there is another
    approach, which is arguably more common in Hoare logic. We turn to
    it, next.  *)

(* ################################################################# *)
(** * Hoare Logic and Proof Theory *)

(** Instead of using states and evaluation as the basis for reasoning,
    let's take the proof rules from [Hoare] as the basis.  Those
    proof rules give us a set of axioms and inference rules that
    constitute a logic in their own right.  We repeat them here: *)

(**

             ----------------  (hoare_skip)
             {{P}} skip {{P}}

             ----------------------------- (hoare_asgn)
             {{Q [X |-> a]}} X ::= a {{Q}}

               {{P}} c1 {{Q}}
               {{Q}} c2 {{R}}
              ------------------  (hoare_seq)
              {{P}} c1;; c2 {{R}}

              {{P /\   b}} c1 {{Q}}
              {{P /\ ~ b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} if b then c1 else c2 end {{Q}}

            {{P /\ b}} c {{P}}
      ----------------------------- (hoare_while)
      {{P} while b do c end {{P /\ ~b}}

                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

(** Read the Hoare triples in those rules as devoid of any
    meaning other than what the rules give them.  Forget about states
    and evaluations.  They are just syntax that the rules tell us how
    to manipulate in legal ways.

    Through this new lens, triple [{{X = 0}} X ::= X + 1 {{X = 1}}]
    is _derivable_, because we can derive a proof tree using the rules:
*)

(**

                 ---------------------------  (hoare_asgn)
X=0 ->> X+1=1    {{X+1=1}} X ::= X+1 {{X=1}}
----------------------------------------------------------  (hoare_consequence)
                  {{X=0}} X ::= X+1 {{X=1}}
*)

(** At each step we have either used one of the rules, or we
    have appealed to reasoning about assertions, which do not involve
    Hoare triples.  (Note that we have left off the trivial part of
    [hoare_consequence] above, namely X=1 ->> X=1, only because of
    horizontal space contraints: it's hard to fit that many characters
    on a line and have the page still be readable.  If you prefer,
    think of it as using [hoare_consequence_pre] instead.)

    On the other hand, [{{X = 0}} skip {{X = 1}}] is _not_ derivable,
    because there is no way to apply the rules to construct a proof
    tree with this triple at its root. *)

(** This approach gives meaning to triples not in terms of a model,
    but in terms of how they can be used to construct proof trees.
    It's a different way of giving semantic meaning to something
    syntactic, and it's part of the branch of mathematical logic known
    as _proof theory_.

    Our goal for the rest of this chapter is to formalize Hoare logic
    using proof theory, and then to prove that the model-theoretic and
    proof-theoretic formalizations are consistent with one another.
*)

(* ################################################################# *)
(** * Derivability *)

(** To formalize derivability of Hoare triples, we introduce inductive type
    [derivable], which describes legal proof trees using the Hoare rules. *)

Inductive derivable : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      derivable P <{skip}> P
  | H_Asgn : forall Q V a,
      derivable (Q [V |-> a]) <{V := a}> Q
  | H_Seq  : forall P c Q d R,
      derivable P c Q -> derivable Q d R -> derivable P <{c;d}> R
  | H_If : forall P Q b c1 c2,
    derivable (fun st => P st /\ bassn b st) c1 Q ->
    derivable (fun st => P st /\ ~(bassn b st)) c2 Q ->
    derivable P <{if b then c1 else c2 end}> Q
  | H_While : forall P b c,
    derivable (fun st => P st /\ bassn b st) c P ->
    derivable P <{while b do c end}> (fun st => P st /\ ~ (bassn b st))
  | H_Consequence  : forall (P Q P' Q' : Assertion) c,
    derivable P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    derivable P c Q.

(** We don't need to include axioms corresponding to
    [hoare_consequence_pre] or [hoare_consequence_post], because these
    can be proven easily from [H_Consequence]. *)

Lemma H_Consequence_pre : forall (P Q P': Assertion) c,
    derivable P' c Q ->
    (forall st, P st -> P' st) ->
    derivable P c Q.
Proof. eauto using H_Consequence. Qed.

Lemma H_Consequence_post  : forall (P Q Q' : Assertion) c,
    derivable P c Q' ->
    (forall st, Q' st -> Q st) ->
    derivable P c Q.
Proof. eauto using H_Consequence. Qed.

(** As an example, let's construct a proof tree for

        {{(X=3) [X |-> X + 2] [X |-> X + 1]}}
      X ::= X + 1;;
      X ::= X + 2
        {{X=3}}
*)

Example sample_proof :
  derivable
    ((fun st:state => st X = 3) [X |-> X + 2] [X |-> X + 1])
    <{ X := X + 1; X := X + 2}>
    (fun st:state => st X = 3).
Proof.
  eapply H_Seq.
  - apply H_Asgn.
  - apply H_Asgn.
Qed.

(** You can see how the structure of the proof script mirrors the structure
    of the proof tree: at the root there is a use of the sequence rule; and
    at the leaves, the assignment rule. *)

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

(** Show that any Hoare triple whose postcondition is [True] is derivable. Proceed
    by induction on [c]. *)

Theorem provable_true_post : forall c P,
    derivable P c True.
Proof.
  intros.
  generalize dependent P.
  induction c; intros.
  - (* skip *)
    eapply H_Consequence_post; constructor; auto.
  - (* ass *)
    eapply H_Consequence_pre; constructor; auto.
  - (* seq *)
    econstructor. apply IHc1. apply IHc2.
  - (* if *)
    eapply H_Consequence_post; constructor; auto.
  - (* while *)
    eapply H_Consequence.
    econstructor. apply IHc.
    auto. auto.
Qed.

(** [] *)

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

(** Show that any Hoare triple whose precondition is [False] is derivable. Again,
    proceed by induction on [c]. *)

Theorem provable_false_pre : forall c Q,
    derivable False c Q.
Proof.
  intros.
  generalize dependent Q.
  induction c; intros.
  - (* skip *)
    eapply H_Consequence_pre; try contradiction.
    constructor; auto.
  - (* ass *)
    eapply H_Consequence_pre; try contradiction.
    constructor.
  - (* seq *)
    eapply H_Consequence_pre; try contradiction.
    econstructor. apply IHc1. apply IHc2.
  - (* if *)
    eapply H_Consequence_post; try contradiction.
    constructor.
    + eapply H_Consequence_pre. apply IHc1. intros. destruct H. contradiction.
    + eapply H_Consequence_pre. apply IHc2. intros. destruct H. contradiction.
    + intros. apply H.
  - (* while *)
    eapply H_Consequence_post; try contradiction.
    + constructor. eapply H_Consequence_pre. apply IHc.
      intros. destruct H. contradiction.
    + intros. simpl in H. destruct H. contradiction.
Qed.

(** [] *)

(* ################################################################# *)
(** * Soundness and Completeness *)

(** We now have two approaches to formulating Hoare logic:

    - The model-theoretic approach uses [valid] to characterize when a Hoare
      triple holds in a model, which is based on states.

    - The proof-theoretic approach uses [derivable] to characterize when a Hoare
      triple is derivable as the end of a proof tree.

    Do these two approaches agree?  That is, are the valid Hoare triples exactly
    the derivable ones?  This is a standard question investigated in
    mathematical logic.  There are two pieces to answering it:

    - A logic is _sound_ if everything that is derivable is valid.

    - A logic is _complete_ if everything that is valid is derivable.

    We can prove that Hoare logic is sound and complete.

*)

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

(** Prove that if a Hoare triple is derivable, then it is valid.
    Nearly all the work for this was already done in [Hoare] as
    theorems [hoare_skip], [hoare_asgn], etc.; leverage those
    proofs. Proceed by induction on the derivation of the triple. *)

Theorem hoare_sound : forall P c Q,
  derivable P c Q -> valid P c Q.
Proof.
  intros.
  induction X.
  - apply hoare_skip.
  - apply hoare_asgn.
  - eapply hoare_seq; eassumption.
  - eapply hoare_if; eassumption.
  - eapply hoare_while; eassumption.
  - eapply hoare_consequence; eassumption.
Qed.
(** [] *)

(** The proof of completeness is more challenging.  To carry out the
    proof, we need to invent some intermediate assertions using a
    technical device known as _weakest preconditions_ (which are also
    discussed in [Hoare2]).  Given a command [c] and a desired
    postcondition assertion [Q], the weakest precondition [wp c Q] is
    an assertion [P] such that [{{P}} c {{Q}}] holds, and moreover,
    for any other assertion [P'], if [{{P'}} c {{Q}}] holds then [P'
    ->> P].

    Another way of stating that idea is that [wp c Q] is the following
    assertion: *)

Definition wp (c:com) (Q:Assertion) : Assertion :=
  fun s => forall s', s =[ c ]=> s' -> Q s'.

Hint Unfold wp : core.

(** The following two theorems show that the two ways of thinking
    about [wp] are the same. *)

Theorem wp_is_precondition : forall c Q,
  {{wp c Q}} c {{Q}}.
Proof. auto. Qed.

Theorem wp_is_weakest : forall c Q P',
    {{P'}} c {{Q}} ->
    P' ->> (wp c Q).
Proof. eauto. Qed.

(** Weakest preconditions are useful because they enable us to
    identify assertions that otherwise would require clever thinking.
    The next two lemmas show that in action. *)

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

(** What if we have a sequence [c1;; c2], but not an intermediate assertion for
    what should hold in between [c1] and [c2]?  No problem.  Prove that [wp c2 Q]
    suffices as such an assertion. *)

Lemma wp_seq : forall P Q c1 c2,
    derivable P c1 (wp c2 Q) ->
    derivable (wp c2 Q) c2 Q ->
    derivable P <{c1; c2}> Q.
Proof.
  intros.
  econstructor.
  apply X.
  assumption.
Qed.

(** [] *)

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

(** What if we have a while loop, but not an invariant for it?  No
    problem.  Prove that for any [Q], assertion [wp (while b do c end)
    Q] is a loop invariant of [while b do c end]. *)

Lemma wp_invariant : forall b c Q,
    valid (wp <{while b do c end}> Q /\ b) c (wp <{while b do c end}> Q).
Proof.
  unfold valid.
  intros.
  destruct H0.
  unfold wp.
  info_eauto.
Qed.

(** [] *)

(** **** Exercise: 4 stars, standard (hoare_complete)  *)

(** Now we are ready to prove the completeness of Hoare logic.  Finish
    the proof of the theorem below.

    Hint: for the [while] case, use the invariant suggested by
    [wp_invariant].

    Acknowledgment: Our approach to this proof is inspired by:

      https://www.ps.uni-saarland.de/courses/sem-ws11/script/Hoare.html
*)

Hint Constructors derivable : core.
Hint Resolve H_Consequence_pre : core.
Hint Resolve H_Consequence_post : core.

Theorem hoare_complete: forall P c Q,
  valid P c Q -> derivable P c Q.
Proof.
  unfold valid. intros P c. generalize dependent P.
  induction c; intros P Q HT.
  - (* skip *)
    eauto.
  - (* ass *)
    eauto.
  - (* seq *)
    apply wp_seq; eauto.
  - (* if *)
    constructor.
    + (* if true *)
      apply IHc1. intros. eapply HT.
      apply E_IfTrue.
      apply H0. apply H. apply H0.
    + (* if false *)
      apply IHc2. intros. eapply HT.
      apply E_IfFalse. simpl in H0. rewrite Bool.not_true_iff_false in H0.
      apply H0. apply H. apply H0.
  - (* while *)
    eapply H_Consequence.
    + apply H_While. apply IHc. apply wp_invariant.
    + (* precondition *)
      intros. unfold wp. intros st' HH. eapply HT. apply HH. apply H.
    + (* postcondition *)
      simpl. intros.
      rewrite Bool.not_true_iff_false in H.
      destruct H.
      unfold wp in H.
      apply H. apply E_WhileFalse. apply H0.
Qed.
(** [] *)

(* ################################################################# *)
(** * Postscript: Decidability *)

(** We might hope that Hoare logic would be _decidable_; that is, that
    there is an (terminating) algorithm (a _decision procedure_) that
    can determine whether or not a given Hoare triple is valid or
    derivable.  But such a decision procedure cannot exist.

    Consider the triple [{{True}} c {{False}}]. This triple is valid if and
    only if [c] is non-terminating.  So any algorithm that could
    determine validity of arbitrary triples could solve the Halting
    Problem.

    Similarly, the triple [{{True}} skip {{P}}] is valid if and only if
    [forall s, P s] is valid, where [P] is an arbitrary assertion of Coq's
    logic. But it is known that there can be no decision procedure for
    this logic. *)

(* 2020-09-09 21:08 *)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Relations.

From Undecidability.MinskyMachines
  Require Import MMA mma_defs ndMM2.

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

From Undecidability.Synthetic
  Require Import Definitions ReducibilityFacts.

Set Implicit Arguments.

Local Tactic Notation "vec2" hyp(v) "into" ident(x) ident(y) :=
    vec split v with x; vec split v with y; vec nil v; clear v.

Section MMA2_ndMM2.

  Notation STOPₙ := (@ndmm2_stop _).
  Notation INCₙ  := (@ndmm2_inc _).
  Notation DECₙ  := (@ndmm2_dec _).
  Notation ZEROₙ := (@ndmm2_zero _).

  Notation α := true.
  Notation β := false.

  Infix "∊" := In (at level 70).
  Infix "⊆" := incl (at level 70).

  Notation ø := vec_nil.

  Definition pos2_to_bool (p : pos 2) :=
    match p with pos0 => α | _ => β end.

  Notation "⌈ p ⌉" := (pos2_to_bool p) (at level 1, format "⌈ p ⌉").

  Definition mma2_instr_enc i (ρ : mm_instr (pos 2)) :=
    match ρ with
      | INCₐ x   => INCₙ ⌈x⌉ i (1+i) :: nil
      | DECₐ x j => DECₙ ⌈x⌉ i j :: ZEROₙ ⌈x⌉ i (1+i) :: nil
    end.

  Notation "'⟨' i , ρ '⟩₁'" := (mma2_instr_enc i  ρ) (format "⟨ i , ρ ⟩₁").

  Reserved Notation "'⟪' i , l '⟫ₗ'" (at level 1, format "⟪ i , l ⟫ₗ").

  Fixpoint mma2_linstr_enc i l :=
    match l with
      | nil  => nil
      | ρ::l => ⟨i,ρ⟩₁ ++ ⟪1+i,l⟫ₗ
    end
  where "⟪ i , l ⟫ₗ" := (mma2_linstr_enc i l).

  Fact mma2_linstr_enc_app i l m : ⟪i,l++m⟫ₗ = ⟪i,l⟫ₗ ++ ⟪length l+i,m⟫ₗ.
  Proof.
    revert i; induction l as [ | ? l IHl ]; intros ?; simpl; auto.
    rewrite app_ass, IHl; do 3 f_equal; auto.
  Qed.

  Fact mma2_linstr_enc_In i P c :
          c ∊ ⟪i,P⟫ₗ -> exists L ρ R, P = L++ρ::R /\ c ∊ ⟨length L+i,ρ⟩₁.
  Proof.
    revert i; induction P as [ | ρ P IH ]; intros i.
    + intros [].
    + simpl; rewrite in_app_iff; intros [ H | H ].
      * exists nil, ρ, P; split; auto.
      * destruct (IH (1+i)) as (l & ρ' & r & H1 & H2); auto.
        exists (ρ::l), ρ', r; split; auto.
        - simpl; f_equal; auto.
        - eq goal H2; do 2 f_equal; simpl; lia.
  Qed.

  Notation "Σ //ₙ a ⊕ b ⊦ u" := (ndmm2_accept Σ a b u) (at level 70, no associativity).

  Notation "ρ //ₐ s -1> t" := (mma_sss ρ s t) (at level 70, no associativity).
  Notation "P //ₐ r :1> s" := (sss_step (@mma_sss _) P r s)  (at level 70, no associativity).
  Notation "P //ₐ s ->> t" := (sss_compute (@mma_sss _) P s t) (at level 70, no associativity).
  Notation "P //ₐ s ~~> t" := (sss_output (@mma_sss _) P s t) (at level 70, no associativity).

  Tactic Notation "state" "rebuild" ident(s) hyp(i) hyp(a) hyp(b) :=
    set (s := (i,a##b##ø));
    change a with (vec_pos (snd s) pos0);
    change b with (vec_pos (snd s) pos1);
    change i with (fst s).

  Hint Resolve in_eq in_cons : core.

  Local Fact mma2_instr_enc_sound Σ ρ i a b j a' b' :
          ρ //ₐ (i,a##b##ø) -1> (j,a'##b'##ø)
       -> ⟨i,ρ⟩₁ ⊆ Σ
       -> Σ //ₙ a' ⊕ b' ⊦ j
       -> Σ //ₙ a  ⊕ b  ⊦ i.
  Proof.
    state rebuild s1 i a b.
    state rebuild s2 j a' b'.
    generalize s1 s2; clear s1 s2 i a b j a' b'.
    destruct 1 as [ i x v | i x k v Hv | i x k v u Hv ]; try revert Hv;
      vec2 v into a b; repeat invert pos x; simpl.
    + constructor 2 with (1+i); auto.
    + constructor 3 with (1+i); auto.
    + intros -> ?; constructor 6 with (1+i); auto.
    + intros -> ?; constructor 7 with (1+i); auto.
    + intros -> ?; constructor 4 with k; auto.
    + intros -> ?; constructor 5 with k; auto.
  Qed.

  Local Fact mma2_step_linstr_sound Σ P i a b j a' b' :
          (1,P) //ₐ (i,a##b##ø) :1> (j,a'##b'##ø)
       -> ⟪1,P⟫ₗ ⊆  Σ
       -> Σ //ₙ a' ⊕ b' ⊦ j
       -> Σ //ₙ a  ⊕ b  ⊦ i.
  Proof.
    intros (n & L & ρ & R & v & H1 & H2 & H3).
    inversion H1; subst n P; clear H1.
    inversion H2; subst v i; clear H2.
    intros H.
    apply mma2_instr_enc_sound with (1 := H3).
    apply incl_tran with (2 := H).
    rewrite mma2_linstr_enc_app; simpl.
    rewrite Nat.add_comm.
    apply incl_appr, incl_appl, incl_refl.
  Qed.

  Variable P : list (mm_instr (pos 2)).

  Definition mma2_prog_enc := STOPₙ 0 :: ⟪1,P⟫ₗ.
  Notation ΣP := mma2_prog_enc.

  Local Lemma mma2_compute_linstr_sound i a b j a' b'  :
          (1,P) //ₐ (i,a##b##ø) ->> (j,a'##b'##ø)
       -> ΣP //ₙ a' ⊕ b' ⊦ j
       -> ΣP //ₙ a  ⊕ b  ⊦ i.
  Proof.
    intros (n & Hn); revert Hn.
    state rebuild s1 i a b.
    state rebuild s2 j a' b'.
    generalize s1 s2; clear s1 s2 i a b j a' b'.
    induction 1 as [ (i,v) | n (i,u) (j,v) (k,w) H1 H2 IH2 ]; simpl; auto.
    revert H1 H2 IH2; vec2 u into au bu; vec2 v into av bv; vec2 w into aw bw.
    simpl; intros H1 H2 IH3 H; generalize (IH3 H).
    apply mma2_step_linstr_sound with (1 := H1), incl_tl, incl_refl.
  Qed.

  Local Lemma mma2_prog_enc_stop : ΣP //ₙ 0 ⊕ 0 ⊦ 0.
  Proof. constructor 1; simpl; auto. Qed.

  Hint Resolve mma2_prog_enc_stop : core.

  Local Lemma mma2_prog_enc_sound i a b  :
          (1,P) //ₐ (i,a##b##ø) ->> (0,0##0##ø) -> ΣP //ₙ a  ⊕ b  ⊦ i.
  Proof. intros H; apply mma2_compute_linstr_sound in H; auto. Qed.

  Local Lemma mma2_prog_enc_complete a b i :
             ΣP //ₙ a ⊕ b ⊦ i -> (1,P) //ₐ (i,a##b##ø) ->> (0,0##0##ø).
  Proof.
    induction 1 as [ u H
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | b p u H H1 IH1
                   | a p u H H1 IH1 ].
    + destruct H as [ H | H ].
      * inversion H; subst u.
        exists 0; constructor 1.
      * apply mma2_linstr_enc_In in H
          as (l & [ x | x ] & r & H1 & H2); repeat invert pos x; simpl in H2.
        1-2: now destruct H2.
        1-2: now destruct H2 as [ | [] ].
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      2: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss INC with pos0.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss INC with pos1.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC S with pos0 v a.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC S with pos1 v b.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x j ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC zero with pos0 j.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x j ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC zero with pos1 j.
      mma sss stop.
  Qed.

  Theorem MMA2_ndMM2_equiv a b : (1,P) //ₐ (1,a##b##ø) ~~> (0,0##0##ø)
                             <-> ΣP //ₙ a ⊕ b ⊦ 1.
  Proof.
    split.
    + intros []; apply mma2_prog_enc_sound; auto.
    + split.
      * now apply mma2_prog_enc_complete.
      * simpl; lia.
  Qed.

End MMA2_ndMM2.

Theorem reduction : MMA2_HALTS_ON_ZERO ⪯ @ndMM2_ACCEPT nat.
Proof.
  apply reduces_dependent; exists.
  intros (P & v); vec2 v into a b.
  exists (existT _ (mma2_prog_enc P) (1,(a,b))).
  apply MMA2_ndMM2_equiv.
Qed.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import SetsClass.SetsClass. Import SetsNotation.
Require Import PV.Syntax.
Require Import PV.DenotationalSemantics.
Local Open Scope string.
Local Open Scope Z.
Local Open Scope sets.

Module HoareSimpleWhile.
Import Lang_SimpleWhile
       DntSem_SimpleWhile2
       DntSem_SimpleWhile3
       DntSem_SimpleWhile4.

Notation "x < y" := (ELt x y)
  (in custom expr_entry at level 13, no associativity).
Notation "x && y" := (EAnd x y)
  (in custom expr_entry at level 14, left associativity).
Notation "! x" := (ENot x)
  (in custom expr_entry at level 10).
Notation "x = e" := (CAsgn x e)
  (in custom expr_entry at level 18, no associativity).
Notation "c1 ; c2" := (CSeq c1 c2)
  (in custom expr_entry at level 20, right associativity).
Notation "'skip'" := (CSkip)
  (in custom expr_entry at level 10).
Notation "'if' e 'then' '{' c1 '}' 'else' '{' c2 '}'" := (CIf e c1 c2)
  (in custom expr_entry at level 19,
   e custom expr_entry at level 5,
   c1 custom expr_entry at level 99,
   c2 custom expr_entry at level 99,
   format  "'if'  e  'then'  '{'  c1  '}'  'else'  '{'  c2  '}'").
Notation "'while' e 'do' '{' c1 '}'" := (CWhile e c1)
  (in custom expr_entry at level 19,
   e custom expr_entry at level 5,
   c1 custom expr_entry at level 99).

(** 首先定义断言。*)

Definition assertion: Type := state -> Prop.

Definition derives (P Q: assertion): Prop :=
  forall s, P s -> Q s.

Definition logical_equiv (P Q: assertion): Prop :=
  forall s, P s <-> Q s.

Definition andp (P Q: assertion): assertion := fun s => P s /\ Q s.

Definition exp (P: Z -> assertion): assertion := fun s => exists n, P n s.

(** 下面的Notation定义可以跳过*)

Declare Custom Entry assn_entry.

Notation "( x )" := x
  (in custom assn_entry, x custom assn_entry at level 99).
Notation "x" := x
  (in custom assn_entry at level 0, x constr at level 0).
Notation "f x" := (f x)
  (in custom assn_entry at level 1, only parsing,
   f custom assn_entry,
   x custom assn_entry at level 0).

(* Notation "P '|--' Q" := (derives P Q)
  (at level 80,
   P custom assn_entry,
   Q custom assn_entry,
   no associativity).

Notation "P '--||--' Q" := (logical_equiv P Q)
  (at level 80,
   P custom assn_entry,
   Q custom assn_entry,
   no associativity). *)

Notation "x && y" := (andp x y)
  (in custom assn_entry at level 14, left associativity).

Notation "'exists' x , P" := (exp (fun x: Z => P))
  (in custom assn_entry at level 20,
      x constr at level 0,
      P custom assn_entry).

(** 下面定义霍尔三元组。*)

Inductive HoareTriple: Type :=
| BuildHoareTriple: assertion -> com -> assertion -> HoareTriple.

Notation "{{ P }}  c  {{ Q }}" :=
  (BuildHoareTriple P c Q) (at level 1,
                            P custom assn_entry at level 99,
                            Q custom assn_entry at level 99,
                            c custom expr_entry at level 99).

(** 一个布尔表达式为真是一个断言：*)

Definition eb2assn (b: expr_bool): assertion := fun s => eval_expr_bool b s = true.

(** 断言中描述整数的逻辑表达式（区分于程序表达式）：*)

Definition exprZ: Type := state -> Z.

(** 一个程序中的整数类型可以用作逻辑表达式：*)

Definition ei2exprZ (e: expr_int): exprZ :=
  eval_expr_int e.

(** 断言中的等号：*)

Definition exprZ_eq (e1 e2: exprZ): assertion :=
  fun s => e1 s = e2 s.

(** 程序状态中的替换：*)

Definition state_subst (s: state) (x: var_name) (v: Z): state :=
  fun y =>
    if String.eqb x y
    then v
    else s y.

(** 断言中的替换：*)

Definition assn_subst (P: assertion) (x: var_name) (v: exprZ): assertion :=
  fun s =>
    P (state_subst s x (v s)).

Definition exprZ_subst (u: exprZ) (x: var_name) (v: exprZ): exprZ :=
  fun s =>
    u (state_subst s x (v s)).

(** 下面的Notation定义可以跳过*)

Notation "[[ e ]]" := (eb2assn e)
  (in custom assn_entry at level 0,
      e custom expr_entry at level 99,
      only printing).

Notation "[[ e ]]" := (ei2exprZ e)
  (in custom assn_entry at level 0,
      e custom expr_entry at level 99,
      only printing).

Ltac any_expr e :=
  match goal with
  | |- assertion => exact (eb2assn e)
  | |- exprZ => exact (ei2exprZ e)
  | _ => match type of e with
         | expr_bool => exact (eb2assn e)
         | expr_int => exact (ei2exprZ e)
         end
  end.

Notation "[[ e ]]" := (ltac:(any_expr e))
  (in custom assn_entry,
      e custom expr_entry at level 99,
      only parsing).

Notation "u == v" := (exprZ_eq u v)
  (in custom assn_entry at level 10,
      u custom assn_entry,
      v custom assn_entry,
      no associativity).

Tactic Notation "unfold_substs" :=
  unfold exprZ_subst, assn_subst.

Tactic Notation "unfold_substs" "in" ident(H) :=
  unfold exprZ_subst, assn_subst in H.

Notation "'exprZ_subst' u x v" := (exprZ_subst u x v)
  (in custom assn_entry at level 1,
      u custom assn_entry at level 0,
      x custom assn_entry at level 0,
      v custom assn_entry at level 0).

Notation "'assn_subst' P x v" := (assn_subst P x v)
  (in custom assn_entry at level 1,
      P custom assn_entry at level 0,
      x custom assn_entry at level 0,
      v custom assn_entry at level 0).

(** 下面定义有效：*)

Definition valid: HoareTriple -> Prop :=
  fun ht =>
  match ht with
  | BuildHoareTriple P c Q =>
      forall s1 s2,
        P s1 ->
        eval_com c s1 s2 ->
        Q s2
  end.

Lemma hoare_skip_sound:
  forall P: assertion,
    valid {{ P }} skip {{ P }}.
Proof.
  simpl.
  unfold skip_sem.
  unfold_RELS_tac.
  intros.
  rewrite <- H0; tauto.
Qed.

Lemma hoare_seq_sound:
  forall (P Q R: assertion) (c1 c2: com),
    valid {{ P }} c1 {{ Q }} ->
    valid {{ Q }} c2 {{ R }} ->
    valid {{ P }} c1; c2 {{ R }}.
Proof.
  simpl.
  unfold seq_sem.
  unfold_RELS_tac.
  intros.
  destruct H2 as [s1' [? ?] ].
  specialize (H _ _ H1 H2).
  specialize (H0 _ _ H H3).
  apply H0.
Qed.

(** 习题：*)
Lemma hoare_if_sound:
  forall (P Q: assertion) (e: expr_bool) (c1 c2: com),
    valid {{ P && [[ e ]] }} c1 {{ Q }} ->
    valid {{ P && [[! e ]] }} c2 {{ Q }} ->
    valid {{ P }} if (e) then { c1 } else { c2 } {{ Q }}.
Proof.
  simpl.
  unfold if_sem, test_true, test_false.
  unfold_RELS_tac.
  intros.
  unfold andp, eb2assn in H, H0.
  simpl in H0.
  unfold not_sem in H0.
  destruct H2 as [ [? [ [? ?] ?] ] | [? [ [? ?] ?] ] ].
  - rewrite <- H3 in H4.
    exact (H _ _ (conj H1 H2) H4).
  - rewrite <- H3 in H4.
    specialize (H0 s1 s2).
    rewrite H2 in H0.
    simpl in H0.
    exact (H0 (conj H1 (eq_refl _)) H4).
Qed. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 习题：*)
Lemma hoare_while_sound:
  forall (P: assertion) (e: expr_bool) (c: com),
    valid {{ P && [[ e ]] }} c {{ P }} ->
    valid {{ P }} while (e) do { c } {{ P && [[! e ]] }}.
Proof.
  simpl.
  unfold while_sem.
  unfold_RELS_tac.
  intros.
  destruct H1.
  unfold andp, eb2assn.
  unfold andp, eb2assn in H.
  revert s1 s2 H0 H1.
  induction x;
  intros;
  simpl in H1;
  [ unfold test_false in H1 | unfold test_true in H1 ];
  revert H1; unfold_RELS_tac; intro;
  destruct H1.
  - split; rewrite <- H2; try tauto.
    simpl.
    unfold not_sem, negb.
    rewrite H1.
    reflexivity.
  - destruct H1 as [ [? ?] [s1' [? ?] ] ].
    rewrite <- H2 in H3.
    clear x0 H2.
    exact (IHx _ _ (H _ _ (conj H0 H1) H3) H4).
Qed. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

Lemma state_subst_fact:
  forall (s1 s2: state) (x: var_name),
    (forall y, x <> y -> s2 y = s1 y) ->
      state_subst s2 x (s1 x) = s1.
Proof.
  intros.
  apply functional_extensionality.
  intros y.
  unfold state_subst.
  destruct (String.eqb x y) eqn:EQ.
  + apply String.eqb_eq in EQ.
    rewrite EQ.
    reflexivity.
  + apply String.eqb_neq in EQ.
    apply H; tauto.
Qed.

(** 习题：*)
Lemma hoare_asgn_fwd_sound:
  forall P x e,
    valid {{ P }} x = e {{ exists x', exprZ_subst [[ e ]] x [[ x' ]] == [[ x ]] && assn_subst P x [[ x' ]] }}.
Proof.
  simpl.
  unfold asgn_sem, exp, andp, exprZ_eq, const_sem, var_sem, ei2exprZ.
  unfold_substs.
  intros.
  destruct H0.
  exists (s1 x).
  rewrite (state_subst_fact _ _ _ H1).
  exact (conj (eq_sym H0) H).
Qed. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

Lemma hoare_conseq_sound:
  forall (P P' Q Q' : assertion) (c : com),
    valid {{ P' }} c {{ Q' }} ->
    derives P P' ->
    derives Q' Q ->
    valid {{ P }} c {{ Q }}.
Proof.
  simpl.
  unfold derives.
  intros.
  apply H0 in H2.
  specialize (H _ _ H2 H3).
  apply H1.
  tauto.
Qed.

(** 下面定义可证：*)

Inductive provable: HoareTriple -> Prop :=
| hoare_skip:
    forall P: assertion,
      provable {{ P }} skip {{ P }}
| hoare_seq:
    forall (P Q R: assertion) (c1 c2: com),
      provable {{ P }} c1 {{ Q }} ->
      provable {{ Q }} c2 {{ R }} ->
      provable {{ P }} c1; c2 {{ R }}
| hoare_if:
    forall (P Q: assertion) (e: expr_bool) (c1 c2: com),
      provable {{ P && [[ e ]] }} c1 {{ Q }} ->
      provable {{ P && [[! e ]] }} c2 {{ Q }} ->
      provable {{ P }} if (e) then { c1 } else { c2 } {{ Q }}
| hoare_while:
    forall (P: assertion) (e: expr_bool) (c: com),
      provable {{ P && [[ e ]] }} c {{ P }} ->
      provable {{ P }} while (e) do { c } {{ P && [[! e ]] }}
| hoare_asgn_fwd:
    forall P x e,
      provable {{ P }} x = e {{ exists x', exprZ_subst [[ e ]] x [[ x' ]] == [[ x ]] && assn_subst P x [[ x' ]] }}
| hoare_conseq:
    forall (P P' Q Q': assertion) (c: com),
      provable {{ P' }} c {{ Q' }} ->
      derives P P' ->
      derives Q' Q ->
      provable {{ P }} c {{ Q }}.

Theorem hoare_sound : forall ht, provable ht -> valid ht.
  intros.
  induction H.
  - apply hoare_skip_sound.
  - apply (hoare_seq_sound _ Q); tauto.
  - apply hoare_if_sound; tauto.
  - apply hoare_while_sound; tauto.
  - apply hoare_asgn_fwd_sound; tauto.
  - apply (hoare_conseq_sound P P' Q Q'); tauto.
Qed.

End HoareSimpleWhile.

Require Import List.
Import ListNotations.

Inductive Permutation { A : Type } : list A -> list A -> Prop :=
| perm_nil : Permutation nil nil
| perm_skip (x : A) (l l' : list A) : Permutation l l' -> Permutation (x :: l) (x :: l')
| perm_swap (x y : A) (l : list A) : Permutation (x :: y :: l) (y :: x :: l)
| perm_trans (l1 l2 l3 : list A) : Permutation l1 l2 -> Permutation l2 l3 -> Permutation l1 l3.

Goal Permutation [1;3;5] [3;5;1].
intros.
apply (perm_trans _ [3;1;5]).
- apply perm_swap.
- apply perm_skip, perm_swap.
Qed.

Goal forall { A : Type } (l1 l2 : list A), Permutation l1 l2 -> Permutation l2 l1.
intros.
induction H.
- apply perm_nil.
- apply perm_skip; tauto.
- apply perm_swap.
- apply (perm_trans _ l2); tauto.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import variables.
Require Import variables_fun_rules.
Require Import states.
Require Import util.
Require Import fun_util.

(* EXPRESSION *)
Inductive VAR : Type :=
  | current  : VNAME -> VAR
  | previous : VNAME -> VAR.

Inductive OP : Type :=
  | le : OP
  | lt : OP
  | eq : OP
  | ne : OP
  | gt : OP
  | ge : OP.

Definition is_valid_op
(op : OP) (v : VALUE) : Prop :=
  match op with
  | le | lt | gt | ge => match v with
                         | b _ => False
                         | _   => True
                         end
  | _                 => True
  end.

Record BEXP : Set := mkBEXP {
  v : VAR ;
  op : OP ;
  literal : VALUE
}.

Definition ind_rules_disj (lb : list BEXP) : Prop :=
  0 < length lb.

Record DISJ : Set := mkDISJ {
  disjs : list BEXP

  ; rules_disj : ind_rules_disj disjs
}.

Record CONJ : Set := mkCONJ {
  conjs : list DISJ
}.

Definition EXP := CONJ.

Definition var_name (be : BEXP) : VNAME :=
  match be.(v) with
  | current vn  => vn
  | previous vn => vn
  end.

Fixpoint find_var_declaration (v : VNAME)
  (l : list (VNAME * TYPE)) : option (VNAME * TYPE) :=
    match l with
    | []     => None
    | h :: t => if bstring_dec (fst h).(vname)
                                v.(vname)
                then Some h
                else find_var_declaration v t
    end.

Definition var_consistent_be
(be : BEXP) (f T : list (VNAME * TYPE)) : Prop :=
    let n := var_name be in
    let value := be.(literal) in
    let op := be.(op) in
    let dom_f := map (fun x => fst x) f in
    let dom_T := map (fun x => fst x) T in
    let var := find_var_declaration n f in
      in_list n dom_f comp_vname
      /\ match var with
         | None   => False
         | Some p => is_valid_value value (snd p)
         end
      /\ is_valid_op op value
      /\ if bin_list n dom_T bcomp_vname
         then match be.(v) with
              | current _ => True
              | _         => False
              end
         else True.

Fixpoint var_consistent_dis
(disjs : list BEXP) (f T : list (VNAME * TYPE)) : Prop :=
  match disjs with
  | []      => True
  | h :: tl => var_consistent_be h f T
               /\ var_consistent_dis tl f T
  end.

Fixpoint var_consistent_conj
  (conjs : list DISJ) (f T : list (VNAME * TYPE)) : Prop :=
  match conjs with
  | []      => True
  | h :: tl => var_consistent_dis h.(disjs) f T
               /\ var_consistent_conj tl f T
  end.

Definition var_consistent_exp
  (exp : EXP) (f T : list (VNAME * TYPE)) : Prop :=
    var_consistent_conj exp.(conjs) f T.

(* ASSIGNMENT *)
Record ASGMT : Set := mkASGMT {
  asgmt : VNAME * VALUE
}.

Definition ind_rules_asgmts (l : list ASGMT) : Prop :=
  (0 < (length l))
  /\ is_function l
        (fun (asgmt1 asgmt2 : ASGMT)
              => string_dec
                   (fst asgmt1.(asgmt)).(vname)
                   (fst asgmt2.(asgmt)).(vname)).

Record ASGMTS : Set := mkASGMTS {
  asgmts : list ASGMT

  ; rules_asgmts : ind_rules_asgmts asgmts
}.

Fixpoint is_valid_asgmts_names
  (la : list ASGMT) (ln : list VNAME) : Prop :=
    match la with
    | [] => True
    | h :: t =>
        in_list h ln
          (fun a v => comp_vname (fst a.(asgmt)) v)
        /\ is_valid_asgmts_names t ln
    end.

Fixpoint well_typed_asgmts
  (la : list ASGMT) (f : list (VNAME * TYPE)) : Prop :=
    is_valid_asgmts_names la (map (fun x => fst x) f)
    /\
    (
      match la with
      | []      => True
      | h :: tl => (let
                      var := find_var_declaration (fst h.(asgmt)) f
                    in
                    match var with
                    | None   => False
                    | Some p => is_valid_value
                                (snd h.(asgmt))
                                (snd p)
                    end
                   ) /\ well_typed_asgmts tl f
      end
    ).

(* FUNCTION *)
Definition REQUIREMENT := string.

Fixpoint ind_rules_function
  (l : list (EXP * EXP * ASGMTS * REQUIREMENT) ) : Prop :=
    match l with
    | []      => True
    | h :: tl => (let
                    sGuard := (fst (fst (fst h)))
                  in
                  let
                    tGuard := (snd (fst (fst h)))
                  in
                  0 < List.length (sGuard.(conjs) ++ tGuard.(conjs))
                 ) /\ ind_rules_function tl
    end.

Record FUNCTION : Set := mkFUNCTION {
  function : list (EXP * EXP * ASGMTS * REQUIREMENT) ;
  rules_function : ind_rules_function function
}.

Definition ind_rules_dfrs_functions
  (lf : list FUNCTION) : Prop :=
    0 < (List.length lf).

Record DFRS_FUNCTIONS : Set := mkDFRS_FUNCTIONS {
  F : list FUNCTION

  ; rules_dfrs_functions : ind_rules_dfrs_functions F
}.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq order.
From mathcomp Require Import ssralg ssrnum ssrint rat.
From fourcolor Require Import real.
From Coq Require Import Setoid Morphisms.

(******************************************************************************)
(*   Construcion of the real numbers as a complete totally ordered field.     *)
(* We use the standard Dedekind cut construction, assuming only a classical   *)
(* excluded middle assumption. We repeat small parts of the generic theory of *)
(* reals (see realprop.v), e.g., the setoid structure, absolute values and    *)
(* definitions by cases, to aid in the definition of multiplication and       *)
(* inverse (the latter defined as a sup). Note that there are three kinds of  *)
(* comparisons involved in this construction:                                 *)
(*      (a < b)%R, (a <= b)%R : boolean comparison of rationals               *)
(*              x < a, x >= a : comparison of a rational a with a cut x.      *)
(*                              x >= a is notation for ~ (x < a).             *)
(*                     x <= y : cut comparison.                               *)
(* The rat >-> cut coercion we define is such that (a < b)%R and a < b are    *)
(* convertible. However a >= x and x <= a are equivalent but NOT convertible, *)
(* and neither are (a <= b)%R, a <= b, and b >= a.                            *)
(*   In addition to the comaprisons above we also define internally the usual *)
(* arithmetic operations (0, 1, +, *, -, ^-1) on cuts, along with             *)
(*             x == y, x != y : (setoid) cut (in)equality.                    *)
(*    `|x|, '|x|*|y|, `|x|^-1 : absolute value, producy, inverse of abs.      *)
(* Our main result is an opaque Dedekind.real : excluded_middle -> Real.model *)
(* theorem, which we also export in a transparent form Dedekind.model that    *)
(* exposes the cut construction.                                              *)
(******************************************************************************)

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

Import Order.TTheory GRing.Theory Num.Theory.

Module Dedekind.

Section Construction.

(* Classical Prop. *)
Hypothesis classical : excluded_middle.
Lemma notK P : ~ ~ P <-> P. Proof. by case: (classical P); split=> // ? ?. Qed.

(* We use nontrivial open filters of rat to represent the reals. *)

Implicit Types a b c d e f g : rat.
Implicit Types m : int.
Implicit Types n i : nat.

(* Dedekind cuts. *)

Declare Scope cut_scope.
Delimit Scope cut_scope with cut.
Open Scope cut_scope.

Notation "{ x | E }" := (fun x => E) : cut_scope.

Variant is_cut (X : rat -> Prop) : Prop :=
  IsCut (ub : exists a, X a)
        (lb : exists a, ~ X a)
        (filter : forall a b, X a -> (a < b)%R -> X b)
        (open : forall a, X a -> exists2 b, X b & (b < a)%R).

Record cut := Cut {ltc; _ : is_cut ltc}.
Arguments ltc : simpl never.

Implicit Types x y z : cut.
Implicit Types E F : cut -> Prop.

Bind Scope cut_scope with cut.

Lemma ltcE ltc_x x_cut : ltc (@Cut ltc_x x_cut) = ltc_x. Proof. by []. Qed.

Notation "x < a" := (ltc x a) : cut_scope.
Notation "x >= b" := (~ ltc x b)  : cut_scope.

Lemma ltcP x a : x < a \/ x >= a. Proof. exact: classical. Qed.

Lemma cut_ub x : exists a, x < a. Proof. by case: x => x []. Qed.

Lemma cut_lb x : exists b, x >= b. Proof. by case: x => x []. Qed.

Lemma ltc_trans x a b : x < a -> (a < b)%R -> x < b.
Proof. by case: x a b => x []. Qed.

Lemma open x a : x < a -> exists2 b, x < b & (b < a)%R.
Proof. by case: x a => x []. Qed.

Lemma ltc_le_trans x a b : x < a -> (a <= b)%R -> x < b.
Proof. by rewrite le_eqVlt => ltxa /predU1P[<-//| /(ltc_trans ltxa)]. Qed.

Lemma gec_lt_trans a x b : x >= a -> x < b -> (a < b)%R.
Proof. by case: ltrP => // /ltc_le_trans-leba leax /leba. Qed.

Lemma le_gec_trans a b x : (a <= b)%R -> x >= b -> x >= a.
Proof. by move=> leab lebx ltxa; apply: lebx (ltc_le_trans ltxa leab). Qed.

Lemma lt_gec_trans a b x : (a < b)%R -> x >= b -> x >= a.
Proof. by move/ltW; apply: le_gec_trans. Qed.

(* The preorder on cuts. *)

Definition leR x y := forall a, y < a -> x < a.

Notation "x <= y" := (leR x y) : cut_scope.

Definition eqR x y := x <= y /\ y <= x.

Notation "x == y" := (eqR x y) : cut_scope.
Notation "x != y" := (~ (x == y)) : cut_scope.

Lemma leRR x : x <= x. Proof. by []. Qed.
Arguments leRR x : clear implicits.

Lemma eqRR x : x == x. Proof. by split. Qed.
Hint Resolve leRR eqRR : core.

Lemma eqR_sym x y : x == y -> y == x. Proof. by case. Qed.

Lemma leR_ltc_trans x y a : x <= y -> y < a -> x < a.
Proof. exact. Qed.

Lemma gec_leR_trans a x y : x >= a -> x <= y -> y >= a.
Proof. by move=> leax lexy /lexy. Qed.

Lemma leR_trans x y z : x <= y -> y <= z -> x <= z.
Proof. by move=> le_xy le_yz a /le_yz/le_xy. Qed.

Lemma eqR_trans x y z : x == y -> y == z -> x == z.
Proof. by case=> lexy leyx [leyz lezy]; split=> a; auto. Qed.

Add Relation cut eqR
  reflexivity proved by eqRR
  symmetry proved by eqR_sym
  transitivity proved by eqR_trans
as eqR_setoid.

Instance ltc_Proper : Proper (eqR ==> eq ==> iff) ltc.
Proof. by move=> x y [lexy leyx] _ a ->; split=> [/leyx | /lexy]. Qed.

Instance leR_Proper : Proper (eqR ==> eqR ==> iff) leR.
Proof.
by move=> x1 x2 Dx y1 y2 Dy; split=> le_x a; have:= le_x a; rewrite Dx Dy.
Qed.

(* Embedding of Q. *)

Fact lt_is_cut a : is_cut {b | a < b}%R.
Proof.
split=> [||b c /lt_trans| b /midf_lt[ltac ltcb]]; last 2 [exact].
- by exists (a + 1)%R; rewrite ltr_addl.
- by exists a; rewrite ltxx.
by exists ((a + b) / 2%:R)%R.
Qed.

Coercion ratR a := Cut (lt_is_cut a).
Notation "0" := (ratR 0) : cut_scope.
Notation "1" := (ratR 1) : cut_scope.

Lemma leRq a x : x >= a <-> a <= x.
Proof. by split=> [/gec_lt_trans | leax /leax]; last rewrite ltcE ltxx. Qed.

Lemma ltcW a x : x < a -> x <= a. Proof. by move/ltc_trans. Qed.

(* Supremum definition and properties. *)

Definition has E := exists x, E x.

Definition ub E := {z | forall y, E y -> y <= z}.

Definition down E := {x | exists2 y, E y & x <= y}.

Definition has_sup E := has E /\ has (ub E).

Definition lt_sup E a := exists2 b, forall x, E x -> x < b & b < a.

Fact sup_is_cut E : is_cut {a | IF has_sup E then lt_sup E a else 0 < a}.
Proof.
split=> [||a b ltEa ltab| a].
- have [supE|] := classical (has_sup E); last by exists 1%R; right.
  have [_ [x ubEx]] := supE; have [a /open[b ltab ltbx]] := cut_ub x.
  by exists a; left; split; last by exists b => // y /ubEx/leR_ltc_trans; apply.
- have [supE|] := classical (has_sup E); last by exists 0%R => -[][].
  have [[y Ey] _] := supE; have [a leay] := cut_lb y.
  by exists a => -[][] // _ [b ltEb /lt_gec_trans/(_ leay)[]]; apply: ltEb.
- case: ltEa => -[supE ltEa]; last by right; rewrite ltcE (lt_trans ltEa).
  by have [c] := ltEa; left; split=> //; exists c; last apply: lt_trans ltab.
case=> -[supE]  => [supEa | /open[c]]; last by exists c; first right.
have [c ltEc /open[b ltcb ltba]] := supEa.
by exists b; first by left; split; last exists c.
Qed.

Definition sup E := Cut (sup_is_cut E).

Lemma sup_default E : ~ has_sup E -> sup E == 0.
Proof. by split=> [|a [] [] //]; right. Qed.

Instance sup_Proper : Proper (pointwise_relation cut iff ==> eqR) sup.
Proof.
move=> E F eqEF.
have eq_ub x: ub E x <-> ub F x by split=> ub_x y /eqEF/ub_x.
have eq_has_sup: has_sup E <-> has_sup F.
  by split=> -[[y /eqEF-Ey] [x /eq_ub-ubEx]]; (split; [exists y | exists x]).
have eq_sup a: lt_sup E a <-> lt_sup F a.
  by split=> -[b ltEb ltba]; exists b => // x /eqEF/ltEb.
have [supE | not_supE] := classical (has_sup E).
  by split=> a; rewrite !ltcE /IF_then_else eq_has_sup eq_sup.
by rewrite !sup_default // -eq_has_sup.
Qed.

Section SupProperties.

Variables (E : cut -> Prop) (x : cut).

Hypothesis has_supE : has_sup E.

Lemma sup_ub : ub E (sup E).
Proof. by move=> y Ey a [][]// _ [b ltEb]; apply/ltc_trans/ltEb. Qed.

Lemma sup_le_ub y : ub E y -> sup E <= y.
Proof.
by move=> ubEy a /open[b]; left; split; last by exists b => // z ?; apply: ubEy.
Qed.

Lemma sup_total : down E x \/ sup E <= x.
Proof.
have [|leEx] := classical (down E x); [by left | right].
apply: sup_le_ub => // y Ey a ltxa; apply/notK=> /leRq-leay; case: leEx.
by exists y => // b ltyb; apply/(ltc_trans ltxa)/(leR_ltc_trans leay).
Qed.

End SupProperties.

Lemma def_sup E x : E x -> ub E x -> sup E == x.
Proof.
move=> Ex ubEx; have supE: has_sup E by split; exists x.
by split; [apply: sup_le_ub | apply: sup_ub].
Qed.

(* Definition by cases *)

Section If.

Variables (P : Prop) (x1 x2 : cut).

Definition ifR := sup (fun x => IF P then x == x1 else x == x2).

Variant ifR_spec : cut -> Prop :=
  | IfR_true of  P & ifR == x1 : ifR_spec ifR
  | IfR_not of ~ P & ifR == x2 : ifR_spec ifR.

Lemma ifR_cases : ifR_spec ifR.
Proof.
have [haveP | notP] := classical P; [left | right] => //.
  by apply: def_sup => [|y []-[_ []] //]; left.
by apply: def_sup => [|y []-[_ [] //]]; right.
Qed.

End If.

Instance ifR_Proper : Proper (iff ==> eqR ==> eqR ==> eqR) ifR.
Proof.
rewrite /ifR /IF_then_else => P Q eqPQ x1 x2 Dx y1 y2 Dy.
by setoid_rewrite eqPQ; setoid_rewrite Dx; setoid_rewrite Dy.
Qed.

(* Opposite. *)

Definition opp_cut x := {a | exists2 b, (- a < b)%R & x >= b}.

Fact opp_is_cut x : is_cut (opp_cut x).
Proof.
split=> [||a b [c lt_na_c lecx] | a [b /(@open (- a)%R)[c lt_na_c ltcb] lebx]].
- by have [a leax] := cut_lb x; exists (1 - a)%R, a; rewrite // opprB gtr_addl.
- have [a ltxa] := cut_ub x; exists (- a)%R => -[b ltab []].
  by apply: ltc_trans ltab; rewrite opprK.
- by exists c; first by apply: lt_trans lt_na_c; rewrite ltr_opp2.
by exists (- c)%R; [exists b; rewrite ?opprK | rewrite ltr_oppl].
Qed.

Definition opp x := Cut (opp_is_cut x).
Notation "- x" := (opp x) : cut_scope.

Lemma leR_opp2 x y : x <= y -> - y <= - x.
Proof. by move=> lexy a [b ltab ltyb]; exists b => // /lexy. Qed.

Instance opp_Proper : Proper (eqR ==> eqR) opp.
Proof. by move=> x y []; split; apply: leR_opp2. Qed.

Lemma gec0_opp x : x < 0 -> - x >= 0.
Proof. by move=> ltx0 [a lt0a []]; apply: ltc_trans lt0a; rewrite oppr0. Qed.

Lemma opp_ind E :
  (forall x, E (- x) -> E x) -> (forall x, x >= 0 -> E x) -> forall x, E x.
Proof. by move=> IHopp IHpos x; case: (ltcP x 0) gec0_opp; auto. Qed.

Lemma oppK x : - (- x) == x.
Proof.
split=> [a /open[b ltxb ltba] | a [b lt_na_b le_b_nx]].
  by exists (- b)%R => [|[c]]; rewrite ?ltr_opp2 ?opprK => // /(ltc_trans ltxb).
by apply/notK=> leax; case: le_b_nx; exists a; rewrite // ltr_oppl.
Qed.

Lemma eqR_opp2 x y : opp x == opp y -> x == y.
Proof. by move=> eq_nx_ny; rewrite -(oppK x) eq_nx_ny oppK. Qed.

(* Absolute value *)

Definition abs_cut x := {a | x < a /\ - x < a}.

Definition abs_is_cut x : is_cut (abs_cut x).
Proof.
split=> [||a b [ltxa ltnxa] ltab | a [ltxa ltnxa]].
- have [[a ltxa] [b ltnxb]] := (cut_ub x, cut_ub (- x)).
  case: (ltrP b a); first by exists a; split; last apply: ltc_trans ltnxb _.
  by exists b; split; first apply: ltc_le_trans ltxa _.
- by exists 0%R => -[lt0x [a lt0a []]]; apply: ltc_trans lt0a; rewrite oppr0.
- by split; apply: ltc_trans ltab.
have [[b1 ltxb1 ltab1] [b2 ltnxb2 ltab2]] := (open ltxa, open ltnxa).
have [ltb21 | leb12] := ltrP b2 b1.
  by exists b1 => //; split; last apply: ltc_trans ltnxb2 _.
by exists b2 => //; split; first apply: ltc_le_trans ltxb1 _.
Qed.

Definition abs x := Cut (abs_is_cut x).
Local Notation "`| x |" := (abs x) : cut_scope.

Instance abs_Proper : Proper (eqR ==> eqR) abs.
Proof. by move=> x y Dx; split=> a; rewrite !ltcE /abs_cut Dx. Qed.

Lemma abs_ge0 x : 0 <= `|x|.
Proof.
by apply/leRq=> -[lt0x [a lt0a []]]; apply: ltc_trans lt0a; rewrite oppr0.
Qed.

Lemma ge0_abs x : x >= 0 -> `|x| == x.
Proof.
move=> le0x; split=> [a ltxa | a []//]; split=> //.
by exists 0%R; rewrite // oppr_lt0; apply/leRq: a ltxa.
Qed.

Lemma absN x : `|- x| == `|x|.
Proof. by split=> a; rewrite !ltcE /abs_cut oppK => -[]. Qed.

(* Addition. *)

Definition add_cut x y := {a | exists2 b, x < b & y < a - b}.

Fact add_is_cut x y : is_cut (add_cut x y).
Proof.
split=> [|| a b [c ltxc ltyac] ltab | a [b ltxb /open[c ltyc ltcab]]].
- have [[a ltxa] [b ltyb]] := (cut_ub x, cut_ub y).
  by exists (b + a)%R, a; rewrite ?addrK.
- have [[a leax] [b /leRq-leby]] := (cut_lb x, cut_lb y).
  exists (b + a)%R => -[c ltxc /leby].
  by rewrite ltcE ltr_subr_addr ltr_add2l => /(ltc_trans ltxc).
- by exists c => //; apply: ltc_trans ltyac _; rewrite ltr_add2r.
by exists (c + b)%R; [exists b; rewrite ?addrK | rewrite -ltr_subr_addr].

Qed.

Definition add x y := Cut (add_is_cut x y).
Infix "+" := add : cut_scope.
Notation "x - y" := (x + (- y)) : cut_scope.

Instance add_Proper : Proper (eqR ==> eqR ==> eqR) add.
Proof.
move=> x1 x2 Dx y1 y2 Dy.
by split=> b [a ltxa ltyba]; exists a; rewrite ?Dx ?Dy in ltxa ltyba *.
Qed.

Lemma add_monotony x y z : y <= z -> x + y <= x + z.
Proof. by move=> leyz b [a ltxa /leyz]; exists a. Qed.

Lemma addC x y : x + y == y + x.
Proof.
by split=> a [b ltxb ltyab]; exists (a - b)%R; rewrite // opprD addNKr opprK.
Qed.

Lemma addA x y z : x + (y + z) == x + y + z.
Proof.
wlog suffices: x y z / x + y + z <= x + (y + z).
  by split; rewrite // -!(addC z) !(addC x).
move=> c [a ltxa [b ltyb ltzc]]; exists (a + b)%R; last by rewrite opprD addrA.
by exists a; last rewrite addrC addKr.
Qed.

Lemma addN x : x - x == 0.
Proof.
apply eqR_sym; split=> [c [a ltxa [b lt_ac_b /leRq-lebx]] | d d_gt0].
  by rewrite ltcE -(ltr_addr (- a)) ltr_oppl (lt_trans lt_ac_b) ?lebx.
have [[a ltxa] [b lebx]] := (cut_ub x, cut_lb x).
have{a ltxa d_gt0} []: exists n, x < b + d *+ n.
  have ltab: (0 < a - b)%R by move/leRq in lebx; rewrite subr_gt0 lebx.
  pose c := ((a - b) / d)%R; have c_ge0: (0 <= c)%R by rewrite ltW ?divr_gt0.
  exists `|numq c|%N; apply: ltc_le_trans ltxa _; rewrite -ler_subl_addl.
  rewrite pmulrn gez0_abs -?ge_rat0 // -mulrzl numqE mulrAC.
  by rewrite divfK ?gt_eqF ?ler_pmulr // ler1z -gtz0_ge1 denq_gt0.
elim=> [|n IHn]; rewrite ?addr0 // mulrSr => /open[a ltxa lt_a_dnd].
have [/IHn//| le_bdn_x] := classical (x < b + d *+ n).
by exists a => //; exists (b + d *+ n)%R; rewrite // opprB ltr_subl_addr -addrA.
Qed.

Lemma add0 x : 0 + x == x.
Proof.
split=> [a /open[b ltxb ltba] | a [b b_gt0] ltxab].
  by exists (a - b)%R; [rewrite ltcE subr_gt0 | rewrite opprD opprK addNKr].
by apply: ltc_trans ltxab _; rewrite gtr_addl oppr_lt0.
Qed.

Lemma opp0 : - 0 == 0. Proof. by rewrite -[opp 0]add0 addN. Qed.

Lemma oppD x y : - (x + y) == - x - y.
Proof.
rewrite addC -[- x - y]add0 -(addN (y + x)) -addA [- _ + _]addC addA.
by rewrite -(addA y) (addA x) !(addN, add0).
Qed.

Lemma gec0N_eq0 x : x >= 0 -> - x >= 0 -> x == 0.
Proof. by move/leRq=> le0x /leRq/leR_opp2; rewrite oppK opp0. Qed.

(* Multiplication. *)

Definition amul_cut x y := {a | exists2 b, `|x| < b & `|y| < a / b}.

Fact amul_is_cut x y : is_cut (amul_cut x y).
Proof.
split=> [|| a b [c ltxc ltyac] ltab | a [b ltxb /open[c ltyc ltcab]]].
- have [[a ltxa] [b ltyb]] := (cut_ub `|x|, cut_ub `|y|).
  by exists (b * a)%R, a; rewrite ?mulfK ?gt_eqF // (abs_ge0 ltxa).
- by exists 0%R => -[a _ /abs_ge0]; rewrite mul0r ltcE ltxx.
- exists c => //; have c_gt0: 0 < c := abs_ge0 ltxc.
  by apply: ltc_trans ltyac _; rewrite ltr_pmul2r ?invr_gt0.
have b_gt0: 0 < b := abs_ge0 ltxb.
by exists (c * b)%R; first exists b; rewrite -?ltr_pdivl_mulr ?mulfK ?gt_eqF.
Qed.

Definition amul x y := Cut (amul_is_cut x y).
Notation "`| x |*| y |" := (amul x y)
  (at level 0, x, y at level 99, format "`| x |*| y |") : cut_scope.

Definition mul x y := ifR (x < 0 <-> y < 0) `|x|*|y| (- `|x|*|y|).
Infix "*" := mul : cut_scope.

Instance amul_Proper : Proper (eqR ==> eqR ==> eqR) amul.
Proof.
move=> x1 x2 Dx y1 y2 Dy.
by split=> b [a ltxa ltyba]; exists a; rewrite ?Dx ?Dy in ltxa ltyba *.
Qed.

Instance mul_Proper : Proper (eqR ==> eqR ==> eqR) mul.
Proof. by move=> x1 x2 Dx y1 y2 Dy; rewrite /mul Dx Dy. Qed.

Lemma amul_ge0 {x y} : `|x|*|y| >= 0.
Proof. by case=> a _ /abs_ge0; rewrite ltcE mul0r ltxx. Qed.

Lemma ge0_mul x y : x >= 0 -> y >= 0 -> x * y == `|x|*|y|.
Proof. by rewrite /mul => le0x le0y; case: ifR_cases => [|[]]. Qed.

Lemma amulC x y : `|x|*|y| == `|y|*|x|.
Proof.
without loss suffices: x y / `|y|*|x| <= `|x|*|y| by [].
move=> b [a ltxa ltyba]; exists (b / a)%R; rewrite // invf_div mulrC divfK //.
by rewrite gt_eqF // -(mul0r a) -ltr_pdivl_mulr (abs_ge0 ltxa, abs_ge0 ltyba).
Qed.

Lemma amulA x y z : `|x|*|`|y|*|z| | == `| `|x|*|y| |*|z|.
Proof.
without loss suffices: x y z / `| `|x|*|y| |*|z| <= `|x|*|`|y|*|z| |.
  by split=> //; rewrite !(amulC x) -!(amulC z).
move=> c [a ltxa [[b ltyb ltz_cab] _]]; have a_gt0: 0 < a := abs_ge0 ltxa.
exists (a * b)%R; last by rewrite invfM mulrA.
by rewrite (ge0_abs amul_ge0); exists a; rewrite //= mulrC mulKf ?gt_eqF.
Qed.

Lemma amul0 x : `|0|*|x| == 0.
Proof.
split=> [a a_gt0|]; last exact/leRq/amul_ge0.
have [b lexb] := cut_ub `|x|; have b_gt0 := abs_ge0 lexb.
exists (a / b)%R; first by rewrite ltcE /abs_cut opp0 ltcE divr_gt0.
by rewrite invfM invrK mulVKf ?gt_eqF.
Qed.

Lemma mulC x y : x * y == y * x.
Proof. by rewrite /mul [_ <-> _]and_comm amulC. Qed.

Lemma amulN x y : `|- x|*|y| == `|x|*|y|.
Proof. by split=> a [b]; do 2?[rewrite absN | exists b]. Qed.

Lemma mulNR x y : - x * y == - (x * y).
Proof.
elim/opp_ind: x => [x | x le0x]; first by rewrite oppK => ->; rewrite oppK.
rewrite /mul amulN; case: ifR_cases => le0nx ->; case: ifR_cases => gt0y ->;
  rewrite ?oppK // (gec0N_eq0 le0x) ?amul0 ?opp0 // ?le0nx -?gt0y // => gt0nx.
by case: gt0y; split=> // gt0y; case: le0nx.
Qed.

Lemma mulRN x y : x * - y == - (x * y).
Proof. by rewrite !(mulC x) mulNR. Qed.

Lemma mulA x y z : x * (y * z) == x * y * z.
Proof.
elim/opp_ind: x => [* | x le0x]; first by apply: eqR_opp2; rewrite -!mulNR.
elim/opp_ind: y => [y IHy | y le0y].
  by apply: eqR_opp2; rewrite -mulRN -mulNR IHy mulRN mulNR.
elim/opp_ind: z => [* | z le0z]; first by apply: eqR_opp2; rewrite -!mulRN.
by rewrite !ge0_mul ?amulA //; apply: amul_ge0.
Qed.

Lemma mulDr x y z : x * (y + z) == x * y + x * z.
Proof.
elim/opp_ind: x => [x IHx | x le0x].
  by apply/eqR_opp2; rewrite oppD -!mulNR IHx.
elim/opp_ind: y => [y IHy | y le0y] in z *.
  by apply/eqR_opp2; rewrite oppD -!mulRN oppD IHy.
without loss le0z: y z le0y / z >= 0.
  move=> IHz; have [/gec0_opp-le0nz | /(IHz y)->//] := ltcP z 0.
  move Dt: (y + z) => t; have {} Dt: y + z == t by rewrite Dt.
  elim/opp_ind: t => [t IHt | t le0t] in y z Dt le0y le0nz *.
    by apply/eqR_opp2; rewrite oppD -!mulRN addC -IHt ?oppK // addC -oppD Dt.
  rewrite -(add0 (x * t)) -(addN (x * z)) -mulRN -addA -{}IHz //.
  by rewrite addC -Dt (addC y) addA -(addC z) addN add0.
have [/leRq-leR0y /leRq-leR0z] := (le0y, le0z).
have le0yz: y + z >= 0 by move/(add_monotony leR0z); rewrite addC add0.
rewrite !ge0_mul //; symmetry; split=> [c [a ltxa] | c [d [a1 ltxa1]]].
  rewrite ge0_abs // => -[b ltyb ltz_cab]; have a_gt0 := abs_ge0 ltxa.
  exists (b * a)%R, a => //; first by rewrite mulfK ?gt_eqF // ge0_abs.
  by rewrite mulrBl mulfK ?gt_eqF // ge0_abs.
rewrite ge0_abs // => lty_da1 [a2]; rewrite (ge0_abs le0z) // => ltxa2 ltz_cda2.
have [a ltxa [lea1 lea2]]: exists2 a, `|x| < a & (a <= a1)%R /\ (a <= a2)%R.
  exists (Num.min a1 a2); first by rewrite fun_if; case: ifP.
  by apply/andP; rewrite -lexI.
have [[a_gt0 a1_gt0] a2_gt0] := (abs_ge0 ltxa, abs_ge0 ltxa1, abs_ge0 ltxa2).
have dgt0: 0 < d by move/leR0y: lty_da1; rewrite ltcE pmulr_lgt0 ?invr_gt0.
have cdgt0: 0 < c - d.
  by move/leR0z: ltz_cda2; rewrite ltcE pmulr_lgt0 ?invr_gt0.
exists a; rewrite // (ge0_abs le0yz); exists (d / a)%R; last rewrite -mulrBl.
  by apply: ltc_le_trans lty_da1 _; rewrite ler_pmul2l ?lef_pinv.
by apply: ltc_le_trans ltz_cda2 _; rewrite ler_pmul2l ?lef_pinv.
Qed.

Lemma mul1 x : 1 * x == x.
Proof.
elim/opp_ind: x => [x IHx | x le0x].
  by apply eqR_opp2; rewrite -IHx mulRN.
rewrite ge0_mul //; split=> [b /open[a ltxa ltab] | b [a [lt1a _] ltxba]].
  have a_gt0: 0 < a by apply/leRq: (a) ltxa.
  by rewrite amulC; exists a; rewrite ge0_abs // ltcE ltr_pdivl_mulr ?mul1r.
have a_gt0: 0 < a by apply: lt_trans lt1a.
have b_gt0: 0 < b by rewrite ltcE -(mul0r a) -ltr_pdivl_mulr ?(abs_ge0 ltxba).
rewrite -[x]ge0_abs //; apply: ltc_trans ltxba _.
by rewrite gtr_pmulr ?invf_lt1.
Qed.

Lemma mul_monotony x y z : 0 <= x -> y <= z -> x * y <= x * z.
Proof.
move=> le0x leyz; set xy := mul x y; pose t := add (- y) z.
have le0t: 0 <= t by rewrite -(addN y) addC; apply: add_monotony.
rewrite -(add0 z) -(addN y) -addA -/t mulDr -[xy]add0 addC -/xy.
by rewrite ge0_mul => [|/le0x|/le0t] //; apply/add_monotony/leRq/amul_ge0.
Qed.

(* Inverse. *)

Definition ainv x := sup {y | `|x|*|y| < 1}.
Notation "`| x |^-1" := (ainv x)
  (at level 0, x at level 99, format "`| x |^-1") : cut_scope.
Definition inv x := ifR (x < 0) (- `|x|^-1) `|x|^-1.
Notation "x ^-1" := (inv x) : cut_scope.

Instance ainv_Proper : Proper (eqR ==> eqR) ainv.
Proof. by move=> x y Dx; rewrite /ainv; setoid_rewrite Dx. Qed.

Instance inv_Proper : Proper (eqR ==> eqR) inv.
Proof. by move=> x y Dx; rewrite /inv Dx. Qed.

Lemma ainv0 : ainv 0 == 0.
Proof.
apply: sup_default => -[_ [z ub_z]].
by have [a /notK[]] := cut_ub z; apply/leRq/ub_z; rewrite amul0.
Qed.

Lemma invN x : (- x)^-1 == - x^-1.
Proof.
rewrite /inv /`|_|^-1; setoid_rewrite amulN; rewrite -/`|x|^-1.
have [/gec0_opp-le0nx -> | le0x ->] := ifR_cases (x < 0).
  by rewrite oppK; case: ifR_cases.
by case: ifR_cases => // /(gec0N_eq0 le0x)-> ->; rewrite ainv0 opp0.
Qed.

Lemma mulV x : x != 0 -> x * x^-1 == 1.
Proof.
elim/opp_ind: x => [x IHx | x le0x] nz_x.
  by rewrite -(oppK x^-1) -invN mulRN -mulNR IHx // -opp0 => /eqR_opp2.
rewrite /inv; set y := `|x|^-1; case: ifR_cases => // _ ->.
have{nz_x} [a lt0a leax]: exists2 a, 0 < a & x >= a.
  by have [[a] | /(gec0N_eq0 le0x)//] := ltcP (- x) 0; rewrite oppr0; exists a.
pose E z := `|x|*|z| < 1; have E_0: E 0 by rewrite /E amulC amul0.
have supE: has_sup E.
  split; [by exists 0 | exists a^-1%R => //].
  move=> z [b ltxb [lt_z_vb _]]; apply/ltcW/(ltc_trans lt_z_vb).
  by rewrite mul1r (ltf_pinv (abs_ge0 ltxb)) ?(gec_lt_trans _ ltxb) // => -[].
have ubEy: ub E y by apply: sup_ub.
have le0y: y >= 0 by apply/leRq/ubEy.
rewrite ge0_mul //; split=> [b lt1b | b [c ltxc [ltybc _]]]; last first.
  have [d ltxd ltdc] := open ltxc.
  have [c_gt0 d_gt0] := (abs_ge0 ltxc, abs_ge0 ltxd).
  suffices: (1 / c < b / c)%R by rewrite ltr_pmul2r ?invr_gt0.
  apply: gec_lt_trans ltybc; apply/leRq/ubEy; exists d => //.
  by rewrite !mul1r ge0_abs ltcE ?ltf_pinv // lt_gtF ?invr_gt0.
have lt0b: 0 < b by apply: lt_trans lt1b.
pose e := (1 - b^-1)%R; have lt0e: 0 < e by rewrite ltcE subr_gt0 invf_lt1.
have [c ltxc [d lt_cea_d ledx]]: x - x < a * e by rewrite addN ltcE mulr_gt0.
have ltac: a < c := gec_lt_trans leax ltxc.
have lt0c: 0 < c := lt_trans lt0a ltac.
have lt0d: 0 < d.
  apply: lt_trans lt_cea_d; rewrite opprB subr_gt0 mulrBr mulr1.
  by rewrite ltr_snsaddr // oppr_lt0 divr_gt0.
have le_y_vd: y <= d^-1%R.
  apply/sup_le_ub=> // z -[f ltxf [lt_z_vf _]]; apply/ltcW/(ltc_trans lt_z_vf).
  by rewrite mul1r (ltf_pinv (abs_ge0 ltxf)) ?(gec_lt_trans _ ltxf) // => -[].
exists c; rewrite ge0_abs //; apply: le_y_vd; rewrite ltcE.
rewrite -invf_div ltf_pinv ?rpred_div //; apply: lt_trans lt_cea_d.
by rewrite ltr_oppr -[c in (_ - c)%R]mulr1 ltr_subl_addl -mulrBr ltr_pmul2r.
Qed.

Definition structure := Real.Structure leR sup add 0 opp mul 1 inv.

Lemma axioms : Real.axioms structure.
Proof.
move: leRR leR_trans sup_ub sup_total add_monotony addC addA add0 addN.
by move: mul_monotony mulC mulA mulDr mul1 mulV; split=> //= -[/leRq[]].
Qed.

Definition model := Real.Model axioms.

End Construction.

Theorem real : excluded_middle -> Real.model. Proof. exact: model. Qed.

End Dedekind.


From stdpp Require Import prelude well_founded.

Lemma wf_tc :
  forall {A : Type} (R : A -> A -> Prop),
    wf R -> wf (tc R).
Proof.
  unfold wf.
  intros A R Hwf a.
  specialize (Hwf a).
  induction Hwf as [a H IH].
  constructor.
  intros y Hy.
  induction Hy.
  - by apply IH.
  - by apply IHHy; [| | constructor].
Qed.

Module Fail.

Require Import Equality.

Inductive step : nat -> nat -> Prop :=
| step' : forall n : nat, step n (S n).

Lemma wf_step :
  wf step.
Proof.
  intro n.
  induction n as [| n' IH].
  - constructor. inversion 1.
  - constructor. inversion 1; subst. apply IH.
Defined.

Lemma wf_tc_step :
  wf (tc step).
Proof.
  intro n.
  induction n as [| n' IH].
  - constructor.
    intros m H.
    exfalso.
    dependent induction H.
    + inversion H.
    + by apply IHtc.
  - constructor.
    intros m H.
    revert IH.
    dependent induction H; intros.
    + by inversion H; subst.
    + inversion H; subst.
      specialize (IHtc _ eq_refl IH).
      inversion IHtc.
      apply H1.
      do 2 constructor.
Defined.

End Fail.

Module Success.

Inductive step : nat -> nat -> Prop :=
| step' : forall n : nat, step (S n) n.

Lemma wf_step :
  wf step.
Proof.
  intro n.
  induction n as [| n' IH].
  - constructor. inversion 1; subst. constructor. inversion 1; subst.
Abort.

End Success.


Require Import PeanoNat.

Require Export SystemFR.ErasedVar.
Require Export SystemFR.ErasedArrow.
Require Export SystemFR.ErasedSingleton.

Opaque reducible_values.
Opaque T_singleton.

Lemma open_tvar:
  forall Θ Γ x T,
    lookup Nat.eq_dec Γ x = Some T ->
    [ Θ; Γ ⊨ fvar x term_var : T_singleton T (fvar x term_var) ].
Proof.
  intros.
  eapply open_reducible_singleton; repeat step || t_lookup || unfold subset;
    eauto using open_reducible_var.
Qed.

Lemma open_tabs:
  forall Γ x t U V,
    wf U 0 ->
    wf t 1 ->
    subset (fv_context Γ) (support Γ) ->
    subset (fv U) (support Γ) ->
    subset (fv t) (support Γ) ->
    ~(x ∈ support Γ) ->
    ~(x ∈ fv t) ->
    ~(x ∈ fv V) ->
    is_erased_term t ->
    is_erased_type V ->
    [ (x, U) :: Γ ⊫ open 0 t (fvar x term_var) : open 0 V (fvar x term_var) ] ->
    [ Γ ⊫ notype_lambda t : T_singleton (T_arrow U V) (notype_lambda t) ].
Proof.
  eauto using open_reducible_singleton, open_reducible_lambda.
Qed.


From SE Require Export Equality.

Fixpoint treeSize (tree: ExecutionTree) : nat :=
  match tree with
  | empty => O
  | Tr node l r => S ((treeSize l) + (treeSize r))
  end.

(** Traversal strategy *)
Fixpoint findNode (tree: ExecutionTree) (target: nat) : TreeNode :=
  match tree with
  | empty => empty_node
  | Tr h l r =>
    match target with
    | O => h
    | _ => if (Nat.leb target (treeSize l))
           then findNode l (target - 1)
           else findNode r (target - (treeSize l) - 1)
    end
  end.

Fixpoint addNode (tree: ExecutionTree) (target: nat) (node: TreeNode) : ExecutionTree :=
  match target with
  | O =>
    match tree with
    | empty => Tr node empty empty
    | Tr h empty r => Tr h (Tr node empty empty) r
    | Tr h l empty => Tr h l (Tr node empty empty)
    | Tr h l r => tree
    end
  | _ =>
    match tree with
    | empty => Tr node empty empty
    | Tr h l r =>
      match (Nat.ltb target (treeSize l)) with
      | true => Tr h (addNode l (target - 1) node) r
      | false => Tr h l (addNode r (target - (treeSize l) - 1) node)
      end
    end
  end.

Fixpoint isLeaf (tree: ExecutionTree) (target: nat) : bool :=
  match target with
  | O =>
    match tree with
    | empty => false
    | Tr h empty empty => true
    | _ => false
    end
  | _ =>
    match tree with
    | empty => false
    | Tr h l r => orb (isLeaf l (target - 1)) (isLeaf r (target - (treeSize l) - 1))
    end
  end.

(** This function will compare the structure of two trees:
    the common case is that the first argument is a subtree
    of the second. Conceptually, it overlays the two trees,
    and returns a list of all nodes which don't have a
    counterpart in the same position in the other tree. Since
    Coq can't infer a strictly decreasing argument otherwise,
    we provide a maximum tree depth and wrap this helper
    inside another function. *)
Fixpoint treeDiffHelper (tr1 tr2: ExecutionTree) (gas: nat) : list TreeNode :=
  match gas with
  | O => nil
  | S gas' =>
    match tr1 with
    | empty =>
      match tr2 with
      | empty => nil
      | Tr h2 l2 r2 => h2 :: ((treeDiffHelper empty l2 gas') ++ (treeDiffHelper empty r2 gas'))
      end
    | Tr h1 l1 r1 =>
      match tr2 with
      | empty => h1 :: ((treeDiffHelper l1 empty gas') ++ (treeDiffHelper r1 empty gas'))
      | Tr h2 l2 r2 => (treeDiffHelper l1 l2 gas') ++ (treeDiffHelper r1 r2 gas')
      end
    end
  end.

Definition MAX_TREE_DEPTH : nat := 1000.

Definition treeDiff (tr1 tr2: ExecutionTree) : list TreeNode :=
  treeDiffHelper tr1 tr2 MAX_TREE_DEPTH.

(** This function is similar, but returns a list of all
    nodes in the second tree which don't appear in the first.
    We use our nodeEq function to ensure stricter equality. *)
Fixpoint treeDiffStrictHelper (tr1 tr2: ExecutionTree) (gas: nat) : list TreeNode :=
  match gas with
  | O => nil
  | S gas' =>
    match tr1 with
    | empty =>
      match tr2 with
      | empty => nil
      | Tr h l r => h :: ((treeDiffStrictHelper tr1 l gas') ++ (treeDiffStrictHelper tr1 r gas'))
      end
    | Tr h1 l1 r1 =>
      match tr2 with
      | empty => h1 :: ((treeDiffStrictHelper l1 tr2 gas') ++ (treeDiffStrictHelper r1 tr2 gas'))
      | Tr h2 l2 r2 =>
        match (nodeEq h1 h2) with
        | true => (treeDiffStrictHelper l1 l2 gas') ++ (treeDiffStrictHelper r1 r2 gas')
        | false => h2 :: (treeDiffStrictHelper l1 l2 gas') ++ (treeDiffStrictHelper r1 r2 gas')
        end
      end
    end
  end.

Definition treeDiffStrict (tr1 tr2: ExecutionTree) : list TreeNode :=
  treeDiffStrictHelper tr1 tr2 MAX_TREE_DEPTH.