Require Export Iron.Language.SystemF2Effect.Type.Exp.Base.
Require Export Iron.Language.SystemF2Effect.Type.Relation.EquivT.

(********************************************************************)
(* Type subsumptinon.
   The interesting cases all concern sums. *)
Inductive SubsT : kienv -> stprops -> ty -> ty -> ki -> Prop :=
 | SbEquiv
   :  forall  ke sp t1 t2 k
   ,  EquivT  ke sp t1 t2 k
   -> SubsT   ke sp t1 t2 k

 | SbTrans
   :  forall  ke sp t1 t2 t3 k
   ,  SubsT   ke sp t1 t2 k -> SubsT  ke sp t2 t3 k
   -> SubsT   ke sp t1 t3 k

 | SbBot
   :  forall  ke sp t k
   ,  SumKind k
   -> KindT   ke sp t k
   -> SubsT   ke sp t (TBot k) k

 | SbSumAbove
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> SubsT   ke sp t1 t2 k -> SubsT  ke sp t1 t3 k
   -> SubsT   ke sp t1 (TSum t2 t3) k

 | SbSumBelow
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> KindT   ke sp t3 k
   -> SubsT   ke sp t1 t2 k
   -> SubsT   ke sp (TSum t1 t3) t2 k

 | SbSumAboveLeft
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> SubsT   ke sp t1 (TSum t2 t3) k
   -> SubsT   ke sp t1 t2 k

 | SbSumAboveRight
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> SubsT   ke sp t1 (TSum t2 t3) k
   -> SubsT   ke sp t1 t3 k.

Hint Constructors SubsT.

(********************************************************************)
(* Kind projection *)
Lemma subsT_kind_left
 :  forall ke sp t1 t2 k
 ,  SubsT  ke sp t1 t2 k
 -> KindT  ke sp t1 k.
Proof.
 intros.
 induction H; eauto.
Qed.
Hint Resolve subsT_kind_left.

Lemma subsT_kind_right
 :  forall ke sp t1 t2 k
 ,  SubsT  ke sp t1 t2 k
 -> KindT  ke sp t2 k.
Proof.
 intros.
 induction H; eauto.
  inverts IHSubsT. eauto.
  inverts IHSubsT. eauto.
Qed.
Hint Resolve subsT_kind_right.

(* Sumkind projection *)
Lemma subsT_sumkind_left
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp (TSum t1 t2) t3 k
 -> SumKind k.
Proof.
 intros.
 inverts H; eauto.
Qed.
Hint Resolve subsT_sumkind_left.

Lemma subsT_sumkind_right
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp t1 (TSum t2 t3) k
 -> SumKind k.
Proof.
 intros.
 inverts H; eauto.
Qed.
Hint Resolve subsT_sumkind_right.

(* Subs/Equiv *)
Lemma subsT_equiv_above
 :  forall ke sp t1 t1' t2 k
 ,  EquivT ke sp t1  t1' k
 -> SubsT  ke sp t1  t2  k
 -> SubsT  ke sp t1' t2  k.
Proof.
 intros.
 eapply SbTrans with (t2 := t1); eauto.
Qed.
Hint Resolve subsT_equiv_above.

Lemma subsT_equiv_below
 :  forall ke sp t1 t2 t2' k
 ,  EquivT ke sp t2 t2' k
 -> SubsT  ke sp t1 t2  k
 -> SubsT  ke sp t1 t2' k.
Proof.
 intros.
 eapply SbTrans with (t1 := t1); eauto.
Qed.
Hint Resolve subsT_equiv_below.

(* Subs sum lemmas *)
Lemma subsT_sum_comm_below
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp t1 (TSum t2 t3) k
 -> SubsT  ke sp t1 (TSum t3 t2) k.
Proof.
 intros.
 eapply subsT_equiv_below with (t2 := TSum t2 t3).
  have HK: (KindT ke sp (TSum t2 t3) k). inverts HK.
  eapply EqSumComm; eauto.
  auto.
Qed.
Hint Resolve subsT_sum_comm_below.

Lemma subsT_sum_comm_above
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp (TSum t1 t2) t3 k
 -> SubsT  ke sp (TSum t2 t1) t3 k.
Proof.
 intros.
 eapply subsT_equiv_above with (t1 := TSum t1 t2).
  have HK: (KindT ke sp (TSum t1 t2) k). inverts HK.
  eapply EqSumComm; eauto.
  auto.
Qed.
Hint Resolve subsT_sum_comm_above.

