(* Re-export of Iris and some general stuff *)

From iris_c.lib Require Export CpdtTactics Integers.
From stdpp Require Export prelude countable strings.
From mathcomp Require Import ssreflect.
Open Scope Z_scope.

Definition ident : Set := string.

Lemma drop_app {A} (xs ys: list A):
  drop (length xs) (xs ++ ys) = ys.
Proof. generalize ys. induction xs; crush. Qed.

Lemma take_drop_app {A} (xs ys: list A) n:
  length xs ≥ n → drop n (take n xs ++ ys) = ys.
Proof.
  intros ?. replace n with (length (take n xs)) at 1.
  - apply drop_app.
  - apply take_length_le. done.
Qed.

Definition is_some {A} (x: option A): bool := match x with Some _ => true | None => false end.

Definition offset_by_int32 (o: nat) (i: int32) : nat := o + Z.to_nat (Int.intval i).
Definition offset_by_byte (o: nat) (i: byte) : nat := o + Z.to_nat (Byte.intval i).

Fixpoint lift_list_option {A} (l: list (option A)): option (list A) :=
  match l with
    | Some x :: l' => (x ::) <$> lift_list_option l'
    | None :: _ => None
    | _ => Some []
  end.

Lemma map_inj {A B} (f: A → B):
  (∀ a1 a2, f a1 = f a2 → a1 = a2) →
  ∀ (l1: list A) l2,
    map f l1 = map f l2 → l1 = l2.
Proof.
  intros Finj.
  induction l1; induction l2.
  - done.
  - intros. simpl in H. inversion H.
  - intros. simpl in H. inversion H.
  - simpl. intros. inversion H.
    apply Finj in H1. apply IHl1 in H2. by subst.
Qed.

Close Scope Z_scope.

Lemma leb_trans (x y z: nat):
  (x <=? y) = true →
  (y <=? z) = true →
  (x <=? z) = true.
Proof.
  intros Hxy Hyz.
  apply Nat.leb_le in Hxy. apply Nat.leb_le in Hyz.
  apply Nat.leb_le.
  eapply le_trans; [ apply Hxy | apply Hyz ].
Qed.

Lemma gtb_trans (x y z: nat):
  (x <=? y) = false →
  (y <=? z) = false →
  (x <=? z) = false.
Proof.
  intros Hxy Hyz.
  apply Nat.leb_gt in Hxy.
  apply Nat.leb_gt in Hyz. apply Nat.leb_gt.
  eapply lt_trans; [apply Hyz | apply Hxy ].
Qed.

Lemma leb_cancel_false {A: Type} (c: A) (l1 l2: list A):
  length (c :: l1) + length l2 <=? length l2 = false.
Proof. rewrite Nat.leb_gt. simpl. omega. Qed.

Lemma leb_cancel_true {A: Type} (c: A) (l1 l2: list A):
  length l2 <=? length (c :: l1 ++ l2) = true.
Proof. rewrite Nat.leb_le. simpl. rewrite app_length. omega. Qed.

Ltac destruct_ands :=
  repeat (match goal with
            | [H: context [?H1 ∧ ?H2] |- _ ] => destruct H
          end); subst.

Require Import Coq.Arith.PeanoNat.

Lemma comm_assoc_s x y: x + S y = S x + y. Proof. omega. Qed.
Lemma assoc_s x y: S (x + y) = S x + y. Proof. omega. Qed.
Lemma distri_one x i: x + x * i = x * (i + 1).
Proof.
  rewrite Nat.mul_add_distr_l. rewrite Nat.mul_1_r. omega.
Qed.

Ltac assoc_nat :=
  match goal with
    | |- context [ ?E + (?E1 + ?E2) ] => replace (E + (E1 + E2)) with (E + E1 + E2); [| omega]
    | |- context [ ?E + ?E1 + ?E2 ] => replace (E + E1 + E2) with (E + (E1 + E2)); [| omega]
  end.

Lemma app_cons {A} (x: A) (y: list A):
  [x] ++ y = x::y.
Proof. induction y; crush. Qed.

Ltac rewrite_nat :=
  repeat (match goal with
            | |- context [?X * O] => rewrite Nat.mul_0_r
            | |- context [?X * 1] => rewrite Nat.mul_1_r
            | |- context [?X + O] => rewrite Nat.add_0_r
          end).

Ltac inversion_eq :=
    match goal with
      | [ H1: ?x = ?y1, H2 : ?x = ?y2 |- _ ] => rewrite H1 in H2; inversion H2
      | [ H1: ?x = ?y1, H2 : ?y2 = ?x |- _ ] => rewrite H1 in H2; inversion H2
      | [ H1: ?y1 = ?x, H2 : ?y2 = ?x |- _ ] => rewrite -H1 in H2; inversion H2
      | [ H1: ?y1 = ?x, H2 : ?x = ?y2 |- _ ] => rewrite -H1 in H2; inversion H2
    end.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Different definitions of pathes in a graph, directed or not.         *)

(* The following notions are defined :                                  *)
(*      - Walk : defined by 2 ends,                                     *)
(*                      a list of vertices and a list of edges          *)
(*              constructors : W_null, W_step;                          *)
(*      - Trail : walk without repetition of edge,                      *)
(*              constructors : T_null, T_step;                          *)
(*      - Path : trail without repetition of inner vertex,              *)
(*              constructors : P_null, P_step;                          *)
(*      - Closed_walk, Closed_trail, Cycle.                             *)

Require Export Graphs.
Require Export Degrees.

Section PATH.

Variable A:Type.

Variable v : @V_set A.
Variable a : @A_set A.

Inductive Walk : @Vertex A -> @Vertex A -> @V_list A -> @E_list A -> Type :=
  | W_null : forall x : Vertex, v x -> Walk x x V_nil E_nil
  | W_step :
      forall (x y z : Vertex) (vl : V_list) (el : E_list),
      Walk y z vl el ->
      v x -> a (A_ends x y) -> Walk x z (y :: vl) (E_ends x y :: el).

Definition Closed_walk (x y : Vertex) (vl : V_list)
  (el : E_list) (w : Walk x y vl el) := x = y.

Inductive Trail : @Vertex A -> @Vertex A -> @V_list A -> @E_list A -> Type :=
  | T_null : forall x : Vertex, v x -> Trail x x V_nil E_nil
  | T_step :
      forall (x y z : Vertex) (vl : V_list) (el : E_list),
      Trail y z vl el ->
      v x ->
      a (A_ends x y) ->
      (forall u : Edge, In u el -> ~ E_eq u (E_ends x y)) ->
      Trail x z (y :: vl) (E_ends x y :: el).

Definition Closed_trail (x y : Vertex) (vl : V_list)
  (el : E_list) (t : Trail x y vl el) := x = y.

Inductive Path : @Vertex A -> @Vertex A -> @V_list A -> @E_list A -> Type :=
  | P_null : forall x : Vertex, v x -> Path x x V_nil E_nil
  | P_step :
      forall (x y z : Vertex) (vl : V_list) (el : E_list),
      Path y z vl el ->
      v x ->
      a (A_ends x y) ->
      x <> y ->
      ~ In y vl ->
      (In x vl -> x = z) ->
      (forall u : Edge, In u el -> ~ E_eq u (E_ends x y)) ->
      Path x z (y :: vl) (E_ends x y :: el).

Definition Cycle (x y : Vertex) (vl : V_list) (el : E_list)
  (p : Path x y vl el) := x = y.

Lemma P_iny_vl :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path x y vl el -> vl <> V_nil -> In y vl.
Proof.
        intros x y vl el p; elim p; intros.
        absurd (V_nil = @V_nil A); auto.

        inversion p0.
        simpl in |- *; auto.

        rewrite H9; simpl in |- *; right.
        apply H; rewrite <- H9; discriminate.
Qed.

Lemma P_endx_inv :
 forall (x y : Vertex) (vl : V_list) (el : E_list), Path x y vl el -> v x.
Proof.
        intros x y vl el p; elim p; auto.
Qed.

Lemma P_endy_inv :
 forall (x y : Vertex) (vl : V_list) (el : E_list), Path x y vl el -> v y.
Proof.
        intros x y vl el p; elim p; auto.
Qed.

Lemma P_invl_inv :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path x y vl el -> forall z : Vertex, In z vl -> v z.
Proof.
        intros x y vl el p; elim p; intros.
        inversion H.

        inversion H0.
        rewrite <- H1; apply (P_endx_inv _ _ _ _ p0).

        auto.
Qed.

Lemma P_inel_ina :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path x y vl el ->
 forall x' y' : Vertex, In (E_ends x' y') el -> a (A_ends x' y').
Proof.
        intros x y vl el p; elim p; intros.
        inversion H.

        inversion H0.
        inversion H1.
        rewrite <- H3; rewrite <- H4; trivial.

        auto.
Qed.

Lemma P_inxyel_inxvl :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path x y vl el ->
 forall x' y' : Vertex, In (E_ends x' y') el -> In x' (x :: vl).
Proof.
        intros x y vl el p; elim p; intros.
        inversion H.

        inversion H0.
        inversion H1.
        simpl in |- *; auto.

        simpl in |- *; right.
        apply (H x' y'); auto.
Qed.

Lemma P_inxyel_inyvl :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path x y vl el ->
 forall x' y' : Vertex, In (E_ends x' y') el -> In y' (x :: vl).
Proof.
        intros x y vl el p; elim p; intros.
        inversion H.

        inversion H0.
        inversion H1.
        simpl in |- *; auto.

        simpl in |- *; right.
        apply (H x' y'); auto.
Qed.

Lemma P_backstep :
 forall (x y z : Vertex) (vl : V_list) (el : E_list),
 Path x z (y :: vl) el -> {el' : E_list &  Path y z vl el'}.
Proof.
        intros; inversion X.
        split with el0; trivial.
Qed.

Lemma Trail_isa_walk :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Trail x y vl el -> Walk x y vl el.
Proof.
        intros x y vl el t; elim t; intros.
        apply W_null; trivial.

        apply W_step; trivial.
Qed.

Lemma Path_isa_trail :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path x y vl el -> Trail x y vl el.
Proof.
        intros x y vl el t; elim t; intros.
        apply T_null; trivial.

        apply T_step; trivial.
Qed.

Lemma Path_isa_walk :
 forall (x y : Vertex) (vl : V_list) (el : E_list)
 (Hp: Path x y vl el), Walk x y vl el.
Proof.
 intros.
 apply Path_isa_trail in Hp.
 apply Trail_isa_walk; auto.
Qed.

End PATH.

Implicit Arguments Path [A].
Implicit Arguments Walk [A].
Implicit Arguments P_backstep [A].
Implicit Arguments P_endx_inv [A].
Implicit Arguments P_inxyel_inxvl [A].
Implicit Arguments P_inxyel_inyvl [A].

Section EXTRACTED.

Variable A:Type.
Variable eq_a_dec: forall x y : A, {x = y} + {x <> y}.

Variable v : @V_set A.
Variable a : @A_set A.

Fixpoint V_extract (x : Vertex) (vl : V_list) {struct vl} : V_list :=
  match vl with
  | nil => V_nil
  | y :: vl' =>
      if V_in_dec eq_a_dec x vl' then V_extract x vl' else vl'
  end.

Lemma V_extract_spec: forall v1 v2 vl,
  In v1 (V_extract v2 vl) ->  v1 <> v2 ->
  In v1 vl.
Proof.
  induction vl; simpl; intros; auto.
    destruct (V_in_dec eq_a_dec v2 vl); auto.
Qed.

Lemma V_extract_spec': forall v1 v2 vl,
  In v1 (V_extract v2 (v1::vl)) ->  v1 <> v2 ->
  In v1 vl.
Proof.
  induction vl; simpl; intros.
    destruct (V_in_dec eq_a_dec v2 nil); auto.
    destruct (V_in_dec eq_a_dec v2 (a0::vl)); auto.
Qed.

Lemma V_extract_spec'': forall v1 v2 vl,
  In v1 (V_extract v2 vl) ->
  In v1 vl.
Proof.
  induction vl; simpl; intros; auto.
    destruct (V_in_dec eq_a_dec v2 vl); auto.
Qed.

Lemma P_extract :
 forall (x y z : Vertex) (vl : V_list) (el : E_list),
 Path v a y z vl el ->
 In x (y :: vl) -> {el' : E_list &  Path v a x z (V_extract x (y :: vl)) el'}.
Proof.
        intros x y z vl; generalize y; elim vl; simpl in |- *; intros.
        split with el.
        replace x with y0; auto.
        case (V_in_dec eq_a_dec y0 nil); auto.

        tauto.

        elim (P_backstep _ _ _ _ _ _ _ X0); intros.
        case (V_in_dec eq_a_dec x (a0 :: l)). intros.
        apply (X a0 x0); auto.

        simpl in |- *. intros. split with el. replace x with y0.
        trivial.

        tauto.
Qed.

Remark P_when_cycle :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path v a x y vl el -> In x vl -> x = y.
Proof.
        intros x y vl el H; inversion H; intros.
        trivial.

        inversion H10.
        absurd (x = y0); auto.

        auto.
Qed.

