Require Export BuildTac.
Require Export Graph.

Set Implicit Arguments.

Unset Strict Implicit.

Parameter eps : R.

Parameter eps_pos : (0 < eps)%R.

Inductive Ut : Type :=
| Vertex
| Graph.

Inductive uop : Type :=
| Ot
| Ou
| Gin
| Gsize
| Gremove.

Inductive usupport_ (T_type:Type) (T_Nat:T_type) (T_User:Ut -> T_type)
 (E_expr:T_type -> Type) : T_type -> Type :=
| weighted : forall (e:E_expr (T_User Graph)) (n i:E_expr T_Nat),
   usupport_ T_Nat T_User E_expr (T_User Vertex).

Module Sem (Gr:GRAPH) <: SEM.

 (* Auxiliary lemmas on Graphs *)
 Lemma Gr_v_eqb_refl : forall v, Gr.v_eqb v v = true.
 Proof.
  intro v; generalize (Gr.v_eqb_spec v v); case (Gr.v_eqb v v); tauto.
 Qed.

 Lemma Gr_v_eqb_true : forall v1 v2, Gr.v_eqb v1 v2 = true -> v1 = v2.
 Proof.
  intros v1 v2; generalize (Gr.v_eqb_spec v1 v2); case (Gr.v_eqb v1 v2).
  tauto.
  intros; discriminate.
 Qed.

 Lemma Gr_is_empty_dec : forall G, {Gr.is_empty G} + {~Gr.is_empty G}.
 Proof.
  intro G'; destruct (Gr.is_empty G'); [left | right]; trivialb.
 Qed.

 Parameter t_ u_ : Gr.vertex.

 Hypothesis t_neq_u : t_ <> u_.

 (** * User-defined type module *)
 Module UT <: UTYPE.

  Definition t := Ut.

  Definition eqb (x y:t) :=
   match x, y with
   | Vertex, Vertex => true
   | Graph, Graph => true
   | _,_ => false
   end.

  Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
  Proof.
   intros x y; case x; case y; simpl; trivial; discriminate.
  Qed.

  Definition eq_dec (x y:t) : {x = y} + {True} :=
   match x as x0 return {x0 = y} + {True} with
   | Vertex =>
     match y as y0 return {Vertex = y0} + {True} with
     | Vertex => left _ (refl_equal _)
     | _ => right _ I
     end
   | Graph =>
     match y as y0 return {Graph = y0} + {True} with
     | Graph => left _ (refl_equal _)
     | _ => right _ I
     end
  end.

  Lemma eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.
  Proof.
   intros x y; case x; case y; simpl; intros; discriminate.
  Qed.

  Definition interp (k:nat) (t0:t) : Type :=
   match t0 with
   | Vertex => Gr.vertex
   | Graph => Gr.t
   end.

  Definition size k (t0:t) (_:interp k t0) := S O.

  Definition default k (t0:t) : interp k t0 :=
   match t0 with
   | Vertex => Gr.dummy_vertex
   | Graph => Gr.empty
   end.

  Definition default_poly (t0:t) := pcst 1.

  Lemma size_positive : forall k t0 (x:interp k t0), (0 < size x)%nat.
  Proof.
   intros k t0 x.
   unfold size; auto with arith.
  Qed.

  Lemma default_poly_spec : forall k (t0:t),
   (size (default k t0) <= peval (default_poly t0) k)%nat.
  Proof.
   intros k t0.
   unfold size, default, default_poly.
   rewrite pcst_spec; trivial.
  Qed.

  Definition i_eqb k t : interp k t -> interp k t -> bool :=
   match t with
   | Vertex => Gr.v_eqb
   | Graph => Gr.eqb
   end.

  Lemma i_eqb_spec : forall k t (x y:interp k t),
   if i_eqb x y then x = y else x <> y.
  Proof.
   intros; unfold i_eqb.
   destruct t0.
   apply Gr.v_eqb_spec.
   apply Gr.eqb_spec.
  Qed.

 End UT.

 Module T := MakeType UT.

 (** * Module for user-defined operators *)
 Module Uop <: UOP UT T.

  Definition t := uop.

  Definition eqb (o1 o2:t) : bool :=
   match o1, o2 with
    | Ot, Ot => true
    | Ou, Ou => true
    | Gin, Gin => true
    | Gsize, Gsize => true
    | Gremove, Gremove => true
    | _, _ => false
   end.

  Lemma eqb_spec :  forall x y, if eqb x y then x = y else x <> y.
  Proof.
   destruct x; destruct y; simpl; trivial; intro; discriminate.
  Qed.

  Definition targs (op : t) : list T.type :=
   match op with
    | Ot => nil
    | Ou => nil
    | Gin => T.User Graph :: T.User Vertex :: nil
    | Gsize => T.User Graph :: nil
    | Gremove => T.User Graph :: T.User Vertex :: nil
   end.

  Definition tres (op: t) : T.type :=
   match op with
    | Ot => T.User Vertex
    | Ou => T.User Vertex
    | Gin => T.Bool
    | Gsize => T.Nat
    | Gremove => T.User Graph
   end.

  Definition interp_op (k:nat) (op:t) : T.type_op k (targs op) (tres op) :=
   match op as op0 return T.type_op k (targs op0) (tres op0) with
    | Ot => u_
    | Ou => t_
    | Gin => Gr.in_graph
    | Gsize => Gr.size
    | Gremove => Gr.remove_vertex
   end.

  Implicit Arguments interp_op [k].

  Definition cinterp_op (k:nat) (op:t) : T.ctype_op k (targs op) (tres op) :=
   match op as op0 return T.ctype_op k (targs op0) (tres op0) with
    | Ot => (u_, O)
    | Ou => (t_, O)
    | Gin => fun x y => (Gr.in_graph x y, Gr.size x)
    | Gsize => fun x => (Gr.size x, S O)
    | Gremove => fun x y => (Gr.remove_vertex x y, S O)
   end.

  Implicit Arguments cinterp_op [k].

  Definition eval_op k
   (op:t) (args: dlist (T.interp k) (targs op)) : T.interp k (tres op) :=
   @T.app_op k (targs op) (tres op) (interp_op op) args.

  Definition ceval_op k
   (op:t) (args: dlist (T.interp k) (targs op)) : T.interp k (tres op) * nat :=
   @T.capp_op k (targs op) (tres op) (cinterp_op op) args.

  Lemma ceval_op_spec : forall k op args,
   @eval_op k op args = fst (@ceval_op k op args).
  Proof.
   intros k o args; destruct o; simpl in args;
    T.dlist_inversion args; subst; trivial.
  Qed.

 End Uop.

 Module Var := MakeVar UT T.

 Module Proc := MakeProc UT T.

 Module O := MakeOp UT T Uop.

 Module Mem := MakeMem UT T Var.

 Module E := MakeExpr UT T Var Mem Uop O.

 Open Scope R_scope.

 Hint Resolve Rle_refl pos_INR exp_pos eps_pos.

 Module US <: USUPPORT UT T Var Mem Uop O E.

  Module VarP := MkEqBool_Leibniz_Theory Var.
  Module Vset := MkListSet VarP.Edec.

  Definition usupport := usupport_ T.Nat T.User E.expr.

  Definition w (i:nat) (n:nat) : R :=
   ((4 / eps) * sqrt (INR n / INR (n - i)))%R.

  Lemma w_pos : forall i n, (i < n)%nat -> 0 < w i n.
  Proof.
   intros; unfold w.
   apply Rmult_lt_0_compat.
   apply Rdiv_lt_0; [fourier | trivial].
   apply sqrt_lt_R0.
   apply Rdiv_lt_0; apply lt_0_INR; omega.
  Qed.

 Definition weighted_choice (G:Gr.t) (i n:nat) : Distr Gr.vertex.
   intros G i n.
   destruct (le_lt_dec n i).
   exact (Munit Gr.dummy_vertex).

   destruct (Gr_is_empty_dec G).
   exact (Munit Gr.dummy_vertex).

   destruct (Gr.not_is_empty n0) as [a Ha].
   eapply finite_distr with
    (l:=Gr.WS.elements (Gr.V G))
    (f:=fun v => (INR (Gr.degree G v) + w i n)) (a:=a).

   intros; apply Rplus_le_le_0_compat.
   apply pos_INR.
   apply Rlt_le, w_pos; trivial.
   apply Gr.in_graph_element with (1:=Ha).

   apply Rplus_le_lt_0_compat.
   apply pos_INR.
   apply w_pos; trivial.
  Defined.

  Definition carV (v:Gr.vertex) : MF Gr.vertex :=
   fun w => if Gr.v_eqb v w then 1%U else 0%tord.

  Lemma carV_prop : forall a, cover (@eq Gr.vertex a) (carV a).
  Proof.
   unfold carV; split; intros.
   subst; rewrite Gr_v_eqb_refl; trivial.
   generalize (Gr.v_eqb_spec a x); destruct (Gr.v_eqb a x); intro.
   exfalso; tauto.
   trivial.
  Qed.

  Lemma weighted_choice_spec_in : forall G i n v,
   (i < n)%nat ->
   Gr.in_graph G v ->
   Gr.size G = (n - i)%nat ->
   iR (mu (weighted_choice G i n) (carV v)%tord) =
   (INR (Gr.degree G v) + w i n) / (INR (Gr.weight G) + INR (n - i) * w i n).
  Proof.
   intros; unfold weighted_choice.
   destruct (le_lt_dec n i).
   exfalso; omega.

   destruct (Gr_is_empty_dec G0).
   exfalso.
   apply Gr.is_empty_size in i0; rewrite H1 in i0; omega.

   destruct (Gr.not_is_empty (g:=G0) n0).
   rewrite finite_distr_in.
   unfold c, y; rewrite retract_R.
   apply f_equal.

   rewrite fold_right_Rplus_plus.
   rewrite fold_right_Rplus_const.
   apply Rplus_eq_compat.

   rewrite <-map_map, fold_right_Rplus_INR, Gr.weight_def; trivial.

   fold Gr.WS.elt; rewrite (Gr.size_elements G0), H1; trivial.

   split.
   apply Rdiv_pos.
   apply Rplus_le_le_0_compat.
   apply pos_INR.
   apply Rlt_le, w_pos; trivial.

   eapply fold_right_Rplus_lt_0 with (y:=INR (Gr.degree G0 x) + w i n).
   apply in_map_iff; exists x; split.
   trivial.
   apply Gr.in_graph_element with (1:=i0).

   apply Rplus_le_lt_0_compat.
   auto.
   apply w_pos; trivial.

   apply map_pos; intros.
   apply Rplus_le_le_0_compat.
   apply pos_INR.
   apply Rlt_le, w_pos; trivial.

   apply Rdiv_le_1.
   eapply fold_right_Rplus_lt_0 with (y:=INR (Gr.degree G0 x) + w i n).
   apply in_map_iff; exists x; split.
   trivial.
   apply Gr.in_graph_element with (1:=i0).

   apply Rplus_le_lt_0_compat.
   auto.
   apply w_pos; trivial.

   apply map_pos; intros.
   subst; apply Rplus_le_le_0_compat.
   apply pos_INR.
   apply Rlt_le, w_pos; trivial.

   rewrite fold_right_Rplus_plus, fold_right_Rplus_const.

   apply Rplus_le_compat.

   rewrite <-map_map, fold_right_Rplus_INR.
   apply le_INR.
   apply Gr.in_graph_element in H0.
   clear -H0; induction (Gr.WS.elements); simpl; [elim H0 | ].
   simpl in H0; destruct H0.

   subst; omega.
   generalize (IHl H); intro; omega.

   fold Gr.WS.elt.
   rewrite (Gr.size_elements G0), H1.
   rewrite <-Rmult_1_l at 1; apply Rmult_le_compat.
   fourier.
   apply Rlt_le, w_pos; trivial.
   change 1 with (INR 1); apply le_INR; omega.
   trivial.

   apply carV_prop.

   apply Gr.NoDup_elements.

   apply Gr.in_graph_element with (1:=H0).
  Qed.

  Lemma weighted_choice_spec_notin : forall G i n v,
   (i < n)% nat ->
   Gr.size G = (n - i)%nat ->
   ~Gr.in_graph G v ->
   mu (weighted_choice G i n) (carV v) == 0%tord.
  Proof.
   intros; unfold weighted_choice.
   destruct (le_lt_dec n i).
   exfalso; omega.

   destruct (Gr_is_empty_dec G0).
   exfalso.
   apply Gr.is_empty_size in i0; rewrite H0 in i0; omega.

   destruct (Gr.not_is_empty (g:=G0)).
   apply finite_distr_notin.
   apply carV_prop.

   intro; elim H1; apply Gr.in_graph_element; trivial.
  Qed.

  Lemma weighted_choice_in_graph : forall G i n,
   (i < n)%nat ->
   Gr.size G = (n - i)%nat ->
   range (Gr.in_graph G) (US.weighted_choice G i n).
  Proof.
   intros G i n Hlt Hsize f Hf; unfold weighted_choice.
   destruct (le_lt_dec n i).
   exfalso; omega.

   destruct (Gr_is_empty_dec G); trivial.
   exfalso.
   apply Gr.is_empty_size in i0; rewrite Hsize in i0; omega.

   destruct (Gr.not_is_empty (g:=G) n0).
   simpl; symmetry; apply fold_right_Uplus_0; intros.
   rewrite <-Hf; [auto | ].
   apply Gr.in_graph_element; trivial.
  Qed.

  Definition eval k t (s:usupport t) (m:Mem.t k) : Distr (T.interp k t) :=
   match s with
    | weighted g i n =>
      weighted_choice (E.eval_expr g m) (E.eval_expr i m) (E.eval_expr n m)
   end.

  Definition ceval k t (s:usupport t) (m:Mem.t k) : Distr (T.interp k t) * nat :=
   match s with
    | weighted g i n =>
      (weighted_choice (E.eval_expr g m) (E.eval_expr i m) (E.eval_expr n m),
       Gr.size (E.eval_expr g m))
   end.

  Lemma ceval_spec : forall k t (s:usupport t) (m:Mem.t k),
   eval s m = fst (ceval s m).
  Proof.
   intros; case s; intros; simpl; trivial.
  Qed.

  (** TODO:Add to EXPR *)
  Variable fv_expr : forall t (e:E.expr t), Vset.t.

  Let req_mem k X (m1 m2:Mem.t k) :=
   forall t (x:Var.var t), Vset.mem x X -> m1 x = m2 x.

  Lemma req_mem_weaken : forall k X X',
   Vset.subset X X' -> forall (m m':Mem.t k), req_mem X' m m' -> req_mem X m m'.
  Proof.
   unfold req_mem; intros; eauto using Vset.subset_correct.
  Qed.

  Let depend_only_distr (X:Vset.t) t (s:usupport t) :=
   forall k (m1 m2:Mem.t k),
    req_mem X m1 m2 -> eval s m1 = eval s m2.

  Let depend_only (X:Vset.t) t (e:E.expr t) :=
   forall k (m1 m2:Mem.t k), req_mem X m1 m2 -> E.eval_expr e m1 = E.eval_expr e m2.

  Axiom depend_only_fv_expr : forall t (e:E.expr t),
   depend_only (fv_expr e) e.

  Definition fv_distr t (s:usupport t) : Vset.t :=
   match s with
    | weighted g i n => Vset.union (fv_expr g) (Vset.union (fv_expr i) (fv_expr n))
   end.

  Module VsetP := MkSet_Theory Vset.

  Lemma depend_only_fv_distr : forall t (s:usupport t),
   depend_only_distr (fv_distr s) s.
  Proof.
   intros t s k m1 m2 H; destruct s; simpl.
   simpl in H.
   rewrite depend_only_fv_expr with (e:=e) (m2:=m2).
   rewrite depend_only_fv_expr with (e:=i) (m2:=m2).
   rewrite depend_only_fv_expr with (e:=n) (m2:=m2).
   trivial.
   apply req_mem_weaken with (2:=H); auto with set.
   apply req_mem_weaken with (2:=H); auto with set.
   apply req_mem_weaken with (2:=H); auto with set.
  Qed.

  Lemma lossless_support : forall k t (s:usupport t) (m:Mem.t k),
   mu (eval s m) (fun _ => 1)%U == 1%U.
  Proof.
   intros; destruct s; simpl;unfold weighted_choice.
   destruct (le_lt_dec (E.eval_expr i m) (E.eval_expr n m)); [trivial | ].
   destruct (Gr_is_empty_dec (E.eval_expr e m)); [trivial | ].
   destruct (Gr.not_is_empty (g:=E.eval_expr e m) n0).
   refine (finite_distr_lossless _ _ _ _ _ _).
  Qed.

  Lemma discrete_support : forall k t (s:usupport t) (m:Mem.t k),
   is_Discrete (eval s m).
  Proof.
   intros; destruct s; simpl.
   unfold weighted_choice.
   destruct (le_lt_dec (E.eval_expr i m) (E.eval_expr n m)).
   apply is_Discrete_Munit.

   destruct (Gr_is_empty_dec (E.eval_expr e m)).
   apply is_Discrete_Munit.

   destruct (Gr.not_is_empty (g:=E.eval_expr e m)).
   apply finite_distr_discrete.
  Qed.

  Definition eqb (t1 t2:T.type) (s1:usupport t1) (s2:usupport t2) : bool :=
   match s1, s2 with
   | weighted g i n, weighted g' i' n' => E.eqb g g' && E.eqb i i' && E.eqb n n'
   end.

  Lemma eqb_spec_dep :  forall t1 (e1 : usupport t1) t2 (e2:usupport t2),
   if eqb e1 e2 then eq_dep T.type usupport t1 e1 t2 e2
   else ~eq_dep T.type usupport t1 e1 t2 e2.
  Proof.
   intros t1 [g1 i1 n1] t2 [g2 i2 n2]; simpl.
   generalize (E.eqb_spec g1 g2); destruct (E.eqb g1 g2);
   generalize (E.eqb_spec i1 i2); destruct (E.eqb i1 i2);
   generalize (E.eqb_spec n1 n2); destruct (E.eqb n1 n2);
   simpl; intros; subst; trivial; intro W; inversion W; tauto.
  Qed.

  Lemma eqb_spec : forall t (e1 e2:usupport t),
   if eqb e1 e2 then e1 = e2 else e1 <> e2.
  Proof.
   intros t e1 e2.
   generalize (eqb_spec_dep e1 e2).
   case (eqb e1 e2); intro H.
   apply T.eq_dep_eq; trivial.
   intro Heq; apply H; rewrite Heq; constructor.
  Qed.

 End US.

 Module DE := MakeDExpr UT T Var Mem Uop O E US.

 Module I := MakeInstr UT T Var Proc Uop O Mem E US DE.

 Module SemI := SemInstr.Make UT T Var Proc Uop O Mem E US DE I.

 Export SemI.

 (* list of expressions *)
 Notation "{ x , .. , y }" :=
  (@dcons T.type E.expr _ _ x ..
   (@dcons T.type E.expr _ _ y (@dnil T.type E.expr)) ..).

 (* boolean expressions *)
 Notation "'!' x"   := (E.Eop O.Onot { x }) (at level 60).
 Notation "x && y"  := (E.Eop O.Oand {x,  y}).
 Notation "x || y"  := (E.Eop O.Oor {x, y}).
 Notation "x ==> y" := (E.Eop O.Oimp {x, y}).
 Notation "b '?' x '?:' y" := (E.Eop (O.Oif _) {b, x, y}) (at level 60).

 (* pair expressions *)
 Notation "'Efst' p" := (E.Eop (O.Ofst _ _) { p }) (at level 0).
 Notation "'Esnd' p" := (E.Eop (O.Osnd _ _) { p }) (at level 0).
 Notation "'(' x '|' y ')'" := (E.Eop (O.Opair _ _) {x,  y} ).

 (* sum expressions *)
 Notation "'Inl' x" := (E.Eop (O.Oinl _ _) { x }) (at level 60).
 Notation "'Inr' x" := (E.Eop (O.Oinr _ _) { x }) (at level 60).
 Notation "'Isl' x" := (E.Eop (O.Oisl _ _) { x }) (at level 60).
 Notation "'Projl' x" := (E.Eop (O.Oprojl _ _) { x }) (at level 60).
 Notation "'Projr' x" := (E.Eop (O.Oprojr _ _) { x }) (at level 60).

 (* option expressions *)
 Notation "'none' t" := (E.Ecte (E.Cnone t)) (at level 0).
 Notation "'some' x" := (E.Eop (O.Osome _) { x }) (at level 60).
 Notation "'IsSome' x" := (E.Eop (O.Oissome _) { x }) (at level 60).
 Notation "'Proj' x" := (E.Eop (O.Oprojo _) { x }) (at level 60).

 (* list expressions *)
 Notation "'Nil' t" := (E.Ecte (E.Cnil t)) (at level 0).
 Notation "x '|::|' y" :=
  (E.Eop (O.Ocons _) {x, y}) (at level 60, right associativity).
 Notation "x |++| l" :=
  (E.Eop (O.Oappend _) {x,l}) (at level 60, right associativity).
 Notation Enth := (E.Eop (O.Onth _)).
 Notation "'Elen' p" := (E.Eop (O.Olength _) {p}) (at level 40).
 Notation "'Zlen' p" := (E.Eop (O.OZlength _) {p}) (at level 40).
 Notation "x 'is_in' y" := (E.Eop (O.Omem _) {x, y}) (at level 60).
 Notation "x 'not_in' y" := (! E.Eop (O.Omem _) {x, y}) (at level 60).

 (* association lists *)
 Notation "x 'in_dom' y" := (E.Eop (O.Oin_dom _ _) {x, y}) (at level 60).
 Notation "x 'in_range' y" := (E.Eop (O.Oin_range _ _) {x, y}) (at level 60).
 Notation "y '[{' x '}]'" := (E.Eop (O.Oimg _ _) {x, y}) (at level 59).
 Notation "l '.[{' x '<<-' v '}]'" :=
   (E.Eop (O.Oupd _ _) {x,v,l}) (at level 50).

 (* nat expressions *)
 Notation "x '+!' y"  := (E.Eop O.Oadd {x, y}) (at level 50, left associativity).
 Notation "x '*!' y"  := (E.Eop O.Omul {x, y}) (at level 40, left associativity).
 Notation "x '-!' y"  := (E.Eop O.Osub {x, y}) (at level 50, left associativity).
 Notation "x '<=!' y" := (E.Eop O.Ole {x, y}) (at level 50).
 Notation "x '<!' y"  := (E.Eop O.Olt {x, y}) (at level 50).

 (* Z expressions *)
 Notation "x '+Z' y"   := (E.Eop O.OZadd {x, y}) (at level 50, left associativity).
 Notation "x '*Z' y"   := (E.Eop O.OZmul {x, y}) (at level 40, left associativity).
 Notation "x '-Z' y"   := (E.Eop O.OZsub {x, y}) (at level 50, left associativity).
 Notation "x '<=Z' y"  := (E.Eop O.OZle {x, y}) (at level 50).
 Notation "x '<Z' y"   := (E.Eop O.OZlt {x, y}) (at level 50).
 Notation "x '>=Z' y"  := (E.Eop O.OZge {x, y}) (at level 50).
 Notation "x '>Z' y"   := (E.Eop O.OZgt {x, y}) (at level 50).
 Notation "'oppZ' x"   := (E.Eop O.OZopp {x}) (at level 40).
 Notation "x '/Z' y"   := (E.Eop O.OZdiv {x, y}) (at level 50).
 Notation "x 'modZ' y" := (E.Eop O.OZmod {x, y}) (at level 50).
 Notation "x 'powZ' y" := (E.Eop O.OZpow {x, y}) (at level 50).

 (* equality *)
 Notation "x '=?=' y" := (E.Eop (O.Oeq_ _) {x, y}) (at level 70, no associativity).

 (* support *)
 Notation "'{0,1}'" := DE.Dbool.
 Notation "'[0..' e ']'" := (DE.Dnat e)%nat.
 Notation "'[' e1 ',,' e2 ']'" := (DE.DZ e1 e2)%nat.