Lemma subsT_sum_left
 : forall ke sp t1 t1' t2 k
 ,  SumKind k
 -> KindT  ke sp t2 k
 -> SubsT  ke sp t1 t1' k
 -> SubsT  ke sp (TSum t1 t2) (TSum t1' t2) k.
Proof.
 intros.
 eapply SbSumAbove; eauto.
Qed.
Hint Resolve subsT_sum_left.

Lemma subsT_sum_right
 :  forall ke sp t1 t2 t2' k
 ,  SumKind k
 -> KindT   ke sp t1 k
 -> SubsT  ke sp t2 t2' k
 -> SubsT  ke sp (TSum t1 t2) (TSum t1 t2') k.
Proof.
 intros.
 eapply SbSumAbove; eauto.
Qed.
Hint Resolve subsT_sum_right.

Lemma subsT_sum_merge
 :  forall ke sp t1 t1' t2 t2' k
 ,  SumKind k
 -> SubsT  ke sp t1 t1' k
 -> SubsT  ke sp t2 t2' k
 -> SubsT  ke sp (TSum t1 t2) (TSum t1' t2') k.
Proof.
 intros.
 eapply SbTrans with (t2 := TSum t1' t2); eauto.
Qed.
Hint Resolve subsT_sum_merge.

Lemma subsT_stprops_snoc
 :  forall ke sp p t1 t2 k
 ,  SubsT  ke sp        t1 t2 k
 -> SubsT  ke (p <: sp) t1 t2 k.
Proof.
 intros.
 induction H; eauto.
Qed.
Hint Resolve subsT_stprops_snoc.

Lemma subsT_stprops_app
 :  forall ke sp sp' t1 t2 k
 ,  SubsT ke sp          t1 t2 k
 -> SubsT ke (sp' >< sp) t1 t2 k.
Proof.
 intros. gen ke sp k.
 induction sp'; intros; snorm; auto.
 - rrwrite ((sp' :> a) >< sp = sp' >< (a <: sp)).
   snorm.
Qed.
Hint Resolve subsT_stprops_app.

Lemma subsT_stprops_extends
 :  forall ke sp sp' e1 e2 k
 ,  extends sp' sp
 -> SubsT ke sp  e1 e2 k
 -> SubsT ke sp' e1 e2 k.
Proof.
 intros.
 unfold extends in *.
 destruct H. subst.
 snorm.
Qed.

Lemma subsT_closed_kenv_cons
 :  forall sp t1 t2 k1 k2
 ,  SubsT nil sp t1 t2 k1
 -> SubsT (nil :> k2) sp t1 t2 k1.
Proof.
 intros.
 remember nil as KE.
 induction H; subst; eauto 4.

 - Case "SbBot".
   eapply SbBot; auto.
   have (ClosedT t).
   eapply kind_kienv_weaken in H0.
   rrwrite (liftTT 1 0 t = t).
   eauto.

 - Case "SbSumAbove".
   eapply SbSumBelow; auto.
   have (ClosedT t3).
   eapply kind_kienv_weaken in H0.
   rrwrite (liftTT 1 0 t3 = t3).
   eauto.
Qed.
Hint Resolve subsT_closed_kenv_cons.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_upp_all_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_upp x1 L1 T1') ->
                  forall T2 T T', T2 = (t_all T T') ->
                             subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


(***************************************************************************)
(*   This is part of FA_Completeness, it is distributed under the terms    *)
(*           of the GNU Lesser General Public License version 3            *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*           Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.              *)
(***************************************************************************)

Require Export R_sup.
Require Import t1.

Section Dedekind.

Variable Fst Snd :Ensemble Real.

Definition R_Divide := ∀ Ξ, Ξ ∈ Fst \/ Ξ ∈ Snd.

Definition ILT_FS := ∀ Ξ Γ, Ξ ∈ Fst -> Γ ∈ Snd -> Ξ < Γ.

Definition Split Ξ :=
  (∀ Γ, Γ < Ξ -> Γ ∈ Fst) /\ (∀ Γ, Γ > Ξ -> Γ ∈ Snd).

End Dedekind.

Theorem DedekindCut : ∀ Fst Snd, R_Divide Fst Snd ->
  No_Empty Fst -> No_Empty Snd -> ILT_FS Fst Snd ->
  (∃ Ξ, Split Fst Snd Ξ).
Proof.
  intros; assert (∃ x, Boundup_Ens x Fst).
  { destruct H1; exists x; red; intros. left; apply H2; auto. }
  apply SupremumT in H0; auto. destruct H0 as [Ξ  [H0]].
  exists Ξ; split; intros.
  - destruct H with Γ; auto. assert (Boundup_Ens Γ Fst).
    { red; intros; left; apply H2; auto. }
    apply H4 in H7; LEGR H7 H5.
  - destruct H with Γ; auto. apply H0 in H6; LEGR H6 H5.
Qed.

Theorem DedekindCut_Unique : ∀ Fst Snd, R_Divide Fst Snd ->
  No_Empty Fst -> No_Empty Snd -> ILT_FS Fst Snd ->
  ∀ Z1 Z2, Split Fst Snd Z1 -> Split Fst Snd Z2 -> Z1 = Z2.
Proof.
  assert (∀ Fst Snd, R_Divide Fst Snd -> No_Empty Fst
    -> No_Empty Snd -> ILT_FS Fst Snd
    -> ∀ Ξ1 Ξ2, Split Fst Snd Ξ1 -> Split Fst Snd Ξ2 -> ~ Ξ1<Ξ2).
  { intros; intro; red in H, H0, H1, H2, H3, H4; destruct H3, H4.
    pose proof (Mid_P' _ _ H5); pose proof (Mid_P _ _ H5).
    apply H6 in H8; apply H4 in H9. intros;
    pose proof (H2 _ _ H9 H8). apply OrdR1 in H10; tauto. }
  intros; destruct (Theorem167 Z1 Z2) as [H6 | [H6 | H6]]; auto;
  eapply H in H6; eauto; tauto.
Qed.


Require Export XR_Rle.
Require Export XR_Rplus_lt_compat.
Require Export XR_Rplus_lt_compat_r.

Local Open Scope R_scope.

Lemma Rplus_lt_le_compat :
  forall r1 r2 r3 r4, r1 < r2 -> r3 <= r4 -> r1 + r3 < r2 + r4.
Proof.
  intros u v w x.
  intros huv hwx.
  unfold "<=" in hwx.
  destruct hwx as [ hwx | heq ].
  {
    apply Rplus_lt_compat.
    { exact huv. }
    { exact hwx. }
  }
  {
    subst w.
    apply Rplus_lt_compat_r.
    exact huv.
  }
Qed.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

Require Import List.
Require Import Arith.
Require Import Permutation.
Require Import Omega.

Set Implicit Arguments.

Section ListAux.

 Variable A : Type.

 Variable eqb : forall (a b : A), {a = b} + {a <> b}.

 Fixpoint is_in x l : bool :=
  match l with
   | nil => false
   | a :: l' => if eqb x a then true else is_in x l'
  end.

 Lemma is_in_correct : forall x l,
  is_in x l = true -> In x l.
 Proof.
  induction l; simpl; intros.
  discriminate.
  destruct (eqb x a); auto.
 Qed.

 Lemma is_in_correct_conv : forall x l,
  is_in x l = false -> ~ In x l.
 Proof.
  induction l; simpl; intros; auto.
  destruct (eqb x a).
  discriminate.
  intros [H1 | H2].
  elim n; auto.
  apply IHl; trivial.
 Qed.

 Fixpoint nodup l :=
  match l with
   | nil => nil
   | a :: l' => if is_in a l' then nodup l' else a :: nodup l'
  end.

 Lemma nodup_in : forall l x, In x l -> In x (nodup l).
 Proof.
  induction l; simpl; intros; trivial.
  case_eq (is_in a l); intros; auto.
  apply is_in_correct in H0.
  destruct H; subst; auto.
  apply is_in_correct_conv in H0.
  destruct H; subst; simpl; auto.
 Qed.

 Lemma nodup_in_rev : forall l x, In x (nodup l) -> In x l.
 Proof.
  induction l; simpl; intros; trivial.
  case_eq (is_in a l); intros; rewrite H0 in H.
  apply is_in_correct in H0; auto.
  apply is_in_correct_conv in H0.
  destruct H; subst; auto.
 Qed.

 Lemma Nodup_nodup : forall l,
   NoDup (nodup l).
 Proof.
  induction l; simpl; auto.
  constructor.
  case_eq (is_in a l); intros; auto.
  apply is_in_correct_conv in H.
  constructor; trivial.
  intro H'; elim H.
  apply nodup_in_rev; trivial.
 Qed.

 Lemma nodup_fix : forall l,
  NoDup l -> nodup l = l.
 Proof.
  induction l; simpl; auto; intros.
  case_eq (is_in a l); intros.
  apply is_in_correct in H0.
  inversion H; subst.
  elim H3; trivial.
  rewrite IHl; auto.
  inversion H; trivial.
 Qed.

 Lemma permutation_cons_inv : forall a (l:list A),
  In a l -> exists l1, permutation (a :: l1) l.
 Proof.
  induction l; intros.
  elim H.
  simpl in H; destruct H.
  subst; exists l; apply permutation_refl.
  destruct (IHl H) as [l2 H0].
  exists (a0 :: l2).
  apply permutation_trans with (a0 :: a :: l2).
  apply permutation_swap.
  constructor; trivial.
 Qed.

 Lemma incl_permutation: forall (l1 l2 : list A),
  NoDup l1 -> incl l1 l2 -> exists l3, permutation l2 (l1 ++ l3).
 Proof.
  induction l1.
  intro l2; exists l2; apply permutation_refl.
  intros l2 H H0.
  destruct (permutation_cons_inv a l2) as [l3 H1].
  intuition.
  destruct (IHl1 l3) as [l4 H2].
  inversion H; trivial.
  intros b Hb.
  assert (In b (a :: l3)).
  apply permutation_sym in H1.
  apply (permutation_in _ b) in H1; intuition.
  simpl in H2; destruct H2; [ | trivial].
  subst; inversion_clear H; intuition.
  exists l4; simpl.
  apply permutation_trans with (a :: l3).
  apply permutation_sym; trivial.
  constructor; trivial.
 Qed.

 Lemma length_surj : forall (l1 l2 : list A),
  NoDup l1 -> incl l1 l2 ->
  length l1 <= length l2.
 Proof.
  intros.
  destruct (incl_permutation H H0).
  rewrite (permutation_length _ _  _ H1).
  rewrite app_length.
  omega.
 Qed.

 Lemma In_nodup : forall x l, In x l -> In x (nodup l).
 Proof.
  induction l; simpl.
  intros.
  apply H.
  intros.
  destruct H; subst.
  case_eq (is_in x l); intros.
  apply is_in_correct in H; auto.
  simpl; auto.
  case_eq (is_in a l); intros.
  apply is_in_correct in H0; auto.
  apply is_in_correct_conv in H0.
  simpl; auto.
 Qed.

 Lemma incl_nodup : forall l1 l2, incl l1 l2 -> incl (nodup l1) l2.
 Proof.
  induction l1; simpl; intros; auto.
  case_eq (is_in a l1); intros.
  apply IHl1.
  apply is_in_correct in H0.
  red; intros.
  apply H.
  simpl; auto.
  apply is_in_correct_conv in H0.
  red; intros.
  simpl in H1; destruct H1.
  apply H.
  simpl; auto.
  apply IHl1; trivial.
  red; intros; apply H.
  simpl; auto.
 Qed.

End ListAux.

Section ListAux_f.

 Variable A B : Type.

 Variable Aeqb : forall (a b : A), {a = b} + {a <> b}.
 Variable Beqb : forall (a b : B), {a = b} + {a <> b}.

 Variable f : A -> B.
 Variable finv : B -> list A.

 Hypothesis finv_nodup : forall b, NoDup (finv b).

 Hypothesis f_spec : forall a b, In a (finv b) <-> f a = b.

 Variable size : nat.
 Hypothesis size_finv : forall x, length (finv x) <= size.

 Lemma length_surj_mult : forall (la : list A),
  NoDup la ->
  length la <= length (nodup Beqb (map f la)) * size.
 Proof.
  intros.
  apply le_trans with (length (flat_map finv (nodup Beqb (map f la)))).
  apply length_surj; auto.

  red; intros.
  eapply in_flat_map.
  apply f_spec; trivial.
  apply In_nodup.
  apply in_map; trivial.

  apply le_trans with
   (fold_right (fun x sum => sum + length (finv x)) 0 (nodup Beqb (map f la))).

  induction la; simpl; auto.
  case_eq (is_in Beqb (f a) (map f la)); intros; simpl.
  apply IHla.
  inversion H; auto.
  rewrite plus_comm.
  rewrite app_length.
  apply plus_le_compat; auto.
  apply IHla.
  inversion H; auto.

  induction la; simpl; auto.
  case_eq (is_in Beqb (f a) (map f la)); intros; simpl.
  apply IHla.
  inversion H; auto.
  rewrite plus_comm.
  apply plus_le_compat; auto.
  apply IHla.
  inversion H; auto.
 Qed.

 Lemma map_incl : forall A B (f : A -> B) l1 l2,
  incl l1 l2 -> incl (map f l1) (map f l2).
 Proof.
  red; intros.
  rewrite in_map_iff.
  rewrite in_map_iff in H0.
  destruct H0.
  exists x.
  split; [ | apply H]; tauto.
 Qed.

 Lemma NoDup_intro : forall l : _ A,
  (forall l1 x l2 l3, l = l1 ++ x :: l2 ++ x :: l3 -> False) ->
  NoDup l.
 Proof.
  induction l ; simpl.
  intros ; constructor.
  intros.
  constructor.
  intro Habs.
  destruct (In_split _ _ Habs).
  destruct H0.
  subst.
  exact (H (@nil _) _ _ _ (refl_equal _)).
  apply IHl.
  intros.
  subst.
  exact (H (_ :: _) _ _ _ (refl_equal _)).
 Qed.

 Lemma NoDup_app_recip : forall l,
  (forall l1 l2, l = l1 ++ l2 -> forall x : A, In x l1 -> In x l2 -> False) ->
  NoDup l.
 Proof.
  intros.
  apply NoDup_intro.
  intros ? ? ? ?.
  change (x :: l2 ++ x :: l3) with ((x :: l2) ++ x :: l3).
  rewrite <- app_ass.
  intros.
  subst.
  eapply H.
  reflexivity.
  apply in_or_app.
  right.
  simpl.
  left.
  reflexivity.
  auto.
  simpl; auto.
 Qed.

 Lemma NoDup_app_intro : forall (A : Type) (l1 : _ A),
  NoDup l1 ->
  forall l2, NoDup l2 ->
   (forall x, In x l1 -> In x l2 -> False) ->
   NoDup (l1 ++ l2).
 Proof.
  induction 1; subst; simpl.
  tauto.
  intros.
  constructor.
  intro.
  destruct (in_app_or _ _ _ H3).
  contradiction.
  eauto.
  eauto.
 Qed.

 Lemma fold_right_incl_eq : forall (la : list A) (lb : list B),
  NoDup la -> NoDup lb ->
  (forall a, In a la) ->
  (forall b, In b lb) ->
  length la = fold_right (fun b r => length (finv b) + r) 0 lb.
 Proof.
  intros la lb Hincl_b Hincl_a Hla_full Hlb_full.
  transitivity (length (flat_map finv lb)).
  2:clear; induction lb; simpl; auto.
  2:rewrite app_length; omega.

  apply le_antisym.
  apply length_surj; auto.
  red; intros.
  eapply in_flat_map.
  apply f_spec; trivial.
  auto.

  apply length_surj; auto.
  clear Hlb_full.
  induction lb; simpl.
  constructor.
  apply NoDup_app_intro; auto.
  apply IHlb.
  inversion Hincl_a; auto.
  intros.
  apply f_spec in H.
  subst.
  apply List.in_flat_map in H0.
  destruct H0 as [x2 [H1 H2] ].
  apply f_spec in H2.
  subst.
  inversion Hincl_a.
  subst.
  apply H2; trivial.
  red.
  auto.
 Qed.

End ListAux_f.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* ---                               main.v                             --- *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(*

  This the entry point of all the development;
  The theorem "addchains" states you can compute
  x^n in a given monoid , once you got a strategy
  (see strategies, dicho_strat, binary_strat)

*)

Require Import Constants.
Require Import generation.
Require Import monoid.
Require Import machine.
Require Import strategies.
Require Import spec.
Require Import log2_spec.
Require Import log2_implementation.
Require Import Compare_dec.

Require Import while.
Require Import imperative.
Require Import develop.
Require Import dicho_strat.
Require Import binary_strat.
Require Import trivial.
Require Import standard.
Require Import monofun.
Require Import matrix.
Require Import ZArith.

Definition code_gen (s : strategy) := chain_algo s log2_impl.
Definition power_algo_r (s : strategy) := power_algo s log2_impl.

Theorem addchains :
 forall (gamma : strategy) (n : nat) (M : Set) (MO : monoid M) (a : M),
 {b : M | b = power M MO a n}.
(*******************************************)
Proof.
 intros gamma n M MO a; elim (zerop n); intro H;
  [ exists (u M MO)
  | exists
     (config_X M
        (Exec M MO
           match power_algo gamma log2_impl n H with
           | addchain_spec_intro gc =>
               match gc with
               | gencode_intro co _ => co
               end
           end (config M a (emptystack M)))) ].
(*
Realizer [gamma:nat->nat]
          [n:nat][M:Set][MO:(monoid M)]
          [a:M]
           <M> if (zerop n) then (u M MO)
           else
             [{H:(lt O n)}](config_X M (Exec M MO
                                             (power_algo gamma log2_impl n)
                                             (config M a emptystack))).
 Program_all.
 *)
 rewrite H; auto with arith.
 elim (power_algo gamma log2_impl n H); intro g; elim g; intros co s.
 inversion_clear s.
 rewrite H0; simpl in |- *; auto with arith.
Qed.

Definition dic := dicho log2_impl.

Opaque matrix.

(*  Fibonacci comes back again! *)
(********************************)

Lemma fibonacci : forall n : nat, {q : Z | q = Z_of_nat (Fib n)}.

refine
 (fun n =>
  match zerop n with
  | left e => exist _ 1%Z _
  | right l =>
      match addchains dic n Mat2 matrix fib_mat with
      | exist m e => exist _ (M11 m) _
      end
  end).

(*
Realizer [n:nat]<nat>if (zerop n) then (S O)
                     else (M11 (addchains dic n  Mat2 matrix fib_mat )).
Program_all.
*)
rewrite e; rewrite Unfold_FibO; auto with arith.
rewrite fib_computation.
 rewrite e; auto with arith.
auto with arith.
Qed.

Transparent matrix.


(* (** Subtypes *) *)

(* Fixpoint toSubList (X: Type) (A: list X) (p: X -> Prop) (D:forall x, dec (p x))  : list (subtype p) := *)
(*   match A with *)
(*   | nil => nil *)
(*   | cons x A' => match Dec (p x) with *)
(*                 | left px => (exist  _ x (purify px)) :: toSubList A' D *)
(*                 | right _ => toSubList  A' _ end *)
(*   end. *)

(* Arguments toSubList {X} A p {D}. *)

(* Lemma toSubList_count (X: eqType) (p: X -> Prop) (A: list X) (_:forall x, dec (p x)) x: *)
(*   count (toSubList A p) x = count A (proj1_sig x). *)
(* Proof. *)
(*   induction A. *)
(*   - reflexivity. *)
(*   - cbn. decide (p a). *)
(*     + simpl. dec.  *)
(*       * congruence. *)
(*       * now rewrite <- subtype_extensionality in e. *)
(*       * change a with (proj1_sig (exist (pure p) a (purify p0)))  in e. now rewrite subtype_extensionality in e. *)
(*       * exact IHA.         *)
(*     + destruct x.  cbn. dec. *)
(*       * subst a. now impurify p0. *)
(*       * exact IHA. *)
(* Qed.  *)

(* Lemma subType_enum_ok (X:finType) (p: X -> Prop) (_: forall x, dec (p x)) x: *)
(*   count (toSubList (elem X) p) x = 1. *)
(* Proof. *)
(*   rewrite toSubList_count. apply enum_ok. *)
(* Qed. *)

(* Instance finTypeC_sub (X:finType) (p: X -> Prop) (_:forall x, dec (p x)): finTypeC (EqSubType p). *)
(* Proof. *)
(*   econstructor.  apply subType_enum_ok. *)
(* Defined. *)

(* Canonical Structure finType_sub (X: finType) (p: X -> Prop) (_: forall x, dec (p x))   := FinType (EqSubType p). *)
(* Arguments finType_sub {X} p {_}. *)

(* Lemma finType_sub_correct (X: finType) (p: X -> Prop) (_: forall x, dec (p x)) : subtype p = finType_sub p _. *)
(* Proof. *)
(* reflexivity.   *)
(* Qed. *)

(* Lemma finType_sub_enum (X: finType) (p: X -> Prop) (_: forall x, dec (p x)): *)
(*   toSubList (elem X) p= elem (finType_sub p _). *)
(* Proof. *)
(* reflexivity.   *)
(* Qed. *)
(* Set Printing Coercions. *)
(* Lemma tofinType_sub_correct (X: finType) (p: X -> Prop) (_: forall x, dec (p x)) : *)
(*   tofinType (subtype p) = finType_sub p _. *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)


Require Export ZArith.
Require Export Znumtheory.
Require Import Coq.Lists.List.
Require Import Lia.
Import ListNotations.

Class Inhabitant (A: Type) := default : A.

Instance Inhabitant_Z : Inhabitant Z := 0.
Instance Inhabitant_nat : Inhabitant nat := O.
Instance Inhabitant_positive : Inhabitant positive := 1%positive.
Instance Inhabitant_list {T: Type} : Inhabitant (list T) := @nil T.
Instance Inhabitant_fun {T1 T2: Type} {H: Inhabitant T2} : Inhabitant (T1->T2) := fun _ => H.
Instance Inhabitant_Prop : Inhabitant Prop := False.
Instance Inhabitant_bool : Inhabitant bool := false.
Instance Inhabitant_pair {T1 T2 : Type} {x1: Inhabitant T1} {x2: Inhabitant T2} : Inhabitant (T1*T2)%type := (x1,x2).

Ltac inv H := inversion H; clear H; subst.

Lemma Zlength_length:
  forall A (al: list A) (n: Z),
    0 <= n ->
    (Zlength al = n <-> length al = Z.to_nat n).
Proof.
intros. rewrite Zlength_correct.
split; intro.
rewrite <- (Z2Nat.id n) in H0 by lia.
apply Nat2Z.inj in H0; auto.
lia.
Qed.

Lemma firstn_app1: forall {A} n (p l: list A),
  (n <= Datatypes.length p)%nat ->
   firstn n (p ++ l) = firstn n p.
Proof. intros A n.
induction n; simpl; intros. trivial.
  destruct p; simpl in H. lia.
  apply le_S_n in H. simpl. f_equal. auto.
Qed.

Lemma firstn_app2: forall {A} (n: nat) (al bl: list A),
 (n >= length al)%nat ->
 firstn n (al++bl) = al ++ firstn (n - length al) bl.
Proof.
intros. revert al H.
induction n; destruct al; intros.
reflexivity.
inv H.
simpl.
destruct bl; auto.
simpl.
f_equal. apply IHn.
simpl in H; lia.
Qed.

Definition list_repeat {A} (n : nat) (x : A) :=
  repeat x n.

Lemma length_list_repeat : forall {A} (n : nat) (x : A),
  length (list_repeat n x) = n.
Proof.
  intros. apply repeat_length.
Qed.

Lemma firstn_list_repeat {A} (v:A): forall i k, (i<=k)%nat ->
      firstn i (list_repeat k v) = list_repeat i v.
Proof.
  induction i; simpl; trivial; intros.
  destruct k. lia. simpl. rewrite IHi; trivial. lia.
Qed.

Lemma firstn_app:
 forall {A} n m (al: list A), firstn n al ++ firstn m (skipn n al) =
  firstn (n+m) al.
Proof. induction n; destruct al; intros; simpl; auto.
destruct m; reflexivity.
f_equal; auto.
Qed.

Lemma nth_skipn:
  forall {A} i n data (d:A),
       nth i (skipn n data) d = nth (i+n) data d.
Proof.
intros.
revert i data; induction n; simpl; intros.
f_equal; lia.
destruct data; auto.
destruct i; simpl; auto.
rewrite IHn.
replace (i + S n)%nat with (S (i + n))%nat by lia; auto.
Qed.

Lemma skipn_skipn: forall {A} n m (xs: list A),
  skipn n (skipn m xs) = skipn (m + n) xs.
Proof.
  intros.
  revert xs; induction m; intros.
  + reflexivity.
  + simpl.
    destruct xs.
    - destruct n; reflexivity.
    - apply IHm.
Qed.

Lemma firstn_exact_length: forall {A} (xs: list A), firstn (length xs) xs = xs.
Proof.
  intros.
  induction xs.
  + reflexivity.
  + simpl.
    rewrite IHxs.
    reflexivity.
Qed.

Lemma skipn_exact_length: forall {A} (xs: list A), skipn (length xs) xs = nil.
Proof.
  intros.
  induction xs.
  + reflexivity.
  + simpl.
    rewrite IHxs.
    reflexivity.
Qed.

Lemma len_le_1_rev: forall {A} (contents: list A),
  (length contents <= 1)%nat ->
  contents = rev contents.
Proof.
  intros.
  destruct contents.
  + reflexivity.
  + destruct contents.
    - reflexivity.
    - simpl in H. lia.
Qed.

Lemma firstn_firstn: forall {A} (contents: list A) n m,
  (n <= m)%nat ->
  firstn n (firstn m contents) = firstn n contents.
Proof.
  intros.
  revert n m H;
  induction contents;
  intros.
  + destruct n, m; reflexivity.
  + destruct n, m; try solve [lia].
    - simpl; reflexivity.
    - simpl; reflexivity.
    - simpl.
      rewrite IHcontents by lia.
      reflexivity.
Qed.

Lemma firstn_1_skipn: forall {A} n (ct: list A) d,
  (n < length ct)%nat ->
  nth n ct d :: nil = firstn 1 (skipn n ct).
Proof.
  intros.
  revert ct H; induction n; intros; destruct ct.
  + simpl in H; lia.
  + simpl. reflexivity.
  + simpl in H; lia.
  + simpl in H |- *.
    rewrite IHn by lia.
    reflexivity.
Qed.

Lemma skipn_length: forall {A} (contents: list A) n,
  length (skipn n contents) = (length contents - n)%nat.
Proof.
  intros.
  revert n;
  induction contents;
  intros.
  + destruct n; reflexivity.
  + destruct n; simpl.
    - reflexivity.
    - apply IHcontents.
Qed.

Lemma nth_firstn: forall {A} (contents: list A) n m d,
  (n < m)%nat ->
  nth n (firstn m contents) d = nth n contents d.
Proof.
  intros.
  revert n m H;
  induction contents;
  intros.
  + destruct n, m; reflexivity.
  + destruct n, m; try lia.
    - simpl. reflexivity.
    - simpl. apply IHcontents. lia.
Qed.

Lemma skipn_length_short:
  forall {A} n (al: list A),
    (length al <= n)%nat ->
    (length (skipn n al) = 0)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 lia.
 apply IHn. lia.
Qed.

Lemma skipn_short:
   forall {A} n (al: list A), (n >= length al)%nat -> skipn n al = nil.
Proof.
intros.
pose proof (skipn_length_short n al).
assert (length al <= n)%nat by auto.
specialize (H0 H1).
destruct (skipn n al); inv H0; auto.
Qed.

Lemma nth_map':
  forall {A B} (f: A -> B) d d' i al,
  (i < length al)%nat ->
   nth i (map f al) d = f (nth i al d').
Proof.
induction i; destruct al; simpl; intros; try lia; auto.
apply IHi; lia.
Qed.

Lemma skipn_nil: forall A n, skipn n (@nil A) = nil.
Proof. induction n; simpl; auto.
Qed.

Lemma skipn_drop:
 forall A n m (al: list A), skipn n (skipn m al) = skipn (n+m) al.
Proof.
induction m; intros.
* simpl; auto. f_equal; lia.
* replace (n + S m)%nat with (S (n + m))%nat by lia.
  destruct al; [ rewrite skipn_nil; auto | ].
  unfold skipn at 3; fold skipn.
 rewrite <- IHm.
 f_equal.
Qed.

Lemma skipn_app1:
 forall A n (al bl: list A),
  (n <= length al)%nat ->
  skipn n (al++bl) = skipn n al ++ bl.
Proof.
intros. revert al H;
induction n; destruct al; intros; simpl in *; try lia; auto.
apply IHn; lia.
Qed.

Lemma skipn_app2:
 forall A n (al bl: list A),
  (n >= length al)%nat ->
  skipn n (al++bl) = skipn (n-length al) bl.
Proof.
intros. revert al H;
induction n; destruct al; intros; simpl in *; try lia; auto.
apply IHn; lia.
Qed.

Lemma list_repeat_app: forall A a b (x:A),
  list_repeat a x ++ list_repeat b x = list_repeat (a+b) x.
Proof.
intros; induction a; simpl; f_equal.
auto.
Qed.

Lemma firstn_same:
  forall A n (b: list A), (n >= length b)%nat -> firstn n b = b.
Proof.
induction n; destruct b; simpl; intros; auto.
inv H.
f_equal; auto.
apply IHn.
lia.
Qed.

Lemma nth_firstn_low:
 forall A i n al (d: A),
  (i < n <= length al)%nat -> nth i (firstn n al) d = nth i al d.
Proof.
intros.
revert n al H; induction i; destruct n,al; simpl; intros; auto; try lia.
apply IHi; lia.
Qed.

Lemma nth_error_nth:
  forall A (d: A) i al, (i < length al)%nat -> nth_error al i = Some (nth i al d).
Proof.
induction i; destruct al; simpl; intros; auto.
inv H.
inv H.
apply IHi; lia.
Qed.

Lemma skipn_rev:
  forall {A} n (vl: list A),
   skipn n (rev vl) = rev (firstn (length vl - n) vl).
Proof.
induction n; intros.
simpl. rewrite Nat.sub_0_r. rewrite firstn_exact_length. auto.
destruct (rev vl) eqn:?.
pose proof (rev_length vl). rewrite Heql in H.
destruct vl; inv H. reflexivity.
simpl.
assert (vl = rev l ++ rev [a]).
rewrite <- rev_app_distr. simpl app. rewrite <- Heql; rewrite rev_involutive; auto.
rewrite H.
rewrite app_length.
simpl length.
rewrite <- (rev_involutive l) at 1.
rewrite IHn.
replace (length (rev l) + 1 - S n)%nat with (length (rev l) -n)%nat by lia.
f_equal.
rewrite firstn_app1 by lia.
reflexivity.
Qed.

(* Module X.
Fixpoint list_repeat {A: Type} (n: nat) (x: A) {struct n} :=
  match n with
  | O => nil
  | S m => x :: list_repeat m x
  end. *)

Lemma Forall_list_repeat:
  forall {A} (P: A -> Prop) (n: nat) (a: A),
    P a -> Forall P (list_repeat n a).
Proof.
induction n; intros.
constructor.
unfold list_repeat in *; constructor; auto.
Qed.

Lemma skipn_firstn: forall {A} n m (xs: list A),
  skipn n (firstn m xs) = firstn (m-n) (skipn n xs).
Proof.
intros.
revert xs n; induction m; intros.
simpl. destruct n; reflexivity.
destruct xs; simpl.
rewrite skipn_nil.
destruct match n with
            | O => S m
            | S l => (m - l)%nat
            end; reflexivity.
destruct n.
simpl. reflexivity.
simpl.
apply IHm.
Qed.

Lemma rev_skipn:
 forall {A} n (vl: list A),
  rev (skipn n vl) = firstn (length vl -n) (rev vl).
Proof.
induction n; intros.
simpl. rewrite Nat.sub_0_r.
rewrite <- rev_length.
rewrite firstn_exact_length.
auto.
destruct vl.
simpl. auto.
simpl.
rewrite IHn.
rewrite firstn_app1 by (rewrite rev_length; lia).
auto.
Qed.

Lemma firstn_skipn_rev:
  forall {A} lo n (vl: list A),
  (n+lo <= length vl)%nat ->
  firstn n (skipn lo (rev vl)) =
  rev (firstn n (skipn (length vl - (lo+n))%nat vl)).
Proof.
intros.
rewrite skipn_rev.
assert (n = (length vl - lo) - (length vl - (lo+n)))%nat by lia.
rewrite H0 at 2.
rewrite <- skipn_firstn.
rewrite rev_skipn.
rewrite firstn_length. rewrite min_l by lia.
f_equal.
auto.
Qed.

Lemma map_firstn:
  forall A B (F: A -> B) n (al: list A),
  map F (firstn n al) = firstn n (map F al).
Proof.
induction n; destruct al; simpl; intros; auto.
f_equal; auto.
Qed.

Lemma map_skipn:
  forall A B (F: A -> B) n (al: list A),
  map F (skipn n al) = skipn n (map F al).
Proof.
induction n; destruct al; simpl; intros; auto.
Qed.

Lemma Zlength_app: forall T (al bl: list T),
    Zlength (al++bl) = Zlength al + Zlength bl.
Proof. induction al; intros. simpl app; rewrite Zlength_nil; lia.
 simpl app; repeat rewrite Zlength_cons; rewrite IHal; lia.
Qed.

Lemma Zlength_rev: forall T (vl: list T), Zlength (rev vl) = Zlength vl.
Proof. induction vl; simpl; auto. rewrite Zlength_cons. rewrite <- IHvl.
rewrite Zlength_app. rewrite Zlength_cons. rewrite Zlength_nil; lia.
Qed.

Lemma Zlength_map: forall A B (f: A -> B) l, Zlength (map f l) = Zlength l.
Proof. induction l; simpl; auto. repeat rewrite Zlength_cons. f_equal; auto.
Qed.

Lemma ZtoNat_Zlength:
 forall {A} (l: list A), Z.to_nat (Zlength l) = length l.
Proof.
intros. rewrite Zlength_correct. apply Nat2Z.id.
Qed.
Hint Rewrite @ZtoNat_Zlength : norm.

Lemma Zlength_nonneg:
 forall {A} (l: list A), 0 <= Zlength l.
Proof.
intros. rewrite Zlength_correct. lia.
Qed.

Definition Zlength' := @Zlength.

Ltac pose_Zlength_nonneg1 T A :=
     lazymatch goal with
      | H:  0 <= @Zlength T A |- _ => idtac
      | H:  0 <= @Zlength T A /\ _ |- _ => idtac
      | |- _ => pose proof (@Zlength_nonneg T A)
     end;
     (* the next three lines are to avoid blowups in the change command *)
     let x := fresh "x" in set (x:= @Zlength T A) in *;
     let y := fresh "y" in set (y := @Zlength) in x;
     fold @Zlength' in y; subst y; subst x.

Ltac pose_Zlength_nonneg :=
 repeat
  match goal with
  | |- context [@Zlength ?T ?A] => pose_Zlength_nonneg1 T A
  | H: context [@Zlength ?T ?A] |- _ => pose_Zlength_nonneg1 T A
 end;
  unfold Zlength' in *.

Ltac old_list_solve := autorewrite with sublist; pose_Zlength_nonneg; lia.

Definition zlt := Z_lt_ge_dec.

Definition Znth {X}{d: Inhabitant X} n (xs: list X) :=
  if (zlt n 0) then default else nth (Z.to_nat n) xs d.

(* Begin: copied from msl/Coqlib2.v *)

Lemma if_true: forall (A: Prop) (E: {A}+{~A}) (T: Type) (B C: T), A -> (if E then B else C) = B.
Proof.
intros.
destruct E; auto.
contradiction.
Qed.

Lemma if_false: forall (A: Prop) (E: {A}+{~A}) (T: Type) (B C: T), ~A -> (if E then B else C) = C.
Proof.
intros.
destruct E; auto.
contradiction.
Qed.

Tactic Notation "if_tac" :=
  match goal with |- context [if ?a then _ else _] =>
    lazymatch type of a with
    | sumbool _ _ =>destruct a as [?H | ?H]
    | bool => fail "Use simple_if_tac instead of if_tac, since your expression"a" has type bool"
    | ?t => fail "Use if_tac only for sumbool; your expression"a" has type" t
   end end.

Tactic Notation "if_tac" "in" hyp(H0)
 := match type of H0 with context [if ?a then _ else _] =>
    lazymatch type of a with
    | sumbool _ _ =>destruct a as [?H | ?H]
    | bool => fail "Use simple_if_tac instead of if_tac, since your expression"a" has type bool"
    | ?t => fail "Use if_tac only for sumbool; your expression"a" has type" t
   end end.

Tactic Notation "forget" constr(X) "as" ident(y) :=
   set (y:=X) in *; clearbody y.

(* End: copied from msl/Coqlib2.v *)

Lemma Znth_map:
  forall {A:Type} {da: Inhabitant A}{B:Type}{db: Inhabitant B} i (f: A -> B) (al: list A),
  0 <= i < Zlength al ->
  Znth i (map f al)  = f (Znth i al).
Proof.
unfold Znth.
intros.
rewrite if_false by lia.
rewrite if_false by lia.
rewrite nth_map' with (d' := da); auto.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by lia.
change (Inhabitant A) with A.
rewrite <- Zlength_correct. lia.
Qed.

Hint Rewrite
   (@Znth_map Z _) (@Znth_map nat _) (@Znth_map positive _)
    using (auto; rewrite ?Zlength_map in *; lia) : sublist.

(* Add these in a later file where things are in scope ...
Hint Rewrite (Znth_map Int.zero) (Znth_map Vundef)
    using (auto; rewrite ?Zlength_map in *; lia) : sublist.
*)

Lemma Znth_succ: forall {A}{a: Inhabitant A} i lo (v: list A), Z.succ lo <= i -> Znth (i - lo) v = Znth (i - (Z.succ lo)) (skipn 1 v).
Proof.
  intros.
  unfold Znth.
  if_tac; [lia |].
  if_tac; [lia |].
  rewrite nth_skipn.
  f_equal.
  change 1%nat with (Z.to_nat 1).
  rewrite <- Z2Nat.inj_add by lia.
  f_equal.
  lia.
Qed.

Lemma Znth_0_cons {A}{a: Inhabitant A} l (v:A): Znth 0 (v::l) = v.
Proof. reflexivity. Qed.
Hint Rewrite @Znth_0_cons : sublist.

Lemma Znth_pos_cons {A}{a: Inhabitant A} i l (v:A): 0<i -> Znth i (v::l) = Znth (i-1) l.
Proof. intros. unfold Znth. if_tac. lia. if_tac. lia.
  assert (Z.to_nat i = S (Z.to_nat (i-1))).
    rewrite <- Z2Nat.inj_succ. assert (i = Z.succ (i - 1)). lia. rewrite <- H2. trivial. lia.
  rewrite H2; reflexivity.
Qed.

Lemma Znth_In : forall {A}{a: Inhabitant A} i l, 0 <= i < Zlength l -> In (Znth i l) l.
Proof.
  intros; unfold Znth.
  destruct (zlt i 0); [lia|].
  apply nth_In; rewrite Zlength_correct in *.
  apply Nat2Z.inj_lt; rewrite Z2Nat.id; lia.
Qed.

Lemma split3_full_length_list: forall {A}{a: Inhabitant A} lo mid hi (ct: list A),
  lo <= mid < hi ->
  Zlength ct = hi - lo ->
  ct = firstn (Z.to_nat (mid - lo)) ct ++
       (Znth (mid - lo) ct :: nil) ++
       skipn (Z.to_nat (mid - lo + 1)) ct.
Proof.
  intros.
  rewrite <- firstn_skipn with (l := ct) (n := Z.to_nat (mid - lo)) at 1.
  f_equal.
  rewrite Z2Nat.inj_add by lia.
  rewrite <- skipn_skipn.
  replace (Znth (mid - lo) ct :: nil) with (firstn (Z.to_nat 1) (skipn (Z.to_nat (mid - lo)) ct)).
  + rewrite firstn_skipn; reflexivity.
  + unfold Znth.
    if_tac; [lia |].
    rewrite firstn_1_skipn; [reflexivity |].
    rewrite <- (Nat2Z.id (length ct)).
    apply Z2Nat.inj_lt.
    - lia.
    - lia.
    - rewrite Zlength_correct in H0.
      lia.
Qed.

Lemma Forall_Znth:
 forall {A}{a: Inhabitant A} (F: A -> Prop) (al: list A) i,
   0 <= i < Zlength al ->
   Forall F al ->
   F (Znth i al).
Proof.
intros.
unfold Znth. rewrite if_false by lia.
rewrite Zlength_correct in H.
assert (Z.to_nat i < length al)%nat.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by lia; lia.
clear H.
revert al H0 H1; induction (Z.to_nat i); destruct al; intros; simpl in *.
lia.
inv H0. auto.
inv H1.
inv H0.
apply IHn; auto.
lia.
Qed.

Hint Rewrite @app_nil_l @app_nil_r : sublist.

Lemma app_Znth1:
  forall A (a: Inhabitant A) (l l': list A) (i:Z),
  i < Zlength l -> Znth i (l++l') = Znth i l.
Proof.
intros.
unfold Znth.
if_tac; auto.
apply app_nth1.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by lia.
rewrite Zlength_correct in H; auto.
Qed.

Lemma app_Znth2:
  forall A (a: Inhabitant A) (l l': list A) (i:Z),
  i >= Zlength l -> Znth i (l++l') = Znth (i-Zlength l) l'.
Proof.
intros.
unfold Znth.
pose proof (Zlength_nonneg l).
if_tac.
rewrite if_true by lia; auto.
rewrite if_false by lia.
rewrite app_nth2.
f_equal.
rewrite Z2Nat.inj_sub by auto.
rewrite Zlength_correct.
rewrite Nat2Z.id; auto.
apply Nat2Z.inj_ge. rewrite Z2Nat.id by lia.
rewrite <- Zlength_correct; auto.
Qed.

Lemma Znth_firstn:
  forall {A}{a: Inhabitant A} (al: list A) (n m : Z),
  n<m -> Znth n (firstn (Z.to_nat m) al) = Znth n al.
Proof.
intros.
unfold Znth.
if_tac; auto.
apply nth_firstn.
apply Z2Nat.inj_lt; lia.
Qed.

Lemma Znth_skipn: forall {A}{a: Inhabitant A}  i n xs,
  0 <= i ->
  0 <= n ->
  Znth i (skipn (Z.to_nat n) xs) = Znth (i+n) xs.
Proof.
  intros.
  unfold Znth.
  rewrite if_false by lia. rewrite if_false by lia.
  rewrite nth_skipn. f_equal.
  rewrite Z2Nat.inj_add by lia. auto.
Qed.

Lemma Z2Nat_neg: forall i, i < 0 -> Z.to_nat i = 0%nat.
Proof.
  intros.
  destruct i; try reflexivity.
  pose proof Zgt_pos_0 p; lia.
Qed.

Lemma Zmin_spec:
  forall x y, Z.min x y = if Z_lt_dec x y then x else y.
Proof.
  intros. destruct (Zmin_spec x y); destruct H as [H H0]; rewrite H0; clear H0; destruct (Z_lt_dec x y); lia.
Qed.

Lemma Zmax_spec:
  forall x y, Z.max x y = if Z_lt_dec y x then x else y.
Proof.
  intros. destruct (Zmax_spec x y); destruct H as [H H0]; rewrite H0; clear H0; destruct (Z_lt_dec y x); lia.
Qed.

Lemma Zlength_firstn:
  forall {A} n (v: list A), Zlength (firstn (Z.to_nat n) v) = Z.min (Z.max 0 n) (Zlength v).
Proof.
intros. rewrite !Zlength_correct.
rewrite firstn_length.
(* solve by SMT *)
  rewrite Zmin_spec, Zmax_spec.
if_tac; [rewrite min_l | rewrite min_r].
if_tac.
rewrite Z2Nat_neg; auto.
apply Z2Nat.id; lia.
if_tac in H.
rewrite Z2Nat_neg; auto. lia.
rewrite <- (Nat2Z.id (length v)).
apply Z2Nat.inj_le; try lia.
auto.
if_tac in H; lia.
Qed.

Lemma Zlength_skipn:
  forall {A} n (v: list A),
  Zlength (skipn (Z.to_nat n) v) = Z.max 0 (Zlength v - (Z.max 0n)).
Proof.
intros.
(* solve by SMT *)
rewrite !Zlength_correct.
rewrite skipn_length. rewrite !Zmax_spec.
if_tac.
if_tac in H.
lia.
apply inj_minus2. apply Nat2Z.inj_gt. rewrite Z2Nat.id by lia.
lia.
if_tac.
rewrite (Z2Nat_neg n) by lia.
rewrite Nat.sub_0_r.
lia.
rewrite Nat2Z.inj_sub.
rewrite Z2Nat.id by lia. auto.
apply Nat2Z.inj_le.
rewrite Z2Nat.id by lia.  lia.
Qed.

Lemma Znth_cons:
 forall {A}(a: Inhabitant A)  i (al: list A) bl,
  0 <= i < Zlength al  ->
  Znth i al :: bl = firstn (Z.to_nat 1) (skipn (Z.to_nat i) al) ++ bl.
Proof.
intros.
pose proof (Znth_skipn 0 i al).
rewrite Z.add_0_l in H0.
rewrite <- H0 by lia; clear H0.
change (Znth 0 (skipn (Z.to_nat i) al) :: bl) with
   ([Znth 0 (skipn (Z.to_nat i) al)] ++ bl).
f_equal.
unfold Znth.
rewrite if_false  by lia.
assert (Zlength (skipn (Z.to_nat i) al) > 0).
rewrite Zlength_skipn.
rewrite (Z.max_r 0 i) by lia.
rewrite Z.max_r by lia.
lia.
destruct (skipn (Z.to_nat i) al).
rewrite Zlength_nil in H0; lia.
reflexivity.
Qed.

Lemma Zfirstn_app1:
 forall A n (al bl: list A),
  n <= Zlength al -> firstn (Z.to_nat n) (al++bl) = firstn (Z.to_nat n) al.
Proof.
intros.
apply firstn_app1.
apply Nat2Z.inj_le. rewrite Zlength_correct in H.
destruct (Z_lt_dec n 0).
rewrite Z2Nat_neg by auto. change (Z.of_nat 0) with 0; lia.
rewrite Z2Nat.id by lia.
lia.
Qed.

Lemma Zfirstn_same:
  forall A n (b: list A), n >= Zlength b -> firstn (Z.to_nat n) b = b.
Proof.
intros.
apply firstn_same.
rewrite Zlength_correct in H.
apply Nat2Z.inj_ge.
rewrite Z2Nat.id by lia.
auto.
Qed.

Lemma Zfirstn_app2: forall {A} n (al bl: list A),
 n >= Zlength al ->
 firstn (Z.to_nat n) (al++bl) = al ++ firstn (Z.to_nat (n - Zlength al)) bl.
Proof.
intros.
rewrite firstn_app2.
f_equal. f_equal.
rewrite Z2Nat.inj_sub.
rewrite Zlength_correct, Nat2Z.id. auto.
apply Zlength_nonneg.
apply Nat2Z.inj_ge.
rewrite Zlength_correct in H.
rewrite Z2Nat.id by lia.
auto.
Qed.

Lemma Zfirstn_firstn: forall {A} (contents: list A) n m,
  n <= m ->
  firstn (Z.to_nat n) (firstn (Z.to_nat m) contents) = firstn (Z.to_nat n) contents.
Proof.
intros.
destruct (Z_lt_dec n 0).
rewrite (Z2Nat_neg n) by lia.
reflexivity.
apply firstn_firstn.
apply Z2Nat.inj_le; lia.
Qed.
Lemma Zskipn_app1:
 forall A n (al bl: list A),
  n <= Zlength al ->
  skipn (Z.to_nat n) (al++bl) = skipn (Z.to_nat n) al ++ bl.
Proof.
intros.
apply skipn_app1.
rewrite Zlength_correct in H.
apply Nat2Z.inj_le.
destruct (Z_lt_dec n 0).
rewrite (Z2Nat_neg n) by lia.
change (Z.of_nat 0) with 0.  lia.
rewrite Z2Nat.id by lia.
auto.
Qed.

Lemma Zskipn_app2:
 forall A n (al bl: list A),
  n >= Zlength al ->
  skipn (Z.to_nat n) (al++bl) = skipn (Z.to_nat (n-Zlength al)) bl.
Proof.
intros.
rewrite Zlength_correct in *.
rewrite skipn_app2.
f_equal.
rewrite Z2Nat.inj_sub by lia.
rewrite Nat2Z.id.
auto.
apply Nat2Z.inj_ge.
destruct (Z_lt_dec n 0).
rewrite (Z2Nat_neg n) by lia.
change (Z.of_nat 0) with 0.  lia.
rewrite Z2Nat.id by lia.
auto.
Qed.

Lemma Znth_rev:
  forall {A}{d: Inhabitant A} i (al:list A),
  0 <= i < Zlength al ->
  Znth i (rev al) = Znth (Zlength al - i - 1) al.
Proof.
intros.
 unfold Znth. rewrite !if_false by lia.
rewrite !Z2Nat.inj_sub by lia.
rewrite Zlength_correct in*.
rewrite Nat2Z.id.
assert (Z.to_nat i < length al)%nat.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by lia. lia.
change (Z.to_nat 1) with 1%nat.
clear H.
rewrite rev_nth; auto.
f_equal.
lia.
Qed.

Lemma Zskipn_firstn: forall {A} n m (xs: list A),
 0 <= n ->
 skipn (Z.to_nat n) (firstn (Z.to_nat m) xs) =
  firstn (Z.to_nat (m-n)) (skipn (Z.to_nat n) xs).
Proof.
intros.
rewrite skipn_firstn.
f_equal.
rewrite Z2Nat.inj_sub; auto.
Qed.

Lemma Zskipn_skipn: forall {A} n m (xs: list A),
  0 <= n -> 0 <= m ->
  skipn (Z.to_nat n) (skipn (Z.to_nat m) xs) = skipn (Z.to_nat (m + n)) xs.
Proof.
  intros.
  rewrite skipn_skipn.
 f_equal.
 rewrite Z2Nat.inj_add; auto.
Qed.

Lemma Zfirstn_app:
 forall {A} n m (al: list A),
  0 <= n -> 0 <= m ->
  firstn (Z.to_nat n) al ++ firstn (Z.to_nat m) (skipn (Z.to_nat n) al) =
  firstn (Z.to_nat (n+m)) al.
Proof.
intros.
rewrite firstn_app.
f_equal.
rewrite Z2Nat.inj_add; lia.
Qed.

Lemma Zfirstn_exact_length:
  forall {A} n (al: list A),
  n = Zlength al ->
  firstn (Z.to_nat n) al = al.
Proof.
intros.
subst.
rewrite Zlength_correct.
rewrite Nat2Z.id.
apply firstn_exact_length.
Qed.

(*****   SUBLIST  ******)

Definition sublist {A} (lo hi: Z) (al: list A) : list A :=
  skipn (Z.to_nat lo) (firstn (Z.to_nat hi) al).

Definition old_sublist {A} (lo hi: Z) (al: list A) : list A :=
  firstn (Z.to_nat (hi-lo)) (skipn (Z.to_nat lo) al).

Lemma sublist_old_sublist {A} (lo hi : Z) (al : list A) :
  0 <= lo ->
  sublist lo hi al = old_sublist lo hi al.
Proof.
  intros.
  unfold sublist, old_sublist.
  rewrite Z2Nat.inj_sub; auto.
  apply skipn_firstn_comm.
Qed.

Ltac unfold_sublist_old :=
  rewrite !sublist_old_sublist by lia; unfold old_sublist.

Definition upd_Znth {A} (i : Z) (al : list A) (x : A) : list A :=
  if Sumbool.sumbool_and _ _ _ _ (Z_le_gt_dec 0 i) (Z_lt_dec i (Zlength al)) then
    sublist 0 i al ++ x :: sublist (i+1) (Zlength al) al
  else
    al.

Definition old_upd_Znth {A} (i: Z) (al: list A) (x: A): list A :=
  sublist 0 i al ++ x :: sublist (i+1) (Zlength al) al.

Lemma upd_Znth_old_upd_Znth {A} (i : Z) (al : list A) (x : A) :
  0 <= i < Zlength al ->
  upd_Znth i al x = old_upd_Znth i al x.
Proof.
  intros.
  unfold upd_Znth, old_upd_Znth.
  if_tac; auto; lia.
Qed.

Ltac unfold_upd_Znth_old :=
  rewrite !upd_Znth_old_upd_Znth by (
    repeat rewrite Zlength_app;
    repeat rewrite Zlength_cons;
    pose_Zlength_nonneg;
    lia
  ); unfold old_upd_Znth.

Lemma upd_Znth_out_of_range : forall {A} i l (x : A),
  0 > i \/ i >= Zlength l ->
  upd_Znth i l x = l.
Proof.
  intros.
  unfold upd_Znth. if_tac; try lia.
  auto.
Qed.

Lemma sublist_sublist {A} i j k m (l:list A): 0<=m -> 0<=k <=i -> i <= j-m ->
  sublist k i (sublist m j l) = sublist (k+m) (i+m) l.
Proof.
  intros. unfold_sublist_old.
  rewrite skipn_firstn.
  rewrite firstn_firstn, skipn_skipn, <- Z2Nat.inj_add,(Z.add_comm _ k), Zminus_plus_simpl_r; trivial.
  lia.
  rewrite <- Z2Nat.inj_sub; trivial. apply Z2Nat.inj_le; try lia. lia.
Qed.

Lemma sublist_sublist' : forall {A} lo hi lo' hi' (al: list A),
  0 <= lo <= hi ->
  hi <= hi'-lo' ->
  0 <= lo' <= hi' ->
  hi' <= Zlength al ->
  sublist lo hi (sublist lo' hi' al) = sublist (lo+lo') (hi+lo') al.
Proof.
  intros.
  unfold_sublist_old.
  rewrite Zskipn_firstn by lia.
  rewrite Zfirstn_firstn by lia.
  rewrite Zskipn_skipn by lia.
  f_equal. f_equal. lia.
  f_equal. f_equal. lia.
Qed.

Lemma sublist_rejoin:
  forall {A} lo mid hi (al: list A),
  0 <= lo <= mid ->
  mid <= hi <= Zlength al ->
  sublist lo mid al ++ sublist mid hi al = sublist lo hi al.
Proof.
intros.
unfold_sublist_old.
replace (hi-lo) with ((mid-lo)+(hi-mid)) by lia.
rewrite <- Zfirstn_app by lia.
f_equal.
rewrite Zskipn_skipn by lia.
f_equal. f_equal. f_equal. lia.
Qed.

Lemma sublist_map:
  forall {A B} (F: A -> B) lo hi (al: list A),
  sublist lo hi (map F al) = map F (sublist lo hi al).
Proof.
intros.
unfold sublist.
rewrite map_skipn, map_firstn; auto.
Qed.

Lemma map_sublist:
  forall {A B} (F: A -> B) lo hi (al: list A),
  map F (sublist lo hi al) = sublist lo hi (map F al).
Proof.
intros.
symmetry. apply sublist_map.
Qed.

Lemma sublist_len_1:
  forall {A}{d: Inhabitant A} i (al: list A),
  0 <= i < Zlength al ->
  sublist i (i+1) al = Znth i al :: nil.
Proof.
  intros.
  unfold_sublist_old.
  replace (i+1-i) with 1 by lia.
  rewrite Znth_cons by lia.
  symmetry; apply app_nil_r.
Qed.

Lemma Znth_cons_sublist:
  forall {A}{d: Inhabitant A} i (al: list A) bl,
  0 <= i < Zlength al ->
  Znth i al :: bl = sublist i (i+1) al ++ bl.
Proof.
  intros.
  erewrite sublist_len_1 by eauto.
  reflexivity.
Qed.

Lemma Zlength_sublist:
  forall {A} lo hi (al: list A),
 0 <= lo <= hi -> hi <= Zlength al ->
 Zlength (sublist lo hi al) = hi-lo.
Proof.
intros.
unfold_sublist_old.
rewrite Zlength_firstn, Z.max_r by lia.
rewrite Zlength_skipn.
rewrite (Z.max_r 0 lo) by lia.
rewrite Z.max_r by lia.
rewrite Z.min_l by lia.
auto.
Qed.

Lemma sublist_same_gen:
forall {A} lo hi (al: list A),
  lo = 0 -> hi >= Zlength al ->
  sublist lo hi al = al.
Proof.
intros.
unfold_sublist_old; subst.
rewrite Z.sub_0_r.
simpl; rewrite firstn_all2; auto.
apply Nat2Z.inj_le.
pose proof (Zlength_nonneg al).
rewrite Z2Nat.id, <- Zlength_correct; lia.
Qed.

Lemma sublist_same:
forall {A} lo hi (al: list A),
  lo = 0 -> hi = Zlength al ->
  sublist lo hi al = al.
Proof.
intros; apply sublist_same_gen; lia.
Qed.

Lemma Znth_sublist:
  forall {A}{d: Inhabitant A} lo i hi (al: list A),
 0 <= lo ->
 0 <= i < hi-lo ->
 Znth i (sublist lo hi al) = Znth (i+lo) al.
Proof.
intros.
unfold_sublist_old.
rewrite Znth_firstn by lia.
rewrite Znth_skipn by lia. auto.
Qed.

Lemma rev_sublist:
  forall {A} lo hi (al: list A),
  0 <= lo <= hi -> hi <= Zlength al ->
  rev (sublist lo hi al) = sublist (Zlength al - hi) (Zlength al - lo) (rev al).
Proof.
intros.
unfold_sublist_old.
replace (skipn (Z.to_nat lo) al)
 with (skipn (length al - (Z.to_nat (Zlength al - hi) + (Z.to_nat (hi - lo)))) al).
rewrite <- firstn_skipn_rev.
f_equal.
f_equal. lia.
apply Nat2Z.inj_le.
rewrite Nat2Z.inj_add.
rewrite <- Zlength_correct.
rewrite !Z2Nat.id by lia.
lia.
f_equal.
apply Nat2Z.inj.
rewrite Nat2Z.inj_sub.
rewrite Nat2Z.inj_add.
rewrite !Z2Nat.id by lia.
rewrite <- Zlength_correct; lia.
apply Nat2Z.inj_le.
rewrite <- Zlength_correct.
rewrite Nat2Z.inj_add.
rewrite !Z2Nat.id by lia.
lia.
Qed.

Lemma sublist_nil:
  forall {A} lo (al: list A),
  sublist lo lo al = nil.
Proof.
intros.
unfold sublist.
rewrite skipn_firstn_comm.
rewrite Nat.sub_diag. reflexivity.
Qed.

Lemma Z_to_nat_monotone : forall n m,
  n <= m ->
  (Z.to_nat n <= Z.to_nat m)%nat.
Proof.
  intros.
  destruct n; destruct m; unfold Z.le in H; simpl in *; try lia.
  contradiction.
  apply Pos2Nat.inj_le. auto.
  contradiction.
Qed.

Lemma sublist_nil_gen : forall {A} (l : list A) i j, j <= i -> sublist i j l = [].
Proof.
  intros.
  unfold sublist.
  rewrite skipn_firstn_comm.
  assert (Z.to_nat j <= Z.to_nat i)%nat. apply Z_to_nat_monotone. auto.
  replace (Z.to_nat j - Z.to_nat i)%nat with O; auto.
  rewrite (proj2 (Nat.sub_0_le _ _)); auto.
Qed.

Lemma sublist_rev:
  forall {A} lo hi (al: list A),
  0 <= lo <= hi -> hi <= Zlength al ->
  sublist lo hi (rev al) = rev (sublist (Zlength al - hi) (Zlength al - lo) al).
Proof.
intros.
rewrite rev_sublist by lia.
f_equal; lia.
Qed.

Ltac pose_Zmin_irreducible :=
  match goal with
  | |- context [Z.min ?a ?b] =>
    pose proof (Zmin_irreducible a b)
  end.

Lemma sublist_app:
  forall {A} lo hi (al bl: list A),
  0 <= lo <= hi -> hi <= Zlength al + Zlength bl ->
  sublist lo hi (al++bl) =
  sublist (Z.min lo (Zlength al)) (Z.min hi (Zlength al)) al ++
  sublist (Z.max (lo-Zlength al) 0) (Z.max (hi-Zlength al) 0) bl.
Proof.
intros.
rewrite sublist_old_sublist by lia.
rewrite sublist_old_sublist by (pose_Zmin_irreducible; pose proof (Zlength_nonneg al); lia).
rewrite sublist_old_sublist by (apply Z.le_max_r).
unfold old_sublist.
destruct (Z_lt_dec hi (Zlength al)).
rewrite (Z.min_l hi (Zlength al)) by lia.
rewrite (Z.min_l lo (Zlength al)) by lia.
rewrite (Z.max_r (hi-Zlength al) 0) by lia.
rewrite (Z.max_r (lo-Zlength al) 0) by lia.
simpl firstn.
rewrite <- app_nil_end.
rewrite Zskipn_app1 by lia.
rewrite Zfirstn_app1
 by (rewrite Zlength_skipn, !Z.max_r; try lia;
      rewrite Z.max_r; lia).
auto.
rewrite (Z.min_r hi (Zlength al)) by lia.
rewrite (Z.max_l (hi-Zlength al) 0) by lia.
destruct (Z_lt_dec lo (Zlength al)).
rewrite (Z.min_l lo (Zlength al)) by lia.
rewrite (Z.max_r (lo-Zlength al) 0) by lia.
rewrite Zskipn_app1 by lia.
rewrite Zfirstn_app2
 by (rewrite Zlength_skipn, !Z.max_r; try lia;
      rewrite Z.max_r; lia).
rewrite Zlength_skipn, !Z.max_r; try lia;
      rewrite ?Z.max_r; try lia.
simpl skipn.
f_equal.

rewrite Zfirstn_exact_length; auto.
rewrite Zlength_skipn, !Z.max_r; try lia.
f_equal.
f_equal.
lia.
rewrite (Z.min_r lo (Zlength al)) by lia.
rewrite (Z.max_l (lo-Zlength al) 0) by lia.
rewrite Zskipn_app2 by lia.
rewrite Z.sub_diag.
simpl app.
f_equal.
f_equal.
lia.
Qed.

Lemma sublist_split:
  forall {A} lo mid hi (al: list A),
  0 <= lo <= mid ->
  mid <= hi <= Zlength al ->
  sublist lo hi al = sublist lo mid al ++ sublist mid hi al.
Proof.
intros.
symmetry; apply sublist_rejoin; auto.
Qed.

Lemma sublist_last_1 : forall {A}{d: Inhabitant A} lo hi (al : list A), 0 <= lo <= hi -> hi + 1 <= Zlength al ->
  sublist lo (hi + 1) al = sublist lo hi al ++ [Znth hi al].
Proof.
  intros.
  erewrite sublist_split with (mid := hi)(hi0 := hi + 1), sublist_len_1; auto; lia.
Qed.

Lemma Zlen_le_1_rev:
 forall {A} (al: list A),
  Zlength al <= 1 -> rev al = al.
Proof.
intros.
symmetry.
apply len_le_1_rev.
apply Nat2Z.inj_le. rewrite <- Zlength_correct; apply H.
Qed.

Lemma skipn_0:
  forall A (l: list A), skipn 0 l = l.
Proof.
reflexivity.
Qed.

Lemma sublist_1_cons {A} l (v:A) n: sublist 1 n (v::l) = sublist 0 (n-1) l.
Proof.
  unfold_sublist_old. rewrite Z2Nat.inj_sub, skipn_0, Zminus_0_r. simpl. rewrite Z2Nat.inj_sub. trivial.
  lia. lia.
Qed.

Lemma sublist_nil': forall (A : Type) (lo lo': Z) (al : list A), lo=lo' -> sublist lo lo' al = [].
Proof. intros. subst. apply sublist_nil. Qed.

Lemma sublist_skip {A} (l:list A) i : 0<=i ->  sublist i (Zlength l) l = skipn (Z.to_nat i) l.
Proof. intros; unfold_sublist_old. apply firstn_same. rewrite skipn_length.
  rewrite Z2Nat.inj_sub, Zlength_correct, Nat2Z.id. lia. trivial.
Qed.

Lemma sublist_firstn {A} (l:list A) i: sublist 0 i l = firstn (Z.to_nat i) l.
Proof. unfold_sublist_old. rewrite Zminus_0_r, skipn_0. trivial. Qed.

Lemma sublist_app1:
  forall (A : Type) (k i : Z) (al bl : list A),
  0 <= k <= i -> i <= Zlength al -> sublist k i (al ++ bl) = sublist k i al.
Proof. intros.
  unfold_sublist_old. rewrite skipn_app1. rewrite firstn_app1. trivial.
  rewrite skipn_length, Z2Nat.inj_sub. apply Nat2Z.inj_le.
  repeat rewrite Nat2Z.inj_sub. rewrite Z2Nat.id, <- Zlength_correct. lia. lia.
  rewrite <- ZtoNat_Zlength. apply Z2Nat.inj_le; lia.
  apply Z2Nat.inj_le; lia. lia. rewrite <- ZtoNat_Zlength. apply Z2Nat.inj_le; lia.
Qed.

Lemma sublist0_app1 {A} i (al bl:list A): 0<= i <= Zlength al ->
  sublist 0 i (al ++ bl) = sublist 0 i al.
Proof. intros. apply sublist_app1; lia. Qed.

Lemma sublist_app2 {A} i j (al bl:list A): 0<=Zlength al <= i->
  sublist i j (al ++ bl) = sublist (i-Zlength al) (j-Zlength al) bl.
Proof.
  intros. unfold_sublist_old.
  rewrite skipn_app2.
  repeat rewrite Z2Nat.inj_sub. repeat rewrite ZtoNat_Zlength.
  remember ((Z.to_nat i - length al)%nat) as k.
  rewrite <- Nat.sub_add_distr.
  assert (K: (length al + k = Z.to_nat i)%nat).
    subst k. rewrite <- le_plus_minus. trivial.
    apply Nat2Z.inj_le. rewrite Z2Nat.id. rewrite Zlength_correct in H; apply H. lia.
  rewrite K. trivial.
  lia. lia. lia. lia.
  apply Nat2Z.inj_le. rewrite Z2Nat.id. rewrite Zlength_correct in H; apply H. lia.
Qed.

Lemma sublist_sublist0 {A} i j k (l:list A): 0<=k -> k<=i<=j ->
  sublist k i (sublist 0 j l) = sublist k i l.
Proof. intros. rewrite sublist_sublist; repeat rewrite Zplus_0_r; trivial; lia. Qed.

Lemma sublist_sublist00 {A} i j (l:list A): 0<=i<=j ->
  sublist 0 i (sublist 0 j l) = sublist 0 i l.
Proof. intros. apply sublist_sublist0; lia. Qed.

Lemma skipn_list_repeat:
   forall A k n (a: A),
     (k <= n)%nat -> skipn k (list_repeat n a) = list_repeat (n-k) a.
Proof.
 induction k; destruct n; simpl; intros; auto.
 apply IHk; auto. lia.
Qed.

Lemma sublist_list_repeat {A} i j k (v:A) (I: 0<=i)
          (IJK: i <= j <= k):
      sublist i j (list_repeat (Z.to_nat k) v) = list_repeat (Z.to_nat (j-i)) v.
Proof.
  unfold_sublist_old.
  rewrite skipn_list_repeat.
  rewrite firstn_list_repeat.
  trivial.
  rewrite <- Z2Nat.inj_sub by lia.
  apply Z2Nat.inj_le; lia.
  apply Z2Nat.inj_le; lia.
Qed.

Lemma Zlength_list_repeat:
  forall {A} n (x: A),
  0 <= n ->
  Zlength (list_repeat (Z.to_nat n) x) = n.
Proof.
intros.
rewrite Zlength_correct.
rewrite length_list_repeat.
apply Z2Nat.id; auto.
Qed.

Lemma list_repeat_0:
  forall {A} (x:A), list_repeat (Z.to_nat 0) x = nil.
Proof.
simpl. auto.
Qed.

Lemma Znth_list_repeat_inrange:
  forall {A}{d: Inhabitant A} i n (a: A),
   (0 <= i < n)%Z ->
   Znth i (list_repeat (Z.to_nat n) a) = a.
Proof.
intros.
unfold Znth; rewrite if_false by lia.
assert (Z.to_nat i < Z.to_nat n)%nat
  by (apply Z2Nat.inj_lt; lia).
forget (Z.to_nat n) as k.
revert k H0; induction (Z.to_nat i); destruct k; simpl; intros.
lia. auto. lia. apply IHn0; lia.
Qed.

Lemma firstn_nil {A} n: firstn n (nil:list A) = nil.
Proof.  destruct n; reflexivity. Qed.

Lemma firstn_In {A} (x:A): forall l n, In x (firstn n l) -> In x l.
Proof.
  induction l; simpl; intros.
  rewrite firstn_nil in H. inv H.
  destruct n; simpl in *. contradiction.
  destruct H; eauto.
Qed.
Lemma skipn_In {A} (x:A): forall l n, In x (skipn n l) -> In x l.
Proof.
  induction l; simpl; intros.
  rewrite skipn_nil in H. inv H.
  destruct n; simpl in *. trivial. right; eauto.
Qed.

Lemma sublist_In {A} lo hi data (x:A) (I:In x (sublist lo hi data)): In x data.
Proof. eapply firstn_In. eapply skipn_In. apply I. Qed.

Lemma Zlength_list_repeat' {A} n (v:A): Zlength (list_repeat n v) = Z.of_nat n.
Proof. rewrite Zlength_correct, length_list_repeat; trivial. Qed.

Lemma sublist0_app2 {A : Type} i (al bl : list A):
  Zlength al <= i <= Zlength al + Zlength bl ->
  sublist 0 i (al ++ bl) = al ++ sublist 0 (i - Zlength al) bl.
Proof. specialize (Zlength_nonneg al); specialize (Zlength_nonneg bl); intros.
rewrite <- (sublist_rejoin 0 (Zlength al) i); try rewrite Zlength_app; try lia.
rewrite sublist0_app1, sublist_same; try lia.
 rewrite sublist_app2, Zminus_diag; trivial. lia.
Qed.

Lemma sublist_rejoin':
  forall {A} lo mid mid' hi (al: list A),
  mid=mid' ->
  0 <= lo <= mid ->
  mid' <= hi <= Zlength al ->
  sublist lo mid al ++ sublist mid' hi al = sublist lo hi al.
Proof.
intros.
subst mid'.
apply sublist_rejoin; auto.
Qed.

Hint Rewrite @sublist_nil' using old_list_solve: sublist.
Hint Rewrite @app_nil_l : sublist.
Hint Rewrite @Zlength_rev : sublist.
Hint Rewrite @sublist_rejoin' using old_list_solve : sublist.

Lemma subsub1:
 forall a b : Z, (a-(a-b)) = b.
Proof.  intros. lia. Qed.
Hint Rewrite subsub1 : sublist.

Lemma sublist_app':
  forall {A} lo hi (al bl: list A),
  0 <= lo <= Zlength al ->
  0 <= hi-Zlength al <= Zlength bl ->
  sublist lo hi (al++bl) =
  sublist lo (Zlength al) al ++
  sublist 0 (hi-Zlength al) bl.
Proof.
intros.
unfold_sublist_old.
simpl.
rewrite Zskipn_app1 by lia.
rewrite Zfirstn_app2
 by (rewrite Zlength_skipn, Z.max_r;
      rewrite ?Z.max_r; lia).
rewrite Zlength_skipn, Z.max_r;
      rewrite ?Z.max_r; try lia.
rewrite (Zfirstn_exact_length (Zlength al - lo))
 by (rewrite Zlength_skipn, Z.max_r;
      rewrite ?Z.max_r; lia).
f_equal.
f_equal.
f_equal.
lia.
Qed.

Lemma upd_Znth_Zlength {A} i (l:list A) v: 0<=i < Zlength l ->
      Zlength (upd_Znth i l v) = Zlength l.
Proof. intros.
   unfold_upd_Znth_old. rewrite Zlength_app, Zlength_cons; simpl.
  repeat rewrite Zlength_sublist; simpl; lia.
Qed.

Lemma upd_Znth_map {A B} (f:A -> B) i l v:
      upd_Znth i (map f l) (f v) =
      map f (upd_Znth i l v).
Proof.
  unfold upd_Znth. repeat if_tac; rewrite ?Zlength_map in *; auto; try lia.
  rewrite !map_app. simpl. rewrite !map_sublist. auto.
Qed.

Lemma upd_Znth_lookup K {A}{d: Inhabitant A}: forall l (L:Zlength l = K) i j (v:A) (I: 0<=i<K) (J: 0<=j<K),
   (i=j /\ Znth i (upd_Znth j l v) = v) \/
   (i<>j /\ Znth i (upd_Znth j l v) = Znth i l).
Proof.
  intros. unfold_upd_Znth_old.
  destruct (Z.eq_dec i j); subst.
  + left; split; trivial.
    rewrite app_Znth2; rewrite Zlength_sublist; try rewrite Zminus_0_r; try rewrite Zminus_diag; try lia.
    rewrite Znth_0_cons. trivial.
  + right; split; trivial.
    destruct (Z_lt_dec i j).
    - rewrite app_Znth1; try rewrite Zlength_sublist; try lia.
      rewrite Znth_sublist; try lia. rewrite Zplus_0_r; trivial.
    - rewrite app_Znth2; rewrite Zlength_sublist; try lia.
      rewrite Zminus_0_r, Znth_pos_cons, Znth_sublist; try lia.
      assert (H: i - j - 1 + (j + 1) = i) by lia. rewrite H; trivial.
Qed.

Lemma upd_Znth_lookup' K {A}{d: Inhabitant A}: forall l (L:Zlength l = K) i (I: 0<=i<K) j (J: 0<=j<K) (v:A),
    Znth i (upd_Znth j l v) = if Z.eq_dec i j then v else Znth i l.
Proof. intros.
  destruct (upd_Znth_lookup K l L i j v I J) as [[X Y] | [X Y]]; if_tac; try lia; trivial.
Qed.

Lemma upd_Znth_char {A} n l1 (v:A) l2 w: Zlength l1=n ->
      upd_Znth n (l1 ++ v :: l2) w = l1 ++ w :: l2.
Proof. intros. unfold_upd_Znth_old.
  specialize (Zlength_nonneg l1); intros.
  f_equal. rewrite sublist0_app1. apply sublist_same; lia. lia.
  f_equal. rewrite sublist_app2, <- H, Zlength_app, Zlength_cons. do 2 rewrite Zminus_plus.
                rewrite sublist_1_cons. apply sublist_same; lia. lia.
Qed.

Lemma upd_Znth_same {A}{d: Inhabitant A}: forall i l u, 0<= i< Zlength l -> Znth i (upd_Znth i l u) = u.
Proof.
  intros. rewrite (upd_Znth_lookup' _ _ (eq_refl _)); trivial.
  destruct (Z.eq_dec i i); try lia; trivial.
Qed.

Lemma upd_Znth_diff {A}{d: Inhabitant A}: forall i j l u, 0<= i< Zlength l -> 0<= j< Zlength l -> i<>j ->
      Znth i (upd_Znth j l u) = Znth i l.
Proof.
  intros. rewrite (upd_Znth_lookup' _ _ (eq_refl _)); trivial.
  destruct (Z.eq_dec i j); try lia; trivial.
Qed.

Lemma upd_Znth_app1 {A} i l1 l2 (I: 0 <= i < Zlength l1) (v:A):
      upd_Znth i (l1++l2) v = upd_Znth i l1 v ++ l2.
Proof.
  assert (L2NN:= Zlength_nonneg l2).
  unfold_upd_Znth_old.
  rewrite sublist_app1, Zlength_app, <- app_assoc; try lia.
  f_equal. simpl. f_equal.
  rewrite <- (sublist_rejoin (i+1) (Zlength l1)); try lia.
  rewrite sublist_app1; try lia. f_equal.
  rewrite sublist_app2, Zminus_diag, Zminus_plus; try lia.
  apply sublist_same; trivial.
  rewrite Zlength_app; lia.
Qed.

Lemma upd_Znth_app2 {A} (l1 l2:list A) i v:
  Zlength l1 <= i <= Zlength l1 + Zlength l2 ->
  upd_Znth i (l1 ++ l2) v = l1 ++ upd_Znth (i-Zlength l1) l2 v.
Proof. intros.
  destruct (Z_lt_dec i (Zlength l1 + Zlength l2)).
  - unfold_upd_Znth_old.
    rewrite sublist0_app2; trivial. rewrite <- app_assoc. f_equal. f_equal. f_equal.
    rewrite sublist_app2, Zlength_app, Zminus_plus.
    assert (i + 1 - Zlength l1 = i - Zlength l1 + 1) by lia. rewrite H0; trivial.
    specialize (Zlength_nonneg l1); lia.
  - unfold upd_Znth. repeat if_tac; rewrite ?Zlength_app in *; try lia.
    auto.
Qed.

Lemma upd_Znth0_old {A} (l:list A) v:
  Zlength l > 0 ->
  upd_Znth 0 l v = v :: sublist 1 (Zlength l) l.
Proof. intros. unfold_upd_Znth_old. rewrite sublist_nil. reflexivity. Qed.

Lemma upd_Znth0 : forall {A} x (l : list A) y,
  upd_Znth 0 (x :: l) y = y :: l.
Proof.
  intros.
  unfold upd_Znth. if_tac.
  - simpl. rewrite sublist_1_cons.
    rewrite sublist_same; auto.
    rewrite Zlength_cons. lia.
  - rewrite Zlength_cons in H.
    pose proof (Zlength_nonneg l).
    lia.
Qed.

Lemma sublist_upd_Znth_l: forall {A} (l: list A) i lo hi v,
  0 <= lo <= hi ->
  hi <= i < Zlength l ->
  sublist lo hi (upd_Znth i l v) = sublist lo hi l.
Proof.
  intros.
  unfold_upd_Znth_old.
  rewrite sublist_app1.
  2: lia.
  2: rewrite Zlength_sublist by lia; lia.
  rewrite sublist_sublist by lia.
  f_equal; lia.
Qed.

Lemma sublist_upd_Znth_r: forall {A} (l: list A) i lo hi v,
  0 <= i < lo ->
  lo <= hi <= Zlength l ->
  sublist lo hi (upd_Znth i l v) = sublist lo hi l.
Proof.
  intros.
  unfold_upd_Znth_old.
  replace (sublist 0 i l ++ v :: sublist (i + 1) (Zlength l) l) with
    ((sublist 0 i l ++ v :: nil) ++ sublist (i + 1) (Zlength l) l)
    by (rewrite <- app_assoc; auto).
  rewrite sublist_app2.
  2: rewrite Zlength_app, Zlength_sublist, Zlength_correct by lia; simpl; lia.
  rewrite Zlength_app, Zlength_sublist, Zlength_correct by lia; simpl.
  rewrite sublist_sublist by lia.
  f_equal; lia.
Qed.

Lemma sublist_upd_Znth_lr: forall {A} (l: list A) i lo hi v,
  0 <= lo <= i->
  i < hi <= Zlength l ->
  sublist lo hi (upd_Znth i l v) = upd_Znth (i - lo) (sublist lo hi l) v.
Proof.
  intros.
  unfold_upd_Znth_old.
  rewrite upd_Znth_old_upd_Znth. 2 : {
    rewrite Zlength_sublist by lia.
    lia.
  }
  unfold old_upd_Znth.
  change (v :: sublist (i + 1) (Zlength l) l) with
    ((v :: nil) ++ sublist (i + 1) (Zlength l) l).
  rewrite !sublist_app'.
  2: change (Zlength [v]) with 1; lia.
  2: change (Zlength [v]) with 1; rewrite !Zlength_sublist by lia; lia.
  2: rewrite !Zlength_sublist by lia; lia.
  2: rewrite Zlength_app, !Zlength_sublist by lia; change (Zlength [v]) with 1; lia.
  rewrite !Zlength_sublist by lia.
  change (Zlength [v]) with 1.
  rewrite (@sublist_len_1 _ v) by (change (Zlength [v]) with 1; lia).
  change (@Znth _ v 0 [v]) with v.
  simpl.
  rewrite !sublist_sublist by lia.
  f_equal; [| f_equal]; f_equal; lia.
Qed.

Hint Rewrite @Znth_list_repeat_inrange : sublist.
Hint Rewrite @Zlength_cons @Zlength_nil: sublist.
Hint Rewrite @list_repeat_0: sublist.
Hint Rewrite <- @app_nil_end : sublist.
Hint Rewrite @Zlength_app: sublist.
Hint Rewrite @Zlength_map: sublist.
Hint Rewrite @Zlength_list_repeat using old_list_solve: sublist.
Hint Rewrite Z.sub_0_r Z.add_0_l Z.add_0_r : sublist.
Hint Rewrite @Zlength_sublist using old_list_solve: sublist.
Hint Rewrite Z.max_r Z.max_l using lia : sublist.
Hint Rewrite Z.min_r Z.min_l using lia : sublist.
Hint Rewrite Z.add_simpl_r Z.sub_add Z.sub_diag : sublist.
Hint Rewrite @sublist_sublist using old_list_solve : sublist.
Hint Rewrite @sublist_app1 using old_list_solve : sublist.
Hint Rewrite @sublist_app2 using old_list_solve : sublist.
Hint Rewrite @sublist_list_repeat  using old_list_solve : sublist.
Hint Rewrite @sublist_same using old_list_solve : sublist.
Hint Rewrite Z.add_simpl_l : sublist.
Hint Rewrite Z.add_add_simpl_l_l Z.add_add_simpl_l_r
     Z.add_add_simpl_r_l Z.add_add_simpl_r_r : sublist.
Hint Rewrite Z.add_0_r : sublist.
Hint Rewrite @app_Znth1 using old_list_solve : sublist.
Hint Rewrite @app_Znth2 using old_list_solve : sublist.
Hint Rewrite @Znth_sublist using old_list_solve : sublist.
Hint Rewrite @upd_Znth_Zlength using old_list_solve : sublist.

Hint Rewrite @sublist_nil : sublist.

Lemma list_repeat_app':
 forall {A: Type} a b (x:A),
    0 <= a -> 0 <= b ->
    list_repeat (Z.to_nat a) x ++ list_repeat (Z.to_nat b) x = list_repeat (Z.to_nat (a+b)) x.
Proof.
 intros.
 rewrite list_repeat_app. f_equal.
  apply Nat2Z.inj. rewrite <- Z2Nat.inj_add; auto.
Qed.

Lemma Znth_overflow:
  forall {A}{d: Inhabitant A} i (al: list A), i >= Zlength al -> Znth i al = d.
Proof.
intros.
  pose proof (Zlength_nonneg al).
   unfold Znth. rewrite if_false by lia.
  apply nth_overflow.
  apply Nat2Z.inj_le. rewrite <- Zlength_correct.
  rewrite Z2Nat.id by lia. lia.
Qed.

Lemma Znth_underflow:
  forall {A}{d: Inhabitant A} i (al: list A),  i < 0 -> Znth i al = d.
Proof.
intros.
   unfold Znth. rewrite if_true by lia. auto.
Qed.

Lemma Znth_outofbounds:
  forall {A}{d: Inhabitant A} i (al: list A),  (i < 0 \/ i >= Zlength al) -> Znth i al = d.
Proof.
intros.
  destruct H. apply Znth_underflow; auto. apply Znth_overflow; auto.
Qed.

Lemma sublist_one:
  forall {A}{d: Inhabitant A} lo hi (al: list A),
    0 <= lo -> hi <= Zlength al ->
    lo+1=hi -> sublist lo hi al = Znth lo al :: nil.
Proof.
intros.
subst.
rewrite Znth_cons_sublist by lia. rewrite <- app_nil_end.
auto.
Qed.

Lemma Forall_app :
forall {A} P (l1 l2 :list A),
Forall P (l1 ++ l2) <->
Forall P l1 /\ Forall P l2.
intros.
split; induction l1; intros.
inv H. destruct l2; inv H0. auto.
split. auto. simpl in H2. inv H2.
constructor; auto.
split. inv H. constructor; auto. apply IHl1 in H3.
intuition.
inv H. apply IHl1 in H3. intuition.
simpl. intuition.
simpl. constructor.
destruct H. inv H. auto.
apply IHl1. intuition.
inv H0; auto.
Qed.

Lemma Forall_firstn:
  forall A (f: A -> Prop) n l, Forall f l -> Forall f (firstn n l).
Proof.
induction n; destruct l; intros.
constructor. constructor. constructor.
inv H. simpl. constructor; auto.
Qed.

Lemma Forall_skipn:
  forall A (f: A -> Prop) n l, Forall f l -> Forall f (skipn n l).
Proof.
induction n; destruct l; intros.
constructor. inv H; constructor; auto. constructor.
inv H. simpl.  auto.
Qed.

Lemma Forall_map:
  forall {A B} (f: B -> Prop) (g: A -> B) al,
   Forall f (map g al) <-> Forall (Basics.compose f g) al.
Proof.
intros.
induction al; simpl; intuition; inv H1; constructor; intuition.
Qed.

Lemma Forall_sublist:
  forall {A} (f: A -> Prop) lo hi al,
   Forall f al -> Forall f (sublist lo hi al).
Proof.
intros.
apply Forall_skipn. apply Forall_firstn. auto.
Qed.

Hint Rewrite @upd_Znth_app1 using old_list_solve : sublist.
Hint Rewrite @upd_Znth_app2 using old_list_solve : sublist.

Lemma map_list_repeat: forall {A B} (f: A->B) n (x:A), map f (list_repeat n x) = list_repeat n (f x).
Proof.
intros. induction n; simpl; f_equal; auto.
Qed.
Hint Rewrite @map_list_repeat : sublist.

Lemma Zlength_sublist_correct: forall {A} (l: list A) (lo hi: Z),
  0 <= lo <= hi ->
  hi <= Zlength l ->
  Zlength (sublist lo hi l) = hi - lo.
Proof.
  intros.
  unfold_sublist_old.
  rewrite Zlength_firstn.
  rewrite Z.max_r by lia.
  rewrite Z.min_l; auto.
  rewrite Zlength_skipn.
  rewrite (Z.max_r 0 lo) by lia.
  rewrite Z.max_r by lia.
  lia.
Qed.

Lemma Zlength_sublist_incorrect: forall {A} (l: list A) (lo hi: Z),
  0 <= lo < hi ->
  hi > Zlength l ->
  Zlength (sublist lo hi l) < hi - lo.
Proof.
  intros.
  unfold_sublist_old.
  rewrite Zlength_firstn.
  rewrite Z.max_r by lia.
  assert (Zlength (skipn (Z.to_nat lo) l) < hi - lo); [| rewrite Z.min_r; lia].
  rewrite Zlength_skipn.
  rewrite (Z.max_r 0 lo) by lia.
  apply Z.max_lub_lt; lia.
Qed.

Lemma nth_Znth {A} {d: Inhabitant A}:
forall n (xs:list A), 0 <= n < Zlength xs -> (nth (Z.to_nat n) xs d) = (Znth n xs).
Proof. intros; unfold Znth; if_tac; unfold default. lia. reflexivity. Qed.


(*
Just some extra (optional) thms, feel free to add more.
*)

Require Import exindprop.
Import IndProp.

Theorem empty_star : forall {T} (x : T) (xs : list T),
  ~(x::xs ∈ (ε : regex T)**).
Admitted.

Definition regex_eq {T} (re1 re2 : regex T) := forall (x : list T),
  x ∈ re1 <-> x ∈ re2.

Notation "re1 ∋∈ re2" := (regex_eq re1 re2) (at level 75, no associativity).

Theorem concat_left_id : forall {T} (re : regex T),
  (ε·re) ∋∈ re.
Admitted.

Theorem concat_assoc : forall {T} (re1 re2 re3 : regex T),
  ((re1·re2)·re3) ∋∈ (re1·re2·re3).
Admitted.

Theorem concat_replace : forall {T} (re1 re2 re3 : regex T),
  re1 ∋∈ re2 -> (re1·re3) ∋∈ (re2·re3).
Admitted.

Theorem union_comm : forall {T} (re1 re2 : regex T),
  (re1 ∪ re2) ∋∈ (re2 ∪ re1).
Admitted.

(* splitting this proof into some lemmas might be useful *)
Theorem many_stars : forall {T} (re : regex T),
  (re** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **) ∋∈ (re**).
Admitted.


Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export AmberBase.

Fixpoint mode_xor (m1 m2 : Mode) : Mode :=
  match m1 with
  | Pos => match m2 with
           | Pos => Pos
           | Neg => Neg
           end
  | Neg => match m2 with
           | Pos => Neg
           | Neg => Pos
           end
  end.

Lemma xor_prop_1: forall m,
    (mode_xor Pos m) = m.
Proof with auto.
  intros.
  destruct m...
Qed.

Lemma xor_prop_2: forall m,
    (mode_xor m Pos) = m.
Proof with auto.
  intros.
  destruct m...
Qed.

Lemma xor_prop_3: forall m1 m2,
    (mode_xor m1 m2) = mode_xor (flip m1) (flip m2).
Proof with auto.
  intros.
  destruct m1;destruct m2...
Qed.

Lemma xor_prop_4: forall m1 m2,
    flip (mode_xor m1 m2) = mode_xor (flip m1) ( m2).
Proof with auto.
  intros.
  destruct m1;destruct m2...
Qed.

Lemma pos_rename_3: forall X m n A B Y,
    posvar m X A B ->
    Y \notin {{X}} \u fv_tt A \u fv_tt B ->
    posvar n Y A B.
Proof with auto.
  intros.
  generalize dependent Y.
  generalize dependent n.
  induction H;intros...
  -
    simpl in *...
  -
    simpl in *...
  -
    simpl in *...
    apply pos_rec with (L:=L \u {{X}} \u {{Y}} \u fv_tt A \u fv_tt B).
    +
      intros.
      apply H2...
      apply notin_union...
      split...
      apply notin_union...
      split...
      apply notin_fv_tt_open_aux...
      apply notin_fv_tt_open_aux...
    +
      intros.
      apply H1...
  -
    simpl in *.
    apply pos_rec_t with (L:=L \u {{X}} \u {{Y}})...
Qed.

Lemma posvar_comm: forall m A B X,
    posvar m X A B ->
    posvar m X B A.
Proof with auto.
  intros.
  induction H...
  -
    apply pos_rec with (L:=L)...
  -
    apply pos_rec_t with (L:=L)...
Qed.

Inductive typePairR : typ -> typ -> Prop :=
| tp_nat:
    typePairR  typ_nat typ_nat
| tp_top: forall  A ,
    type A ->
    typePairR  A typ_top
| tp_top_flip: forall A ,
    type A ->
    typePairR  typ_top A
| tp_fvar_x: forall X,
    typePairR (typ_fvar X) (typ_fvar X)
| tp_arrow: forall  A1 A2 B1 B2,
    typePairR  B1 A1 ->
    typePairR  A2 B2 ->
    typePairR  (typ_arrow A1 A2) (typ_arrow B1 B2)
| tp_rec: forall  A B L,
    (forall X, X \notin L ->
               typePairR (open_tt A X) (open_tt B X)) ->
    typePairR (typ_mu A) (typ_mu B).

Hint Constructors typePairR : core.

Lemma posvar_calc_sign: forall A B,
    typePairR A B ->
    forall X m1 Y m2 m4 C D,
    posvar m1 X A B ->
    posvar m2 Y A B ->
    posvar (mode_xor m1 m2) X C D ->
    posvar m4 Y C D ->
    X <> Y ->
    posvar m1 X (subst_tt Y C A) (subst_tt Y D B) /\
    posvar (mode_xor m2 m4) Y (subst_tt Y C A) (subst_tt Y D B).
Proof with auto.
  intros A B  H.
  dependent induction H;intros...
  -
    split.
    simpl...
    constructor...
    apply subst_tt_type...
    apply posvar_regular in H2...
    destruct H2...
    simpl...
    constructor...
    apply subst_tt_type...
    apply posvar_regular in H2...
    destruct H2...
  -
    split.
    simpl...
    constructor...
    apply subst_tt_type...
    apply posvar_regular in H2...
    destruct H2...
    simpl...
    constructor...
    apply subst_tt_type...
    apply posvar_regular in H2...
    destruct H2...
  -
    split.
    simpl.
    destruct (X==Y)...
    dependent destruction H...
    destruct H3...
    dependent destruction H0...
    rewrite xor_prop_2 in H1...
    destruct H0...
    simpl.
    destruct (X==Y)...
    dependent destruction H0...
    dependent destruction H...
    destruct H3...
    rewrite xor_prop_1...
    destruct H0...
  -
    dependent destruction H1...
    dependent destruction H2...
    simpl in *...
    split...
    +
      constructor...
      apply IHtypePairR1 with (m2:=flip m0) (m4:=m4)...
      rewrite <- xor_prop_3...
      apply posvar_comm...
      apply posvar_comm...
      apply IHtypePairR2 with (m2:=m0) (m4:=m4)...
    +
      constructor...
      rewrite xor_prop_4...
      apply IHtypePairR1 with (m1:=flip m) (X:=X)...
      rewrite <- xor_prop_3...
      apply posvar_comm...
      apply posvar_comm...
      apply IHtypePairR2 with (m1:=m) (X:=X)...
  -
    split.
    +
      simpl...
      assert (type C /\ type D).
      apply posvar_regular in H4...
      destruct H6.
      dependent destruction H2;dependent destruction H1.
      *
        apply pos_rec with (L:=L \u L0 \u L1 \u {{X}} \u {{X0}}  \u fv_tt A \u fv_tt B \u fv_tt C \u fv_tt D).
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          eapply H0...
          eassumption.
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          eapply H0...
          eapply pos_rename_3...
          eassumption.
          eassumption.
      *
        apply pos_rec with (L:=L \u L0 \u L1 \u {{X}} \u {{X0}}  \u fv_tt B \u fv_tt C \u fv_tt D).
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          apply H0 with (m2:=m0) (m4:=m4)...
          eapply posvar_self_notin...
          apply notin_fv_tt_open_aux...
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          apply H0 with (m2:=m0) (m4:=m4)...
          apply pos_rename_3 with (X:=X0) (m:=m4)...
      *
        apply pos_rec with (L:=L \u L0 \u L1 \u {{X}} \u {{X0}}  \u fv_tt B \u fv_tt C \u fv_tt D).
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          apply H0 with (m2:=m0) (m4:=m4)...
          eapply posvar_self_notin...
          apply notin_fv_tt_open_aux...
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          apply H0 with (m2:=m0) (m4:=m4)...
          eapply posvar_self_notin...
          apply notin_fv_tt_open_aux...
          apply pos_rename_3 with (X:=X0) (m:=m4)...
      *
        rewrite <- subst_tt_fresh...
        rewrite <- subst_tt_fresh...
        apply pos_rec_t with (L:=L0)...
    +
      simpl...
      assert (type C /\ type D).
      apply posvar_regular in H4...
      destruct H6.
      dependent destruction H2;dependent destruction H1.
      *
        apply pos_rec with (L:=L \u L0 \u L1 \u {{X}} \u {{X0}}  \u fv_tt A \u fv_tt B \u fv_tt C \u fv_tt D).
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          eapply H0...
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          eapply H0...
          eapply pos_rename_3...
          eassumption.
          eassumption.
      *
        apply pos_rec with (L:=L \u L0 \u L1 \u {{X}} \u {{X0}}  \u fv_tt B \u fv_tt C \u fv_tt D).
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          eapply H0 with (m2:=m0) (m4:=m4) (X0:=X) (m1:=m)...
          eapply posvar_self_notin...
          apply notin_fv_tt_open_aux...
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          apply H0 with (m2:=m0) (m4:=m4)...
          apply pos_rename_3 with (X:=X0) (m:=m4)...
      *
        apply pos_rec with (L:=L \u L0 \u L1 \u {{X}} \u {{X0}}  \u fv_tt B \u fv_tt C \u fv_tt D).
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          eapply H0 with (m2:=m0) (m4:=m4) (X0:=X) (m1:=m)...
          eapply posvar_self_notin...
          apply notin_fv_tt_open_aux...
        --
          intros.
          rewrite subst_tt_open_tt_var...
          rewrite subst_tt_open_tt_var...
          apply H0 with (m2:=m0) (m4:=m4)...
          eapply posvar_self_notin...
          apply notin_fv_tt_open_aux...
          apply pos_rename_3 with (X:=X0) (m:=m4)...
      *
        rewrite <- subst_tt_fresh...
        rewrite <- subst_tt_fresh...
        apply pos_rec_t with (L:=L1)...
Qed.

Lemma typePairR_refl: forall A,
    type A ->
    typePairR A A.
Proof with auto.
  intros.
  induction H...
  apply tp_rec with (L:=L)...
Qed.

Lemma posvar_typePairR : forall m A B X,
    posvar m X A B ->
    typePairR A B.
Proof with auto.
  intros.
  induction H...
  -
    apply tp_rec with (L:=L \u {{X}})...
  -
    apply typePairR_refl...
    apply type_mu with (L:=L \u {{X}})...
Qed.

Lemma posvar_keeps_sign : forall X Y A B m,
    posvar Pos Y A B ->
    Y <> X ->
    posvar m X A B ->
    posvar m X (subst_tt Y A A) (subst_tt Y B B).
Proof with auto.
  intros.
  apply posvar_calc_sign with (Y:=Y) (m2:=Pos) (m4:=Pos) (C:=A) (D:=B) in H1...
  destruct H1...
  eapply posvar_typePairR...
  eassumption.
  rewrite xor_prop_2...
Qed.

Lemma sub_single_implies_double1: forall E A B C D X,
      sub E A B ->
      posvar Pos X A B ->
      sub E C D ->
      sub E (subst_tt X C A) (subst_tt X D B)
with sub_single_implies_double2: forall E A B C D X,
      sub E B A ->
      posvar Neg X A B ->
      sub E C D ->
      sub E (subst_tt X D B) (subst_tt X C A).
Proof with auto.
  -
    intros.
    generalize dependent X.
    generalize dependent C.
    generalize dependent D.
    induction H;intros.
    +
      simpl.
      constructor...
    +
      simpl.
      destruct (X==X0).
      apply H1.
      apply completeness.
      apply refl...
    +
      simpl.
      constructor...
      apply completeness_wf.
      apply subst_tt_wfs...
      apply soundness in H1.
      apply sub_regular in H1.
      destruct H1.
      destruct H3...
      apply soundness_wf...
    +
      dependent destruction H2.
      simpl in *.
      constructor.
      apply sub_single_implies_double2;try assumption.
      apply posvar_comm...
      apply IHsub2;try assumption.
    +
      dependent destruction H4.
      *
        assert (H6:=H3).
        apply soundness in H6.
        apply sub_regular in H6.
        destruct H6.
        destruct H7.
        apply wfs_type in H8.
        apply wfs_type in H7.
        simpl in *.
        apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E \u fv_tt A1 \u fv_tt A2).
        intros.
        rewrite subst_tt_open_tt_var...
        rewrite subst_tt_open_tt_var...
        apply H0...
        rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
        apply completeness.
        apply Sub_weakening...
        apply soundness...
        simpl.
        constructor...
        intros.
        assert ((open_tt (subst_tt X C A1) X0) = subst_tt X C (open_tt A1 X0)).
        rewrite subst_tt_open_tt_var...
        rewrite H10.
        rewrite <- subst_tt_open_tt...
        assert ((open_tt (subst_tt X D A2) X0) = subst_tt X D (open_tt A2 X0)).
        rewrite subst_tt_open_tt_var...
        rewrite H11.
        rewrite <- subst_tt_open_tt...
        apply H2...
        rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
        apply completeness.
        apply Sub_weakening...
        apply soundness...
        simpl.
        constructor...
        rewrite subst_tt_intro with (X:=X0)...
        remember (subst_tt X0 (open_tt A1 X0) (open_tt A1 X0)).
        rewrite subst_tt_intro with (X:=X0)...
        subst.
        apply posvar_keeps_sign...
      *
        assert (H6:=H3).
        apply soundness in H6.
        apply sub_regular in H6.
        destruct H6.
        destruct H7.
        apply wfs_type in H8.
        apply wfs_type in H7.
        simpl in *.
        apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E  \u fv_tt A2).
        intros.
        rewrite subst_tt_open_tt_var...
        rewrite subst_tt_open_tt_var...
        apply H0...
        rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
        apply completeness.
        apply Sub_weakening...
        apply soundness...
        simpl.
        constructor...
        apply posvar_self_notin...
        apply notin_fv_tt_open_aux...
        intros.
        assert ((open_tt (subst_tt X C A2) X0) = subst_tt X C (open_tt A2 X0)).
        rewrite subst_tt_open_tt_var...
        rewrite H10.
        rewrite <- subst_tt_open_tt...
        assert ((open_tt (subst_tt X D A2) X0) = subst_tt X D (open_tt A2 X0)).
        rewrite subst_tt_open_tt_var...
        rewrite H11.
        rewrite <- subst_tt_open_tt...
        apply H2...
        rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
        apply completeness.
        apply Sub_weakening...
        apply soundness...
        simpl.
        constructor...
        apply posvar_self_notin...
        rewrite subst_tt_intro with (X:=X0)...
        apply subst_tt_type...
        apply notin_fv_tt_open_aux...
        apply notin_fv_tt_open_aux...
  -
    intros.
    generalize dependent X.
    generalize dependent C.
    generalize dependent D.
    induction H;intros.
    +
      simpl...
    +
      simpl.
      dependent destruction H2.
      destruct (X==X0).
      destruct H2...
      apply completeness.
      apply refl...
    +
      simpl.
      constructor...
      apply completeness_wf.
      apply subst_tt_wfs...
      apply soundness in H1.
      apply sub_regular in H1.
      destruct H1.
      destruct H3...
      apply soundness_wf...
    +
      dependent destruction H2.
      simpl in *.
      constructor.
      apply sub_single_implies_double1;try assumption.
      apply posvar_comm...
      apply IHsub2;try assumption.
    +
      dependent destruction H4.
      *
        assert (H6:=H3).
        apply soundness in H6.
        apply sub_regular in H6.
        destruct H6.
        destruct H7.
        apply wfs_type in H8.
        apply wfs_type in H7.
        simpl in *.
        apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E \u fv_tt A1 \u fv_tt A2).
        intros.
        rewrite subst_tt_open_tt_var...
        rewrite subst_tt_open_tt_var...
        apply H0...
        rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
        apply completeness.
        apply Sub_weakening...
        apply soundness...
        simpl.
        constructor...
        intros.
        assert ((open_tt (subst_tt X D A1) X0) = subst_tt X D (open_tt A1 X0)).
        rewrite subst_tt_open_tt_var...
        rewrite H10.
        rewrite <- subst_tt_open_tt...
        assert ((open_tt (subst_tt X C A2) X0) = subst_tt X C (open_tt A2 X0)).
        rewrite subst_tt_open_tt_var...
        rewrite H11.
        rewrite <- subst_tt_open_tt...
        apply H2...
        rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
        apply completeness.
        apply Sub_weakening...
        apply soundness...
        simpl.
        constructor...
        rewrite subst_tt_intro with (X:=X0)...
        remember (subst_tt X0 (open_tt A2 X0) (open_tt A2 X0)).
        rewrite subst_tt_intro with (X:=X0)...
        subst.
        apply posvar_keeps_sign...
      *
        assert (H6:=H3).
        apply soundness in H6.
        apply sub_regular in H6.
        destruct H6.
        destruct H7.
        apply wfs_type in H8.
        apply wfs_type in H7.
        simpl in *.
        apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E).
        intros.
        rewrite subst_tt_open_tt_var...
        rewrite subst_tt_open_tt_var...
        apply H0...
        rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
        apply completeness.
        apply Sub_weakening...
        apply soundness...
        simpl.
        constructor...
        apply posvar_self_notin...
        apply notin_fv_tt_open_aux...
        intros.
        assert ((open_tt (subst_tt X D A1) X0) = subst_tt X D (open_tt A1 X0)).
        rewrite subst_tt_open_tt_var...
        rewrite H10.
        rewrite <- subst_tt_open_tt...
        assert ((open_tt (subst_tt X C A1) X0) = subst_tt X C (open_tt A1 X0)).
        rewrite subst_tt_open_tt_var...
        rewrite H11.
        rewrite <- subst_tt_open_tt...
        apply H2...
        rewrite_alist (nil ++ (X0 ~ bind_sub) ++ E).
        apply completeness.
        apply Sub_weakening...
        apply soundness...
        simpl.
        constructor...
        apply posvar_self_notin...
        assert (X0 \notin L) by auto.
        specialize (H1 _ H12).
        apply soundness in H1.
        apply sub_regular in H1.
        destruct H1.
        destruct H13.
        apply wfs_type in H13...
        apply notin_fv_tt_open_aux...
        apply notin_fv_tt_open_aux...
Qed.

Lemma sub_single_implies_double: forall E A B C D X,
      sub E A B ->
      posvar Pos X A B ->
      sub E C D ->
      sub E (subst_tt X C A) (subst_tt X D B).
Proof with auto.
  intros.
  apply sub_single_implies_double1 with (C:=C) (D:=D) (X:=X) in H...
Qed.

Lemma sub_amber_2_to_sub: forall E A B,
    sub_amber2 E A B ->
    sub E A B.
Proof with auto.
  intros.
  induction H...
  -
    constructor...
    apply completeness_wf...
    apply soundness_wfa...
  -
    apply sa_rec with (L:=L \u fv_tt A \u fv_tt B \u dom E).
    intros...
    intros.
    assert (X \notin L) by auto.
    apply H1 in H3.
    dependent destruction H3.
    +
      pick fresh Y.
      rewrite <- open_subst_twice with (X:=Y)...
      remember (subst_tt Y X (open_tt A (open_tt A Y))).
      rewrite <- open_subst_twice with (X:=Y)...
      subst.
      rewrite_alist (nil ++ (X~bind_sub) ++ E).
      apply sub_replacing...
      simpl.
      rewrite subst_tt_intro with (X:=Y)...
      remember (subst_tt Y (open_tt A Y) (open_tt A Y)).
      rewrite subst_tt_intro with (X:=Y)...
      subst.
      apply sub_single_implies_double...
      apply H0...
      apply H0...
      specialize_x_and_L X L.
      apply suba_regular in H0.
      destruct_hypos...
    +
      specialize_x_and_L X L.
      apply suba_regular in H0.
      destruct_hypos...
      apply refl_algo...
      rewrite subst_tt_intro with (X:=X)...
      apply subst_tt_wfs...
      apply soundness_wf...
       apply soundness_wf...
Qed.

Theorem amber_soundness: forall E A B,
    sub_amber E A B ->
    sub (env_trans E) (rename_env E A) (rename_env E B).
Proof with auto.
  intros.
  apply sub_amber_2_to_sub.
  apply sub_amber_to_amber_2...
Qed.

Theorem amber_soundness2: forall E A B,
    sub_amber E A B ->
    Sub (env_trans E) (rename_env E A) (rename_env E B).
Proof with auto.
  intros.
  apply soundness...
  apply amber_soundness...
Qed.


From mathcomp Require Import all_ssreflect.
Require Import Base.
Require Import Coq.Reals.Abstract.ConstructiveReals.
Require Import QArith.

(* Auxiliary lemmas, simple consequences of lem *)
Lemma and_or_distr_r P Q R : (P \/ R) /\ (Q \/ R) -> (P /\ Q) \/ R.
Proof.
  intros [HP HQ].
  have [r|nr] := (lem R).
  auto.
  left.
  destruct HP.
  destruct HQ. auto.
  absurd R; auto.
  absurd R; auto.
Qed.

Lemma and_or_distr_3_mid P Q R S :
(P \/ Q \/ S) /\ (P \/ R \/ S) -> P \/ (Q /\ R) \/ S.
Proof.
  intros [HQ HR].
  have [p|np] := (lem P). auto.
  destruct HQ. absurd P; auto.
  destruct HR. absurd P; auto.
  right.
  by apply and_or_distr_r.
Qed.

Local Open Scope ConstructiveReals.
Axiom cr : ConstructiveReals.

(* Compatibility with coq-aern: *)

Definition Real := CRcarrier cr.

Definition Real0 : Real := 0.
Definition Real1 : Real := 1.
Definition Realplus x y : Real := x + y.
Definition Realmult x y : Real := x * y.
Definition Realopp x : Real := - x.

(* Definition Realinv : forall {z}, z <> Real0 -> Real := TODO. *)

Notation "x > y" := (CRlt _ y x) : ConstructiveReals.
Notation "x >= y" := (CRle _ y x) : ConstructiveReals.

Lemma CRlt_antisym (x y : Real) : y > x -> x > y -> False.
Proof.
  have L := CRltLinear cr.
  unfold isLinearOrder in L.
  destruct L as [[L' _] _].
  apply L'.
Qed.

Notation "x <@ y" := (CRltProp _ x y) (at level 70, no associativity) : ConstructiveReals.
Notation "x <=@ y" := ((CRltProp _ y x) -> False) (at level 70, no associativity) : ConstructiveReals.
Notation "x >@ y" := (CRltProp _ y x) (at level 70, no associativity) : ConstructiveReals.
Notation "x >=@ y" := ((CRltProp _ x y) -> False) (at level 70, no associativity) : ConstructiveReals.
Notation "x =@ y" := ((x <=@ y)/\(x >=@ y)) (at level 70, right associativity) : ConstructiveReals.

Definition Reallt : Real -> Real -> Prop := CRltProp cr.

Lemma Realeq_refl (x : Real) : x =@ x.
Proof.
  suff lt: x <=@ x by auto.
  intros.
  apply (CRltEpsilon cr) in H.
  by apply (CRlt_antisym x x); auto.
Qed.

Lemma Realeq_sym (x y : Real) : x =@ y -> y =@ x.
Proof.
  intros [H1 H2].
  split; auto.
Qed.

Lemma Realtotal_order : forall r1 r2 : Real, r1 <@ r2 \/ r1 =@ r2 \/ r1 >@ r2.
Proof.
  intros.
  apply and_or_distr_3_mid.
  split.
  have [gt|ngt] := (lem (r1 >@ r2)).
  right. right. auto.
  right. left. auto.
  have [gt|ngt] := (lem (r2 >@ r1)).
  left. auto.
  right. left. auto.
Qed.

Lemma Reallt_nlt : forall r1 r2 : Real, r1 <@ r2 -> ~ r2 <@ r1.
Proof.
  intros.
  have L := CRltLinear cr.
  unfold isLinearOrder in L.
  destruct L as [[L' _] _].
  have L := L' r1 r2. clear L'.
  apply (CRltEpsilon cr) in H.
  have L2 := (L H).
  have [gt|ngt] := (lem (r1 >@ r2)).
  apply (CRltEpsilon cr) in gt.
  auto. auto.
Qed.

Lemma Reallt_le : forall x y : Real, x <@ y -> x <=@ y.
Proof.
  intros.
  have L := CRltLinear cr.
  unfold isLinearOrder in L.
  destruct L as [[L' _] _].
  have L := L' x y. clear L'.
  destruct L.
  by apply (CRltEpsilon cr).
  by apply (CRltEpsilon cr).
Qed.

Definition W_M (x y z : Real)
  := (x >@ y -> z =@ x) /\ (x =@ y -> z =@ x) /\ (x <@ y -> z =@ y).

Lemma W_M_or : forall x y z, W_M x y z -> (z =@ x) \/ (z =@ y).
Proof.
  intros x y z m.
  destruct m as [a [b c]].
  destruct (Realtotal_order x y) as [p1 | [p2 | p3]].
  right. auto.
  left. auto.
  left. auto.
Qed.

Lemma W_M_Or : forall x y z, W_M x y z -> (z=@x /\ x>=@y) \/ (z=@y /\ y>=@x).
Proof.
  intros x y z m.
  destruct m as [a [b c]].
  destruct (Realtotal_order x y) as [p1 | [p2 | p3]].
  right. split. auto.
  by apply Reallt_le.
  left. split. auto.
  destruct p2. auto.
  left. split. auto.
  by apply Reallt_le.
Qed.

Lemma W_max : forall x y, (exists z, W_M x y z).
Proof.
  intros x y.
  destruct (Realtotal_order x y) as [c1 | [c2 | c3]]; unfold W_M.

  exists y.
  split; auto.
  intro H; contradict H; apply Reallt_nlt; auto.
  split. apply Realeq_sym.
  intros. apply Realeq_refl.

  exists x.
  split; split;auto.
  apply Realeq_refl.
  apply Realeq_refl.
  intro. apply Realeq_refl.

  exists x.
  split; split; auto.
  apply Realeq_refl.
  apply Realeq_refl.
  intro. apply Realeq_refl.
  intro H; contradict c3; apply Reallt_nlt; auto.
Qed.

Lemma Realmax : forall x y, {z | W_M x y z}.
Proof.
  intros.

(* TODO *)
Admitted.
(*
  apply Real_mslimit_P_lt.
  + (* max is single valued predicate *)
    unfold unique.
    pose proof (W_max x y).
    destruct H as [m H].
    exists m.
    split; auto.
    intros m' H'.
    destruct (W_M_Or x y m H) as [[H11 H12]|[H11 H12]];
      destruct (W_M_Or x y m' H') as [[H11' H12']|[H11' H12']];
      try rewrite <- H11; try rewrite <- H11'; auto with Realiny.
  + (* construct limit *)
    intros.
    apply (mjoin (x>y - prec n) (y > x - prec n)).
    ++ intros [c1|c2].
       +++ (* when x>y-2ⁿ *)
         exists x.
         destruct (W_max x y).
         exists x0.
         constructor; auto.
         destruct (W_M_Or x y x0 H) as [[H1 _]|[H1 H2]].
         ++++ rewrite H1.
              destruct (dist_zero x0 x0) as [o t]; rewrite (t eq_refl).
                apply prec_pos.

         ++++ rewrite <- H1.
              pose proof (prec_pos n) as P.
              apply (Reallt_plus_lt y Real0 (prec n)) in P; ring_simplify in P.
              apply (Realge_le) in H2.
              apply (Realle_lt_lt x y (y+prec n) H2) in P.
              assert (y-prec n < x < y+prec n) by auto.
              pose proof (prec_pos n) as Q.
              rewrite (dist_symm).
              apply (Realmetric_gtgt_sand y x (prec n) Q H0).

       +++ (* when x<y-2ⁿ *)
         exists y.
         destruct (W_max x y).
         exists x0.
         constructor; auto.
         destruct (W_M_Or x y x0 H) as [[H1 H2]|[H1 _]].
         ++++ rewrite <- H1.
              pose proof (prec_pos n) as P.
              apply (Reallt_plus_lt x Real0 (prec n)) in P; ring_simplify in P.
              apply (Realge_le) in H2.
              apply (Realle_lt_lt y x (x+prec n) H2) in P.
              assert (x-prec n < y < x+prec n) by auto.
              pose proof (prec_pos n) as Q.
              rewrite (dist_symm).
              apply (Realmetric_gtgt_sand x y (prec n) Q H0).
           ++++ rewrite H1.
                destruct (dist_zero x0 x0) as [o t]; rewrite (t eq_refl).
                apply prec_pos.

    ++ apply M_split.
       apply prec_pos.
Defined. *)