Lemma Walk_to_path :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Walk v a x y vl el ->
 {vl0 : V_list &  {el0 : E_list &  Path v a x y vl0 el0}}.
Proof.
        intros x y vl el w; elim w; intros.
        split with V_nil; split with E_nil; apply P_null; trivial.

        elim X; clear X; intros vl' X.
        elim X; clear X; intros el' X.
        case (V_in_dec eq_a_dec x0 (y0 :: vl')); intros.
        elim (P_extract _ _ _ _ _ X i); intros.
        split with (V_extract x0 (y0 :: vl')); split with x1; auto.

        case (V_in_dec eq_a_dec y0 vl'); intros.
        split with (y0 :: V_nil); split with (E_ends x0 y0 :: E_nil). apply P_step.
        replace z with y0.
        apply P_null; apply (P_endx_inv _ _ _ _ _ _ X).

        apply (P_when_cycle _ _ _ _ X); auto.

        trivial.

        trivial.

        red in |- *; intros; elim n; rewrite H; simpl in |- *; auto.

        tauto.

	simpl in |- *. tauto.

        tauto.

        split with (y0 :: vl'); split with (E_ends x0 y0 :: el').
        apply P_step.
        trivial.

        trivial.

        trivial.

        red in |- *; intros; elim n; rewrite H; simpl in |- *; auto.

        trivial.

        intros; absurd (In x0 vl').
        red in |- *; intros; elim n; simpl in |- *; auto.

        trivial.

        red in |- *; intros.
        elim n; inversion H0.
        apply (P_inxyel_inxvl _ _ _ _ _ _ X x0 y0).
        rewrite <- H2; auto.

        apply (P_inxyel_inyvl _ _ _ _ _ _ X y0 x0).
        rewrite <- H3; rewrite <- H4; rewrite H1; trivial.
Qed.

End EXTRACTED.

Implicit Arguments Cycle [A].
Implicit Arguments P_inel_ina [A].
Implicit Arguments P_iny_vl [A].

Section PATH_AND_DEGREE.

Variable A:Type.
Variable eq_a_dec: forall x y : A, {x = y} + {x <> y}.
Variable v : (@V_set A).
Variable a : (@A_set A).
Variable g : Graph v a.

Lemma Path_degree_one :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path v a x y vl el -> forall z : Vertex, In z vl -> degree eq_a_dec z v a g > 0.
Proof.
        intros x y vl el p; elim p; intros.
        inversion H.

        inversion H0.
        rewrite <- H1; apply Degree_not_isolated.
        split with x0; apply (G_non_directed v a g); trivial.

        apply H; auto.
Qed.

Lemma Path_consx_degree_one :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path v a x y vl el ->
 vl <> V_nil -> forall z : Vertex, In z (x :: vl) -> degree eq_a_dec z v a g > 0.
Proof.
        simple destruct vl; intros.
        absurd (nil = @V_nil A); auto.

        inversion H0.
        rewrite <- H1; apply Degree_not_isolated.
        inversion X; split with v0; trivial.

        apply (Path_degree_one x y (v0 :: l) el X); auto.
Qed.

Lemma Path_degree_two :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path v a x y vl el ->
 forall z : Vertex, In z vl -> z <> y -> degree eq_a_dec z v a g > 1.
Proof.
        intros x y vl el p; elim p; intros.
        inversion H.

        inversion H0.
        inversion p0.
        absurd (z0 = z).
        trivial.

        rewrite <- H2; auto.

        rewrite <- H2; apply Degree_not_pendant.
        split with x0.
        apply (G_non_directed v a g); trivial.

        split with y1.
        trivial.

        red in |- *; intros.
        elim (n1 (E_ends y0 y1)).
        rewrite <- H12; simpl in |- *; auto.

        rewrite H13; apply E_rev.

        apply H; trivial.
Qed.

Lemma Path_last_step :
 forall (x y : Vertex) (vl : V_list) (el : E_list) (p : Path v a x y vl el),
 el <> E_nil -> exists z : Vertex, In (E_ends z y) el.
Proof.
        intros x y vl el p; elim p.
        intros; elim H; trivial.

        simple destruct el0; intros.
        split with x0.
        inversion p0.
        simpl in |- *; left; trivial.

        elim H; intros.
        split with x1.
        simpl in |- *; auto.

        discriminate.
Qed.

Lemma Cycle_degree_two :
 forall (x y : Vertex) (vl : V_list) (el : E_list) (p : Path v a x y vl el),
 Cycle v a x y vl el p -> forall z : Vertex, In z vl -> degree eq_a_dec z v a g > 1.
Proof.
        intros; case (V_eq_dec eq_a_dec z y); intros.
        rewrite e; apply Degree_not_pendant.
        inversion p.
        rewrite <- H4 in H0; inversion H0.

        inversion H.
        split with y0.
        rewrite <- H11; trivial.

        elim (Path_last_step y0 y vl0 el0 X); intros.
        split with x1.
        apply (G_non_directed v a g); apply (P_inel_ina v a y0 y vl0 el0 X);
         trivial.

        red in |- *; intros; elim (H6 (E_ends x1 y)).
        trivial.

        rewrite H11; rewrite H13; apply E_rev.

        inversion X.
        absurd (x = y0).
        trivial.

        rewrite H14; trivial.

        discriminate.

        apply (Path_degree_two x y vl el p); trivial.
Qed.

Lemma Cycle_consx_degree_two :
 forall (x y : Vertex) (vl : V_list) (el : E_list) (p : Path v a x y vl el),
 vl <> V_nil ->
 Cycle v a x y vl el p ->
 forall z : Vertex, In z (x :: vl) -> degree eq_a_dec z v a g > 1.
Proof.
        intros; inversion H1.
        rewrite <- H2; inversion H0.
        apply (Cycle_degree_two x y vl el p H0 y).
        apply (P_iny_vl v a x y vl el p); trivial.

        apply (Cycle_degree_two x y vl el p H0); trivial.
Qed.

Lemma Path_degree_zero_nil :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Path v a x y vl el ->
 (exists2 z : Vertex, In z (x :: vl) & degree eq_a_dec z v a g = 0) -> vl = V_nil.
Proof.
        simple destruct vl; intros.
        trivial.

        elim H; intros.
        absurd (degree eq_a_dec x0 v a g > 0).
        omega.

        apply (Path_consx_degree_one _ _ _ _ X).
        discriminate.

        trivial.
Qed.

Lemma Cycle_degree_one_nil :
 forall (x y : Vertex) (vl : V_list) (el : E_list) (p : Path v a x y vl el),
 Cycle v a x y vl el p ->
 (exists2 z : Vertex, In z (x :: vl) & degree eq_a_dec z v a g <= 1) -> vl = V_nil.
Proof.
        simple destruct vl; intros.
        trivial.

        elim H0; intros.
        absurd (degree eq_a_dec x0 v a g > 1).
        omega.

        apply (Cycle_consx_degree_two _ _ _ _ p).
        discriminate.

        trivial.

        trivial.
Qed.

End PATH_AND_DEGREE.

Implicit Arguments Trail [A].

Section PATH_EQ.

Variable A:Type.

Lemma Walk_eq :
 forall (v v' : V_set) (a a' : @A_set A) (x y : Vertex)
   (vl : V_list) (el : E_list),
 Walk v a x y vl el -> v = v' -> a = a' -> Walk v' a' x y vl el.
Proof.
        intros; elim X; intros.
        apply W_null.
        rewrite <- H; trivial.

        apply W_step.
        trivial.

        rewrite <- H; trivial.

        rewrite <- H0; trivial.
Qed.

Lemma Trail_eq :
 forall (v v' : V_set) (a a' : @A_set A) (x y : Vertex)
   (vl : V_list) (el : E_list),
 Trail v a x y vl el -> v = v' -> a = a' -> Trail v' a' x y vl el.
Proof.
        intros; elim X; intros.
        apply T_null.
        rewrite <- H; trivial.

        intros; apply T_step.
        trivial.

        rewrite <- H; trivial.

        rewrite <- H0; trivial.

        trivial.
Qed.

Lemma Path_eq :
 forall (v v' : V_set) (a a' : @A_set A) (x y : Vertex)
   (vl : V_list) (el : E_list),
 Path v a x y vl el -> v = v' -> a = a' -> Path v' a' x y vl el.
Proof.
        intros; elim X; intros.
        apply P_null.
        rewrite <- H; trivial.

        intros; apply P_step.
        trivial.

        rewrite <- H; trivial.

        rewrite <- H0; trivial.

        trivial.

        trivial.

        trivial.

        trivial.
Qed.

End PATH_EQ.

Section PATH_IN_A_SUBGRAPH.

Variable A:Type.

Lemma Walk_subgraph :
 forall (v v' : V_set) (a a' : @A_set A) (x y : Vertex)
   (vl : V_list) (el : E_list),
 Walk v a x y vl el ->
 V_included v v' -> A_included a a' -> Walk v' a' x y vl el.
Proof.
        intros; elim X; intros.
        apply W_null; apply (H x0); trivial.

        apply W_step.
        trivial.

        apply (H x0); trivial.

        apply (H0 (A_ends x0 y0)); trivial.
Qed.

Lemma Trail_subgraph :
 forall (v v' : V_set) (a a' : @A_set A) (x y : Vertex)
   (vl : V_list) (el : E_list),
 Trail v a x y vl el ->
 V_included v v' -> A_included a a' -> Trail v' a' x y vl el.
Proof.
        intros; elim X; intros.
        apply T_null; apply (H x0); trivial.

        apply T_step.
        trivial.

        apply (H x0); trivial.

        apply (H0 (A_ends x0 y0)); trivial.

        trivial.
Qed.

Lemma Path_subgraph :
 forall (v v' : V_set) (a a' : @A_set A) (x y : Vertex)
   (vl : V_list) (el : E_list),
 Path v a x y vl el ->
 V_included v v' -> A_included a a' -> Path v' a' x y vl el.
Proof.
        intros; elim X; intros.
        apply P_null; apply (H x0); trivial.

        apply P_step.
        trivial.

        apply (H x0); trivial.

        apply (H0 (A_ends x0 y0)); trivial.

        trivial.

        trivial.

        trivial.

        trivial.
Qed.

Lemma Path_supergraph_vertex :
 forall (v v' : V_set) (a : A_set) (x y : Vertex) (vl : V_list) (el : @E_list A),
 Path v a x y vl el ->
 v' x -> (forall z : Vertex, In z vl -> v' z) -> Path v' a x y vl el.
Proof.
        intros v v' a x y vl el p; elim p; intros.
        apply P_null; trivial.

        apply P_step.
        apply X.
        apply H0; simpl in |- *; auto.

        intros; apply H0; simpl in |- *; auto.

        trivial.

        trivial.

        trivial.

        trivial.

        trivial.

        trivial.
Qed.

Lemma Path_supergraph_cons_vertex :
 forall (v : V_set) (a : A_set) (x y z : Vertex) (vl : V_list) (el : @E_list A),
 Path (V_union (V_single z) v) a x y vl el ->
 z <> x -> ~ In z vl -> Path v a x y vl el.
Proof.
        intros v a x y z vl el p; elim p; intros.
        apply P_null.
        inversion v0.
        inversion H1; absurd (z = x0); auto.

        trivial.

        apply P_step.
        apply X.
        red in |- *; intros; elim H0.
        rewrite H1; simpl in |- *; auto.

        red in |- *; intros; elim H0; simpl in |- *; auto.

        inversion v0.
        inversion H1; absurd (z = x0); auto.

        trivial.

        trivial.

        trivial.

        trivial.

        trivial.

        trivial.
Qed.

Lemma Path_supergraph_arc :
 forall (v v' : V_set) (a a' : A_set) (x y : Vertex)
   (vl : V_list) (el : @E_list A),
 Path v a x y vl el ->
 Graph v' a' ->
 v' x ->
 (forall x' y' : Vertex, In (E_ends x' y') el -> a' (A_ends x' y')) ->
 Path v' a' x y vl el.
Proof.
        intros v v' a a' x y vl el p; elim p; intros.
        apply P_null; trivial.

        apply P_step.
        apply X.
        trivial.

        apply (G_ina_inv2 v' a' X0 x0 y0).
        apply H0; simpl in |- *; auto.

        intros; apply H0; simpl in |- *; auto.

        trivial.

        apply H0; simpl in |- *; auto.

        trivial.

        trivial.

        trivial.

        trivial.
Qed.

Lemma Path_supergraph_cons_arc :
 forall (v : V_set) (a : A_set) (x y x' y' : Vertex)
   (vl : V_list) (el : @E_list A),
 Path v (A_union (E_set x' y') a) x y vl el ->
 ~ In (E_ends x' y') el -> ~ In (E_ends y' x') el -> Path v a x y vl el.
Proof.
        intros v a x y x' y' vl el p; elim p; intros.
        apply P_null; trivial.

        apply P_step.
        apply X.
        red in |- *; intros; elim H.
        simpl in |- *; auto.

        red in |- *; intros; elim H0; simpl in |- *; auto.

        trivial.

        inversion a0.
        inversion H1.
        absurd (In (E_ends x' y') (E_ends x0 y0 :: el0)).
        trivial.

        rewrite H4; rewrite H5; simpl in |- *; auto.

        absurd (In (E_ends y' x') (E_ends x0 y0 :: el0)).
        trivial.

        rewrite H4; rewrite H5; simpl in |- *; auto.

        trivial.

        trivial.

        trivial.

        trivial.

        trivial.
Qed.

End PATH_IN_A_SUBGRAPH.

Section APPEND_WALKS.

Variable A:Type.
Variable v : @V_set A.
Variable a : @A_set A.

Lemma Walk_append :
 forall (x y z : Vertex) (vl vl' : V_list) (el el' : E_list),
 Walk v a x y vl el ->
 Walk v a y z vl' el' -> Walk v a x z (vl ++ vl') (el ++ el').
Proof.
        intros x y z vl vl' el el' Hw; elim Hw; simpl in |- *; intros.
        trivial.

        apply W_step; auto.
Qed.

End APPEND_WALKS.

Implicit Arguments Walk_append [A].

Section REVERSE_WALK.

Variable A:Type.
Variable eq_a_dec: forall x y : A, {x = y} + {x <> y}.

Variable v : @V_set A.
Variable a : @A_set A.
Variable g : Graph v a.

Definition cdr (vl : @V_list A) : V_list :=
  match vl with
  | nil => V_nil
  | x :: vl' => vl'
  end.

Lemma cdr_app :
 forall vl vl' : V_list, vl <> V_nil -> cdr (vl ++ vl') = cdr vl ++ vl'.
Proof.
        simple induction vl; simpl in |- *; intros.
        absurd (V_nil = @V_nil A); auto.

        trivial.
Qed.

Fixpoint E_reverse (el : E_list) : E_list :=
  match el with
  | nil => E_nil
  | E_ends x y :: el' => E_reverse el' ++ E_ends y x :: @E_nil A
  end.

Lemma G_ends_in : forall x y : Vertex, a (A_ends x y) -> v x.
Proof.
        elim g; intros.
        inversion H.

        case (V_eq_dec eq_a_dec x x0); intros.
        rewrite e; apply V_in_left; apply V_in_single.

        apply V_in_right; apply (H x0 y); trivial.

        inversion H0.
        inversion H1; rewrite <- H4; trivial.

        apply (H x0 y0); trivial.

        rewrite <- e; apply (H x y); rewrite e0; trivial.
Qed.

Lemma Walk_reverse :
 forall (x y : Vertex) (vl : V_list) (el : E_list),
 Walk v a x y vl el -> Walk v a y x (cdr (rev (x :: vl))) (E_reverse el).
Proof.
        intros; elim X; simpl in |- *; intros.
        apply W_null; trivial.

        rewrite cdr_app.
        apply (Walk_append v a z y0 x0).
        trivial.

        apply W_step.
        apply W_null; trivial.

        apply (G_ina_inv2 v a g x0 y0); trivial.

        apply (G_non_directed v a g); trivial.

        case (rev vl0); intros; simpl in |- *; discriminate.
Qed.

End REVERSE_WALK.

Implicit Arguments Path_degree_zero_nil [A].
Implicit Arguments Cycle_degree_one_nil [A].
Implicit Arguments Walk_subgraph [A].
Implicit Arguments Walk_to_path [A].
Implicit Arguments V_extract [A].


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (plus Zero (mult lv1 lv0))).
Admitted.
QuickChick conj8eqsynthconj2.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B AB Bprime : Universe, ((wd_ A O /\ (wd_ E O /\ (wd_ B O /\ (wd_ E O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime A /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O Eprime Bprime /\ col_ O Eprime A)))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.

Local Open Scope Z_scope.

Section SpecLow.

  Definition is_trusted_intid_spec0 (intid: Z64) (adt: RData) : option Z :=
    match intid with
    | VZ64 _intid =>
      if (_intid >=? 0) then
        let _t'1 := (_intid <=? 31) in
        if _t'1 then
          Some 1
        else
          Some 0
      else
        let _t'1 := 0 in
        Some 0
     end
    .

End SpecLow.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj24eqsynthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv1 lv0)).
Admitted.
QuickChick conj24eqsynthconj6.


Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import
  Coq.Program.Program Coq.setoid_ring.Ring
  Coq.QArith.Qabs CoRN.stdlib_omissions.Q MathClasses.misc.workaround_tactics
  CoRN.model.totalorder.QMinMax CoRN.model.totalorder.QposMinMax CoRN.util.Qdlog
  CoRN.metric2.Complete CoRN.metric2.Prelength CoRN.model.metric2.Qmetric CoRN.metric2.MetricMorphisms
  CoRN.reals.fast.CRArith CoRN.reals.fast.CRpower
  MathClasses.implementations.stdlib_binary_naturals MathClasses.orders.minmax MathClasses.implementations.positive_semiring_elements.
Require Export
  CoRN.reals.faster.ApproximateRationals
  CoRN.reals.faster.AQmetric.

Section ARarith.
Context `{AppRationals AQ}.

Add Ring AQ : (rings.stdlib_ring_theory AQ).
Add Ring Z : (rings.stdlib_ring_theory Z).

Local Open Scope uc_scope.
Local Opaque regFunEq.

Hint Rewrite (rings.preserves_0 (f:=cast AQ Q)) : aq_preservation.
Hint Rewrite (rings.preserves_1 (f:=cast AQ Q)) : aq_preservation.
Hint Rewrite (rings.preserves_plus (f:=cast AQ Q)) : aq_preservation.
Hint Rewrite (rings.preserves_mult (f:=cast AQ Q)) : aq_preservation.
Hint Rewrite (rings.preserves_negate (f:=cast AQ Q)) : aq_preservation.
Hint Rewrite aq_preserves_max : aq_preservation.
Hint Rewrite aq_preserves_min : aq_preservation.
Hint Rewrite (abs.preserves_abs (f:=cast AQ Q)): aq_preservation.
Ltac aq_preservation := autorewrite with aq_preservation; try reflexivity.
Local Obligation Tactic := program_simpl; aq_preservation.

(* Compress *)
Lemma aq_approx_regular_prf (x : AQ) :
  is_RegularFunction_noInf _ (λ ε : Qpos, app_approx x (Qdlog2 (proj1_sig ε))
                              : AQ_as_MetricSpace).
Proof.
  intros ε1 ε2. simpl.
  eapply ball_triangle.
   apply aq_approx_dlog2.
  apply ball_sym, aq_approx_dlog2.
Qed.

Definition AQcompress (x : AQ_as_MetricSpace) : AR :=
  mkRegularFunction (0 : AQ_as_MetricSpace) (aq_approx_regular_prf x).

Lemma AQcompress_uc_prf : is_UniformlyContinuousFunction AQcompress Qpos2QposInf.
Proof.
  intros ε x y E δ1 δ2. simpl in *.
  eapply ball_triangle.
   2: apply ball_sym, aq_approx_dlog2.
  eapply ball_triangle; eauto.
  apply aq_approx_dlog2.
Qed.

Definition AQcompress_uc := Build_UniformlyContinuousFunction AQcompress_uc_prf.

Definition ARcompress : AR --> AR := Cbind AQPrelengthSpace AQcompress_uc.

Lemma ARcompress_correct (x : AR) : ARcompress x = x.
Proof.
  apply regFunEq_equiv, regFunEq_e. intros ε.
  assert (QposEq (ε + ε) ((1#2) * ε + ((1#2) * ε + ε)))
    by (unfold QposEq; simpl; ring).
 apply (ball_wd _ H5 _ _ (reflexivity _) _ _ (reflexivity _)). clear H5.
  eapply ball_triangle.
   apply_simplified (aq_approx_dlog2 (approximate x ((1 # 2) * ε)%Qpos) ((1#2) * ε)%Qpos).
  apply regFun_prf.
Qed.

(* Constants *)
Global Instance inject_PosAQ_AR: Cast (AQ₊) AR := (cast AQ AR ∘ cast (AQ₊) AQ)%prg.
Global Instance inject_Z_AR: Cast Z AR := (cast AQ AR ∘ cast Z AQ)%prg.

Lemma ARtoCR_inject (x : AQ) : cast AR CR (cast AQ AR x) = cast Q CR (cast AQ Q x).
Proof.
  apply regFunEq_equiv, regFunEq_e. intros ε. apply ball_refl.
  apply (Qpos_nonneg (ε + ε)).
Qed.

Global Instance AR0: Zero AR := cast AQ AR 0.
Lemma ARtoCR_preserves_0 : cast AR CR 0 = 0.
Proof. unfold "0", AR0. rewrite ARtoCR_inject. aq_preservation. Qed.
Hint Rewrite ARtoCR_preserves_0 : ARtoCR.

Global Instance AR1: One AR := cast AQ AR 1.
Lemma ARtoCR_preserves_1 : cast AR CR 1 = 1.
Proof. unfold "1", AR1. rewrite ARtoCR_inject. aq_preservation. Qed.
Hint Rewrite ARtoCR_preserves_1 : ARtoCR.

(* Plus *)
Program Definition AQtranslate_uc (x : AQ_as_MetricSpace) := unary_uc
  (cast AQ Q_as_MetricSpace)
  ((x +) : AQ_as_MetricSpace → AQ_as_MetricSpace) (Qtranslate_uc ('x)) _.
Next Obligation. apply Qball_0. apply preserves_sg_op. Qed.

Definition ARtranslate (x : AQ_as_MetricSpace) : AR --> AR := Cmap AQPrelengthSpace (AQtranslate_uc x).

Lemma ARtoCR_preserves_translate x y : 'ARtranslate x y = translate ('x) ('y).
Proof. apply preserves_unary_fun. Qed.
Hint Rewrite ARtoCR_preserves_translate : ARtoCR.

Program Definition AQplus_uc := binary_uc
  (cast AQ Q_as_MetricSpace)
  ((+) : AQ_as_MetricSpace →  AQ_as_MetricSpace → AQ_as_MetricSpace) Qplus_uc _.
Next Obligation. apply Qball_0. apply preserves_sg_op. Qed.

Definition ARplus_uc : AR --> AR --> AR := Cmap2 AQPrelengthSpace AQPrelengthSpace AQplus_uc.
Global Instance ARplus: Plus AR := ucFun2 ARplus_uc.

Lemma ARtoCR_preserves_plus x y : cast AR CR (x + y) = 'x + 'y.
Proof. apply preserves_binary_fun. Qed.
Hint Rewrite ARtoCR_preserves_plus : ARtoCR.

(* Inverse *)
Program Definition AQopp_uc := unary_uc (cast AQ Q_as_MetricSpace)  ((-) : AQ → AQ) Qopp_uc _.
Next Obligation. apply Qball_0. aq_preservation. Qed.

Definition ARopp_uc : AR --> AR := Cmap AQPrelengthSpace AQopp_uc.
Global Instance ARopp: Negate AR := ARopp_uc.

Lemma ARtoCR_preserves_opp x : cast AR CR (-x) = -'x.
Proof. apply preserves_unary_fun. Qed.
Hint Rewrite ARtoCR_preserves_opp : ARtoCR.

(* Mult *)
Program Definition AQboundBelow_uc (x : AQ_as_MetricSpace) :
    AQ_as_MetricSpace --> AQ_as_MetricSpace :=
  unary_uc (cast AQ Q_as_MetricSpace)
  ((x ⊔) : AQ_as_MetricSpace → AQ_as_MetricSpace) (QboundBelow_uc ('x)) _.
Next Obligation. apply Qball_0. aq_preservation. Qed.

Definition ARboundBelow (x : AQ_as_MetricSpace) : AR --> AR := Cmap AQPrelengthSpace (AQboundBelow_uc x).

Lemma ARtoCR_preserves_boundBelow x y : 'ARboundBelow x y = boundBelow ('x) ('y).
Proof. apply preserves_unary_fun. Qed.
Hint Rewrite ARtoCR_preserves_boundBelow : ARtoCR.

Program Definition AQboundAbove_uc (x : AQ_as_MetricSpace) :
    AQ_as_MetricSpace --> AQ_as_MetricSpace := unary_uc
  (cast AQ Q_as_MetricSpace)
  ((x ⊓) : AQ_as_MetricSpace → AQ_as_MetricSpace) (QboundAbove_uc ('x)) _.
Next Obligation. apply Qball_0. aq_preservation. Qed.

Definition ARboundAbove (x : AQ_as_MetricSpace) : AR --> AR := Cmap AQPrelengthSpace (AQboundAbove_uc x).

Lemma ARtoCR_preserves_boundAbove x y : 'ARboundAbove x y = boundAbove ('x) ('y).
Proof. apply preserves_unary_fun. Qed.
Hint Rewrite ARtoCR_preserves_boundAbove : ARtoCR.

Program Definition AQboundAbs_uc (c : AQ₊) :
    AQ_as_MetricSpace --> AQ_as_MetricSpace := unary_uc
  (cast AQ Q_as_MetricSpace)
  (λ x : AQ_as_MetricSpace, (-'c) ⊔ (('c) ⊓ x) : AQ_as_MetricSpace) (QboundAbs ('c)) _.
Next Obligation. apply Qball_0. aq_preservation. Qed.

Definition ARboundAbs (c : AQ₊) : AR --> AR := Cmap AQPrelengthSpace (AQboundAbs_uc c).

Lemma ARtoCR_preserves_bound_abs c x : 'ARboundAbs c x = CRboundAbs ('c) ('x).
Proof. apply preserves_unary_fun. Qed.
Hint Rewrite ARtoCR_preserves_bound_abs : ARtoCR.

Program Definition AQscale_uc (x : AQ_as_MetricSpace) :
    AQ_as_MetricSpace --> AQ_as_MetricSpace := unary_uc
  (cast AQ Q_as_MetricSpace)
  ((x *.)  : AQ_as_MetricSpace → AQ_as_MetricSpace) (Qscale_uc ('x)) _.
Next Obligation. apply Qball_0. aq_preservation. Qed.

Definition ARscale (x : AQ_as_MetricSpace) : AR --> AR := Cmap AQPrelengthSpace (AQscale_uc x).

Lemma ARtoCR_preserves_scale x y : 'ARscale x y = scale ('x) ('y).
Proof. apply preserves_unary_fun. Qed.
Hint Rewrite ARtoCR_preserves_scale : ARtoCR.

Program Definition AQmult_uc (c : AQ₊) :
    AQ_as_MetricSpace --> AQ_as_MetricSpace --> AQ_as_MetricSpace := binary_uc
  (cast AQ Q_as_MetricSpace)
  (λ x y : AQ_as_MetricSpace, x * AQboundAbs_uc c y : AQ_as_MetricSpace) (Qmult_uc ('c)) _.
Next Obligation. apply Qball_0. aq_preservation. Qed.

Definition ARmult_bounded (c : AQ₊) : AR --> AR --> AR
  := Cmap2 AQPrelengthSpace AQPrelengthSpace (AQmult_uc c).

Lemma ARtoCR_preserves_mult_bounded x y c :
  'ARmult_bounded c x y = CRmult_bounded ('c) ('x) ('y).
Proof. apply @preserves_binary_fun. Qed.
Hint Rewrite ARtoCR_preserves_mult_bounded : ARtoCR.

Lemma ARtoCR_approximate (x : AR) (ε : Qpos) : '(approximate x ε) = approximate ('x) ε.
Proof. reflexivity. Qed.

Lemma AR_b_correct (x : AR) :
  cast AQ Q (abs (approximate x (Qpos2QposInf (1#1))) + 1) = Qabs (approximate (cast AR CR x) (Qpos2QposInf (1#1))) + (1#1).
Proof. aq_preservation. Qed.

Program Definition AR_b (x : AR) : AQ₊
  := exist _ (abs (approximate x (Qpos2QposInf (1#1))) + 1) _.
Next Obligation.
  apply (strictly_order_reflecting (cast AQ Q)).
  rewrite AR_b_correct. aq_preservation.
  apply CR_b_pos.
Qed.

Global Instance ARmult: Mult AR := λ x y, ARmult_bounded (AR_b y) x y.

Lemma ARtoCR_preserves_mult x y : cast AR CR (x * y) = 'x * 'y.
Proof.
  unfold "*", ARmult at 1. rewrite ARtoCR_preserves_mult_bounded.
  assert (QposEq ('AR_b y : Qpos) (CR_b (1 # 1) ('y))).
  { unfold QposEq. simpl.
    now rewrite ARtoCR_approximate, <-AR_b_correct. }
  apply (CRmult_bounded_wd H5).
Qed.

Lemma ARmult_scale (x : AQ) (y : AR) :
  'x * y = ARscale x y.
Proof.
  apply (injective (cast AR CR)).
  rewrite ARtoCR_preserves_mult, ARtoCR_preserves_scale, ARtoCR_inject.
  now apply CRmult_scale.
Qed.

Hint Rewrite ARtoCR_preserves_mult : ARtoCR.

(* The approximate reals form a ring *)
Instance ARring: Ring AR.
Proof.
  apply (rings.projected_ring (cast AR CR)).
      exact ARtoCR_preserves_plus.
     exact ARtoCR_preserves_0.
    exact ARtoCR_preserves_mult.
   exact ARtoCR_preserves_1.
  exact ARtoCR_preserves_opp.
Qed.

Instance: SemiRing_Morphism (cast AR CR).
Proof.
  split. apply _. apply _.
  split. apply _. apply _.
  split. apply _. apply _.
  split. apply _. apply _.
  apply _.
     exact ARtoCR_preserves_plus.
    exact ARtoCR_preserves_0.
  split. apply _. apply _.
  split. apply _. apply _.
  split. apply _. apply _.
  apply _.
   exact ARtoCR_preserves_mult.
  exact ARtoCR_preserves_1.
Qed.

Instance: SemiRing_Morphism (cast CR AR).
Proof. change (SemiRing_Morphism (inverse (cast AR CR))). split; apply _. Qed.

Instance: SemiRing_Morphism (cast AQ AR).
Proof.
  split. apply _. apply _.
  split. apply _. apply _.
  split. apply _. apply _.
  split. apply _. apply _.
  apply _.
   intros. apply regFunEq_equiv, regFunEq_e. intros ε. apply ball_refl.
   apply (Qpos_nonneg (ε + ε)).
   apply regFunEq_equiv, regFunEq_e. intros ε.
   apply ball_refl.
   apply (Qpos_nonneg (ε + ε)).

  split. apply _. apply _.
  split. apply _. apply _.
  split. apply _. apply _.
  apply _.
  intros. rewrite ARmult_scale. apply regFunEq_equiv, regFunEq_e. intros ε.
   apply ball_refl.
   apply (Qpos_nonneg (ε + ε)).
   apply regFunEq_equiv, regFunEq_e. intros ε.
   apply ball_refl.
   apply (Qpos_nonneg (ε + ε)).
Qed.

Add Ring CR : (rings.stdlib_ring_theory CR).
Add Ring AR : (rings.stdlib_ring_theory AR).

Lemma ARplus_comm : forall x y : AR, x + y = y + x.
Proof.
  intros. ring.
Qed.

Lemma ARplus_assoc : forall u v w : AR,
    (u + v) + w = u + (v + w).
Proof.
  intros. ring.
Qed.

Lemma ARplus_opp_r :
  forall x : AR, x - x = 0.
Proof.
  intros. ring.
Qed.

Lemma ARmult_comm : forall x y : AR, x * y = y * x.
Proof.
  intros. ring.
Qed.

Lemma ARmult_assoc : forall u v w : AR,
    (u * v) * w = u * (v * w).
Proof.
  intros. ring.
Qed.

Lemma ARmult_1_l : forall x : AR, 1 * x = x.
Proof.
  intros. ring.
Qed.

Lemma ARmult_1_r : forall x : AR, x * 1 = x.
Proof.
  intros. ring.
Qed.

Lemma ARopp_mult_distr_r : forall (r1 r2 : AR),
    - (r1 * r2) = r1 * (- r2).
Proof.
  intros. ring.
Qed.

Lemma ARopp_involutive : forall (r1 : AR), - - r1 = r1.
Proof.
  intros. ring.
Qed.

Lemma ARplus_0_r : forall x : AR, x + 0 = x.
Proof.
  intros. ring.
Qed.

(* Non strict order *)
Definition ARnonNeg (x : AR) : Prop := ∀ ε : Qpos, -cast Qpos Q ε ≤ cast AQ Q (approximate x ε).

Lemma ARtoCR_preserves_nonNeg x : ARnonNeg x ↔ CRnonNeg ('x).
Proof. reflexivity. Qed.
Hint Resolve ARtoCR_preserves_nonNeg.

Global Instance: Proper ((=) ==> iff) ARnonNeg.
Proof.
  intros x1 x2 E.
  split; intros; apply ARtoCR_preserves_nonNeg; [rewrite <-E | rewrite E]; auto.
Qed.

Global Instance ARle: Le AR := λ x y, ARnonNeg (y - x).

Global Instance ARle_wd: Proper ((=) ==> (=) ==> iff) ARle.
Proof. unfold ARle. solve_proper. Qed.

Lemma ARtoCR_preserves_le (x y : AR) : x ≤ y ↔ ' x ≤ ' y.
Proof.
  unfold le, ARle, CRle.
  now rewrite ARtoCR_preserves_nonNeg, rings.preserves_minus.
Qed.

Instance: PartialOrder ARle.
Proof.
  apply (maps.projected_partial_order (cast AR CR)).
  apply ARtoCR_preserves_le.
Qed.

Lemma ARle_trans : forall x y z : AR,
    ARle x y -> ARle y z -> ARle x z.
Proof.
  intros.
  apply ARtoCR_preserves_le.
  apply (@CRle_trans _ ('y)).
  apply ARtoCR_preserves_le, H5.
  apply ARtoCR_preserves_le, H6.
Qed.

Lemma ARsquare_pos : forall x : AR, ARle 0 (x*x).
Proof.
  intros x.
  apply ARtoCR_preserves_le.
  rewrite ARtoCR_preserves_mult.
  rewrite ARtoCR_preserves_0.
  apply CRsquare_pos.
Qed.

Lemma ARplus_le_compat_l :
  forall x y z : AR, ARle x y -> ARle (z+x) (z+y).
Proof.
  intros. apply ARtoCR_preserves_le.
  rewrite ARtoCR_preserves_plus.
  rewrite ARtoCR_preserves_plus.
  apply CRArith.CRplus_le_l.
  apply ARtoCR_preserves_le in H5.
  exact H5.
Qed.

Lemma ARplus_le_compat_r :
  forall x y z : AR, ARle x y -> ARle (x+z) (y+z).
Proof.
  intros. apply ARtoCR_preserves_le.
  rewrite ARtoCR_preserves_plus.
  rewrite ARtoCR_preserves_plus.
  apply CRArith.CRplus_le_r.
  apply ARtoCR_preserves_le in H5.
  exact H5.
Qed.

Global Instance: OrderEmbedding ARtoCR.
Proof. repeat (split; try apply _); apply ARtoCR_preserves_le. Qed.

(* Strict order in Type *)
Global Instance: OrderEmbedding (cast AQ AR).
Proof.
  repeat (split; try apply _); intros x y E.
   apply (order_reflecting (cast AR CR)).
   rewrite 2!ARtoCR_inject.
   now do 2 apply (order_preserving _).
  apply (order_reflecting (cast AQ Q)).
  apply (order_reflecting (cast Q CR)).
  rewrite <-2!ARtoCR_inject.
  now apply (order_preserving _).
Qed.

Definition ARpos (x : AR) : Type := sig (λ y : AQ₊, 'y ≤ x).

Program Definition ARpos_char (ε : AQ₊) (x : AR)
  (Pε : 'ε ≤ approximate x ((1#2) * 'ε)%Qpos) : ARpos x := Pos_shiftl ε (-1 : Z) ↾ _.
Next Obligation.
  intros δ.
  change (-('δ : Q) ≤ '(approximate x ((1 # 2) * δ)%Qpos - ('ε : AQ) ≪ (-1))).
  transitivity (-'((1 # 2) * δ)%Qpos).
   apply rings.flip_le_negate.
   change ((1 # 2) * proj1_sig δ ≤ proj1_sig δ).
   rewrite <-(rings.mult_1_l (proj1_sig δ)) at 2.
   now apply (order_preserving (.* (proj1_sig δ))).
  apply rings.flip_nonneg_minus.
  transitivity ('approximate x ((1#2) * 'ε)%Qpos - 'ε : Q).
   apply (order_preserving (cast AQ Q)) in Pε.
   now apply rings.flip_nonneg_minus.
  apply rings.flip_le_minus_l.
  transitivity (((1 # 2) * 'ε + (1 # 2) * proj1_sig δ)
                + 'approximate x ((1 # 2) * δ)%Qpos).
   apply rings.flip_le_minus_l.
   now destruct (regFun_prf x ((1#2) * 'ε)%Qpos ((1#2) * δ)%Qpos).
  rewrite rings.preserves_minus, aq_shift_opp_1.
  apply orders.eq_le.
  change ((1 # 2) * 'ε + (1 # 2) * proj1_sig δ + 'approximate x ((1 # 2) * δ)%Qpos ==
          'approximate x ((1 # 2) * δ)%Qpos - 'ε * (1#2) - - ((1 # 2) * proj1_sig δ) + 'ε)%Q.
  ring.
Qed.

Lemma ARtoCR_preserves_pos x
  : prod (ARpos x -> CRpos ('x))
         (CRpos ('x) -> ARpos x).
Proof with auto with qarith.
  split; intros [y E].
   exists (cast (AQ₊) (Q₊) y).
   change (cast Q CR (cast AQ Q (cast (AQ₊) AQ y)) ≤ cast AR CR x).
   rewrite <-ARtoCR_inject.
   now apply (order_preserving _).
  destruct (aq_lt_mid 0 (proj1_sig y)) as [z [Ez1 Ez2]]...
  assert (0 < z) as F.
   apply (strictly_order_reflecting (cast AQ Q)). now aq_preservation...
  exists (exist _ z F). simpl.
  change (cast AQ AR (cast (AQ₊) AQ (z ↾ F)) ≤ x).
  apply (order_reflecting (cast AR CR)).
  rewrite ARtoCR_inject.
  transitivity (cast Q CR (cast Qpos Q y)); trivial.
  apply CRle_Qle...
Defined.

Lemma ARpos_wd : ∀ x1 x2, x1 = x2 → ARpos x1 → ARpos x2.
Proof.
  intros x1 x2 E G.
  destruct G. exists x.
  rewrite <- E. exact l.
Defined.

Definition ARltT: AR → AR → Type := λ x y, ARpos (y - x).

Lemma ARtoCR_preserves_ltT x y
  : prod (ARltT x y -> CRltT ('x) ('y))
         (CRltT ('x) ('y) -> ARltT x y).
Proof.
  split; intros.
  - apply ARtoCR_preserves_pos in X.
    eapply CRpos_wd; eauto.
    now autorewrite with ARtoCR.
  - apply ARtoCR_preserves_pos.
    eapply CRpos_wd; eauto.
    now autorewrite with ARtoCR.
Defined.

Lemma CRtoAR_preserves_ltT : forall x y,
    prod (CRltT x y -> ARltT (cast CR AR x) (cast CR AR y))
         (ARltT (cast CR AR x) (cast CR AR y) -> CRltT x y).
Proof.
  intros x y.
  pose proof (CRAR_id x) as H6.
  pose proof (CRAR_id y) as H7.
  split.
  - intros. symmetry in H6. symmetry in H7.
    pose proof (CRltT_wd H6 H7 H5).
    apply ARtoCR_preserves_ltT in H8. exact H8.
  - intros H5.
    apply (CRltT_wd H6 H7).
    apply ARtoCR_preserves_ltT. exact H5.
Qed.

Lemma ARltT_wd : ∀ x1 x2 : AR, x1 = x2 → ∀ y1 y2, y1 = y2 → ARltT x1 y1 → ARltT x2 y2.
Proof.
  intros x1 x2 E y1 y2 F G.
  apply (ARpos_wd (y1 + - x1)). 2: exact G.
  rewrite E, F. reflexivity.
Defined.

(* Apartness in Type *)
Definition ARapartT: AR → AR → Type := λ x y, sum (ARltT x y) (ARltT y x).

Lemma ARapartT_wd : forall x y z t : AR,
    msp_eq x y
    -> msp_eq z t
    -> ARapartT x z
    -> ARapartT y t.
Proof.
  intros. destruct X.
  - left. apply (ARltT_wd _ _ H5 _ _ H6), a.
  - right. apply (ARltT_wd _ _ H6 _ _ H5), a.
Defined.

Lemma ARtoCR_preserves_apartT x y
  : prod (ARapartT x y -> CRapartT ('x) ('y))
         (CRapartT ('x) ('y) -> ARapartT x y).
Proof. split; (intros [|]; [left|right]; now apply ARtoCR_preserves_ltT). Defined.

Lemma ARtoCR_preserves_apartT_0 x
  : prod (ARapartT x 0 -> CRapartT ('x) 0)
         (CRapartT ('x) 0 -> ARapartT x 0).
Proof.
  split; intros.
  - apply (@CRapartT_wd ('x)%mc _ (reflexivity _) (cast AR CR 0)).
    apply ARtoCR_preserves_0.
    apply ARtoCR_preserves_apartT, X.
  - apply (@CRapartT_wd ('x)%mc _ (reflexivity _) _ (cast AR CR 0)) in H5.
    apply ARtoCR_preserves_apartT in H5. exact H5.
    symmetry; apply ARtoCR_preserves_0.
Defined.

(* Strict order in Prop *)

(* Yields Gt if x is certainly greater than 2 ^ k, Lt if x is certainly greater than -2 ^ k,
  Eq otherwise. *)
Definition AR_epsilon_sign_dec (k : Z) (x : AR) : comparison :=
  let ε : AQ₊ := Pos_shiftl 1 k in
  let z : AQ := approximate x ((1#2) * 'ε)%Qpos in
  if decide_rel (≤) ('ε) z
    then Gt
    else if decide_rel (≤) z (-'ε) then Datatypes.Lt else Eq.

Program Definition AR_epsilon_sign_dec_pos (x : AR)
  (k : Z) (Pk : AR_epsilon_sign_dec k x ≡ Gt) : ARpos x := ARpos_char (Pos_shiftl 1 k) x _.
Next Obligation.
  revert Pk. unfold AR_epsilon_sign_dec.
  case (decide_rel (≤)); [ intros; assumption |].
  case (decide_rel (≤)); discriminate.
Qed.

Program Definition AR_epsilon_sign_dec_neg (x : AR)
  (k : Z) (Pk : AR_epsilon_sign_dec k x ≡ Datatypes.Lt) : ARpos (-x) := ARpos_char (Pos_shiftl 1 k) (-x) _.
Next Obligation.
  revert Pk. unfold AR_epsilon_sign_dec.
  case (decide_rel (≤)); [discriminate |].
  case (decide_rel (≤)); [| discriminate].
  intros. apply rings.flip_le_negate.
  now rewrite rings.negate_involutive.
Qed.

Definition AR_epsilon_sign_dec_apartT (x y : AR)
  (k : Z) (Pk : ¬AR_epsilon_sign_dec k (x - y) ≡ Eq) : ARapartT x y.
Proof.
  revert Pk.
  case_eq (AR_epsilon_sign_dec k (x - y)); intros E ?.
    now destruct Pk.
   left. apply ARpos_wd with (-(x - y)).
    ring.
   now apply AR_epsilon_sign_dec_neg with k.
  right. now apply AR_epsilon_sign_dec_pos with k.
Defined.

Lemma AR_epsilon_sign_dec_Gt (k : Z) (x : AR) :
  1 ≪ k ≤ approximate x (Qpos_mult (1#2) ('Pos_shiftl (1:AQ₊) k)) → AR_epsilon_sign_dec k x ≡ Gt.
Proof.
  intros.
  unfold AR_epsilon_sign_dec.
  case (decide_rel _); intuition.
Qed.

Lemma AR_epsilon_sign_dec_pos_rev (x : AR) (k : Z) :
  cast AQ AR (1 ≪ (1 + k)) ≤ x → AR_epsilon_sign_dec k x ≡ Gt.
Proof.
  intros E.
  apply AR_epsilon_sign_dec_Gt.
  apply (order_reflecting (+ -1 ≪ (1 + k))).
  transitivity (-1 ≪ k).
   apply orders.eq_le.
   rewrite (commutativity _ k), shiftl.shiftl_exp_plus, shiftl.shiftl_1.
   rewrite rings.plus_mult_distr_r, rings.mult_1_l.
   rewrite rings.negate_plus_distr, associativity, rings.plus_negate_r.  simpl. ring.
  apply (order_reflecting (cast AQ Q)).
  rewrite rings.preserves_negate.
  exact (E ('Pos_shiftl (1 : AQ₊) k)).
Qed.

(* Hack: we write [-1 - cast nat Z n] instead of [cast nat Z n] because
   approximate is not Proper. *)
Global Instance ARlt: Lt AR := λ x y,
  ∃ n : nat, AR_epsilon_sign_dec (-1 - cast nat Z n) (y - x) ≡ Gt.

Lemma AR_lt_ltT x y : prod (x < y -> ARltT x y)
                           (ARltT x y -> x < y).
Proof.
  split.
  - intros E.
   apply ConstructiveEpsilon.constructive_indefinite_description_nat in E.
    destruct E as [n En].
    now apply AR_epsilon_sign_dec_pos with (-1 - cast nat Z n).
   intros. now apply comparison_eq_dec.
  - intros [ε Eε].
  exists (Z.nat_of_Z (-Qdlog2 ('ε))).
  apply AR_epsilon_sign_dec_pos_rev.
  transitivity ('ε : AR); [| assumption].
  rapply (order_preserving (cast AQ AR)).
  apply (order_reflecting (cast AQ Q)).
  rewrite aq_shift_correct, rings.preserves_1, rings.mult_1_l.
  destruct (decide (('ε : Q) ≤ 1)).
   rewrite Z.nat_of_Z_nonneg.
    mc_setoid_replace (1 + (-1 - - Qdlog2 ('ε))) with (Qdlog2 ('ε)) by ring.
    apply Qdlog2_spec.
    apply semirings.preserves_pos.
    now destruct ε.
   change (0 ≤ -Qdlog2 ('ε)).
   apply rings.flip_nonpos_negate.
   now apply Qdlog2_nonpos.
  rewrite Z.nat_of_Z_nonpos.
   now apply orders.le_flip.
  change (-Qdlog2 ('ε) ≤ 0).
  apply rings.flip_nonneg_negate.
  apply Qdlog2_nonneg.
  now apply orders.le_flip.
Qed.

Instance: Proper ((=) ==> (=) ==> iff) ARlt.
Proof. split; intro E; apply AR_lt_ltT; apply AR_lt_ltT in E;
  eapply ARltT_wd; eauto; now symmetry. Qed.

(* Apartness in Prop *)
Global Instance ARapart: Apart AR := λ x y, x < y ∨ y < x.

Lemma ARtoCR_preserves_lt (x y : AR) : x < y ↔ 'x < 'y.
Proof.
  split; intros E.
   now apply CR_lt_ltT, ARtoCR_preserves_ltT, AR_lt_ltT.
  now apply AR_lt_ltT, ARtoCR_preserves_ltT, CR_lt_ltT.
Qed.

Lemma AR_apart_apartT x y : prod (x ≶ y -> ARapartT x y)
                                 (ARapartT x y -> x ≶ y).
Proof.
  split.
  - intros E.
   set (f (n : nat) := AR_epsilon_sign_dec (-1 - cast nat Z n)).
   assert (∃ n, f n (y - x) ≡ Gt ∨ f n (x - y) ≡ Gt) as E2.
    now destruct E as [[n En] | [n En]]; exists n; [left | right].
   apply ConstructiveEpsilon.constructive_indefinite_description_nat in E2.
    destruct E2 as [n E2].
    destruct (comparison_eq_dec (f n (y - x)) Gt) as [En|En].
     left. now apply AR_epsilon_sign_dec_pos with (-1 - cast nat Z n).
    right. apply AR_epsilon_sign_dec_pos with (-1 - cast nat Z n).
    destruct E2; tauto.
   intros n.
   destruct (comparison_eq_dec (f n (y - x)) Gt); auto.
   destruct (comparison_eq_dec (f n (x - y)) Gt); tauto.
  - intros [E|E].
   left. now apply AR_lt_ltT.
  right. now apply AR_lt_ltT.
Qed.

Let ARtoCR_preserves_apart x y : x ≶ y ↔ cast AR CR x ≶ cast AR CR y.
Proof.
  unfold apart, ARapart, CRapart.
  now rewrite !ARtoCR_preserves_lt.
Qed.

Instance: StrongSetoid AR.
Proof.
  apply (strong_setoids.projected_strong_setoid (cast AR CR)).
   split; intros E; [now rewrite E | now apply (injective (cast AR CR))].
  now apply ARtoCR_preserves_apart.
Qed.

Instance: StrongSetoid_Morphism (cast AR CR).
Proof. split; try apply _; now apply ARtoCR_preserves_apart. Qed.

Global Instance: StrongInjective (cast AR CR).
Proof. split; try apply _; now apply ARtoCR_preserves_apart. Qed.

Global Instance: StrongSemiRing_Morphism (cast AR CR).
Proof. split; try apply _. Qed.

Global Instance: StrongSemiRing_Morphism (cast AQ AR).
Proof.
  repeat (split; try apply _). intros.
  apply (strong_extensionality (cast AQ Q)).
  apply (strong_extensionality (cast Q CR)).
  rewrite <-2!ARtoCR_inject.
  now apply (strong_injective _).
Qed.

Global Instance: StrongInjective (cast AQ AR).
Proof.
  repeat (split; try apply _). intros.
  apply (strong_extensionality (cast AR CR)).
  rewrite 2!ARtoCR_inject.
  apply (strong_injective _).
  now apply (strong_injective _).
Qed.

Global Instance ARfpsro: FullPseudoSemiRingOrder ARle ARlt.
Proof.
  apply (rings.projected_full_pseudo_ring_order (cast AR CR)).
   apply ARtoCR_preserves_le.
  apply ARtoCR_preserves_lt.
Qed.

Lemma ARle_not_lt (x y: AR): ARle x y <-> (ARltT y x -> False).
Proof.
  destruct ARfpsro as [_ flip].
  specialize (flip x y). destruct flip.
  split.
  - intros. apply H5. exact H7.
    apply AR_lt_ltT, X.
  - intros. apply H6. intro abs. apply H7.
    apply AR_lt_ltT, abs.
Qed.

Global Instance: StrictOrderEmbedding (cast AR CR).
Proof. repeat (split; try apply _); apply ARtoCR_preserves_lt. Qed.

(* Division *)
Lemma aq_mult_inv_regular_prf (x : AQ) :
  is_RegularFunction_noInf _ (λ ε : Qpos, app_div 1 x (Qdlog2 (proj1_sig ε)) : AQ_as_MetricSpace).
Proof.
  intros ε1 ε2. simpl.
  eapply ball_triangle.
   now eapply aq_div_dlog2.
  now eapply ball_sym, aq_div_dlog2.
Qed.

Definition AQinv (x : AQ) : AR := mkRegularFunction (0 : AQ_as_MetricSpace) (aq_mult_inv_regular_prf x).

Definition AQinv_bounded (c : AQ₊) (x : AQ_as_MetricSpace) : AR := AQinv (('c) ⊔ x).

Lemma AQinv_pos_uc_prf (c : AQ₊) : is_UniformlyContinuousFunction
  (AQinv_bounded c) (Qinv_modulus ('c)).
Proof.
  intros ε x y E δ1 δ2. simpl in *.
  eapply ball_triangle.
   2: now eapply ball_sym, aq_div_dlog2.
  eapply ball_triangle.
   now eapply aq_div_dlog2.
   simpl. aq_preservation.
  rewrite 2!left_identity.
   pose proof (Qinv_pos_uc_prf (' c) ε (' x) (' y)) as H5.
   simpl in H5. apply H5.
   exact E.
Qed.

Definition AQinv_pos_uc (c : AQ₊) := Build_UniformlyContinuousFunction (AQinv_pos_uc_prf c).

Definition ARinv_pos (c : AQ₊) : AR --> AR := Cbind AQPrelengthSpace (AQinv_pos_uc c).

Lemma ARtoCR_preserves_inv_pos_aux c (x : AR) : is_RegularFunction_noInf _
   (λ γ, / Qmax (''c) ('approximate x (Qinv_modulus ('c) γ)) : Q_as_MetricSpace).
Proof.
  intros ε1 ε2.
  apply_simplified (Qinv_pos_uc_prf ('c) (ε1 + ε2)%Qpos).
  apply AQball_fold.
  setoid_replace (' c * ' c * (` ε1 + ` ε2))%Q
    with (proj1_sig (Qinv_modulus ('c) ε1 + Qinv_modulus ('c) ε2)%Qpos)
    by (unfold equiv, stdlib_rationals.Q_eq; simpl; ring).
  apply regFun_prf.
Qed.

Lemma ARtoCR_preserves_inv_pos x c : 'ARinv_pos c x = CRinv_pos ('c) ('x).
Proof.
  apply regFunEq_equiv, regFunEq_e. intros ε.
  simpl. unfold Cjoin_raw. simpl.
  setoid_replace (proj1_sig ε + proj1_sig ε)%Q
    with (proj1_sig ((1#2) * ε + ((1#2) * ε + ε)))%Qpos
    by (unfold equiv, stdlib_rationals.Q_eq; simpl; ring).
  eapply ball_triangle.
   now apply aq_div_dlog2.
   simpl.
  rewrite aq_preserves_max.
  rewrite rings.preserves_1.
  rewrite Qmult_1_l.
  change (Qball ( (1 # 2) * ` ε + ` ε)
                (/ Qmax (' (' c)) (' approximate x (Qinv_modulus (' c) ((1 # 2) ↾ eq_refl * ε))))%mc
                ( / Qmax (' c) (' approximate x (Qinv_modulus (' c) ε)))).
  apply (ARtoCR_preserves_inv_pos_aux c x ((1 # 2) * ε)%Qpos).
Qed.
Hint Rewrite ARtoCR_preserves_inv_pos : ARtoCR.

Definition ARinvT (x : AR) (x_ : ARapartT x 0) : AR :=
  match x_ with
  | inl (exist _ c _) => - ARinv_pos c (- x)
  | inr (exist _ c _) => ARinv_pos c x
  end.

Lemma ARtoCR_preserves_invT x x_ x__:
  'ARinvT x x_ = CRinvT ('x) x__.
Proof with auto with qarith; try reflexivity.
  unfold ARinvT.
  destruct x_ as [Ec | Ec].
   assert (CRltT ('x) 0) as Px.
    apply CRltT_wd with ('x) (cast AR CR 0).
      reflexivity.
     now apply rings.preserves_0.
    now apply ARtoCR_preserves_ltT.
   rewrite (CRinvT_irrelevant _ (inl Px)).
   unfold CRinvT.
   destruct Ec as [c Ec], Px as [d Ed].
   autorewrite with ARtoCR.
   destruct (Qlt_le_dec (proj1_sig d) (proj1_sig ('c : Qpos))).
    rewrite (CRinv_pos_weaken d ('c))...
    change (cast Q CR (cast AQ Q (cast (AQ₊) AQ c)) ≤ -cast AR CR x).
    rewrite <-ARtoCR_inject, <-rings.preserves_negate.
    apply (order_preserving _).
    rewrite <-(rings.plus_0_l (-x))...
   rewrite (CRinv_pos_weaken ('c) d)...
   rewrite <-(rings.plus_0_l (-cast AR CR x))...
  assert (CRltT 0 ('x)) as Px.
   apply CRltT_wd with (cast AR CR 0) ('x).
     now apply rings.preserves_0.
    reflexivity.
   now apply ARtoCR_preserves_ltT.
  rewrite (CRinvT_irrelevant _ (inr Px)).
  unfold CRinvT.
  destruct Ec as [c Ec], Px as [d Ed].
  autorewrite with ARtoCR.
  destruct (Qlt_le_dec (proj1_sig d) (proj1_sig ('c : Qpos))).
   rewrite (CRinv_pos_weaken d ('c))...
   change (cast Q CR (cast AQ Q (cast (AQ₊) AQ c)) ≤ cast AR CR x).
   rewrite <-ARtoCR_inject.
   apply (order_preserving _).
   setoid_replace x with (x - 0) by ring...
  rewrite (CRinv_pos_weaken ('c) d)...
  rewrite <-(rings.plus_0_r (cast AR CR x))...
Qed.

Lemma ARtoCR_preserves_invT_l x x_ : {x__ | 'ARinvT x x_ = CRinvT ('x) x__}.
Proof.
  exists (fst (ARtoCR_preserves_apartT_0 x) x_).
  apply ARtoCR_preserves_invT.
Qed.

Lemma ARtoCR_preserves_invT_r x x__ : {x_ | 'ARinvT x x_ = CRinvT ('x) x__}.
Proof.
  exists (snd (ARtoCR_preserves_apartT_0 x) x__).
  apply ARtoCR_preserves_invT.
Qed.

Lemma AR_inverseT (x : AR) x_ : x * ARinvT x x_ = 1.
Proof.
  apply (injective (cast AR CR)).
  rewrite rings.preserves_mult, rings.preserves_1.
  destruct (ARtoCR_preserves_invT_l x x_) as [x__ E]. rewrite E.
  apply CRmult_inv_r.
Qed.

Lemma ARinvT_wd x y x_ y_ : x = y → ARinvT x x_ = ARinvT y y_.
Proof.
  intros E.
  apply (injective (cast AR CR)).
  destruct (ARtoCR_preserves_invT_l x x_) as [x__ Ex],
    (ARtoCR_preserves_invT_l y y_) as [y__ Ey].
  rewrite Ex, Ey.
  now apply CRinvT_wd.
Qed.

Lemma ARinvT_irrelevant x x_ x__ : ARinvT x x_ = ARinvT x x__.
Proof. now apply ARinvT_wd. Qed.

(* Division with apartness in Prop *)
Program Instance ARinv: Recip AR := λ x, ARinvT x _.
Next Obligation. apply AR_apart_apartT. now destruct x. Qed.

Global Instance: Field AR.
Proof.
  split. apply _. apply _.
  apply _. apply _.
    apply (strong_injective (cast AQ AR)).
    solve_propholds.
    split. apply _. apply _.
   intros [x Px] [y Py] E.
   now refine (ARinvT_wd _ _ _ _ _).
  intros x.
  now apply AR_inverseT.
Qed.

(* Nat pow *)
Program Definition AQpower_N_uc (n : N) (c : AQ₊) :
    AQ_as_MetricSpace --> AQ_as_MetricSpace := unary_uc
  (cast AQ Q_as_MetricSpace)
  (λ x : AQ_as_MetricSpace, (AQboundAbs_uc c x) ^ n : AQ_as_MetricSpace) (Qpower_N_uc n ('c)) _.
Next Obligation.
  assert (∀ y : AQ, cast AQ Q (y ^ n) = 'y ^ 'n) as preserves_pow_pos.
   intros y.
   rewrite nat_pow.preserves_nat_pow.
   now rewrite (int_pow.int_pow_nat_pow (f:=cast N Z)).
   apply Qball_0.
  rewrite preserves_pow_pos. aq_preservation.
Qed.

Definition ARpower_N_bounded (n : N) (c : AQ₊) : AR --> AR := Cmap AQPrelengthSpace (AQpower_N_uc n c).

Lemma ARtoCR_preserves_power_N_bounded x n c :
  'ARpower_N_bounded n c x = CRpower_N_bounded n ('c) ('x).
Proof. apply preserves_unary_fun. Qed.

Global Instance ARpower_N: Pow AR N := λ x n, ucFun (ARpower_N_bounded n (AR_b x)) x.

Lemma ARtoCR_preserves_power_N (x : AR) (n : N) :
  cast AR CR (x ^ n) = ('x) ^ n.
Proof.
  unfold pow, CRpower_N, ARpower_N.
  rewrite ARtoCR_preserves_power_N_bounded.
  apply Cmap_wd. 2: reflexivity.
  assert (QposEq (cast (AQ₊) (Q₊) (AR_b x)) (CR_b (1#1) ('x))).
  { unfold QposEq. simpl.
    now rewrite ARtoCR_approximate, <-AR_b_correct. }
   rewrite H5. reflexivity.
Qed.

Hint Rewrite ARtoCR_preserves_power_N : ARtoCR.

Global Instance: NatPowSpec AR N _.
Proof.
  split.
    intros ? ? Ex ? ? En.
    apply (injective (cast AR CR)). autorewrite with ARtoCR.
    now rewrite Ex, En.
   intros. apply (injective (cast AR CR)). autorewrite with ARtoCR.
   now rewrite nat_pow_0.
  intros. apply (injective (cast AR CR)). autorewrite with ARtoCR.
  now rewrite nat_pow_S.
Qed.

(* Misc properties *)
Lemma ARmult_bounded_mult (x y : AR) c :
  -'c ≤ y ≤ 'c → ARmult_bounded c x y = x * y.
Proof.
  intros.
  apply (injective (cast AR CR)).
  rewrite ARtoCR_preserves_mult, ARtoCR_preserves_mult_bounded.
  destruct c as [c Pc].
  apply CRmult_bounded_mult.
   change (cast Q CR (-cast AQ Q c) ≤ cast AR CR y).
   rewrite <-rings.preserves_negate.
   rewrite <-ARtoCR_inject.
   apply (order_preserving _). intuition.
  change (cast AR CR y ≤ cast Q CR (cast AQ Q c)).
  rewrite <-ARtoCR_inject.
  apply (order_preserving _). intuition.
Qed.

Lemma ARpower_N_bounded_N_power (n : N) (x : AR) (c : AQ₊) :
  -'c ≤ x ≤ 'c → ARpower_N_bounded n c x = x ^ n.
Proof.
  intros.
  apply (injective (cast AR CR)).
  rewrite ARtoCR_preserves_power_N, ARtoCR_preserves_power_N_bounded.
  destruct c as [c Pc].
  apply CRpower_N_bounded_N_power. split.
   change (cast Q CR (-cast AQ Q c) ≤ cast AR CR x).
   rewrite <-rings.preserves_negate.
   rewrite <-ARtoCR_inject.
   apply (order_preserving _). intuition.
  change (cast AR CR x ≤ cast Q CR (cast AQ Q c)).
  rewrite <-ARtoCR_inject.
  apply (order_preserving _). intuition.
Qed.

Lemma inject_Q_AR_lt : ∀ q r : Q, q < r → ARltT (inject_Q_AR q) (inject_Q_AR r).
Proof.
  intros.
  destruct (ARtoCR_preserves_ltT (' (' q)%CR) (' (' r)%CR)) as [_ a].
  pose proof (inject_Q_AR_CR q).
  pose proof (inject_Q_AR_CR r).
  symmetry in H6. symmetry in H7.
  apply (ARltT_wd _ _ H6 _ _ H7).
  apply a. clear a H6 H7.
  pose proof (CRAR_id ('q)%CR). pose proof (CRAR_id ('r)%CR).
  symmetry in H6. symmetry in H7.
  apply (@CRltT_wd _ _ H6 _ _ H7).
  apply CRlt_Qlt, H5.
Qed.

Lemma inject_Q_AR_lt_rev : ∀ q r : Q, ARltT (inject_Q_AR q) (inject_Q_AR r) → q < r.
Proof.
  intros.
  destruct (ARtoCR_preserves_ltT (' (' q)%CR) (' (' r)%CR)) as [c _].
  pose proof (inject_Q_AR_CR q) as H6.
  pose proof (inject_Q_AR_CR r) as H7.
  apply (ARltT_wd _ _ H6 _ _ H7) in X.
  apply c in X. clear c H6 H7.
  pose proof (CRAR_id ('q)%CR). pose proof (CRAR_id ('r)%CR).
  apply (@CRltT_wd _ _ H5 _ _ H6) in X.
  apply Qlt_from_CRlt, X.
Qed.

Lemma inject_Q_AR_le : ∀ q r : Q, q <= r → ARle (inject_Q_AR q) (inject_Q_AR r).
Proof.
  intros.
  apply ARle_not_lt.
  intro abs.
  apply inject_Q_AR_lt_rev in abs.
  exact (Qlt_not_le _ _ abs H5).
Qed.

Lemma inject_Q_AR_plus : ∀ q r : Q,
    inject_Q_AR (q + r) = inject_Q_AR q + inject_Q_AR r.
Proof.
  intros.
  apply (injective (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace))).
  pose proof CRAR_id as H5.
  unfold cast in H5.
  unfold ARtoCR, ARtoCR_uc in H5.
  unfold cast.
  rewrite (inject_Q_AR_CR (q+r)).
  rewrite (inject_Q_AR_CR q).
  rewrite (inject_Q_AR_CR r).
  unfold cast. unfold cast in H5.
  rewrite H5.
  pose proof (ARtoCR_preserves_plus (CRtoAR (' q)%CR) (CRtoAR (' r)%CR)) as H6.
  rewrite H6.
  rewrite <- CRplus_Qplus.
  apply ucFun2_wd. rewrite (H5 ('q)%CR). reflexivity.
  rewrite (H5 ('r)%CR). reflexivity.
Qed.

Lemma inject_Q_AR_mult : ∀ q r : Q,
    inject_Q_AR (q * r) = inject_Q_AR q * inject_Q_AR r.
Proof.
  intros.
  apply (injective (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace))).
  pose proof CRAR_id as H5.
  unfold cast in H5.
  unfold ARtoCR, ARtoCR_uc in H5.
  rewrite (inject_Q_AR_CR (q*r)).
  rewrite (inject_Q_AR_CR q).
  rewrite (inject_Q_AR_CR r).
  unfold cast. unfold cast in H5.
  rewrite H5.
  pose proof (ARtoCR_preserves_mult (CRtoAR (' q)%CR) (CRtoAR (' r)%CR)) as H6.
  rewrite H6.
  rewrite <- CRmult_Qmult.
  apply CRmult_wd. rewrite (H5 ('q)%CR). reflexivity.
  rewrite (H5 ('r)%CR). reflexivity.
Qed.

Lemma inject_Q_AR_1 : inject_Q_AR (1#1) = 1.
Proof.
  Local Transparent regFunEq.
  intros e1 e2. simpl.
  destruct aq_dense_embedding.
  specialize (dense_inverse 1 e1).
  simpl in dense_inverse.
  rewrite Qplus_0_r.
  apply (@ball_weak_le Q_as_MetricSpace (`e1) (`e1+`e2)).
  apply (Qle_trans _ (`e1 + 0)).
  rewrite Qplus_0_r. apply Qle_refl.
  apply Qplus_le_r, Qpos_nonneg.
  simpl. unfold cast.
  destruct aq_ring_morphism, semiringmor_mult_mor.
  rewrite preserves_mon_unit.
  exact dense_inverse.
Qed.

Lemma inject_Q_AR_0 : inject_Q_AR (0#1) = 0.
Proof.
  intros e1 e2. simpl.
  destruct aq_dense_embedding.
  simpl in dense_inverse.
  rewrite Qplus_0_r.
  apply (@ball_weak_le Q_as_MetricSpace (`e1) (`e1+`e2)).
  apply (Qle_trans _ (`e1 + 0)).
  rewrite Qplus_0_r. apply Qle_refl.
  apply Qplus_le_r, Qpos_nonneg.
  simpl. unfold cast.
  destruct aq_ring_morphism, semiringmor_plus_mor.
  rewrite preserves_mon_unit.
  apply dense_inverse.
Qed.

Lemma inject_Q_AR_wd : forall q r : Q,
    q == r -> inject_Q_AR q = inject_Q_AR r.
Proof.
  intros q r qreq e1 e2.
  simpl.
  destruct aq_dense_embedding.
  unfold cast.
  rewrite Qplus_0_r.
  apply ball_triangle with (b:=q).
  apply dense_inverse.
  simpl.
  rewrite qreq.
  change (Qball (` e2) r (AQtoQ (app_inverse AQtoQ r e2))).
  apply ball_sym.
  apply dense_inverse.
Qed.

Lemma AR_mult_0_lt_compat : ∀ x y : AR,
    ARltT (inject_Q_AR 0) x
    → ARltT (inject_Q_AR 0) y
    → ARltT (inject_Q_AR 0) (ARmult x y).
Proof.
  intros x y X X0.
  destruct (ARtoCR_preserves_ltT (inject_Q_AR 0) (ARmult x y)) as [_ a].
  apply a. clear a.
  pose proof (ARtoCR_preserves_mult x y) as H5.
  unfold mult in H5.
  symmetry in H5.
  assert (0 = ARtoCR (inject_Q_AR 0))%CR as H7.
  { rewrite <- (CRAR_id 0%CR).
    unfold cast.
    rewrite (inject_Q_AR_CR 0). reflexivity. }
  pose proof (ARtoCR_preserves_mult x y) as H8.
  symmetry in H8.
  apply (CRltT_wd H7 H8). clear H8 H5.
  apply CRmult_lt_0_compat.
  - destruct (ARtoCR_preserves_ltT (inject_Q_AR 0) x).
    apply c in X. clear a c.
    symmetry in H7.
    apply (CRltT_wd H7 (reflexivity _)). exact X.
  - destruct (ARtoCR_preserves_ltT (inject_Q_AR 0) y).
    apply c in X0. clear a c.
    symmetry in H7.
    apply (CRltT_wd H7 (reflexivity _)). exact X0.
Qed.

Lemma AR_mult_0_le_compat : ∀ x y : AR,
    ARle 0 x
    → ARle 0 y
    → ARle 0 (x*y).
Proof.
  intros.
  apply ARtoCR_preserves_le.
  rewrite ARtoCR_preserves_mult.
  rewrite ARtoCR_preserves_0.
  apply (CRmult_le_0_compat ('x) ('y)).
  rewrite <- ARtoCR_preserves_0.
  apply ARtoCR_preserves_le, H5.
  rewrite <- ARtoCR_preserves_0.
  apply ARtoCR_preserves_le, H6.
Qed.

End ARarith.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Functor.Bifunctor.
Require Import Category.Structure.Monoidal.
Require Import Category.Functor.Structure.Monoidal.

Generalizable All Variables.

Section MonoidalFunctors.

Context {C : Category}.
Context `{@Monoidal C}.
Context {D : Category}.
Context `{@Monoidal D}.
Context {G : C ⟶ D}.

Context {E : Category}.
Context `{@Monoidal E}.
Context {F : D ⟶ E}.

#[local] Obligation Tactic := program_simpl.

#[export] Program Instance Id_MonoidalFunctor :
  @MonoidalFunctor C C _ _ Id[C] := {
  pure_iso := iso_id;
  ap_functor_iso := {| to   := {| transform := fun _ => _ |}
                     ; from := {| transform := fun _ => _ |} |}
}.
Next Obligation.
  simpl; intros.
  destruct H0; simpl.
  exact id.
Defined.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation.
  simpl; intros.
  destruct H1; simpl.
  exact id.
Defined.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. cat. Qed.
Next Obligation. cat. Qed.
Next Obligation. apply tensor_assoc. Qed.
Next Obligation. rewrite bimap_id_id; cat. Qed.
Next Obligation. rewrite bimap_id_id; cat. Qed.
Next Obligation. rewrite !bimap_id_id; cat. Qed.

#[export] Program Instance Id_LaxMonoidalFunctor :
  @LaxMonoidalFunctor C C _ _ Id[C] := {
  lax_pure := id;
  ap_functor_nat := {| transform := fun _ => _ |}
}.
Next Obligation.
  simpl; intros.
  destruct H0; simpl.
  exact id.
Defined.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. simpl; intros; simplify; cat. Qed.
Next Obligation. apply tensor_assoc. Qed.
Next Obligation. rewrite bimap_id_id; cat. Qed.
Next Obligation. rewrite bimap_id_id; cat. Qed.
Next Obligation. rewrite !bimap_id_id; cat. Qed.

End MonoidalFunctors.


Require Import Nat.
Require Import String.
Require Import List.
From mathcomp Require Import all_ssreflect all_algebra.
From LF Require Export lang type.

Set Implicit Arguments.

Inductive state_equiv (s1 s2:state_sf) (VGamma:venv) (AGamma:aenv) : Prop :=
| st_equiv :
  (forall x, VGamma x = Some Public ->
   s1.(rmap_sf) x = s2.(rmap_sf) x) ->
  (forall a, AGamma a = Some Public ->
   s1.(mmap_sf) a = s2.(mmap_sf) a) ->
  s1.(scmd_sf) = s2.(scmd_sf) ->
  state_equiv s1 s2 VGamma AGamma.

Definition constant_time (VGamma:venv) (AGamma:aenv) (s1 s2:state_sf) := forall s1' s2' l1 l2 n,
state_equiv s1 s2 VGamma AGamma ->
multi_step s1 l1 n s1' ->
multi_step s2 l2 n s2' ->
l1 = l2 /\ (safe_state s1' <-> safe_state s2').

Lemma progress : forall VGamma AGamma s,
type_cmd VGamma AGamma s.(scmd_sf) ->
safe_state s.
Proof.
move=> VGamma AGamma [] /= [].
(* empty *)
+ by left.
(* i::c *)
move=> i c r m hty. induction hty. induction H.
(* x := e:: c*)
+ right.
  exists Lempty.
  exists {| scmd_sf := c0;
            rmap_sf := update_rmap r x
                       (sem_expr {| scmd_sf := Iassgn x e :: c0; rmap_sf := r; mmap_sf := m |} e);
            mmap_sf := m |}.
  by apply Iassgn_sem.
(* x := a[e]::c *)
+ case: a H0=> a e H0. right.
  exists (Lindex (sem_expr {| scmd_sf := Iload x (AA a e) :: c0; rmap_sf := r; mmap_sf := m |} e)).
  exists {| scmd_sf := c0;
            rmap_sf := update_rmap r x
                       (Array.get (mmap_sf {| scmd_sf := Iload x (AA a e) :: c0; rmap_sf := r; mmap_sf := m |} a)
                       (sem_expr {| scmd_sf := Iload x (AA a e) :: c0; rmap_sf := r; mmap_sf := m |} e));
            mmap_sf := m |}.
  by apply Iload_sem.
(* a[e] := e *)
+ case: a H0=> a ei H0. right.
  exists (Lindex (sem_expr {| scmd_sf := Istore (AA a ei) e :: c0; rmap_sf := r; mmap_sf := m |} ei)).
  exists {| scmd_sf := c0;
            rmap_sf := r;
            mmap_sf := update_mem m a
                       (sem_expr {| scmd_sf := Istore (AA a ei) e :: c0; rmap_sf := r; mmap_sf := m |} ei)
                       (sem_expr {| scmd_sf := Istore (AA a ei) e :: c0; rmap_sf := r; mmap_sf := m |} e) |}.
  by apply Istore_sem.
(* if b i1 i2 *)
+ case: b H=> b e1 e2 H. right.
  exists (Lbool (eval_bool_op b
                (sem_expr {| scmd_sf := Iif (Ebool b e1 e2) i0 i' :: c0; rmap_sf := r; mmap_sf := m |} e1)
                (sem_expr {| scmd_sf := Iif (Ebool b e1 e2) i0 i' :: c0; rmap_sf := r; mmap_sf := m |} e2))).
  exists {| scmd_sf := (if (eval_bool_op b (sem_expr {| scmd_sf := Iif (Ebool b e1 e2) i0 i' :: c0; rmap_sf := r; mmap_sf := m |} e1)
                                             (sem_expr {| scmd_sf := Iif (Ebool b e1 e2) i0 i' :: c0; rmap_sf := r; mmap_sf := m |} e2))
                        then i0
                        else i') ++ c0;
            rmap_sf := r;
            mmap_sf := m |}.
  by apply Iif_sem.
by left.
Qed.

Lemma union_public_eq : forall T T',
union_level T T' = Public ->
T = Public /\ T' = Public.
Proof.
unfold union_level. move=> T T'.
case: T=> //=.
Qed.

Lemma expr_equiv_val : forall VGamma s1 s2 e T,
(forall x ,VGamma x = Some Public ->
 s1.(rmap_sf) x = s2.(rmap_sf) x) ->
type_expr VGamma e T ->
T = Public ->
sem_expr s1 e = sem_expr s2 e.
Proof.
move=> VGamma [] st1 r1 m1 [] st2 r2 m2 e T /= hvar hty hteq.
induction hty.
+ rewrite hteq in H. rewrite /=. by move: (hvar x H)=> ->.
apply union_public_eq in hteq. case: hteq=> h1 h2.
case: o=> //=;move: (IHhty1 h1) => ->; by move: (IHhty2 h2) => ->.
Qed.

(* Because our language design is safe: it never goes to a stuck state *)
(* In speculative semantic it might be diff *)
Lemma safe_lang : forall s,
safe_state s.
Proof.
rewrite /safe_state /= /final_state /=.
move=> [] st r m /=. case: st=> //=.
+ by left.
move=> i c. case: i.
(* x := e *)
+ move=> x e. right. exists Lempty.
  exists {| scmd_sf := c;
            rmap_sf := update_rmap r x
                       (sem_expr {| scmd_sf := Iassgn x e :: c; rmap_sf := r; mmap_sf := m |} e);
            mmap_sf := m |}.
  by apply Iassgn_sem.
(* x := a[e]::c *)
+ move=> x [] a e. right.
  exists (Lindex (sem_expr {| scmd_sf := Iload x (AA a e) :: c; rmap_sf := r; mmap_sf := m |} e)).
  exists {| scmd_sf := c;
            rmap_sf := update_rmap r x
                       (Array.get (mmap_sf {| scmd_sf := Iload x (AA a e) :: c; rmap_sf := r; mmap_sf := m |} a)
                       (sem_expr {| scmd_sf := Iload x (AA a e) :: c; rmap_sf := r; mmap_sf := m |} e));
            mmap_sf := m |}.
  by apply Iload_sem.
(* a[e] := e *)
+ move=> [] a ei. right.
  exists (Lindex (sem_expr {| scmd_sf := Istore (AA a ei) e :: c; rmap_sf := r; mmap_sf := m |} ei)).
  exists {| scmd_sf := c;
            rmap_sf := r;
            mmap_sf := update_mem m a
                       (sem_expr {| scmd_sf := Istore (AA a ei) e :: c; rmap_sf := r; mmap_sf := m |} ei)
                       (sem_expr {| scmd_sf := Istore (AA a ei) e :: c; rmap_sf := r; mmap_sf := m |} e) |}.
  by apply Istore_sem.
(* if b i1 i2 *)
+ move=> [] b e1 e2 i i'. right.
  exists (Lbool (eval_bool_op b
                (sem_expr {| scmd_sf := Iif (Ebool b e1 e2) i i' :: c; rmap_sf := r; mmap_sf := m |} e1)
                (sem_expr {| scmd_sf := Iif (Ebool b e1 e2) i i' :: c; rmap_sf := r; mmap_sf := m |} e2))).
  exists {| scmd_sf := (if (eval_bool_op b (sem_expr {| scmd_sf := Iif (Ebool b e1 e2) i i' :: c; rmap_sf := r; mmap_sf := m |} e1)
                                             (sem_expr {| scmd_sf := Iif (Ebool b e1 e2) i i' :: c; rmap_sf := r; mmap_sf := m |} e2))
                        then i
                        else i') ++ c;
            rmap_sf := r;
            mmap_sf := m |}.
  by apply Iif_sem.
Qed.

Lemma sub_public_always_public : forall T,
sub_level T Public = true ->
T = Public.
Proof.
by move=> [] //=.
Qed.

Lemma union_public_always_public : forall T1 T2,
union_level T1 T2 = Public ->
T1 = Public /\ T2 = Public.
Proof.
by move=> [] [] //=.
Qed.

Lemma leakage_eq_n : forall s l n s',
multi_step s l n s' ->
size l = n.
Proof.
move=> [] st r m l n [] st' r' m' hmulti.
induction hmulti; auto.
by induction H;rewrite -cat1s size_cat /= IHhmulti add1n /= addn1.
Qed.

Lemma type_concat : forall VGamma AGamma c1 c2,
type_cmd VGamma AGamma c1 ->
type_cmd VGamma AGamma c2 ->
type_cmd VGamma AGamma (c1 ++ c2).
Proof.
move=> VGamma AGamma c1 c2 hc1 hc2.
induction c1; rewrite /=.
+ by apply hc2.
inversion hc1; subst.
apply T_seq.
+ by apply H1.
apply IHc1. by apply H2.
Qed.

Lemma preservation : forall VGamma AGamma s1 l1 s1',
type_cmd VGamma AGamma s1.(scmd_sf) ->
sem_instr s1 l1 s1' ->
type_cmd VGamma AGamma s1'.(scmd_sf).
Proof.
move=> VGamma AGamma [] st r m l1 s1' hty hstep.
induction hstep.
+ rewrite /update_rmap /update_map /=. rewrite H in hty.
  by inversion hty.
+ rewrite H in hty. inversion hty; subst.
  inversion H2; subst.
  case: ifP=> //=.
  (* true *)
  + move=> htrue. by move: (type_concat H6 H3).
  (* false *)
  move=> hfalse. by move: (type_concat H7 H3).
+ rewrite /update_rmap /update_map /=. rewrite H in hty.
  by inversion hty.
rewrite /update_rmap /update_map /=. rewrite H in hty.
by inversion hty.
Qed.

Lemma type_prev_ct_step : forall VGamma AGamma s1 s2 s1' s2' l1 l2,
type_cmd VGamma AGamma s1.(scmd_sf) ->
state_equiv s1 s2 VGamma AGamma ->
sem_instr s1 l1 s1' ->
sem_instr s2 l2 s2' ->
state_equiv s1' s2' VGamma AGamma /\ l1 = l2.
Proof.
move=> VGamma AGamma [] st1 r1 m1 [] st2 r2 m2 s1' s2' l1 l2 /= hty.
move=> hequiv hstep hstep'. move: (hequiv)=> [] //= hst1 hst2.
move=> hst; subst. move=> {hst1} {hst2}.
move: r1 r2 m1 m2 l1 l2 hstep hstep' hequiv.
elim: hty.
+ move=> i c hity hcty hc r1 r2 m1 m2 l1 l2 hstep hstep' hequiv.
  induction hity.
  (* x := e *)
  + inversion hstep; (try discriminate).
    inversion hstep'; (try discriminate).
    case:H2=> h1 h2 h3; subst.
    case:H6=> h1' h2' h3'; subst.
    + split; last first. + by auto.
    apply st_equiv.
    move=> x' hx' /=. move: (hequiv)=> [] //= hr hm heq.
    rewrite /update_rmap /= /update_map /=.
    case: ifP=> //= hs.
    (* x = x' *)
    + apply eqb_eq in hs. rewrite -hs in hx'.
      rewrite hx' in H. case: H=> ht. rewrite -ht in H1.
      apply sub_public_always_public in H1.
      move: (expr_equiv_val)=> hexpr.
      by move: (hexpr VGamma {| scmd_sf := Iassgn x1 e1 :: c1; rmap_sf := r1; mmap_sf := m1 |}
               {| scmd_sf := Iassgn x1 e1 :: c1; rmap_sf := r2; mmap_sf := m2 |} e1 T' hr H0 H1) => ->.
    (* x != x' *)
    by move: (hr x' hx')=> ->.
    + move=> a ha /=. move: hequiv=> [] //= hr hm _.
      by move: (hm a ha)=> ->.
  by auto.
  (* x := a[e] *)
  + inversion hstep; (try discriminate).
    inversion hstep'; (try discriminate).
    case:H2=> h1 h2 h3; subst.
    case:H6=> h1' h2' h3'; subst.
    inversion H0;(try discriminate); subst.
    move: (hequiv)=> [] //= hr hm heq.
    move: (expr_equiv_val)=> hexpr. have pub : Public = Public. + by auto.
    move: (hexpr VGamma {| scmd_sf := Iload x1 (AA a1 e0) :: c0; rmap_sf := r1; mmap_sf := m1 |}
               {| scmd_sf := Iload x1 (AA a1 e0) :: c0; rmap_sf := r2; mmap_sf := m2 |} e0 Public hr H6 pub) => ->.
    split=> /=; last first. + by auto.
    + apply st_equiv.
      + move=> x' hx' /=. rewrite /update_rmap /update_map /=.
        case: ifP=> //=.
        (* x = x' *)
        + move=> hs /=. apply eqb_eq in hs; rewrite -hs in hx'.
          rewrite hx' in H. case: H=> ht. rewrite -ht in H1.
          apply sub_public_always_public in H1. rewrite ht in H6. symmetry in ht.
          rewrite H1 in H4. by move: (hm a1 H4)=> ->.
        move=> hneq. by move: (hr x' hx')=> ->.
      + move=> a' ha' /=.
        by move: (hm a' ha')=> ->.
    by auto.
   (* a[e] := e *)
   + inversion hstep; (try discriminate).
     inversion hstep'; (try discriminate).
     case:H2=> h1 h2 h3; subst.
     case:H6=> h1' h2' h3' h4'; subst.
     inversion H0;(try discriminate); subst; rewrite /=.
     move: (hequiv)=> [] //= hr hm heq.
     move: (expr_equiv_val)=> hexpr. have pub : Public = Public. + by auto.
     move: (hexpr VGamma {| scmd_sf := Istore (AA a1 e1) e'0:: c1; rmap_sf := r1; mmap_sf := m1 |}
               {| scmd_sf := Istore (AA a1 e1) e'0:: c1; rmap_sf := r2; mmap_sf := m2 |} e1 Public hr H6 pub)=> ->.
     split=> /=; last first. + by auto.
     + apply st_equiv.
       + move=> x' hx' /=.
         by move: (hr x' hx') => ->.
       + rewrite /update_mem /= /update_map /=. move=> a ha.
         case: ifP=> //=.
         (* a2 = a *)
         + move=> hs /=. apply eqb_eq in hs; rewrite -hs in ha.
           rewrite H4 in ha. case: ha=> hpub. rewrite hpub in H1. apply sub_public_always_public in H1.
           rewrite H1 in H.
           move: (hexpr VGamma {| scmd_sf := Istore (AA a1 e1) e'0:: c1; rmap_sf := r1; mmap_sf := m1 |}
               {| scmd_sf := Istore (AA a1 e1) e'0:: c1; rmap_sf := r2; mmap_sf := m2 |} e'0 Public hr H pub)=> ->.
           rewrite hpub in H4.
           by move: (hm a1 H4)=> ->.
         move=> hneq. by move: (hm a ha)=> ->.
       by auto.
   (* if b i1 i2 *)
   + inversion hstep; (try discriminate).
     inversion hstep'; (try discriminate).
     case:H2=> h1 h2 h3 h4; subst.
     case:H6=> h1' h2' h3' h4' h5' h6'; subst.
     move: (hequiv)=> [] //= hr hm heq.
     move: (expr_equiv_val)=> hexpr. have pub : Public = Public. + by auto.
     inversion H. apply union_public_always_public in H6. case: H6=>ht1 ht2.
         move: (hexpr VGamma
         {| scmd_sf := Iif (Ebool bop0 e0 e3) i0 i3 :: c1; rmap_sf := r1; mmap_sf := m1 |}
         {| scmd_sf := Iif (Ebool bop0 e0 e3) i0 i3 :: c1; rmap_sf := r2; mmap_sf := m2 |} e0 T1 hr H4 ht1)=> ->.
         move: (hexpr VGamma
         {| scmd_sf := Iif (Ebool bop0 e0 e3) i0 i3 :: c1; rmap_sf := r1; mmap_sf := m1 |}
         {| scmd_sf := Iif (Ebool bop0 e0 e3) i0 i3 :: c1; rmap_sf := r2; mmap_sf := m2 |} e3 T2 hr H7 ht2)=> ->.
     split=> /=; last first. + by auto.
     apply st_equiv.
     + move=> x hx /=. by move: (hr x hx)=> ->.
     + move=> a ha /=. by move: (hm a ha)=> ->.
     by auto.
move=> r1 r2 m1 m2 l1 l2 hstep hstep' hequiv; by inversion hstep.
Qed.

(* type preserves ct *)
Lemma type_prev_ct : forall VGamma AGamma s1 s2,
type_cmd VGamma AGamma s1.(scmd_sf) ->
constant_time VGamma AGamma s1 s2.
Proof.
move=> VGamma AGamma s1 s2 hty. rewrite /constant_time /=.
move=> s1' s2' l1 l2 n hequiv hmulti hmulti'.
split; last first.
+ by split=> //= hst; apply safe_lang.
move: s1 s2 l1 l2 hmulti hmulti' hequiv hty.
induction n.
+ move=> s1 s2 l1 l2 hmulti hmulti' hequiv hty.
  inversion hmulti; (try discriminate); subst.
  inversion hmulti'; (try discriminate); subst; auto.
  + by case:(n) H.
  by case: (n) H.
move=> s1 s2 l1 l2 hmulti hmulti' hequiv hty.
inversion hmulti; (try discriminate); subst.
inversion hmulti'; (try discriminate); subst; auto.
move: (type_prev_ct_step)=> hprev.
move: (hprev VGamma AGamma s1 s2 s' s'0 l l0 hty hequiv H0 H2)=> [hequiv'] heql; subst.
rewrite -H in H1. apply PeanoNat.Nat.add_cancel_r in H1; subst.
rewrite -(addn1 n) in H. apply PeanoNat.Nat.add_cancel_r in H; subst.
move: (preservation hty H0)=> hty'.
by move: (IHn s' s'0 l' l'0 H3 H6 hequiv' hty')=> ->.
Qed.