End Sem.

(** Semantics with optimizations *)
Module Entries (Gr:GRAPH).

 Module SemO <: SEM_OPT.

  Module Sem := Sem Gr.
  Export Sem.

  Definition simpl_op (op : Uop.t) :
   E.args (Uop.targs op) -> E.expr (Uop.tres op) :=
   match op as op0 return E.args (Uop.targs op0) -> E.expr (Uop.tres op0) with
    | op => fun args => E.Eop (O.Ouser op) args
   end.

  Implicit Arguments simpl_op [].

  Lemma simpl_op_spec : forall k op args (m:Mem.t k),
   E.eval_expr (simpl_op op args) m = E.eval_expr (E.Eop (O.Ouser op) args) m.
  Proof.
   intros; simpl; trivial.
  Qed.

 End SemO.

 Module BP := BaseProp.Make SemO.Sem.

End Entries.

Declare Module Gr : GRAPH.

Module Ent := Entries Gr.

Module Tactics := BuildTac.Make Ent.
Export Tactics.

(* Some useful tactics *)
Ltac elim_assign :=
 rewrite (@deno_cons_elim _ _ (_ <- _)), Mlet_simpl, deno_assign_elim.
Ltac elim_random :=
 rewrite (@deno_cons_elim _ _ (_ <$- _)), Mlet_simpl, deno_random_elim.
Ltac elim_assert :=
 rewrite (@deno_cons_elim _ _ (Assert _)), Mlet_simpl, deno_assert_elim.

Ltac mem_upd_simpl :=
 repeat (rewrite Mem.get_upd_same || (rewrite Mem.get_upd_diff;
  [ | discriminate])); trivial.
Ltac expr_simpl :=
 unfold EP1, EP2, notR, andR, orR, impR, E.eval_expr; simpl;
  unfold O.eval_op; simpl; mem_upd_simpl.

(* Some Notation *)
Notation t := (E.Eop (O.Ouser Ot) (dnil _)).
Notation u := (E.Eop (O.Ouser Ou) (dnil _)).

Notation "v '\in' G" := (E.Eop (O.Ouser Gin) {G, v}) (at level 60).
Notation "G \ v" := (E.Eop (O.Ouser Gremove) {G, v}) (at level 60).
Notation "| G |" := (E.Eop (O.Ouser Gsize) {G}) (at level 60).

Notation "'choose'" :=
 (fun G i n => DE.Duser (@weighted T.type T.Nat T.User E.expr G i n))
 (at level 60).

Lemma sum_inv_sqrt : forall n,
  (sum_f_R0 (fun k : nat => / sqrt (INR (S k))) n <=  2 * sqrt (INR (S n)))%R.
Proof.
induction n.
   simpl; rewrite sqrt_1; fourier.
   rewrite tech5, IHn.
   apply Rmult_le_reg_l with (sqrt (INR (S (S n))));
     [ apply sqrt_lt_R0, lt_0_INR, lt_0_Sn |  ].
   rewrite Rmult_plus_distr_l.
   transitivity (2 * sqrt (INR (S (S n)) * INR (S n)) + 1)%R.
     apply Rplus_le_compat.
     rewrite Rmult_comm, Rmult_assoc, <-sqrt_mult,
       (Rmult_comm (INR _)); auto.
     apply Rfourier_eqLR_to_le; field.
     intro H; apply sqrt_eq_0 in H; rewrite S_INR in H;
       [ pose proof (pos_INR (S n)); fourier | auto ].
   rewrite <-(Rmult_comm (2 * _)%R), Rmult_assoc, sqrt_sqrt; [ | auto ].
   set (X:=sqrt (INR (S (S n)) * INR (S n))).
   set (Y:=INR (S (S n))).
   cut (2 * X <= 2 * Y - 1)%R; [ intro; fourier | ].
   replace (2*Y-1)%R with (2 * (INR n) + 3)%R by
     (unfold Y; rewrite 2 S_INR, 2 Rmult_plus_distr_l; field).
   transitivity (2 * sqrt (Rsqr (INR n + 3/2)))%R.
     apply Rmult_le_compat_l; [ fourier | ].
     unfold X;  apply sqrt_le_1_alt.
     rewrite 2 S_INR; unfold Rsqr.
     match goal with
       |- (?A <= ?B)%R =>
         replace A with (INR n * INR n + 3 * INR n + 2)%R  by field;
           replace B with (INR n * INR n + 3 * INR n + 9 / 4)%R by field
     end.
     fourier.
   rewrite sqrt_Rsqr; [ | pose proof (pos_INR n); fourier ].
   apply Rfourier_eqLR_to_le; field.
Qed.


From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
From Tweetnacl Require Import Low.Reduce_by_P_compose_step.
From stdpp Require Import list.
Require Import Recdef.
Require Import ssreflect.
Open Scope Z.

Definition subst_c t m := t - (Z.land (Z.shiftr m 16) 1).

Definition sub_step_2 (a:Z) (m:list Z) : list Z :=
    let m' := nth (Z.to_nat (a - 1)) m 0 in
    let t' := nth (Z.to_nat a) m 0 in
      upd_nth (Z.to_nat (a-1)) (upd_nth (Z.to_nat a) m (subst_c t' m')) (mod0xffff m').

Lemma sub_step_2_Zlength : forall a m,
  0 < a < Zlength m ->
  Zlength (sub_step_2 a m) = Zlength m.
Proof.
  intros a m Ham.
  rewrite /sub_step_2.
  rewrite ?upd_nth_Zlength.
  reflexivity.
  all: rewrite ?Z2Nat.id.
  all: omega.
Qed.

Lemma sub_fn_rev_s_sub_step_2_ind_Zlength : forall a m,
  0 < a < Zlength m ->
  Zlength (sub_fn_rev_s 1 sub_step_2 a m) = Zlength m ->
  Zlength (sub_fn_rev_s 1 sub_step_2 (a+1) m) = Zlength m.
Proof.
  intros i m Ham Hind.
  rewrite sub_fn_rev_s_equation.
  flatten.
  replace ( i + 1 - 1) with i by omega.
  rewrite <- Hind.
  apply sub_step_2_Zlength.
  rewrite Hind.
  assumption.
Qed.

Lemma sub_fn_rev_s_sub_step_2_Zlength : forall a m,
  0 < a < 16 ->
  Zlength m = 16 ->
  Zlength (sub_fn_rev_s 1 sub_step_2 a m) = Zlength m.
Proof.
  intros.
  pattern a.
  apply P016_impl.
  by rewrite sub_fn_rev_s_1.
  intros ; apply sub_fn_rev_s_sub_step_2_ind_Zlength.
  2: apply H2.
  all: omega.
Qed.

Lemma sub_step_2_Z_inv : forall a m,
0 < a < Zlength m ->
- 2^16 <= nth (Z.to_nat (a - 1)) m 0 <= 0 ->
ZofList 16 (sub_step_2 a m) = ZofList 16 m.
Proof.
intros a m Hm Hbm.
rewrite /sub_step_2 /mod0xffff /subst_c.
rewrite ?ZofList_upd_nth_Zlength.
5: rewrite upd_nth_Zlength.
3,5,6: rewrite Z2Nat.id.
all: try omega.
rewrite Zplus_assoc_reverse.
match goal with
  | [ |- _ + ?A = _ ] => replace A with 0
end.
symmetry.
apply Zplus_0_r_reverse.
replace (16 * Z.to_nat a) with (16 * Z.to_nat (a - 1) + 16).
2: rewrite ?Z2Nat.id ; omega.
rewrite Z.pow_add_r.
2: rewrite ?Z2Nat.id.
2,3,4 : omega.
rewrite Zmult_assoc_reverse.
rewrite Zred_factor4.
symmetry ; rewrite Z.mul_comm; apply Z_eq_mult.
rewrite upd_nth_diff_Zlength.
2,3: rewrite Z2Nat.id.
all: try omega.
2: intro H; apply (f_equal Z.of_nat) in H; rewrite ?Z2Nat.id in H; omega.
change 65535 with (Z.ones 16).
remember (nth _ _ _) as n ; clear Hm Heqn ; clears.
ring_simplify.
repeat match goal with
  | [ |- context[Z.land ?A 1]] => change (Z.land A 1) with (Z.land A (Z.ones 1))
  | _ => rewrite Z.land_ones
  | [ |- ?A - _ + _ - _ = _ ] => replace A with 0 by omega
  | _ => omega
end.
rewrite (Zmod_eq _ (2^16)).
2: apply pown0 ; omega.
rewrite Z.shiftr_div_pow2.
2: omega.
assert(Hn: n = 0 \/ n < 0) by omega.
destruct Hn.
subst n ; reflexivity.

assert(n `div` 2 ^ 16 = -1).
  assert(n `div` 2 ^ 16 < 0).
    apply Z.div_lt_upper_bound ; omega.
  assert((- 2 ^ 16) `div` 2 ^ 16 <= n `div` 2 ^ 16).
    apply Z_div_le; try omega.
  change ((- 2 ^ 16) `div` 2 ^ 16) with (-1) in H1.
  omega.
rewrite H0.
change ((-1) `mod` 2 ^ 1 ) with 1.
ring.
Qed.

Lemma sub_step_2_Z_inv_lss : forall a m,
0 < a < Zlength m ->
- 2^16 <= nth (Z.to_nat (a - 1)) m 0 < 2^16 ->
ZofList 16 (sub_step_2 a m) = ZofList 16 m.
Proof.
intros a m Hm Hbm.
rewrite /sub_step_2 /mod0xffff /subst_c.
rewrite ?ZofList_upd_nth_Zlength.
5: rewrite upd_nth_Zlength.
3,5,6: rewrite Z2Nat.id.
all: try omega.
rewrite Zplus_assoc_reverse.
match goal with
  | [ |- _ + ?A = _ ] => replace A with 0
end.
symmetry.
apply Zplus_0_r_reverse.
replace (16 * Z.to_nat a) with (16 * Z.to_nat (a - 1) + 16).
2: rewrite ?Z2Nat.id ; omega.
rewrite Z.pow_add_r.
2: rewrite ?Z2Nat.id.
2,3,4 : omega.
rewrite Zmult_assoc_reverse.
rewrite Zred_factor4.
symmetry ; rewrite Z.mul_comm; apply Z_eq_mult.
rewrite upd_nth_diff_Zlength.
2,3: rewrite Z2Nat.id.
all: try omega.
2: intro H; apply (f_equal Z.of_nat) in H; rewrite ?Z2Nat.id in H; omega.
change 65535 with (Z.ones 16).
remember (nth _ _ _) as n ; clear Hm Heqn ; clears.
ring_simplify.
repeat match goal with
  | [ |- context[Z.land ?A 1]] => change (Z.land A 1) with (Z.land A (Z.ones 1))
  | _ => rewrite Z.land_ones
  | [ |- ?A - _ + _ - _ = _ ] => replace A with 0 by omega
  | _ => omega
end.
rewrite (Zmod_eq _ (2^16)).
2: apply pown0 ; omega.
rewrite Z.shiftr_div_pow2.
2: omega.
assert(Hn: n = 0 \/ n < 0 \/ n > 0) by omega.
(* assert(Hn: n = 0 \/ n < 0) by omega. *)
destruct Hn as [Hn|[Hn|Hn]].
subst n ; reflexivity.
assert(Hn': n `div` 2 ^ 16 = -1).
  assert(H0: n `div` 2 ^ 16 < 0).
    apply Z.div_lt_upper_bound ; omega.
  assert(H2: (- 2 ^ 16) `div` 2 ^ 16 <= n `div` 2 ^ 16).
    apply Z_div_le; try omega.
  change ((- 2 ^ 16) `div` 2 ^ 16) with (-1) in H2.
  omega.
rewrite Hn'.
change ((-1) `mod` 2 ^ 1 ) with 1.
ring.
assert(Hn': n `div` 2 ^ 16 = 0).
apply Zdiv_small ; omega.
rewrite Hn'.
rewrite Zmod_0_l.
ring.
Qed.

Lemma sub_step_2_Z_bound_nth : forall a m,
0 < a < Zlength m ->
- 2^16 < nth (Z.to_nat a) m 0 <= 0 ->
- 2^16 <= nth (Z.to_nat a) (sub_step_2 a m) 0 <= 0.
Proof.
intros a m Hm Hbm.
rewrite /sub_step_2 /mod0xffff /subst_c.
rewrite upd_nth_diff_Zlength ?upd_nth_same_Zlength ?upd_nth_Zlength.
all: try (intro H; apply (f_equal Z.of_nat) in H; rewrite ?Z2Nat.id in H).
all: rewrite ?Z2Nat.id.
assert(Hand: Z.land (nth (Z.to_nat (a - 1)) m 0 ≫ 16) 1 = 0 \/ Z.land (nth (Z.to_nat (a - 1)) m 0 ≫ 16) 1 = 1).
  assert(H:= and_0_or_1 (nth (Z.to_nat (a - 1)) m 0 ≫ 16)) ; omega.
destruct Hand as [Hand|Hand] ; rewrite Hand.
all: try omega.
Qed.

Lemma sub_step_2_Z_bound_nth_lss : forall a m,
0 < a < Zlength m ->
- 2^16 < nth (Z.to_nat a) m 0 < 2^16 ->
- 2^16 <= nth (Z.to_nat a) (sub_step_2 a m) 0 < 2^16.
Proof.
intros a m Hm Hbm.
rewrite /sub_step_2 /mod0xffff /subst_c.
rewrite upd_nth_diff_Zlength ?upd_nth_same_Zlength ?upd_nth_Zlength.
all: try (intro H; apply (f_equal Z.of_nat) in H; rewrite ?Z2Nat.id in H).
all: rewrite ?Z2Nat.id.
assert(Hand: Z.land (nth (Z.to_nat (a - 1)) m 0 ≫ 16) 1 = 0 \/ Z.land (nth (Z.to_nat (a - 1)) m 0 ≫ 16) 1 = 1).
  assert(H:= and_0_or_1 (nth (Z.to_nat (a - 1)) m 0 ≫ 16)) ; omega.
destruct Hand as [Hand|Hand] ; rewrite Hand.
all: try omega.
Qed.

Lemma sub_fn_rev_s_sub_step_2_ind_bound : forall a m,
  0 < a < 16 ->
  Zlength m = 16 ->
  Forall (fun x => 0 <= x < 2^16) (take (Z.to_nat (a - 1)) (sub_fn_rev_s 1 sub_step_2 a m)) ->
  Forall (fun x => 0 <= x < 2^16) (take (Z.to_nat a) (sub_fn_rev_s 1 sub_step_2 (a + 1) m)).
Proof.
  intros i m Ham Hm. intros.
  rewrite sub_fn_rev_s_equation.
  flatten.
  apply Zle_bool_imp_le in Eq ; omega.
  replace ( i + 1 - 1) with i by omega.
  replace (Z.to_nat i) with (Z.to_nat ((i - 1) + 1)).
  2: fequals ; omega.
  rewrite -(take_cons_Zlength _ _ 0).
  2: rewrite sub_step_2_Zlength sub_fn_rev_s_sub_step_2_Zlength; omega.
  remember (sub_fn_rev_s 1 sub_step_2 i m) as m'.
  apply Forall_app_2.
  rewrite /sub_step_2.
  rewrite (upd_nth_alter _ (fun x => (mod0xffff (nth (Z.to_nat (i - 1)) m' 0)))).
  rewrite take_alter.
  2: reflexivity.
  2: omega.
  2: reflexivity.

  2: {
  rewrite upd_nth_length.
  all: replace (length m')%nat with (Z.to_nat (Z.of_nat (length m')))%nat by (apply Nat2Z.id).
  all: rewrite -Z2Nat.inj_lt ; subst.
  all: rewrite -?Zlength_correct.
  4: split.
  all: try omega.
  all: rewrite sub_fn_rev_s_sub_step_2_Zlength ; omega.
  }

  rewrite (upd_nth_alter _ (fun x => (subst_c (nth (Z.to_nat i) m' 0) (nth (Z.to_nat (i - 1)) m' 0)))).
  2: omega.
  2: reflexivity.

  2: {
  replace (length m')%nat with (Z.to_nat (Z.of_nat (length m')))%nat by (apply Nat2Z.id).
  all: rewrite -Z2Nat.inj_lt ; subst.
  all: rewrite -?Zlength_correct.
  all: try omega.
  all: rewrite sub_fn_rev_s_sub_step_2_Zlength ; omega.
  }

  rewrite take_alter.
  assumption.
  rewrite -Z2Nat.inj_le; omega.
  apply Forall_cons_2.
  2: apply Forall_nil ; trivial.

  rewrite /sub_step_2.
  rewrite upd_nth_same_Zlength /mod0xffff.
  change (65535) with (Z.ones 16).
  rewrite Z.land_ones.
  apply Z_mod_lt.
  apply pown0.
  omega.
  omega.
  rewrite upd_nth_Zlength.
  all: subst m'.
  all: rewrite sub_fn_rev_s_sub_step_2_Zlength.
  all: rewrite ?Z2Nat.id; omega.
Qed.

Lemma sub_fn_rev_s_sub_step_2_bound : forall a m,
  0 < a < 16 ->
  Zlength m = 16 ->
  Forall (fun x => 0 <= x < 2^16) (take (Z.to_nat (a - 1)) (sub_fn_rev_s 1 sub_step_2 a m)).
Proof.
  intros.
  pattern a.
  apply P016_impl ; try omega.
  change (Z.to_nat (1 - 1)) with 0%nat.
  rewrite firstn_O ; apply Forall_nil ; trivial.
  intros.
  replace (i + 1 - 1) with i by omega.
  apply sub_fn_rev_s_sub_step_2_ind_bound ; assumption.
Qed.

(* Lemma sub_fn_rev_s_sub_step_2_ind_bound_ : forall a m,
  0 < a < 16 ->
  Zlength m = 16 ->
  Forall (fun x => 0 <= x < 2^16) (take (Z.to_nat (a)) (sub_fn_rev_s 1 sub_step_2 (a) m)) ->
  Forall (fun x => 0 <= x < 2^16) (take (Z.to_nat (a + 1)) (sub_fn_rev_s 1 sub_step_2 (a + 1) m)).
Proof.
  intros i m Ham Hm. intros.
  rewrite sub_fn_rev_s_equation.
  flatten.
  apply Zle_bool_imp_le in Eq ; omega.
  replace ( i + 1 - 1) with i by omega.
  replace (Z.to_nat i) with (Z.to_nat ((i - 1) + 1)).
  2: fequals ; omega.
  rewrite -(take_cons_Zlength _ _ 0).
  2: rewrite sub_step_2_Zlength sub_fn_rev_s_sub_step_2_Zlength; omega.
  remember (sub_fn_rev_s 1 sub_step_2 i m) as m'.
  apply Forall_app_2.
  rewrite /sub_step_2.
  replace (Z.to_nat i) with (Z.to_nat (i - 1 + 1)).
  rewrite -(take_cons_Zlength _ _ 0).
  2: subst m' ; rewrite upd_nth_Zlength upd_nth_Zlength ?sub_fn_rev_s_sub_step_2_Zlength ?Z2Nat.id; try omega.
  2: oreplace (i - 1 + 1) i ; reflexivity.
  {
  apply Forall_app_2.

  rewrite (upd_nth_alter _ (fun x => (mod0xffff (nth (Z.to_nat (i - 1)) m' 0)))).
  rewrite take_alter.
  2: reflexivity.
  2: omega.
  2: reflexivity.

  Focus 2.
  rewrite upd_nth_length.
  all: replace (length m')%nat with (Z.to_nat (Z.of_nat (length m')))%nat by (apply Nat2Z.id).
  all: rewrite -Z2Nat.inj_lt ; subst.
  all: rewrite -?Zlength_correct.
  4: split.
  all: try omega.
  all: rewrite sub_fn_rev_s_sub_step_2_Zlength ; omega.

  rewrite (upd_nth_alter _ (fun x => (subst_c (nth (Z.to_nat i) m' 0) (nth (Z.to_nat (i - 1)) m' 0)))).
  2: omega.
  2: oreplace (i - 1 + 1) i ; reflexivity.

  Focus 2.
  replace (length m')%nat with (Z.to_nat (Z.of_nat (length m')))%nat by (apply Nat2Z.id).
  all: rewrite -Z2Nat.inj_lt ; subst.
  all: rewrite -?Zlength_correct.
  all: try omega.
  all: rewrite sub_fn_rev_s_sub_step_2_Zlength ; omega.

  rewrite take_alter.
  admit.
  rewrite -Z2Nat.inj_le; omega.
  apply Forall_cons_2.
  2: apply Forall_nil ; trivial.

  rewrite /sub_step_2.
  rewrite upd_nth_same_Zlength /mod0xffff.
  change (65535) with (Z.ones 16).
  rewrite Z.land_ones.
  apply Z_mod_lt.
  apply pown0.
  omega.
  omega.
  rewrite upd_nth_Zlength.
  all: subst m'.
  all: rewrite sub_fn_rev_s_sub_step_2_Zlength.
  all: rewrite ?Z2Nat.id; omega.
  }
  apply Forall_cons_2.
  2: apply Forall_nil ; trivial.

  rewrite /sub_step_2.
  rewrite upd_nth_diff.
  rewrite upd_nth_same_Zlength /mod0xffff.
  rewrite /subst_c.
  change (65535) with (Z.ones 16).
  rewrite Z.land_ones.
  apply Z_mod_lt.
  apply pown0.
  omega.
  omega.
  rewrite upd_nth_Zlength.
  all: subst m'.
  all: rewrite sub_fn_rev_s_sub_step_2_Zlength.
  all: rewrite ?Z2Nat.id; omega.
  }
Qed. *)

Close Scope Z.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-03-25 (setoid)
- Adam Koprowski and Johannes Waldmann, 2008-01
*)

Set Implicit Arguments.

Require Import AMonAlg2 OrdSemiRing2 ATrs LogicUtil RelUtil
  NatUtil AWFMInterpretation Max VecEq Setoid VecOrd Matrix2 VecUtil
  VecArith2.

(***********************************************************************)
(** * Matrix interpretation over domain arctic natural numbers. *)

Section MatrixLinearFunction_arcnat.

  Variables (matrix_arcnat : nat -> nat -> Type) (dim argCnt : nat).

  (** [const_arcnat] being a constant vector of the interpretation of
     size [dim] and [args_arcnat] representing coefficients for the
     arguments with a [dim x dim] matrix per argument. *)

  Record matrixInt_arcnat : Type := mkMatrixInt_arcnat {
    const_arcnat : vector Ar dim;
    args_arcnat : vector (matrix_arcnat dim dim) argCnt
  }.

End MatrixLinearFunction_arcnat.

Implicit Arguments mkMatrixInt_arcnat [matrix_arcnat dim argCnt].

Section S.

  Variable Sig: Signature.
  Variable dim : nat.
  Parameter dim_pos : dim > 0.

  (** Matrix based int over domain arctic naturals. *)

  Section Arctic_nat.

    Section Conf.

      Notation matrixInt := (matrixInt_arcnat matrix_arcnat).

      Record MatrixMethodConf_arcnat : Type :=
        mkMatrixMethodConf_arcnat {
          trsInt_arcnat : forall f : Sig, matrixInt dim (ASignature.arity f)
        }.

      Notation vec := (vector Ar dim).
      Definition vec_at0_arcnat (v : vec) := Vnth v dim_pos.

      Notation "x >>= y" := (ger x y) (at level 70).

      Definition vec_invariant_arcnat (v : vec) := vec_at0_arcnat v >>= A1r.

      Lemma inv_id_matrix_arcnat : vec_invariant_arcnat
        (Vreplace (Vconst A0r dim) dim_pos A1r).
      Proof.
        unfold vec_invariant_arcnat, vec_at0_arcnat.
        rewrite Vnth_replace. apply ge_reflr.
      Qed.

    End Conf.

    Section MatrixBasedInt_arcnat.

      Notation A := Ar.
      Notation A0 := A0r.
      Notation A1 := A1r.
      Notation eqA := eqAr.
      Notation sid_theoryA := sid_theoryAr.
      Notation ge := ger.
      Notation ge_refl := ge_reflr.
      Notation ge_trans := ge_transr.

      (* Define Morphism [vector_plus_mor] to be able to use [rewrite]
         at the Lemma [mint_eval_var_aux] later. *)

      Add Parametric Morphism n : (@vector_plus_arcnat n)
        with signature (@eq_vec_arcnat n)
          ==> (@eq_vec_arcnat n) ==> (@eq_vec_arcnat n)
          as vector_plus_mor_arcnat.
      Proof.
        intros. apply Vforall2n_intro. intros. unfold vector_plus_arcnat.
        repeat rewrite Vnth_map2.
        (*FIXME: rewrite H does not work even if Vnth is declared as morphism *)
        apply Aplus_morr; apply (Vnth_mor eqAr); hyp.
      Qed.

      (* Add new setoid to be able to use [sym] at [eqA] use later in
      some lemma. *)

      Add Setoid A eqA sid_theoryA as A_Setoid_arcnat.

      (* Define [ge] relation to be able to use [trans] for morphism
      of [vec_ge_mor]. *)

      Add Relation A ge
      reflexivity proved by ge_refl
      transitivity proved by ge_trans
        as ge_rel_arcnat.

      (* Define morphism to be able to rewrite [vec_ge_mor] later. *)

      Add Parametric Morphism n : (@vec_ge_arcnat n)
        with signature (@eq_vec_arcnat n)
          ==> (@eq_vec_arcnat n) ==> iff
          as vec_ge_mor_arcnatarcnat.

      Proof.
        unfold vec_ge_arcnat. intros.
        apply (Vforall2n_mor sid_theoryAr). intuition.
        trans a1. apply eq_ge_compatr. sym. hyp.
        trans a2. hyp. apply eq_ge_compatr. hyp.
        trans a1'. apply eq_ge_compatr. hyp.
        trans a2'. hyp. apply eq_ge_compatr. sym. hyp.
        hyp. hyp.
      Qed.

      Implicit Arguments vec_ge_mor_arcnat [n x y x0 y0].

      (* Define this relation on [vec_eq] to be able to use
         [symm], etc. *)

      Add Parametric Relation n : (vector Ar n) (@eq_vec_arcnat n)
        reflexivity proved by (@eq_vec_refl A eqA sid_theoryA n)
        symmetry proved by (@eq_vec_sym A eqA sid_theoryA n)
          transitivity proved by (@eq_vec_trans A eqA sid_theoryA n) as
            eq_vec_rel_arcnat.

      (* Add these relations and morphisms to be able to use it rewriting
         and [trans], etc later for matrix.
         Add [mat_eqA] to be able to use rewrite [mat_mult_id_l]. *)

      Add Parametric Relation m n : (matrix_arcnat m n) (@mat_eqA_arcnat m n)
        reflexivity proved by (@mat_eqA_refl_arcnat m n)
        symmetry proved by (@mat_eqA_sym_arcnat m n)
          transitivity proved by (@mat_eqA_trans_arcnat m n)
            as mat_eqA_rel_arcnat.

      (* Define this morphism to be able to use rewrite
         [zero_matrix_mult_l]. *)

      Add Parametric Morphism m n i (h:i<n) :
        (fun M => @get_col_arcnat m n M i h)
        with signature (@mat_eqA_arcnat m n) ==> (@eq_vec_arcnat m)
          as get_col_mor_arcnat.

      Proof.
        intros. unfold eq_vec_arcnat. apply Vforall2n_intro. intros.
        repeat rewrite <- get_elem_swap_arcnat. apply H.
      Qed.

      (* Define this morphism to be able to use [rewrite H0] in
         [mat_vec_prod_mor]. *)

      Add Parametric Morphism n : (@vec_to_col_mat_arcnat n) with
        signature (@eq_vec_arcnat n) ==> (@mat_eqA_arcnat n 1) as
          vec_to_col_mat_mor_arcnat.

      Proof.
        unfold vec_to_col_mat_arcnat, mat_eqA_arcnat,
          get_elem_arcnat. intros.  repeat rewrite
        get_elem_swap_arcnat. unfold get_col_arcnat.  repeat rewrite
          Vnth_map.  apply (Vnth_mor eqA). rewrite (eq_vec_cons
        eqA). intuition.  apply (Vnth_mor eqA). hyp.
        Qed.

      (* Define this morphism to be able to use [rewrite H] for
      [mat_vec_prod_mor]. *)

        Add Parametric Morphism m n p : (@mat_mult_arcnat m n p) with
          signature (@mat_eqA_arcnat m n) ==> (@mat_eqA_arcnat n p) ==>
          (@mat_eqA_arcnat m p) as mat_mult_mor_arcnat.

        Proof.
          unfold mat_mult_arcnat. intros. unfold mat_eqA_arcnat. intros.
          repeat rewrite mat_build_elem_arcnat. apply dot_product_mor_arcnat.
          apply get_row_mor_arcnat. hyp. apply get_col_mor_arcnat. hyp.
        Qed.

      (* Define this morphism to be able to rewrite
      [mat_vec_prod_distr_vec] later. *)

        Add Parametric Morphism m n : (@mat_vec_prod_arcnat m n) with
          signature (@mat_eqA_arcnat m n) ==> (@eq_vec_arcnat n) ==>
          (@eq_vec_arcnat m) as mat_vec_prod_mor_arcnat.

        Proof.
          unfold mat_vec_prod_arcnat. intros. apply
          get_col_mor_arcnat. rewrite H. rewrite H0. refl.
        Qed.

      (* Adding notations *)

        Notation vec := (vector Ar dim).
        Notation eq_vec_st := (@eq_vec_st _ _ sid_theoryAr dim).
        Notation mat_eqA := (@mat_eqA_arcnat dim dim).
        Notation mat_eqA_st := (@mat_eqA_st_arcnat dim dim).
        Notation matrixInt := (matrixInt_arcnat matrix_arcnat).
        Notation mint := (matrixInt dim).
        Notation mat := (matrix_arcnat dim dim).
        Notation eq_vec_st' := (@eq_vec_st _ _ sid_theoryAr dim).
        Notation eq_vec_mat_eqA_st' := (@VecEq.eq_vec_st _ _ mat_eqA_st).
        Notation eq_vec := (@eq_vec_arcnat dim).
        Notation "x =v y" := (eq_vec x y)(at level 70).
        Notation "x >>= y" := (ger x y) (at level 70).

        Infix "[+]" := vector_plus_arcnat (at level 50).
        Infix "<*>" := mat_mult_arcnat (at level 40).

        Add Parametric Relation k : (vector vec k) (@VecEq.eq_vec _
          eq_vec k) reflexivity proved by (@eq_vec_refl _ _ eq_vec_st k)
        symmetry proved by (@eq_vec_sym _ _ eq_vec_st k) transitivity
          proved by (@eq_vec_trans _ _ eq_vec_st k) as
            eq_vec_eq_vec_rel_arcnat.

        Add Parametric Relation k : (vector (matrix_arcnat dim dim) k)
          (@VecEq.eq_vec _ mat_eqA k) reflexivity proved by
          (@eq_vec_refl _ _ mat_eqA_st k) symmetry proved by
            (@eq_vec_sym _ _ mat_eqA_st k) transitivity proved by
              (@eq_vec_trans _ _ mat_eqA_st k) as eq_vec_mat_eqA_rel_arcnat.

        Definition eq_mint_arcnat k (mi1 mi2 : mint k) :=
          let (c1, args1) := mi1 in
            let (c2, args2) := mi2 in
              c1 =v c2 /\ VecEq.eq_vec mat_eqA args1 args2.

        Notation "x =i y" := (eq_mint_arcnat x y) (at level 70).

        Lemma eq_mint_refl_arcnat : forall k (x : mint k), x =i x.

        Proof.
          unfold eq_mint_arcnat. destruct x. intuition.
        Qed.

        Lemma eq_mint_sym_arcnat : forall k (x y : mint k), x =i y -> y
          =i x.

        Proof.
          unfold eq_mint_arcnat. destruct x. destruct y. intuition.
        Qed.

        Lemma eq_mint_trans_arcnat : forall k (x y z : mint k), x =i y
          -> y =i z -> x =i z.

        Proof.
          unfold eq_mint_arcnat. destruct x. destruct y. destruct
          z. intuition. trans const_arcnat1; hyp. trans args_arcnat1;
          hyp.
        Qed.

        Add Parametric Relation k : (@mint k) (@eq_mint_arcnat k)
          reflexivity proved by (@eq_mint_refl_arcnat k) symmetry proved
            by (@eq_mint_sym_arcnat k) transitivity proved by
              (@eq_mint_trans_arcnat k) as eq_mint_rel_arcnat.

        Add Parametric Morphism k : (@mkMatrixInt_arcnat matrix_arcnat
          dim k) with signature eq_vec ==> (@VecEq.eq_vec _ mat_eqA k)
        ==> (@eq_mint_arcnat k) as mkMatrixInt_mor_arcnat.

        Proof.
          unfold eq_mint_arcnat. auto.
        Qed.

        Add Parametric Morphism k : (@const_arcnat matrix_arcnat dim k)
          with signature (@eq_mint_arcnat k) ==> eq_vec as
            const_mor_arcnat.

        Proof.
          destruct x. destruct y. simpl. intuition.
        Qed.

        Add Parametric Morphism k : (@args_arcnat matrix_arcnat dim k)
          with signature (@eq_mint_arcnat k) ==> (@VecEq.eq_vec _
            mat_eqA k) as args_mor_arcnat.

        Proof.
          destruct x. destruct y. simpl. intuition.
        Qed.

        Section MBI.

          Definition dom_arcnat := { v : vec | vec_invariant_arcnat v }.

          Definition dom2vec_arcnat (d : dom_arcnat) : vec := proj1_sig d.

          Definition add_matrices_arcnat i m n (v : vector
            (matrix_arcnat m n) i) := Vfold_left (@mat_plus_arcnat m n)
          (zero_matrix_arcnat m n) v.

          Definition mi_eval_aux_arcnat n (mi : mint n) (v : vector vec
            n) : vec := add_vectors_arcnat (n:=dim) (k:=n)(Vmap2
              (@mat_vec_prod_arcnat dim dim) (args_arcnat mi) v) [+]
            const_arcnat mi.

          Add Parametric Morphism n : (@mi_eval_aux_arcnat n) with
            signature (@eq_mint_arcnat n) ==> (@VecEq.eq_vec _ eq_vec n)
            ==> eq_vec as mi_eval_aux_mor_arcnat.

          Proof.
            unfold mi_eval_aux_arcnat. intuition. apply vector_plus_mor_arcnat.
            apply add_vectors_mor_arcnat.
            apply Vforall2n_intro. intros. repeat rewrite Vnth_map2.
            apply mat_vec_prod_mor_arcnat.
            apply (Vnth_mor mat_eqA). rewrite H. refl. apply (Vnth_mor eq_vec). hyp.
            rewrite H. refl.
          Qed.

          Variable ma : MatrixMethodConf_arcnat.

          Variable mi_eval_ok : forall f v, vec_invariant_arcnat
            (mi_eval_aux_arcnat (trsInt_arcnat ma f) (Vmap
              dom2vec_arcnat v)).

          Definition mi_eval_arcnat f (v : vector dom_arcnat
            (ASignature.arity f)) : dom_arcnat := exist (fun v =>
              vec_invariant_arcnat v) (mi_eval_aux_arcnat (trsInt_arcnat
                ma f) (Vmap dom2vec_arcnat v)) (mi_eval_ok f v).

          Lemma mi_eval_cons_arcnat : forall n (mi : mint (S n)) v vs,
            mi_eval_aux_arcnat mi (Vcons v vs) =v mat_vec_prod_arcnat
            (Vhead (args_arcnat mi)) v [+] mi_eval_aux_arcnat
            (mkMatrixInt_arcnat (const_arcnat mi) (Vtail (args_arcnat
              mi))) vs.

          Proof.
            intros. unfold mi_eval_aux_arcnat. simpl. rewrite
            vector_plus_assoc_arcnat.
            apply vector_plus_mor_arcnat.
            apply vector_plus_comm_arcnat. refl.
          Qed.

          Definition dom_zero_arcnat: dom_arcnat.

          Proof.
            exists (Vreplace (Vconst A0r dim) dim_pos A1r).
            apply inv_id_matrix_arcnat.
          Defined.

          Definition I_arcnat := @mkInterpretation Sig dom_arcnat
            dom_zero_arcnat mi_eval_arcnat.

          Infix ">=v" := vec_ge_arcnat (at level 70).

          Definition succeq_arcnat (x y : dom_arcnat) := (dom2vec_arcnat
            x) >=v (dom2vec_arcnat y).

          Lemma refl_succeq_arcnat : reflexive succeq_arcnat.

          Proof.
            intro x. apply vec_ge_refl_arcnat.
          Qed.

          Lemma trans_succeq_arcnat : transitive succeq_arcnat.

          Proof.
            unfold succeq_arcnat. apply Rof_trans with
            (f:=dom2vec_arcnat). apply vec_ge_trans_arcnat.
          Qed.

        (** Monotonicity *)

          Section VecMonotonicity_arcnat.

            Variable f : matrix_arcnat dim dim -> vec -> vec.
            Variable f_mon : forall M v1 v2, v1 >=v v2 -> f M v1 >=v f M v2.
            Variables (a b : vec).

            Lemma vec_add_weak_monotone_map2_arcnat : forall n1 (v1 :
              vector vec n1) n2 (v2 : vector vec n2) n (M : vector
                (matrix_arcnat dim dim) n) i_j, a >=v b ->
              add_vectors_arcnat (Vmap2 f M (Vcast (Vapp v1 (Vcons a
                v2)) i_j)) >=v add_vectors_arcnat (Vmap2 f M (Vcast (Vapp
                  v1 (Vcons b v2)) i_j)).

            Proof.
              induction v1; intros; simpl.
              destruct n; try solve [NatUtil.absurd_arith].
              unfold add_vectors_arcnat, succeq_arcnat, vec_ge_arcnat.
              simpl. apply Vforall2n_intro.
              intros. unfold vector_plus_arcnat. do 2 rewrite Vnth_map2.
              assert (Vnth (f (Vhead M) a) ip >>= Vnth (f (Vhead M) b) ip).
              apply Vforall2n_nth. apply f_mon. hyp.
              apply plus_ge_compat_arcnat. apply ge_reflr. hyp.
              destruct n0; try solve [NatUtil.absurd_arith].
              unfold add_vectors_arcnat, succeq_arcnat, vec_ge_arcnat.
              simpl. apply Vforall2n_intro.
              intros. unfold vector_plus_arcnat. do 2 rewrite Vnth_map2.
              apply plus_ge_compat_arcnat.
              apply Vforall2n_nth. unfold add_vectors_arcnat in IHv1. apply IHv1.
              hyp. apply ge_reflr.
            Qed.

          End VecMonotonicity_arcnat.

          Lemma monotone_succeq_arcnat : monotone I_arcnat succeq_arcnat.

          Proof.
            intros f i j i_j vi vj a b ab.
            simpl. unfold mi_eval_arcnat,
            mi_eval_aux_arcnat, succeq_arcnat. simpl.
            apply (@vec_plus_ge_compat_r_arcnat dim).
            do 2 rewrite Vmap_cast. do 2 rewrite Vmap_app. simpl.
            apply vec_add_weak_monotone_map2_arcnat; trivial.
            intros. unfold succeq_arcnat, vec_ge_arcnat.
            apply Vforall2n_intro. intros.
            unfold mat_vec_prod_arcnat.
            do 2 rewrite Vnth_col_mat_arcnat. apply mat_mult_mon_arcnat.
            apply mat_ge_refl_arcnat. intros x y xp yp.
            do 2 rewrite vec_to_col_mat_spec_arcnat.
            apply Vforall2n_nth. hyp.
          Qed.

          Lemma succeq_dec_arcnat : rel_dec succeq_arcnat.

          Proof.
            intros x y. unfold succeq_arcnat, vec_ge_arcnat.
            apply Vforall2n_dec.
            intros m1 n. apply ge_decr.
          Defined.

        (** Decidability of order on terms induced by matrix interpretations. *)

          Section OrderDecidability_arcnat.

            Require Import ABterm.

            Notation bterm := (bterm Sig).

          (** Symbolic computation of term interpretation. *)

            Definition mat_matrixInt_prod_arcnat n M (mi : mint n) :
              mint n := mkMatrixInt_arcnat (mat_vec_prod_arcnat M
                (const_arcnat mi)) (Vmap (mat_mult_arcnat M) (args_arcnat
                  mi)).

            Definition combine_matrices_arcnat n k (v : vector (vector
              mat k) n) := Vbuild (fun i ip => add_matrices_arcnat (Vmap
                (fun v => Vnth v ip) v)).

            Lemma combine_matrices_nil_arcnat : forall i,
              combine_matrices_arcnat Vnil = Vconst (@zero_matrix_arcnat
                dim dim) i.

            Proof.
              intros. apply Veq_nth. intros. unfold combine_matrices_arcnat.
              rewrite Vnth_const. rewrite Vbuild_nth. trivial.
            Qed.

            Lemma combine_matrices_cons_arcnat : forall k n v (vs :
              vector (vector mat k) n), combine_matrices_arcnat (Vcons v
                vs) = Vmap2 (@mat_plus_arcnat _ _)
              (combine_matrices_arcnat vs) v.

            Proof.
              intros. apply Veq_nth. intros.
              unfold combine_matrices_arcnat, add_matrices_arcnat. simpl.
              rewrite Vnth_map2. do 2 rewrite Vbuild_nth. refl.
            Qed.

            Fixpoint mi_of_term_arcnat k (t : bterm k) : mint (S k) :=
              match t with
                | BVar i ip =>
                  let zero_int := Vconst (zero_matrix_arcnat dim dim) (S k) in
                    let args_int := Vreplace zero_int (le_lt_S ip) (id_matrix_arcnat dim) in
                      mkMatrixInt_arcnat (@zero_vec_arcnat dim) args_int
                | BFun f v =>
                  let f_int := trsInt_arcnat ma f in
                    let args_int := Vmap (@mi_of_term_arcnat k) v in
                      let args_int' := Vmap2 (@mat_matrixInt_prod_arcnat (S k))
                        (args_arcnat f_int) args_int in
                        let res_const := add_vectors_arcnat (Vcons (const_arcnat f_int)
                          (Vmap (@const_arcnat matrix_arcnat dim (S k)) args_int')) in
                        let res_args := combine_matrices_arcnat
                          (Vmap (@args_arcnat matrix_arcnat dim (S k))
                            args_int') in
                          mkMatrixInt_arcnat res_const res_args
              end.

            Require Import ATrs.

            Definition rule_mi_arcnat r :=
              let mvl := maxvar (lhs r) in
                let mvr := maxvar (rhs r) in
                  let m := max mvl mvr in
                    let lt := inject_term (le_max_l mvl mvr) in
                      let rt := inject_term (le_max_r mvl mvr) in
                        (mi_of_term_arcnat lt, mi_of_term_arcnat rt).

          (** Order characteristic for symbolically computed
             interpretation and its decidability. *)

            Notation mat_ge := (@mat_ge_arcnat dim dim).

            Definition mint_ge_arcnat n (l r : mint n) := Vforall2n
              mat_ge (args_arcnat l) (args_arcnat r) /\ (@vec_ge_arcnat
                dim) (const_arcnat l) (const_arcnat r).

            Definition term_ord_arcnat (ord : forall n, relation (mint
              n)) l r := let (li, ri) := rule_mi_arcnat (mkRule l r) in
            ord _ li ri.

            Variable mint_gt_arcnat : forall n (l r : mint n), Prop.
            Variable mint_gt_dec_arcnat : forall n, rel_dec
              (@mint_gt_arcnat n).

            Definition term_ge_arcnat := term_ord_arcnat mint_ge_arcnat.
            Definition term_gt_arcnat := term_ord_arcnat mint_gt_arcnat.

            Lemma mint_ge_dec_arcnat : forall n, rel_dec (@mint_ge_arcnat n).

            Proof.
              intros n x y. unfold mint_ge_arcnat. destruct
              (Vforall2n_dec (@mat_ge_dec_arcnat dim dim) (args_arcnat
                x) (args_arcnat y)); intuition.  destruct
              (vec_ge_dec_arcnat (const_arcnat x) (const_arcnat y));
              intuition.
              Defined.

              Lemma term_ge_dec_arcnat : rel_dec term_ge_arcnat.

              Proof.
                intros l r. unfold term_ge_arcnat, term_ord_arcnat. simpl.
                match goal with |- {mint_ge_arcnat ?l ?r} + {~mint_ge_arcnat ?l ?r} =>
                  destruct (mint_ge_dec_arcnat l r); auto
                end.
              Defined.

              Lemma term_gt_dec_arcnat : rel_dec term_gt_arcnat.

              Proof.
                intros l r. unfold term_gt_arcnat, term_ord_arcnat. simpl.
                match goal with |- {mint_gt_arcnat ?l ?r} +
                  {~mint_gt_arcnat ?l ?r} => destruct (mint_gt_dec_arcnat l
                    r); auto end.
              Defined.

              Notation IR_succeq := (IR I_arcnat succeq_arcnat).

              Definition mint_eval_arcnat (val : valuation I_arcnat) k (mi
                : mint k) : vec := let coefs := Vbuild (fun i (ip : i < k)
                  => dom2vec_arcnat (val i)) in add_vectors_arcnat (Vcons
                    (const_arcnat mi) (Vmap2 (@mat_vec_prod_arcnat dim dim)
                      (args_arcnat mi) coefs)).

              Add Parametric Morphism val k : (@mint_eval_arcnat val k)
                with signature (@eq_mint_arcnat k) ==> eq_vec as
                  mint_eval_mor_arcnat.

              Proof.
                unfold eq_mint_arcnat. intros [c1 args1] [c2 args2]. intuition.
                unfold mint_eval_arcnat. simpl. apply add_vectors_mor_arcnat.
                rewrite (eq_vec_cons eq_vec). intuition.
                apply Vmap2_mor with (eqA := @mat_eqA_arcnat dim dim) (eqB := eq_vec).
                apply eq_vec_st. apply mat_vec_prod_mor_arcnat. hyp.
                apply eq_vec_refl. apply eq_vec_st.
              Qed.

              Lemma mint_eval_split_arcnat : forall val k (mi : mint k),
                let coefs := Vbuild (fun i (ip : i < k) => dom2vec_arcnat
                  (val i)) in mint_eval_arcnat val mi =v const_arcnat mi [+]
                add_vectors_arcnat (Vmap2 (@mat_vec_prod_arcnat dim dim)
                  (args_arcnat mi) coefs).

              Proof.
                intros. unfold mint_eval_arcnat, add_vectors_arcnat. simpl.
                rewrite vector_plus_comm_arcnat. refl.
              Qed.

              Hint Rewrite mat_mult_id_l_arcnat zero_matrix_mult_l_arcnat
                using simpl : arith.

              Lemma mint_eval_var_aux_arcnat : forall M i k (v : vector
                vec k) (ip : i < k), add_vectors_arcnat (Vmap2
                  (@mat_vec_prod_arcnat dim dim) (Vreplace (Vconst
                    (zero_matrix_arcnat dim dim) k) ip M) v) =v
                col_mat_to_vec_arcnat (M <*> (vec_to_col_mat_arcnat (Vnth
                  v ip))).

              Proof.
                induction i; intros.
                destruct k. NatUtil.absurd_arith.
                unfold add_vectors_arcnat. simpl.
                fold (add_vectors_arcnat
                  (Vmap2 (@mat_vec_prod_arcnat dim dim)
                    (Vconst (zero_matrix_arcnat dim dim) k) (Vtail v))).
                assert (add_vectors_arcnat
                  (Vmap2 (@mat_vec_prod_arcnat dim dim) (Vconst
                    (zero_matrix_arcnat dim dim) k) (Vtail v))
                  =v @zero_vec_arcnat dim).
                Focus 2. rewrite H.
                rewrite vector_plus_zero_l_arcnat.
                unfold mat_vec_prod_arcnat.
                replace (Vhead v) with (Vnth v ip).
                refl.
                rewrite Vhead_nth.
                rewrite (NatUtil.lt_unique (Lt.lt_O_Sn k) ip). refl.
                apply add_vectors_zero_arcnat.
                apply Vforall_nth_intro. intros.
                rewrite Vnth_map2. rewrite Vnth_const.
                unfold mat_vec_prod_arcnat.
                rewrite zero_matrix_mult_l_arcnat.
                apply Vforall2n_intro. intros.
                rewrite Vnth_col_mat_arcnat.
                unfold zero_matrix_arcnat, zero_vec_arcnat.
                rewrite mat_build_elem_arcnat.
                rewrite Vnth_const. refl.
                destruct k. NatUtil.absurd_arith.
                rewrite Vreplace_tail. simpl.
                rewrite add_vectors_cons_arcnat.
                unfold mat_vec_prod_arcnat at 1.
                rewrite zero_matrix_mult_l_arcnat.
                assert (col_mat_to_vec_arcnat
                  (zero_matrix_arcnat dim 1) =v zero_vec_arcnat dim).
                apply Vforall2n_intro. intros.
                rewrite Vnth_col_mat_arcnat.
                unfold zero_matrix_arcnat, zero_vec_arcnat.
                rewrite mat_build_elem_arcnat.
                rewrite Vnth_const. refl. rewrite H.
                rewrite vector_plus_zero_l_arcnat.
                rewrite IHi. rewrite Vnth_tail.
                rewrite (NatUtil.le_unique (Lt.lt_n_S (Lt.lt_S_n ip)) ip). refl.
              Qed.

              Lemma mint_eval_eq_term_int_var_arcnat : forall v (val :
                valuation I_arcnat) k (t_b : maxvar_le k (Var v)),
              dom2vec_arcnat (bterm_int val (inject_term t_b)) =v
              mint_eval_arcnat val (mi_of_term_arcnat (inject_term
                t_b)).

              Proof.
                intros. rewrite mint_eval_split_arcnat.
                change (const_arcnat (mi_of_term_arcnat
                  (inject_term t_b))) with (zero_vec_arcnat dim).
                rewrite vector_plus_zero_l_arcnat.
                change (args_arcnat (mi_of_term_arcnat
                  (inject_term t_b))) with (Vreplace (Vconst
                    (zero_matrix_arcnat dim dim) (S k))
                  (NatUtil.le_lt_S (maxvar_var t_b))
                  (id_matrix_arcnat dim)).
                rewrite mint_eval_var_aux_arcnat.
                rewrite Vbuild_nth. simpl.
                trans (col_mat_to_vec_arcnat
                  (vec_to_col_mat_arcnat (dom2vec_arcnat (val v)))).
                rewrite col_mat_to_vec_idem_arcnat.
                refl. apply get_col_mor_arcnat.
                rewrite mat_mult_id_l_arcnat. refl.
                ded dim_pos. auto.
              Qed.

              Hint Rewrite vector_plus_zero_l_arcnat
                vector_plus_zero_r_arcnat add_vectors_cons_arcnat : arith.

              Lemma mint_eval_const_arcnat : forall val k (c : vec),
                mint_eval_arcnat (k:=k) val (mkMatrixInt_arcnat c
                  (combine_matrices_arcnat Vnil)) =v c.

              Proof.
                intros. unfold mint_eval_arcnat. simpl. autorewrite with arith.
                trans (c [+] @zero_vec_arcnat dim).
                apply vector_plus_mor_arcnat. refl.
                apply add_vectors_zero_arcnat.
                apply Vforall_nth_intro. intros.
                rewrite Vnth_map2.
                rewrite combine_matrices_nil_arcnat. rewrite Vnth_const.
                unfold mat_vec_prod_arcnat.
                apply Vforall2n_intro. intros.
                rewrite Vnth_col_mat_arcnat.
                trans (get_elem_arcnat (zero_matrix_arcnat dim 1) ip0 access_0).
                apply get_elem_mor_arcnat.
                apply zero_matrix_mult_l_arcnat.
                unfold zero_matrix_arcnat.
                rewrite mat_build_elem_arcnat.
                unfold zero_vec_arcnat. rewrite Vnth_const. refl.
                apply vector_plus_zero_r_arcnat.
              Qed.

              Lemma mint_eval_cons_arcnat : forall n k val c_hd c_tl a_hd
                (a_tl : vector (vector mat k) n), mint_eval_arcnat val
                (mkMatrixInt_arcnat (c_hd [+] c_tl)
                  (combine_matrices_arcnat (Vcons a_hd a_tl))) =v
                mint_eval_arcnat val (mkMatrixInt_arcnat c_hd a_hd) [+]
                mint_eval_arcnat val (mkMatrixInt_arcnat c_tl
                  (combine_matrices_arcnat a_tl)).

              Proof.
                intros. unfold mint_eval_arcnat. simpl.
                set (vali := Vbuild (A := vec)
                  (fun i (_ : i < k) => dom2vec_arcnat (val i))).
                rewrite combine_matrices_cons_arcnat.
                autorewrite with arith.
                repeat rewrite <- vector_plus_assoc_arcnat.
                apply vector_plus_mor_arcnat. refl.
                rewrite vector_plus_assoc_arcnat.
                rewrite (vector_plus_comm_arcnat _ c_tl).
                rewrite <- vector_plus_assoc_arcnat.
                apply vector_plus_mor_arcnat. refl.
                apply add_vectors_split_arcnat. intros.
                repeat rewrite Vnth_map2. rewrite vector_plus_comm_arcnat.
                apply mat_vec_prod_distr_mat_arcnat.
              Qed.

              Lemma mint_eval_mult_factor_arcnat : forall k val M (mi :
                mint k), mint_eval_arcnat val (mat_matrixInt_prod_arcnat M
                  mi) =v mat_vec_prod_arcnat M (mint_eval_arcnat val mi).

              Proof.
                unfold mint_eval_arcnat. intros. simpl.
                autorewrite with arith.
                rewrite mat_vec_prod_distr_vec_arcnat.
                apply vector_plus_mor_arcnat. refl.
                set (gen := Vbuild (A:=vec)
                  (fun i (_ : i < k) => dom2vec_arcnat (val i))).
                rewrite (mat_vec_prod_distr_add_vectors_arcnat M
                  (Vmap2 (@mat_vec_prod_arcnat dim dim) (args_arcnat mi) gen)
                  (Vmap2 (@mat_vec_prod_arcnat dim dim) (Vmap (mat_mult_arcnat M)
                    (args_arcnat mi)) gen)).
                refl. intros. repeat rewrite Vnth_map2. rewrite Vnth_map.
                unfold mat_vec_prod_arcnat. rewrite vec_to_col_mat_idem_arcnat.
                apply get_col_mor_arcnat. rewrite mat_mult_assoc_arcnat. refl.
              Qed.

              Lemma mint_eval_eq_bterm_int_fapp_arcnat : forall k i fi val
                (v : vector (bterm k) i),
                let arg_eval := Vmap2
                  (@mat_matrixInt_prod_arcnat (S k)) (args_arcnat fi)
                  (Vmap (@mi_of_term_arcnat k) v) in
                  mi_eval_aux_arcnat fi (Vmap
                    (fun t : bterm k =>
                      mint_eval_arcnat val (mi_of_term_arcnat t)) v) =v
                  mint_eval_arcnat val (mkMatrixInt_arcnat
                    (add_vectors_arcnat (Vcons (const_arcnat fi) (Vmap
                      (@const_arcnat matrix_arcnat dim (S k)) arg_eval)))
                    (combine_matrices_arcnat (Vmap
                      (@args_arcnat matrix_arcnat dim (S k)) arg_eval))).

              Proof.
                induction i; intros.
                (* i = 0 *)
                VOtac. simpl.
                unfold mi_eval_aux_arcnat, add_vectors_arcnat.
                simpl. autorewrite with arith.
                sym. apply mint_eval_const_arcnat.
                (* i > 0 *)
                VSntac v. simpl mi_eval_aux_arcnat.
                rewrite mi_eval_cons_arcnat.
                rewrite IHi. simpl.
                trans (@mint_eval_arcnat val (S k)
                  (@mkMatrixInt_arcnat matrix_arcnat dim (S k)
                    (@mat_vec_prod_arcnat dim dim
                      (@Vhead (matrix_arcnat dim dim) i
                        (@args_arcnat matrix_arcnat dim (S i) fi))
                      (@const_arcnat matrix_arcnat dim (S k)
                        (@Vhead (mint (S k)) i
                          (@Vmap (ABterm.bterm Sig k)
                            (mint (S k))
                            (@mi_of_term_arcnat k) (S i) v)))
                      [+] @add_vectors_arcnat dim (S i) (@Vcons (vector Ar dim)
                        (@const_arcnat matrix_arcnat dim (S i) fi) i
                        (@Vmap (mint (S k))
                          (vector Ar dim) (@const_arcnat matrix_arcnat dim (S k)) i
                          (@Vmap2 (matrix_arcnat dim dim)
                            (mint (S k))
                            (mint (S k))
                            (@mat_matrixInt_prod_arcnat (S k)) i
                            (@Vtail (matrix_arcnat dim dim) i
                              (@args_arcnat matrix_arcnat dim (S i) fi))
                            (@Vtail (mint (S k)) i
                              (@Vmap (ABterm.bterm Sig k)
                                (mint (S k))
                                (@mi_of_term_arcnat k) (S i) v))))))
                    (@combine_matrices_arcnat (S i) (S k)
                      (@Vcons (vector (matrix_arcnat dim dim) (S k))
                        (@Vmap (matrix_arcnat dim dim) (matrix_arcnat dim dim)
                          (@mat_mult_arcnat dim dim dim
                            (@Vhead (matrix_arcnat dim dim) i
                              (@args_arcnat matrix_arcnat dim (S i) fi)))
                          (S k)
                          (@args_arcnat matrix_arcnat dim (S k)
                            (@Vhead (mint (S k)) i
                              (@Vmap (ABterm.bterm Sig k)
                                (mint (S k))
                                (@mi_of_term_arcnat k) (S i) v)))) i
                        (@Vmap (mint (S k))
                          (vector (matrix_arcnat dim dim) (S k))
                          (@args_arcnat matrix_arcnat dim (S k)) i
                          (@Vmap2 (matrix_arcnat dim dim)
                            (mint (S k))
                            (mint (S k))
                            (@mat_matrixInt_prod_arcnat (S k)) i
                            (@Vtail (matrix_arcnat dim dim) i
                              (@args_arcnat matrix_arcnat dim (S i) fi))
                            (@Vtail (mint (S k)) i
                              (@Vmap (ABterm.bterm Sig k)
                                (mint (S k))
                                (@mi_of_term_arcnat k) (S i) v)))))))).
                Focus 2. apply mint_eval_mor_arcnat. split.
                rewrite add_vectors_perm_arcnat.
                rewrite (add_vectors_cons_arcnat (i := S i)
                  (mat_vec_prod_arcnat (Vhead (args_arcnat fi))
                    (const_arcnat (Vhead (Vmap (mi_of_term_arcnat (k:=k)) v))))). refl.
                apply eq_vec_refl. apply mat_eqA_st.
                rewrite mint_eval_cons_arcnat. apply vector_plus_mor_arcnat.
                Focus 2. rewrite Vmap_tail. refl.
                rewrite H. simpl.
                fold (mat_matrixInt_prod_arcnat
                  (Vhead (args_arcnat fi)) (mi_of_term_arcnat (Vhead v))).
                sym. apply mint_eval_mult_factor_arcnat.
              Qed.

              Lemma mint_eval_eq_bterm_int_arcnat : forall (val :
                valuation I_arcnat) t k (t_b : maxvar_le k t),
              dom2vec_arcnat (bterm_int val (inject_term t_b)) =v
              mint_eval_arcnat val (mi_of_term_arcnat (inject_term
                t_b)).

              Proof.
                intros val t. pattern t. apply term_ind_forall; intros.
                apply mint_eval_eq_term_int_var_arcnat.
                rewrite inject_term_eq. simpl.
                rewrite Vmap_map.
                rewrite (@Vmap_eqA _ _ eq_vec eq_vec_st
                  (fun x => dom2vec_arcnat (bterm_int val x))
                  (fun (t : bterm k) =>
                    mint_eval_arcnat val (mi_of_term_arcnat t))).
                simpl. apply mint_eval_eq_bterm_int_fapp_arcnat.
                apply Vforall_nth_intro. intros.
                rewrite inject_terms_nth. apply (Vforall_nth ip H).
              Qed.

              Lemma mint_eval_eq_term_int_arcnat : forall t (val :
                valuation I_arcnat) k (t_b : maxvar_le k t),
              dom2vec_arcnat (term_int val t) =v mint_eval_arcnat val
              (mi_of_term_arcnat (inject_term t_b)).

              Proof.
                intros. rewrite <- (term_int_eq_bterm_int val t_b).
                apply mint_eval_eq_bterm_int_arcnat.
              Qed.

              Lemma mint_eval_equiv_arcnat : forall l r (val : valuation I_arcnat),
                let (li, ri) := rule_mi_arcnat (mkRule l r) in
                  let lev := term_int val l in
                    let rev := term_int val r in
                      let lv := mint_eval_arcnat val li in
                        let rv := mint_eval_arcnat val ri in
                          lv =v dom2vec_arcnat lev /\ rv =v dom2vec_arcnat rev.

              Proof.
                intros. simpl. split.
                rewrite (mint_eval_eq_term_int_arcnat
                  val (le_max_l (maxvar l) (maxvar r))).
                refl.
                rewrite (mint_eval_eq_term_int_arcnat
                  val (le_max_r (maxvar l) (maxvar r))).
                refl.
              Qed.

              Lemma mint_eval_mon_succeq_args_arcnat : forall k (val :
                vector vec k) (mi mi' : mint k), mint_ge_arcnat mi mi' ->
              add_vectors_arcnat (Vmap2 (@mat_vec_prod_arcnat dim dim)
                (args_arcnat mi) val) >=v add_vectors_arcnat (Vmap2
                  (@mat_vec_prod_arcnat dim dim) (args_arcnat mi') val).

              Proof.
                destruct mi. gen val. clear val. induction args_arcnat0. intros.
                destruct mi'. VOtac.
                unfold mint_eval_arcnat, add_vectors_arcnat. simpl.
                apply (vec_ge_refl_arcnat (@zero_vec_arcnat dim)).
                intros. destruct mi'. VSntac args_arcnat1.
                unfold mint_eval_arcnat, add_vectors_arcnat. simpl.
                destruct H. apply (@vec_plus_ge_compat_arcnat dim).
                apply (IHargs_arcnat0 (Vtail val)
                  (mkMatrixInt_arcnat const_arcnat1 (Vtail (args_arcnat1)))).
                split. simpl. change args_arcnat0 with
                (Vtail (Vcons h args_arcnat0)).
                apply Vforall2n_tail. hyp. hyp.
                apply mat_vec_prod_ge_compat_arcnat.
                change h with (Vhead (Vcons h args_arcnat0)).
                do 2 rewrite Vhead_nth.
                apply Vforall2n_nth. hyp.
                apply (vec_ge_refl_arcnat (Vhead val)).
              Qed.

              Lemma mint_eval_mon_succeq_arcnat : forall (val : valuation
                I_arcnat) k (mi mi' : mint k), mint_ge_arcnat mi mi' ->
              mint_eval_arcnat val mi >=v mint_eval_arcnat val mi'.

              Proof.
                intros. unfold mint_eval_arcnat, add_vectors_arcnat. simpl.
                apply (@vec_plus_ge_compat_arcnat dim).
                exact (mint_eval_mon_succeq_args_arcnat _ H).
                destruct H. hyp.
              Qed.

              Lemma term_ge_incl_succeq_arcnat : term_ge_arcnat << IR_succeq.

              Proof.
                intros l r lr v. destruct (mint_eval_equiv_arcnat l r v). simpl in * .
                unfold succeq_arcnat.
                rewrite <- (vec_ge_mor_arcnat H H0).
                apply mint_eval_mon_succeq_arcnat. hyp.
              Qed.

              Definition succeq_arcnat' := term_ge_arcnat.
              Definition succeq'_sub_arcnat := term_ge_incl_succeq_arcnat.
              Definition succeq'_dec_arcnat := term_ge_dec_arcnat.

            End OrderDecidability_arcnat.
          End MBI.
        End MatrixBasedInt_arcnat.
      End Arctic_nat.
    End S.