From Coq Require Import FSets.FMapPositive.
From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import IndexedStreams.
From Velus Require Import Stc.StcIsLast.
From Velus Require Import Stc.StcIsVariable.
From Velus Require Import Stc.StcIsDefined.
From Velus Require Import Stc.StcIsSystem.
From Velus Require Import Stc.StcOrdered.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import Stc.StcSyntax.
From Velus Require Import CoreExpr.CEClocking.
From Velus Require Import Stc.StcClocking.
From Velus Require Import CoreExpr.CESemantics.
From Velus Require Import Stc.StcSemantics.
From Velus Require Import CoreExpr.CEClockingSemantics.
From Coq Require Import List.

(** * Link (static) clocking predicates to (dynamic) semantic model *)

(**

These results confirm the correctness of the clocking predicates wrt the
semantics. In particular, they are useful for relating static invariants to
dynamic properties. They hold essentially due to the "additional" clocking
constraints in the NLustre semantic model.

 *)

Module Type STCCLOCKINGSEMANTICS
       (Import Ids      : IDS)
       (Import Op       : OPERATORS)
       (Import OpAux    : OPERATORS_AUX           Op)
       (Import CESyn    : CESYNTAX                Op)
       (Import Syn      : STCSYNTAX           Ids Op       CESyn)
       (Import Str      : INDEXEDSTREAMS          Op OpAux)
       (Import Last     : STCISLAST           Ids Op       CESyn Syn)
       (Import Var      : STCISVARIABLE       Ids Op       CESyn Syn)
       (Import Def      : STCISDEFINED        Ids Op       CESyn Syn Var Last)
       (Import Syst     : STCISSYSTEM         Ids Op       CESyn Syn)
       (Import Ord      : STCORDERED          Ids Op       CESyn Syn Syst)
       (Import CESem    : CESEMANTICS         Ids Op OpAux CESyn               Str)
       (Import Sem      : STCSEMANTICS        Ids Op OpAux CESyn Syn Syst Ord Str CESem)
       (Import CEClo    : CECLOCKING          Ids Op       CESyn)
       (Import Clkg     : STCCLOCKING         Ids Op       CESyn Syn Last Var Def Syst Ord CEClo)
       (Import CECloSem : CECLOCKINGSEMANTICS Ids Op OpAux CESyn Str CESem                  CEClo).

  Lemma sem_clocked_var_instant_tc:
    forall P base R S I S' vars x ck tc,
      Ordered_systems P ->
      wc_program P ->
      NoDupMembers vars ->
      sem_trconstr P base R S I S' tc ->
      wc_trconstr P vars tc ->
      Is_defined_in_tc x tc ->
      In (x, ck) vars ->
      sem_clocked_var_instant base R x ck.
  Proof.
    intros ?????????? Ord WCP Nodup Sem WC Def Hin.
    revert dependent ck; revert dependent x; revert dependent vars.
    induction Sem as [????????? Hexp Hvar|
                      ?????????? Find Hvar Hexp Find'|
                      ?????????? Clock Find Init|
                      ??????????????? Hexps Clock Rst Find System Vars Sub IH|
                      ????????? Find Hins Houts Hvars Htcs ??? IH]
                       using sem_trconstr_mult with
        (P_system := fun f S xs ys S' =>
                       forall base R s P',
                         find_system f P = Some (s, P') ->
                         base = clock_of_instant xs ->
                         sem_vars_instant R (map fst s.(s_in)) xs ->
                         sem_vars_instant R (map fst s.(s_out)) ys ->
                         sem_clocked_vars_instant base R (idck s.(s_in)) ->
                         sem_clocked_vars_instant base R (idck s.(s_out)));
      intros; try inversion Def as [| |??????? Hyys];
      try inversion WC
        as [| | |?????? bl' ? sub Hfind' Hfai Hfao]; subst.

    - match goal with H1:In (x, _) vars, H2:In (x, _) vars |- _ =>
                      eapply NoDupMembers_det with (2:=H1) in H2; eauto; subst end.
      unfold sem_clocked_var_instant.
      inv Hexp; eauto; intuition; eauto; by_sem_det.

    - match goal with H1:In (x, _) vars, H2:In (x, _) vars |- _ =>
        eapply NoDupMembers_det with (2:=H1) in H2; eauto; subst end.
      unfold sem_clocked_var_instant.
      inv Hexp; eauto; intuition; eauto; by_sem_det.

    - inversion_clear System as [?????? R' ?? Hfind Hvi Hvo Hsck].
      specialize (IH _ _ _ _ Hfind eq_refl Hvi Hvo).
      assert (Hvi' := Hvi).
      rewrite <-map_fst_idck in Hvi'.
      specialize (IH Hsck).
      rewrite Hfind in Hfind'; inv Hfind'.

      assert (forall x y ys,
                 InMembers x (idck (bl'.(s_in) ++ bl'.(s_out))) ->
                 sub x = Some y ->
                 sem_var_instant R' x ys ->
                 sem_var_instant R y ys) as Htranso.
      { setoid_rewrite InMembers_idck.
        intros; eapply sem_var_instant_transfer_out_instant
                  with (xin := s_in bl') (xout := s_out bl'); eauto.
        - pose proof bl'.(s_nodup) as Hnd.
          rewrite 2 app_assoc in Hnd; apply NoDup_app_weaken in Hnd.
          rewrite <-app_assoc, NoDup_swap, NoDup_app'_iff in Hnd.
          rewrite fst_NoDupMembers, map_app; intuition.
        - apply Forall2_impl_In with (2:=Hfai); intuition.
        - apply Forall2_impl_In with (2:=Hfao); intuition.
      }

      rewrite <-map_fst_idck in Hvo. unfold idck in Hvo. rewrite map_map in Hvo.
      unfold sem_vars_instant in Hvo.
      rewrite Forall2_map_1 in Hvo.
      apply Forall2_swap_args in Hfao.
      apply Forall2_trans_ex with (1:=Hfao) in Hvo.
      apply Forall2_swap_args in Vars.
      apply Forall2_trans_ex with (1:=Hvo) in Vars.
      apply Forall2_same in Vars.
      eapply Forall_forall in Vars
        as (s & Hins & ((x', (xty, xck)) & Hxin &
                       (Hotc & yck' & Hin' & Hinst) & Hsvx) & Hsvy); eauto.
      simpl in *.
      eapply NoDupMembers_det with (2:=Hin) in Hin'; eauto; subst yck'.
      unfold idck in *. setoid_rewrite Forall_map in IH.
      eapply Forall_forall in IH; eauto; simpl in IH.
      apply wc_find_system with (1:=WCP) in Hfind as (WCi & WCo & WCv & WCtcs).
      assert (In (x', xck) (idck (bl'.(s_in) ++ bl'.(s_out)))) as Hxin'
        by (rewrite idck_app, in_app; right;
            apply In_idck_exists; eauto).
      apply wc_env_var with (1:=WCo) in Hxin'.
      destruct s.
      + split; intuition; eauto; try by_sem_det;
          eapply IH, sem_clock_instant_transfer_out_instant in Hsvx; eauto; by_sem_det.
      + split; intuition; eauto; try by_sem_det.
        * eapply sem_clock_instant_transfer_out_instant; eauto; eapply IH; eauto.
        * assert (exists c, sem_var_instant R' x' (present c)) as Hsvx' by eauto.
          eapply IH, sem_clock_instant_transfer_out_instant in Hsvx'; eauto; by_sem_det.

    - (* systems *)
      rename H2 into Find'; rename H4 into Hins'; rename H5 into Houts'.
      rewrite Find' in Find; inv Find.
      apply Forall_forall; unfold idck.
      intros (x, xck) Hxin.
      apply In_idck_exists in Hxin as (xty & Hxin). assert (Hxin' := Hxin).
      apply in_map with (f:=fst), system_output_defined_in_tcs in Hxin.
      apply Is_defined_in_In in Hxin as (tc & Htcin & Hxtc).
      eapply Forall_forall in IH; eauto.
      pose proof Find' as Find; apply find_system_app in Find as (?&?&?); subst.
      apply wc_find_system with (1:=WCP) in Find' as (WCi & WCo & WCv & WCtcs).
      eapply Forall_forall in WCtcs; eauto.
      assert (NoDupMembers (idck (s_in s ++ s_vars s ++ s_out s) ++ idck (s_lasts s)))
        as Hnd.
      { apply fst_NoDupMembers.
        rewrite map_app, 2 map_fst_idck, 2 map_app, <-2 app_assoc.
        apply s_nodup.
      }
      apply IH with (x:=x) (ck:=xck) in Hnd; eauto.
      + simpl in *.
        unfold sem_vars_instant in Hins, Houts, Hins', Houts'.
        rewrite Forall2_map_1 in Hins', Houts'.
        apply Forall2_app with (2:=Houts') in Hins'.
        rewrite Forall2_map_1 in Hins, Houts.
        assert (Houts2:=Houts).
        apply Forall2_app with (1:=Hins) in Houts2.
        apply Forall2_Forall2 with (1:=Houts) in Houts'.
        apply Forall2_in_left with (2:=Hxin') in Houts' as (? & Hsin & Hvs & Hvs').
        destruct x1.
      (* * split; intuition; eauto; try by_sem_det. *)
        * split; intuition; eauto; try by_sem_det.
          -- eapply Hnd in Hvs.
             eapply clock_vars_to_sem_clock_instant with (Hn' := R) in H2; eauto; try by_sem_det.
             eapply in_app; eauto.
          -- eapply clock_vars_to_sem_clock_instant; eauto.
             ++ eapply in_app; eauto.
             ++ apply Hnd; auto.
        * split; intuition; eauto; try by_sem_det;
          assert (exists c, sem_var_instant R x (present c)) as Hvs'' by eauto.
          -- eapply clock_vars_to_sem_clock_instant; eauto.
             ++ eapply in_app; eauto.
             ++ apply Hnd; auto.
          -- eapply Hnd in Hvs''.
             eapply clock_vars_to_sem_clock_instant with (Hn' := R0) in Hvs''; eauto; try by_sem_det.
             eapply in_app; eauto.
      + apply wc_trconstr_program_app; auto.
        apply wc_trconstr_program_cons; auto.
        apply Ordered_systems_append in Ord; auto.
      + rewrite in_app; left; apply In_idck_exists.
        exists xty; rewrite 2 in_app; auto.
  Qed.

  Corollary sem_clocked_var_instant_tcs:
    forall P base R S I S' inputs vars tcs,
      Ordered_systems P ->
      wc_program P ->
      NoDupMembers (inputs ++ vars) ->
      Forall (sem_trconstr P base R S I S') tcs ->
      Forall (wc_trconstr P (inputs ++ vars)) tcs ->
      Permutation.Permutation (defined tcs) (map fst vars) ->
      forall x xck,
        In (x, xck) vars ->
        sem_clocked_var_instant base R x xck.
  Proof.
    intros * OP WCP Hndup Hsem Hwc Hdef x xck Hin.
    assert (In x (defined tcs)) as Hxin
        by (now rewrite Hdef; apply in_map with (f:=fst) in Hin).
    apply Is_defined_in_defined, Is_defined_in_In in Hxin
      as (tc & Hitc & Hdtc).
    eapply Forall_forall in Hsem; eauto.
    eapply Forall_forall in Hwc; eauto.
    eapply sem_clocked_var_instant_tc; eauto.
    rewrite in_app; auto.
  Qed.

End STCCLOCKINGSEMANTICS.

Module StcClockingSemanticsFun
       (Import Ids      : IDS)
       (Import Op       : OPERATORS)
       (Import OpAux    : OPERATORS_AUX           Op)
       (Import CESyn    : CESYNTAX                Op)
       (Import Syn      : STCSYNTAX           Ids Op       CESyn)
       (Import Str      : INDEXEDSTREAMS          Op OpAux)
       (Import Last     : STCISLAST           Ids Op       CESyn Syn)
       (Import Var      : STCISVARIABLE       Ids Op       CESyn Syn)
       (Import Def      : STCISDEFINED        Ids Op       CESyn Syn Var Last)
       (Import Syst     : STCISSYSTEM         Ids Op       CESyn Syn)
       (Import Ord      : STCORDERED          Ids Op       CESyn Syn Syst)
       (Import CESem    : CESEMANTICS         Ids Op OpAux CESyn               Str)
       (Import Sem      : STCSEMANTICS        Ids Op OpAux CESyn Syn Syst Ord Str CESem)
       (Import CEClo    : CECLOCKING          Ids Op       CESyn)
       (Import Clkg     : STCCLOCKING         Ids Op       CESyn Syn Last Var Def Syst Ord CEClo)
       (Import CECloSem : CECLOCKINGSEMANTICS Ids Op OpAux CESyn Str CESem                  CEClo)
<: STCCLOCKINGSEMANTICS Ids Op OpAux CESyn Syn Str Last Var Def Syst Ord CESem Sem CEClo Clkg CECloSem.
  Include STCCLOCKINGSEMANTICS Ids Op OpAux CESyn Syn Str Last Var Def Syst Ord CESem Sem CEClo Clkg CECloSem.
End StcClockingSemanticsFun.


Require Import CT.Category.
Require Import CT.Morphism.
Require Import ProofIrrelevance.

Section ArrowCategory.
  Variable (C : Category).

  (** * Morphisms in the arrow category.

  These correspond to a commutative square as per
  https://ncatlab.org/nlab/show/arrow+category#definition
  *)
  Definition morphism a b :=
    { m : (mor (M_dom a) (M_dom b) * mor (M_cod a) (M_cod b)) |
      comp (M_mor a) (snd m) = comp (fst m) (@M_mor C b) }.

  (* This is annoying. *)
  Lemma exist_injective :
    forall A (f : A -> Prop) a b a' b',
      a = b -> exist f a a' = exist f b b'.
  Proof.
    intros.
    subst.
    f_equal.
    apply proof_irrelevance.
  Qed.

  (** * Arrow categories *)
  Program Definition ArrowCategory : Category :=
    {| ob := @Morphism C;
       mor := morphism
    |}.
  Next Obligation.
  Proof.
    destruct a, b, c, X, X0.
    unfold morphism.
    simpl in *.
    destruct x, x0.
    simpl in *.
    exists (comp m m1, comp m0 m2).
    simpl.
    rewrite <- assoc.
    rewrite <- e0.
    repeat rewrite assoc.
    rewrite <- e.
    reflexivity.
  Defined.
  Next Obligation.
  Proof.
    destruct a.
    unfold morphism.
    exists (id (M_dom), id (M_cod)).
    rewrite id_right.
    rewrite id_left.
    reflexivity.
  Defined.
  Next Obligation.
  Proof.
    destruct a, b, c, d.
    destruct f, g, h.
    destruct x, x0, x1.
    simpl in *.
    apply exist_injective.
    repeat rewrite assoc.
    reflexivity.
  Defined.
  Next Obligation.
  Proof.
    rewrite ArrowCategory_obligation_3.
    reflexivity.
  Defined.
  Next Obligation.
  Proof.
    destruct a, b, f.
    simpl in *.
    destruct x.
    apply exist_injective.
    assert (comp id m = m).
    rewrite id_left.
    reflexivity.
    rewrite H.
    assert (comp id m0 = m0).
    rewrite id_left.
    reflexivity.
    rewrite H0.
    reflexivity.
  Qed.
  Next Obligation.
  Proof.
    destruct a, b, f.
    simpl in *.
    destruct x.
    apply exist_injective.
    assert (comp m id = m).
    rewrite id_right.
    reflexivity.
    rewrite H.
    assert (comp m0 id = m0).
    rewrite id_right.
    reflexivity.
    rewrite H0.
    reflexivity.
  Qed.

  (* Isn't LTac pretty? :P *)
End ArrowCategory.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                        Behaviour_Struct_lemmas.v                         *)
(****************************************************************************)

Require Export Arbitration.
Require Export Arbiter4_Proof.
Require Export Timing_Proof.
Require Export PriorityDecode_Proof.

Set Implicit Arguments.
Unset Strict Implicit.

(* Some tools for proofs *)

Lemma S_tail_Behaviour_TIMING :
 forall (s : Stream (bool * d_list bool 4)) (st : label_t),
 S_tail (Behaviour_TIMING s st) =
 Behaviour_TIMING (S_tail s) (Trans_Timing (S_head s) st).
unfold Behaviour_TIMING in |- *.
unfold Moore in |- *; simpl in |- *; auto.
Qed.

Lemma S_head_Behaviour_TIMING :
 forall (s : Stream (bool * d_list bool 4)) (st : label_t),
 S_head (Behaviour_TIMING s st) = Out_Timing st.
auto.
Qed.

Lemma S_head_Behaviour_PDECODE :
 forall
   (s : Stream (d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4)))
   (sp : STATE_p),
 S_head (Behaviour_PRIORITY_DECODE s sp) = Out_PriorityDecode sp.
auto.
Qed.

Lemma S_tail_Behaviour_PDECODE :
 forall
   (s : Stream (d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4)))
   (sp : STATE_p),
 S_tail (Behaviour_PRIORITY_DECODE s sp) =
 Behaviour_PRIORITY_DECODE (S_tail s) (Trans_PriorityDecode (S_head s) sp).
auto.
Qed.

Lemma S_tail_States_TIMING :
 forall (s : Stream (bool * d_list bool 4)) (st : label_t),
 S_tail (States_TIMING s st) =
 States_TIMING (S_tail s) (Trans_Timing (S_head s) st).
auto.
Qed.

Lemma S_head_States_TIMING :
 forall (s : Stream (bool * d_list bool 4)) (st : label_t),
 S_head (States_TIMING s st) = st.
auto.
Qed.

Lemma S_tail_States_Structure_TIMING :
 forall (i : Stream (bool * d_list bool 4)) (x : d_list bool 2),
 S_tail (States_Structure_TIMING i x) =
 States_Structure_TIMING (S_tail i) (Timing_Aux (S_head i) x).
auto.
Qed.

Lemma S_head_States_Structure_TIMING :
 forall (i : Stream (bool * d_list bool 4)) (x : d_list bool 2),
 S_head (States_Structure_TIMING i x) = x.
auto.
Qed.

Lemma S_tail_States_FOUR_ARBITERS :
 forall (i : Stream (bool * (bool * d_list (d_list bool 4) 4)))
   (s : STATE_a4),
 S_tail (States_FOUR_ARBITERS i s) =
 States_FOUR_ARBITERS (S_tail i) (Trans_Four_Arbiters (S_head i) s).
auto.
Qed.

Lemma S_tail_Structure_States_FOUR_ARBITERS :
 forall (i : Stream (bool * (bool * d_list (d_list bool 4) 4)))
   (olds : d_list bool 2 * bool * (d_list bool 2 * bool) *
           (d_list bool 2 * bool * (d_list bool 2 * bool))),
 S_tail (Structure_States_FOUR_ARBITERS i olds) =
 Structure_States_FOUR_ARBITERS (S_tail i)
   (Trans_Struct_four_arbiters (S_head i) olds).
auto.
Qed.


(** printing ⊢#    %\vdash_{\#}%    #⊢##     *)
(** printing ⊢##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing ⊢##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing ⊢!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

(** This module proves the Canonical Forms Lemmas, which allow us
    to retrieve the shape of a value given its type. *)

Set Implicit Arguments.

Require Import Coq.Program.Equality.
Require Import TLC.LibLN.
Require Import Definitions RecordAndInertTypes PreciseTyping TightTyping InvertibleTyping
        GeneralToTight Subenvironments Weakening Narrowing Substitution.

(** * Simple Implications of Typing *)

(** If a variable can be typed in an environment,
    then it is bound in that environment. *)
Lemma typing_implies_bound: forall G x T,
  G ⊢ trm_var (avar_f x) : T ->
  exists S, binds x S G.
Proof.
  introv Ht. dependent induction Ht; eauto.
Qed.

(** [d1 isin ds]             #
#
    [label(d2) \notin ds]     #
#
    [―――――――――――――――――――――]  #
#
    [label(d1) <> label(d2)]  *)
Lemma defs_has_hasnt_neq: forall ds d1 d2,
  defs_has ds d1 ->
  defs_hasnt ds (label_of_def d2) ->
  label_of_def d1 <> label_of_def d2.
Proof.
  introv Hhas Hhasnt.
  unfold defs_has in Hhas.
  unfold defs_hasnt in Hhasnt.
  induction ds.
  - simpl in Hhas. inversion Hhas.
  - simpl in Hhasnt. simpl in Hhas. case_if; case_if.
    + inversions Hhas. assumption.
    + apply IHds; eauto.
Qed.

(** [G ⊢ ds :: ... /\ D /\ ...]       #
#
    [―――――――――――――――――――――――]       #
#
    [exists d, ds = ... /\ d /\ ...]       #
#
    [G ⊢ d: D]                      *)
Lemma record_has_ty_defs: forall G T ds D,
  G /- ds :: T ->
  record_has T D ->
  exists d, defs_has ds d /\ G /- d : D.
Proof.
  introv Hdefs Hhas. induction Hdefs.
  - inversion Hhas; subst. exists d. split.
    + unfold defs_has. simpl. rewrite If_l; reflexivity.
    + assumption.
  - inversion Hhas; subst.
    + destruct (IHHdefs H4) as [d' [H1 H2]].
      exists d'. split.
      * unfold defs_has. simpl. rewrite If_r. apply H1.
        apply not_eq_sym. eapply defs_has_hasnt_neq; eauto.
      * assumption.
    + exists d. split.
      * unfold defs_has. simpl. rewrite If_l; reflexivity.
      * inversions* H4.
Qed.

(** * Functions under Inert Contexts *)
(** This lemma corresponds to Lemma 3.7 ([forall] to [G(x)]) in the paper.

    [inert G]            #
#
    [G ⊢ x: forall(T)U]       #
#
    [――――――――――――――-]    #
#
    [exists T', U',]          #
#
    [G(x) = forall(T')U']     #
#
    [G ⊢ T <: T']        #
#
    [forall fresh y, G, y: T ⊢ U'^y <: U^y] *)
Lemma var_typ_all_to_binds: forall G x T U,
    inert G ->
    G ⊢ trm_var (avar_f x) : typ_all T U ->
    (exists L T' U',
        binds x (typ_all T' U') G /\
        G ⊢ T <: T' /\
        (forall y, y \notin L -> G & y ~ T ⊢ (open_typ y U') <: (open_typ y U))).
Proof.
  introv Hin Ht.
  lets Htt: (general_to_tight_typing Hin Ht).
  lets Hinv: (tight_to_invertible Hin Htt).
  destruct (invertible_to_precise_typ_all (inert_ok Hin) Hinv) as [T' [U' [V' [L [Htp [Hs1 Hs2]]]]]].
  exists L T' U'. repeat split.
  - apply* inert_precise_all_inv.
  - apply~ tight_to_general.
  - assumption.
Qed.

(** This lemma corresponds to Lemma 3.8 ([forall] to [lambda]) in the paper.

    [inert G]                       #
#
    [G ⊢ v: forall(T)U]                  #
#
    [――――――――――――]                  #
#
    [exists T', t,]                       #
#
    [v = lambda(T')t]              #
#
    [G ⊢ T <: T']                   #
#
    [forall fresh y, G, y: T ⊢ t^y: U^y] *)
Lemma val_typ_all_to_lambda: forall G v T U,
    inert G ->
    G ⊢ trm_val v : typ_all T U ->
    (exists L T' t,
        v = val_lambda T' t /\
        G ⊢ T <: T' /\
        (forall y, y \notin L -> G & y ~ T ⊢ (open_trm y t) : open_typ y U)).
Proof.
  introv Hin Ht.
  lets Htt: (general_to_tight_typing Hin Ht).
  lets Hinv: (tight_to_invertible_v Hin Htt).
  destruct (invertible_val_to_precise_lambda Hin Hinv) as [L [T' [U' [Htp [Hs1 Hs2]]]]].
  inversions Htp.
  exists (L0 \u L \u (dom G)) T' t. repeat split~.
  intros. assert (HL: y \notin L) by auto. assert (HL0: y \notin L0) by auto.
  specialize (Hs2 y HL).
  specialize (H2 y HL0).
  eapply ty_sub; eauto. eapply narrow_typing in H2; eauto.
Qed.

(** * Objects under Inert Contexts *)
(** This lemma corresponds to Lemma 3.9 ([mu] to [G(x)]) in the paper.

    [inert G]                    #
#
    [G ⊢ x: {a: T}]              #
#
    [―――――――――――――――――――――――]    #
#
    [exists S, T', G(x) = mu(S)]       #
#
    [S^x = ... /\ {a: T'} /\ ...]  #
#
    [G ⊢ T' <: T]                *)
Lemma var_typ_rcd_to_binds: forall G x a T,
    inert G ->
    G ⊢ trm_var (avar_f x) : typ_rcd (dec_trm a T) ->
    (exists S T',
        binds x (typ_bnd S) G /\
        record_has (open_typ x S) (dec_trm a T') /\
        G ⊢ T' <: T).
Proof.
  introv Hin Ht.
  destruct (typing_implies_bound Ht) as [S BiG].
  lets Htt: (general_to_tight_typing Hin Ht).
  lets Hinv: (tight_to_invertible Hin Htt).
  destruct (invertible_to_precise_trm_dec Hinv) as [T' [U [Htp Hs]]].
  destruct (pf_inert_rcd_U Hin Htp) as [U' Hr]. subst.
  lets Hr': (precise_flow_record_has Hin Htp). apply pf_binds in Htp.
  exists U' T'. split. assumption. split. assumption. apply* tight_to_general.
Qed.

Lemma var_typ_rcd_typ_to_binds: forall G x a T U,
    inert G ->
    G ⊢ trm_var (avar_f x) : typ_rcd (dec_typ a T U) ->
    (exists S T' U',
        binds x (typ_bnd S) G /\
        record_has (open_typ x S) (dec_typ a T' U') /\
        G ⊢ T <: T' /\
        G ⊢ U' <: U).
Proof.
  introv Hin Ht.
  destruct (typing_implies_bound Ht) as [S BiG].
  lets Htt: (general_to_tight_typing Hin Ht).
  lets Hinv: (tight_to_invertible Hin Htt).
  destruct (invertible_to_precise_typ_dec Hinv) as [T' [U' [U0 [Htp Hs]]]].
  destruct (pf_inert_rcd_U Hin Htp) as [U'1 Hr]. subst.
  lets Hr': (precise_flow_record_has Hin Htp). apply pf_binds in Htp.
  exists U'1 T' U'. split. assumption. split. assumption.
  destruct Hs. split.
  apply~ tight_to_general. assumption.
Qed.

(** This lemma corresponds to Lemma 3.10 ([mu] to [nu]) in the paper.

    [inert G]                  #
#
    [G ⊢ v: mu(T)]             #
#
    [G ⊢ x: T^x]               #
#
    [T = ... /\ {a: U} /\ ...  ] #
#
    [――――――――――――――――――――――――] #
#
    [exists t, ds, v = nu(T)ds     ] #
#
    [ds^x = ... /\ {a = t} /\ ...] #
#
    [G ⊢ t: U] *)
Lemma val_mu_to_new: forall G v T U a x,
    inert G ->
    G ⊢ trm_val v: typ_bnd T ->
    G ⊢ trm_var (avar_f x) : open_typ x T ->
    record_has (open_typ x T) (dec_trm a U) ->
    exists t ds,
      v = val_new T ds /\
      defs_has (open_defs x ds) (def_trm a t) /\
      G ⊢ t: U.
Proof.
  introv Hi Ht Hx Hr.
  lets Htt: (general_to_tight_typing Hi Ht).
  lets Hinv: (tight_to_invertible_v Hi Htt).
  inversions Hinv. inversions H.
  pick_fresh z. assert (z \notin L) as Hz by auto.
  specialize (H3 z Hz).
  assert (G /- open_defs x ds :: open_typ x T) as Hds. {
    apply* renaming_def; eauto.
  }
  destruct (record_has_ty_defs Hds Hr) as [d [Hh Hd]]. inversions Hd.
  exists t ds. split*.
Qed.

(** * Well-typedness *)

(** If [s: G], the variables in the domain of [s] are distinct. *)
Lemma well_typed_to_ok_G: forall s G,
    well_typed G s -> ok G.
Proof.
  intros. destruct H as [? [? ?]]. auto.
Qed.
Hint Resolve well_typed_to_ok_G.

Lemma well_typed_to_ok_s: forall s G,
    well_typed G s -> ok s.
Proof.
  intros. destruct H as [? [? ?]]. auto.
Qed.
Hint Resolve well_typed_to_ok_s.

(** [s: G]       #
#
    [x ∉ dom(G)] #
#
    [――――――――――] #
#
    [x ∉ dom(s)] *)
Lemma well_typed_notin_dom: forall G s x,
    well_typed G s ->
    x # s ->
    x # G.
Proof.
  introv Hwt. destruct Hwt as [? [? [?Hdom ?]]].
  unfold notin. rewrite Hdom.
  auto.
Qed.

Lemma well_typed_empty:
    well_typed empty empty.
Proof.
  repeat split; auto.
  - simpl_dom; auto.
  - introv B. exfalso; apply* binds_empty_inv.
Qed.
Hint Resolve well_typed_empty.

Lemma well_typed_push: forall G s x T v,
    well_typed G s ->
    x # G ->
    x # s ->
    G ⊢ trm_val v : T ->
    well_typed (G & x ~ T) (s & x ~ v).
Proof.
  intros. unfold well_typed in *.
  destruct_all.
  repeat split; auto.
  - simpl_dom. fequal. auto.
  - intros x0 T0 v0 BxG. gen v0.
    destruct (binds_push_inv BxG) as [[?Heqx ?HeqT] | [?Hneq ?HB]].
    + subst x0 T0. introv Bxv. apply binds_push_eq_inv in Bxv.
      subst v0. apply weaken_ty_trm; auto.
    + intros.
      assert (binds x0 T0 G) by eauto using binds_push_neq_inv.
      assert (binds x0 v0 s) by eauto using binds_push_neq_inv.
      apply weaken_ty_trm; eauto.
Qed.
Hint Resolve well_typed_push.

(** [s: G]              #
#
    [G(x) = T]          #
#
    [―――――――――――――]     #
#
    [exists v, s(x) = v]     #
#
    [G ⊢ v: T]          *)
Lemma corresponding_types: forall G s x T,
    well_typed G s ->
    binds x T G ->
    (exists v, binds x v s /\
          G ⊢ trm_val v : T).
Proof.
  introv Hwt BiG. destruct Hwt as [?HokG [?HokS [?HdomEq ?]]].
  pose proof (get_some_inv BiG) as HinDom.
  symmetry in HdomEq.
  pose proof (get_some (Logic.eq_ind_r _ HinDom HdomEq)) as [?v Bis].
  exists v. split.
  - apply Bis.
  - eauto.
Qed.

(** * Canonical Forms for Functions

    [inert G]            #
#
    [s: G]               #
#
    [G ⊢ x: forall(T)U]       #
#
    [――――――――――――――――――] #
#
    [s(x) = lambda(T')t] #
#
    [G ⊢ T <: T']        #
#
    [G, x: T ⊢ t: U]          *)
Lemma canonical_forms_fun: forall G s x T U,
  inert G ->
  well_typed G s ->
  G ⊢ trm_var (avar_f x) : typ_all T U ->
  (exists L T' t, binds x (val_lambda T' t) s /\ G ⊢ T <: T' /\
  (forall y, y \notin L -> G & y ~ T ⊢ open_trm y t : open_typ y U)).
Proof.
  introv Hin Hwt Hty.
  destruct (var_typ_all_to_binds Hin Hty) as [L [S [T' [BiG [Hs1 Hs2]]]]].
  destruct (corresponding_types Hwt BiG) as [v [Bis Ht]].
  destruct (val_typ_all_to_lambda Hin Ht) as [L' [S' [t [Heq [Hs1' Hs2']]]]].
  subst.
  exists (L \u L' \u (dom G)) S' t. repeat split~.
  - eapply subtyp_trans; eauto.
  - intros.
    assert (HL: y \notin L) by auto.
    assert (HL': y \notin L') by auto.
    specialize (Hs2 y HL).
    specialize (Hs2' y HL').
    apply narrow_typing with (G':=G & y ~ T) in Hs2'; auto.
    + eapply ty_sub; eauto.
Qed.

(** * Canonical Forms for Objects

    [inert G]            #
#
    [s: G]               #
#
    [G ⊢ x: {a:T}]       #
#
    [――――――――――――――――――] #
#
    [exists S, ds, t,] #
#
    [s(x) = nu(S)ds] #
#
    [ds^x = ... /\ {a = t} /\ ...] #
#
    [G ⊢ t: T] *)
Lemma canonical_forms_obj: forall G s x a T,
  inert G ->
  well_typed G s ->
  G ⊢ trm_var (avar_f x) : typ_rcd (dec_trm a T) ->
  (exists S ds t, binds x (val_new S ds) s /\ defs_has (open_defs x ds) (def_trm a t) /\ G ⊢ t : T).
Proof.
  introv Hi Hwt Hty.
  destruct (var_typ_rcd_to_binds Hi Hty) as [S [T' [Bi [Hr Hs]]]].
  destruct (corresponding_types Hwt Bi) as [v [Bis Ht]].
  apply ty_var in Bi. apply ty_rec_elim in Bi.
  destruct (val_mu_to_new Hi Ht Bi Hr) as [t [ds [Heq [Hdefs Ht']]]].
  subst. exists S ds t. repeat split~. eapply ty_sub; eauto.
Qed.


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

(****************************************************************************)
(*                                                                          *)
(*  Proof of the three gap theorem.                                         *)
(*                                                                          *)
(*  Micaela Mayero (INRIA-Rocquencourt)                                     *)
(*  September 1998                                                          *)
(*                                                                          *)
(****************************************************************************)
(****************************************************************************)
(*                               preuve1.v                                  *)
(****************************************************************************)

(*********************************************************)
(*           Intermediate proof 1                        *)
(*                                                       *)
(*********************************************************)

Require Export prop_fl.

Unset Standard Proposition Elimination Names.

Section particular.
Hypothesis alpha_irr : forall n p : Z, (alpha * IZR p)%R <> IZR n.
Hypothesis prop_alpha : (0 < alpha)%R /\ (alpha < 1)%R.
Hypothesis prop_N : forall N : nat, N >= 2.

(**********)
Definition M (N : nat) := first N + last N.

(**********)
Lemma inter31a :
 forall N n : nat, 0 < n -> n < last (M N) -> after (M N) n = n + first (M N).
intros; apply (sym_equal (x:=n + first (M N)) (y:=after (M N) n));
 apply (tech_after alpha_irr (M N) n (n + first (M N)) H);
 auto with arith real.
apply (lt_le_trans n (last (M N)) (M N) H0 (last_N01 (M N))).
unfold M at 2 in |- *;
 rewrite (last_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real;
 rewrite (first_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
rewrite (plus_comm (first (M N)) (last (M N)));
 apply (plus_lt_compat_r n (last (M N)) (first (M N)) H0).
fold (frac_part_n_alpha (n + first (M N)) > frac_part_n_alpha n)%R in |- *;
 apply
  (Rnot_le_lt (frac_part_n_alpha (n + first (M N))) (frac_part_n_alpha n));
 red in |- *; intro;
 generalize
  (Rplus_le_compat_l (- frac_part_n_alpha (first (M N)))
     (frac_part_n_alpha (n + first (M N))) (frac_part_n_alpha n) H1);
 rewrite
  (Rplus_comm (- frac_part_n_alpha (first (M N)))
     (frac_part_n_alpha (n + first (M N))));
 rewrite
  (Rplus_comm (- frac_part_n_alpha (first (M N))) (frac_part_n_alpha n))
  ;
 fold
  (frac_part_n_alpha (n + first (M N)) - frac_part_n_alpha (first (M N)))%R
  in |- *;
 fold (frac_part_n_alpha n - frac_part_n_alpha (first (M N)))%R in |- *;
 cut
  (frac_part_n_alpha (n + first (M N)) >= frac_part_n_alpha (first (M N)))%R.
intro; unfold frac_part_n_alpha at 1 2 in |- *;
 unfold frac_part_n_alpha in H2;
 rewrite <-
  (Rminus_fp1 (INR (n + first (M N)) * alpha) (INR (first (M N)) * alpha) H2)
  ; rewrite (plus_INR n (first (M N)));
 rewrite (Rmult_comm (INR n + INR (first (M N))) alpha);
 rewrite (Rmult_plus_distr_l alpha (INR n) (INR (first (M N))));
 rewrite (Rmult_comm alpha (INR (first (M N)))); unfold Rminus at 1 in |- *;
 rewrite
  (Rplus_assoc (alpha * INR n) (INR (first (M N)) * alpha)
     (- (INR (first (M N)) * alpha)));
 rewrite (Rplus_opp_r (INR (first (M N)) * alpha)).
 elim (Rplus_ne (alpha * INR n)); intros a b; rewrite a; clear a b;
  rewrite (Rmult_comm alpha (INR n)); fold (frac_part_n_alpha n) in |- *;
  intro; cut (0 < frac_part_n_alpha (first (M N)))%R.
intro;
 generalize
  (tech_Rgt_minus (frac_part_n_alpha n) (frac_part_n_alpha (first (M N))) H4);
 clear H4 H1 H2; intro; unfold Rgt in H1;
 generalize
  (Rgt_not_le (frac_part_n_alpha n)
     (frac_part_n_alpha n - frac_part_n_alpha (first (M N))) H1);
 auto with arith real.
fold (frac_part_n_alpha (first (M N)) > 0)%R in |- *;
 apply (fp_first_R0 alpha_irr prop_N (M N)).
unfold Rge in |- *; unfold Rgt in |- *;
 cut
  ((frac_part_n_alpha (first (M N)) < frac_part_n_alpha (n + first (M N)))%R \/
   frac_part_n_alpha (first (M N)) = frac_part_n_alpha (n + first (M N))).
intro; elim H2; intro.
left; auto with arith real.
right; auto with arith real.
fold
 (frac_part_n_alpha (first (M N)) <= frac_part_n_alpha (n + first (M N)))%R
 in |- *; apply (first_n (M N) (n + first (M N)));
 auto with arith real;
 generalize (plus_lt_compat_r n (last (M N)) (first (M N)) H0);
 intro; unfold M at 2 in |- *;
 rewrite (first_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real;
 rewrite (last_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real; rewrite (plus_comm (first (M N)) (last (M N)));
 assumption.
(**)
intro; elim H1; intros; elim H2; intros; elim H4; intros; elim H6; intros;
 clear H6 H4 H2 H1.
elim (le_or_lt x n); intro.
generalize
 (Ropp_lt_gt_contravar (frac_part_n_alpha n) (frac_part_n_alpha x) H7);
 intro;
 generalize
  (Rplus_gt_compat_l (frac_part_n_alpha (n + first (M N)))
     (- frac_part_n_alpha n) (- frac_part_n_alpha x) H2);
 fold (frac_part_n_alpha (n + first (M N)) - frac_part_n_alpha n)%R in |- *;
 fold (frac_part_n_alpha (n + first (M N)) - frac_part_n_alpha x)%R in |- *;
 fold (frac_part_n_alpha (n + first (M N)) > frac_part_n_alpha x)%R in H8;
 generalize
  (Rgt_ge (frac_part_n_alpha (n + first (M N))) (frac_part_n_alpha x) H8);
 intro; unfold frac_part_n_alpha in H4; unfold frac_part_n_alpha in |- *;
 rewrite <- (Rminus_fp1 (INR (n + first (M N)) * alpha) (INR x * alpha) H4);
 fold (frac_part_n_alpha x > frac_part_n_alpha n)%R in H7;
 generalize
  (Rgt_trans (frac_part_n_alpha (n + first (M N)))
     (frac_part_n_alpha x) (frac_part_n_alpha n) H8 H7);
 intro;
 generalize
  (Rgt_ge (frac_part_n_alpha (n + first (M N))) (frac_part_n_alpha n) H6);
 intro; unfold frac_part_n_alpha in H9;
 rewrite <- (Rminus_fp1 (INR (n + first (M N)) * alpha) (INR n * alpha) H9);
 rewrite (plus_INR n (first (M N)));
 rewrite (Rmult_comm (INR n + INR (first (M N))) alpha);
 rewrite (Rmult_plus_distr_l alpha (INR n) (INR (first (M N))));
 rewrite (Rmult_comm alpha (INR n)); unfold Rminus at 1 in |- *;
 rewrite (Rplus_comm (INR n * alpha) (alpha * INR (first (M N))));
 rewrite
  (Rplus_assoc (alpha * INR (first (M N))) (INR n * alpha)
     (- (INR n * alpha))); rewrite (Rplus_opp_r (INR n * alpha));
 elim (Rplus_ne (alpha * INR (first (M N)))); intros a b;
 rewrite a; clear a b; rewrite (Rmult_comm alpha (INR (first (M N))));
 fold (frac_part_n_alpha (first (M N))) in |- *; unfold Rminus in |- *;
 rewrite
  (Rplus_assoc (INR (first (M N)) * alpha) (INR n * alpha)
     (- (INR x * alpha))); rewrite (Rmult_comm (INR (first (M N))) alpha);
 rewrite (Rmult_comm (INR n) alpha);
 rewrite <- (Ropp_mult_distr_l_reverse (INR x) alpha);
 rewrite (Rmult_comm (- INR x) alpha);
 rewrite <- (Rmult_plus_distr_l alpha (INR n) (- INR x));
 rewrite <- (Rmult_plus_distr_l alpha (INR (first (M N))) (INR n + - INR x));
 fold (INR n - INR x)%R in |- *; rewrite <- (minus_INR n x H1);
 rewrite <- (plus_INR (first (M N)) (n - x));
 rewrite (Rmult_comm alpha (INR (first (M N) + (n - x))));
 fold (frac_part_n_alpha (first (M N) + (n - x))) in |- *;
 intro; clear H2 H4 H6 H9; cut (0 < first (M N) + (n - x)).
cut (first (M N) + (n - x) < M N).
intros;
 generalize
  (first_n (M N) (first (M N) + (n - x)) (prop_N (M N)) H4 H2 prop_alpha);
 intro; clear H2 H4; unfold Rgt in H10;
 generalize
  (Rgt_not_le (frac_part_n_alpha (first (M N)))
     (frac_part_n_alpha (first (M N) + (n - x))) H10);
 auto with arith real.
unfold M at 2 in |- *;
 rewrite (first_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
apply (plus_lt_compat_l (n - x) (last N) (first (M N)));
 rewrite (last_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
apply (lt_minus_p n (last (M N)) x H0).
apply (lt_O_plus (first (M N)) (n - x) (first_0 (M N) (prop_N (M N)))).
(**)
generalize
 (Rplus_lt_compat_l (- frac_part_n_alpha n) (frac_part_n_alpha x)
    (frac_part_n_alpha (n + first (M N))) H8);
 rewrite (Rplus_comm (- frac_part_n_alpha n) (frac_part_n_alpha x));
 rewrite
  (Rplus_comm (- frac_part_n_alpha n) (frac_part_n_alpha (n + first (M N))))
  ; fold (frac_part_n_alpha x - frac_part_n_alpha n)%R in |- *;
 fold (frac_part_n_alpha (n + first (M N)) - frac_part_n_alpha n)%R in |- *;
 fold (frac_part_n_alpha x > frac_part_n_alpha n)%R in H7;
 generalize (Rgt_ge (frac_part_n_alpha x) (frac_part_n_alpha n) H7);
 intro;
 fold (frac_part_n_alpha (n + first (M N)) > frac_part_n_alpha x)%R in H8;
 generalize
  (Rgt_trans (frac_part_n_alpha (n + first (M N)))
     (frac_part_n_alpha x) (frac_part_n_alpha n) H8 H7);
 intro;
 generalize
  (Rgt_ge (frac_part_n_alpha (n + first (M N))) (frac_part_n_alpha n) H4);
 intro; unfold frac_part_n_alpha in H2, H6; unfold frac_part_n_alpha in |- *;
 rewrite <- (Rminus_fp1 (INR x * alpha) (INR n * alpha) H2);
 rewrite <- (Rminus_fp1 (INR (n + first (M N)) * alpha) (INR n * alpha) H6);
 rewrite (plus_INR n (first (M N)));
 rewrite (Rmult_comm (INR n + INR (first (M N))) alpha);
 rewrite (Rmult_plus_distr_l alpha (INR n) (INR (first (M N))));
 rewrite (Rmult_comm alpha (INR n));
 rewrite (Rmult_comm alpha (INR (first (M N)))); unfold Rminus at 2 in |- *;
 rewrite (Rplus_comm (INR n * alpha) (INR (first (M N)) * alpha));
 rewrite
  (Rplus_assoc (INR (first (M N)) * alpha) (INR n * alpha)
     (- (INR n * alpha))); rewrite (Rplus_opp_r (INR n * alpha));
 elim (Rplus_ne (INR (first (M N)) * alpha)); intros a b;
 rewrite a; clear a b; fold (frac_part_n_alpha (first (M N))) in |- *;
 clear H2 H4 H6; unfold Rminus in |- *; rewrite (Rmult_comm (INR x) alpha);
 rewrite <- (Ropp_mult_distr_l_reverse (INR n) alpha);
 rewrite (Rmult_comm (- INR n) alpha);
 rewrite <- (Rmult_plus_distr_l alpha (INR x) (- INR n));
 fold (INR x - INR n)%R in |- *; rewrite (Rmult_comm alpha (INR x - INR n));
 generalize (lt_le_weak n x H1); intro; rewrite <- (minus_INR x n H2);
 fold (frac_part_n_alpha (x - n)) in |- *; intro; cut (0 < x - n).
intro; cut (x - n < M N).
intro; generalize (first_n (M N) (x - n) (prop_N (M N)) H6 H9 prop_alpha);
 intro; clear H9 H6;
 generalize
  (Rgt_not_le (frac_part_n_alpha (first (M N))) (frac_part_n_alpha (x - n))
     H4); auto with arith real.
apply (lt_minus_p x (M N) n H5).
apply (lt_minus2 n x H1).
Qed.

(**********)
Lemma inter31b :
 forall N n : nat,
 last (M N) <= n -> n < M N -> after (M N) n = n - last (M N).
intros; elim (le_lt_or_eq (last (M N)) n H); intro; clear H.
apply (sym_equal (x:=n - last (M N)) (y:=after (M N) n));
 apply (tech_after alpha_irr (M N) n (n - last (M N)));
 auto with arith real.
apply (lt_trans 0 (last (M N)) n (last_0 (M N) (prop_N (M N))) H1).
apply (lt_minus_p n (M N) (last (M N)) H0).
cut
 (frac_part_n_alpha n <
  frac_part_n_alpha n - frac_part_n_alpha (last (M N)) + 1)%R.
intro; unfold frac_part_n_alpha in H; generalize H; clear H;
 rewrite <- (Rminus_fp2 (INR n * alpha) (INR (last (M N)) * alpha)).
fold (frac_part_n_alpha n) in |- *; rewrite (Rmult_comm (INR n) alpha);
 unfold Rminus in |- *;
 rewrite <- (Ropp_mult_distr_l_reverse (INR (last (M N))) alpha);
 rewrite (Rmult_comm (- INR (last (M N))) alpha);
 rewrite <- (Rmult_plus_distr_l alpha (INR n) (- INR (last (M N))));
 fold (INR n - INR (last (M N)))%R in |- *;
 rewrite <- (minus_INR n (last (M N)) (lt_le_weak (last (M N)) n H1));
 rewrite (Rmult_comm alpha (INR (n - last (M N))));
 fold (frac_part_n_alpha (n - last (M N))) in |- *;
 trivial.
fold (frac_part_n_alpha n) in |- *;
 fold (frac_part_n_alpha (last (M N))) in |- *;
 generalize
  (last_n (M N) n (prop_N (M N))
     (lt_trans 0 (last (M N)) n (last_0 (M N) (prop_N (M N))) H1) H0
     prop_alpha); intro; unfold Rle in H; elim H; intro;
 auto with arith real.
generalize
 (contra_tech_fp_alp_irr alpha_irr prop_alpha (last (M N)) n
    (lt_not_eq (last (M N)) n H1)); intro; elimtype False;
 auto with arith real.
unfold Rminus in |- *;
 rewrite
  (Rplus_assoc (frac_part_n_alpha n) (- frac_part_n_alpha (last (M N))) 1)
  ; rewrite (Rplus_comm (- frac_part_n_alpha (last (M N))) 1);
 fold (1 - frac_part_n_alpha (last (M N)))%R in |- *;
 elim (Rplus_ne (frac_part_n_alpha n)); intros a b;
 pattern (frac_part_n_alpha n) at 1 in |- *; rewrite <- a;
 clear a b;
 apply
  (Rplus_lt_compat_l (frac_part_n_alpha n) 0
     (1 - frac_part_n_alpha (last (M N))));
 fold (1 - frac_part_n_alpha (last (M N)) > 0)%R in |- *;
 apply (Rgt_minus 1 (frac_part_n_alpha (last (M N))));
 unfold Rgt in |- *; unfold frac_part_n_alpha in |- *;
 elim (base_fp (INR (last (M N)) * alpha)); intros;
 assumption.
(**)
intro; elim H; intros; elim H2; intros; elim H4; intros; elim H6; intros;
 clear H H2 H4 H6.
elim (le_or_lt n x); intro.
generalize
 (Rplus_lt_compat_l (- frac_part_n_alpha (n - last (M N)))
    (frac_part_n_alpha n) (frac_part_n_alpha x) H7);
 intro;
 generalize
  (Rplus_lt_compat_l 1
     (- frac_part_n_alpha (n - last (M N)) + frac_part_n_alpha n)
     (- frac_part_n_alpha (n - last (M N)) + frac_part_n_alpha x) H2);
 clear H2;
 rewrite
  (Rplus_comm 1 (- frac_part_n_alpha (n - last (M N)) + frac_part_n_alpha n))
  ;
 rewrite
  (Rplus_comm 1 (- frac_part_n_alpha (n - last (M N)) + frac_part_n_alpha x))
  ;
 rewrite
  (Rplus_comm (- frac_part_n_alpha (n - last (M N))) (frac_part_n_alpha n))
  ;
 rewrite
  (Rplus_comm (- frac_part_n_alpha (n - last (M N))) (frac_part_n_alpha x))
  ; fold (frac_part_n_alpha n - frac_part_n_alpha (n - last (M N)))%R in |- *;
 fold (frac_part_n_alpha x - frac_part_n_alpha (n - last (M N)))%R in |- *;
 unfold frac_part_n_alpha in |- *;
 rewrite <- (Rminus_fp2 (INR n * alpha) (INR (n - last (M N)) * alpha)).
rewrite <- (Rminus_fp2 (INR x * alpha) (INR (n - last (M N)) * alpha)).
rewrite (minus_INR n (last (M N)) (lt_le_weak (last (M N)) n H1));
 unfold Rminus in |- *;
 rewrite (Rmult_comm (INR n + - INR (last (M N))) alpha);
 rewrite (Rmult_plus_distr_l alpha (INR n) (- INR (last (M N))));
 rewrite (Ropp_plus_distr (alpha * INR n) (alpha * - INR (last (M N))));
 rewrite <-
  (Rplus_assoc (INR n * alpha) (- (alpha * INR n))
     (- (alpha * - INR (last (M N))))); rewrite (Rmult_comm (INR n) alpha);
 rewrite (Rplus_opp_r (alpha * INR n));
 elim (Rplus_ne (- (alpha * - INR (last (M N)))));
 intros a b; rewrite b; clear a b;
 rewrite (Rmult_comm alpha (- INR (last (M N))));
 rewrite <- (Ropp_mult_distr_l_reverse (- INR (last (M N))) alpha);
 rewrite (Ropp_involutive (INR (last (M N))));
 fold (frac_part_n_alpha (last (M N))) in |- *;
 rewrite <-
  (Rplus_assoc (INR x * alpha) (- (alpha * INR n)) (INR (last (M N)) * alpha))
  ; rewrite (Rmult_comm alpha (INR n));
 rewrite <- (Ropp_mult_distr_l_reverse (INR n) alpha);
 rewrite (Rmult_comm (- INR n) alpha); rewrite (Rmult_comm (INR x) alpha);
 rewrite <- (Rmult_plus_distr_l alpha (INR x) (- INR n));
 fold (INR x - INR n)%R in |- *; rewrite <- (minus_INR x n H);
 rewrite (Rmult_comm (INR (last (M N))) alpha);
 rewrite <- (Rmult_plus_distr_l alpha (INR (x - n)) (INR (last (M N))));
 rewrite <- (plus_INR (x - n) (last (M N)));
 rewrite (Rmult_comm alpha (INR (x - n + last (M N))));
 fold (frac_part_n_alpha (x - n + last (M N))) in |- *;
 intro; cut (0 < x - n + last (M N)).
intro; cut (x - n + last (M N) < M N).
intro;
 generalize
  (last_n (M N) (x - n + last (M N)) (prop_N (M N)) H4 H6 prop_alpha);
 intro; clear H4 H6;
 generalize
  (Rgt_not_le (frac_part_n_alpha (x - n + last (M N)))
     (frac_part_n_alpha (last (M N))) H2); intro; elimtype False;
 auto with arith real.
apply (tech_inter31b (last (M N)) n x (M N) H1 H H5).
rewrite plus_comm;
 apply (lt_O_plus (last (M N)) (x - n) (last_0 (M N) (prop_N (M N)))).
fold (frac_part_n_alpha x) in |- *;
 fold (frac_part_n_alpha (n - last (M N))) in |- *;
 assumption.
fold (frac_part_n_alpha n) in |- *;
 fold (frac_part_n_alpha (n - last (M N))) in |- *;
 apply
  (Rlt_trans (frac_part_n_alpha n) (frac_part_n_alpha x)
     (frac_part_n_alpha (n - last (M N))) H7 H8).
(**)
generalize
 (Ropp_lt_gt_contravar (frac_part_n_alpha x)
    (frac_part_n_alpha (n - last (M N))) H8); unfold Rgt in |- *;
 intro;
 generalize
  (Rplus_lt_compat_l (frac_part_n_alpha n)
     (- frac_part_n_alpha (n - last (M N))) (- frac_part_n_alpha x) H2);
 clear H2;
 fold (frac_part_n_alpha n - frac_part_n_alpha (n - last (M N)))%R in |- *;
 fold (frac_part_n_alpha n - frac_part_n_alpha x)%R in |- *;
 intro;
 generalize
  (Rplus_lt_compat_l 1
     (frac_part_n_alpha n - frac_part_n_alpha (n - last (M N)))
     (frac_part_n_alpha n - frac_part_n_alpha x) H2);
 clear H2;
 rewrite
  (Rplus_comm 1 (frac_part_n_alpha n - frac_part_n_alpha (n - last (M N))))
  ; rewrite (Rplus_comm 1 (frac_part_n_alpha n - frac_part_n_alpha x));
 unfold frac_part_n_alpha in |- *;
 rewrite <- (Rminus_fp2 (INR n * alpha) (INR (n - last (M N)) * alpha)).
rewrite <- (Rminus_fp2 (INR n * alpha) (INR x * alpha)).
rewrite (Rmult_comm (INR n) alpha); unfold Rminus at 2 in |- *;
 rewrite <- (Ropp_mult_distr_l_reverse (INR x) alpha);
 rewrite (Rmult_comm (- INR x) alpha);
 rewrite <- (Rmult_plus_distr_l alpha (INR n) (- INR x));
 fold (INR n - INR x)%R in |- *;
 rewrite <- (minus_INR n x (lt_le_weak x n H));
 rewrite (Rmult_comm alpha (INR (n - x)));
 fold (frac_part_n_alpha (n - x)) in |- *;
 rewrite (minus_INR n (last (M N)) (lt_le_weak (last (M N)) n H1));
 unfold Rminus in |- *;
 rewrite (Rmult_comm (INR n + - INR (last (M N))) alpha);
 rewrite (Rmult_plus_distr_l alpha (INR n) (- INR (last (M N))));
 rewrite (Ropp_plus_distr (alpha * INR n) (alpha * - INR (last (M N))));
 rewrite <-
  (Rplus_assoc (alpha * INR n) (- (alpha * INR n))
     (- (alpha * - INR (last (M N))))); rewrite (Rplus_opp_r (alpha * INR n));
 elim (Rplus_ne (- (alpha * - INR (last (M N)))));
 intros a b; rewrite b; clear a b;
 rewrite (Rmult_comm alpha (- INR (last (M N))));
 rewrite <- (Ropp_mult_distr_l_reverse (- INR (last (M N))) alpha);
 rewrite (Ropp_involutive (INR (last (M N))));
 fold (frac_part_n_alpha (last (M N))) in |- *; intro;
 cut (0 < n - x).
intro; cut (n - x < M N).
intro; generalize (last_n (M N) (n - x) (prop_N (M N)) H4 H6 prop_alpha);
 intro;
 generalize
  (Rgt_not_le (frac_part_n_alpha (n - x)) (frac_part_n_alpha (last (M N))) H2);
 intro; elimtype False; auto with arith real.
apply (lt_minus_p n (M N) x H0).
apply (lt_minus2 x n H).
fold (frac_part_n_alpha n) in |- *; fold (frac_part_n_alpha x) in |- *;
 assumption.
fold (frac_part_n_alpha n) in |- *;
 fold (frac_part_n_alpha (n - last (M N))) in |- *;
 apply
  (Rlt_trans (frac_part_n_alpha n) (frac_part_n_alpha x)
     (frac_part_n_alpha (n - last (M N))) H7 H8).
rewrite <- H1; rewrite <- (minus_n_n (last (M N)));
 apply (after_last prop_alpha prop_N (M N)).
Qed.

(**********)
Lemma tech1 :
 forall N n : nat,
 N - first N <= n ->
 n < last N ->
 (frac_part_n_alpha n < frac_part_n_alpha (n + first N - last N))%R.
intros; cut (frac_part_n_alpha n < frac_part_n_alpha (n + first N))%R.
intro;
 cut
  (frac_part_n_alpha (n + first N) < frac_part_n_alpha (n + first N - last N))%R.
intro;
 apply
  (Rlt_trans (frac_part_n_alpha n) (frac_part_n_alpha (n + first N))
     (frac_part_n_alpha (n + first N - last N)) H1 H2).
cut (0 < n + first N).
cut (n + first N < M N).
intros;
 apply (tech_after_lt (M N) (n + first N) (n + first N - last N) H3 H2).
apply (lt_minus_not (last N) (n + first N)).
generalize (le_minus_plus N (first N) n H); intro;
 apply (lt_le_trans (last N) N (n + first N) (last_N N (prop_N N)) H4).
rewrite (last_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
generalize H2; clear H2;
 rewrite (first_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
intro; cut (last (M N) <= n + first (M N)).
intro; apply (inter31b N (n + first (M N)) H4 H2).
rewrite <- (last_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
rewrite <- (first_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
generalize (le_minus_plus N (first N) n H); intro;
 apply (le_trans (last N) N (n + first N) (last_N01 N) H4).
unfold M in |- *; rewrite (plus_comm (first N) (last N));
 apply (plus_lt_compat_r n (last N) (first N) H0).
generalize (le_minus_plus N (first N) n H); intro; cut (0 < N).
intro; apply (lt_le_trans 0 N (n + first N) H3 H2).
apply (arith_2_0 N (prop_N N)).
(**)
cut (0 < n).
cut (n < M N).
intros; apply (tech_after_lt (M N) n (n + first N) H2 H1).
generalize (lt_O_plus n (first N) H2); intro; apply Compare.not_eq_sym;
 red in |- *; intro; apply (lt_not_eq 0 (n + first N) H3 H4).
rewrite (first_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
generalize H0; rewrite (last_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real; clear H0; intro; apply (inter31a N n H2 H0).
generalize (lt_trans n (last N) N H0 (last_N N (prop_N N))); intro;
 unfold M in |- *; cut (N <= first N + last N).
intro; apply (lt_le_trans n N (first N + last N) H1 H2).
apply (le_N_M alpha_irr prop_alpha prop_N N (M N)); auto with arith real.
apply
 (lt_le_trans 0 (N - first N) n
    (lt_minus2 (first N) N (first_N N (prop_N N))) H).
Qed.

(**********)
Lemma tech_suc_N :
 forall N n : nat,
 0 < n ->
 n < N ->
 forall k : nat,
 0 < k ->
 k < N ->
 (frac_part_n_alpha n < frac_part_n_alpha k)%R ->
 frac_part_n_alpha k <> frac_part_n_alpha (after N n) ->
 (frac_part_n_alpha (after N n) < frac_part_n_alpha k)%R.
unfold after in |- *; intros; generalize H4; clear H4;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N);
 intro.
elim s; intros x y H4; clear s; elim y; intros; clear y; unfold Rgt in H6;
 cut (0 <= k).
elim H6; intros; elim H8; intros; generalize (H11 k H9 H2 H3);
 unfold Rge in |- *; unfold Rgt in |- *; intro; elim H12;
 auto with arith real.
intro; elimtype False; auto with arith real.
apply (lt_le_weak 0 k H1).
unfold frac_part_n_alpha in |- *; simpl in |- *; rewrite Rmult_0_l;
 rewrite fp_R0; elim (base_fp (INR k * alpha)); intros;
 unfold Rge in H4; elim H4; auto with arith real.
intro; elimtype False; auto with arith real.
Qed.

(**********)
Lemma tech_suc_M :
 forall N n : nat,
 N - first N <= n ->
 n < last N ->
 (exists k : nat,
    0 < k /\
    k < N /\
    (frac_part_n_alpha n < frac_part_n_alpha k)%R /\
    (frac_part_n_alpha k < frac_part_n_alpha (n + first N - last N))%R) ->
 False.
intros; elim H1; intros; clear H1.
elim H2; intros; elim H3; intros; clear H3; clear H2; elim H5; intros;
 clear H5.
cut (0 < n).
intro; cut (n < M N).
intros; cut (x < M N).
intro;
 elim (Rtotal_order (frac_part_n_alpha x) (frac_part_n_alpha (n + first N)));
 intro.
cut (n + first N = after (M N) n).
intro; rewrite H9 in H8;
 cut (frac_part_n_alpha x <> frac_part_n_alpha (after (M N) n)).
intro; generalize (tech_suc_N (M N) n H5 H6 x H1 H7 H2 H10).
intro;
 generalize
  (Rlt_asym (frac_part_n_alpha x) (frac_part_n_alpha (after (M N) n)) H8).
intro; auto with arith real.
apply
 (Rlt_dichotomy_converse (frac_part_n_alpha x)
    (frac_part_n_alpha (after (M N) n))).
left; auto with arith real.
apply sym_equal.
rewrite (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)).
apply (inter31a N n H5).
rewrite <- (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)).
assumption.
auto with arith real.
auto with arith real.
(**)
elim H8; intro; clear H8.
cut (x <> n + first N).
intro;
 generalize (contra_tech_fp_alp_irr alpha_irr prop_alpha x (n + first N) H8);
 auto with arith real.
cut (x < n + first N).
intro; red in |- *; intro; apply (lt_not_eq x (n + first N) H8); assumption.
generalize (le_minus_plus N (first N) n H); intro;
 apply (lt_le_trans x N (n + first N) H4 H8).
(**)
cut (0 < n + first (M N)).
intro; cut (n + first (M N) < M N).
intro;
 cut
  (frac_part_n_alpha x <> frac_part_n_alpha (after (M N) (n + first (M N)))).
intro; unfold Rgt in H9;
 rewrite
  (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N))) in H9;
 generalize (tech_suc_N (M N) (n + first (M N)) H8 H10 x H1 H7 H9 H11);
 intro; cut (last (M N) <= n + first (M N)).
intro; rewrite (inter31b N (n + first (M N)) H13 H10) in H12.
rewrite
 (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
    (refl_equal (first N + last N))) in H3;
 rewrite
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N))) in H3;
 generalize
  (Rlt_asym (frac_part_n_alpha (n + first (M N) - last (M N)))
     (frac_part_n_alpha x) H12); intro; auto with arith real.
generalize (le_minus_plus N (first N) n H); intro.
generalize (last_N01 N); intro.
rewrite <-
 (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
    (refl_equal (first N + last N)));
 rewrite <-
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N)));
 apply (le_trans (last N) N (n + first N) H14 H13).
cut (last (M N) <= n + first (M N)).
intro; rewrite (inter31b N (n + first (M N)) H11 H10);
 rewrite <-
  (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N)));
 rewrite <-
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N)));
 apply
  (Rlt_dichotomy_converse (frac_part_n_alpha x)
     (frac_part_n_alpha (n + first N - last N))).
left; assumption.
generalize (le_minus_plus N (first N) n H); intro.
generalize (last_N01 N); intro;
 rewrite <-
  (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N)));
 rewrite <-
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N)));
 apply (le_trans (last N) N (n + first N) H12 H11).
rewrite <-
 (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
    (refl_equal (first N + last N))); unfold M in |- *;
 rewrite (plus_comm (first N) (last N));
 apply (plus_lt_compat_r n (last N) (first N) H0).
apply (lt_O_plus n (first (M N)) H5).
cut (N <= M N).
intro; apply (lt_le_trans x N (M N) H4 H7).
apply
 (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (first N + last N))).
cut (last N < N).
intro; cut (N <= M N).
intro; generalize (lt_trans n (last N) N H0 H6).
intro; apply (lt_le_trans n N (M N) H8 H7).
apply
 (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (first N + last N))).
apply (last_N N (prop_N N)).
cut (0 < N - first N).
intro; apply (lt_le_trans 0 (N - first N) n H5 H).
apply (lt_minus2 (first N) N (first_N N (prop_N N))).
Qed.

(**********)
Lemma tech_suc_M1 :
 forall N n : nat,
 N - first N <= n ->
 n < last N ->
 forall k : nat,
 ~
 (0 < k /\
  k < N /\
  (frac_part_n_alpha n < frac_part_n_alpha k)%R /\
  (frac_part_n_alpha k < frac_part_n_alpha (n + first N - last N))%R).
intros; generalize (tech_suc_M N n H H0); intro; red in |- *; intro; apply H1;
 split with k; auto with arith real.
Qed.

(**********)
Lemma eq_after_M_N1 :
 forall N n : nat, 0 < n -> n < N - first N -> after (M N) n = after N n.
intros; cut (n < last (M N)).
intro; generalize (inter31a N n H H1);
 rewrite <-
  (first_eq_M_N alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)))
  ; intro; apply (tech_fp_alp_irr alpha_irr (after (M N) n) (after N n));
 apply
  (Rge_antisym (frac_part_n_alpha (after (M N) n))
     (frac_part_n_alpha (after N n))).
apply
 (Rnot_lt_ge (frac_part_n_alpha (after (M N) n))
    (frac_part_n_alpha (after N n))); red in |- *;
 intro; cut (0 < after (M N) n).
intro; cut (after (M N) n < N).
intro; cut (frac_part_n_alpha n < frac_part_n_alpha (after (M N) n))%R.
intro;
 generalize
  (tech_suc_N N n H (contra_lt_minus_p n N (first N) H0)
     (after (M N) n) H4 H5 H6
     (Rlt_dichotomy_converse (frac_part_n_alpha (after (M N) n))
        (frac_part_n_alpha (after N n))
        (or_introl
           (frac_part_n_alpha (after (M N) n) > frac_part_n_alpha (after N n))%R
           H3))); intro;
 generalize
  (Rlt_asym (frac_part_n_alpha (after (M N) n))
     (frac_part_n_alpha (after N n)) H3); intro; elimtype False;
 auto with arith real.
apply
 (tech_after_lt (M N) n (after (M N) n) H
    (lt_le_trans n N (M N) (contra_lt_minus_p n N (first N) H0)
       (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)))));
 auto with arith real.
rewrite H2; red in |- *; intro; apply (lt_O_plus_eq n (first N) H);
 auto with arith real.
rewrite H2; apply (lt_n_minus_plus n N (first N) H0).
rewrite H2; apply (lt_O_plus n (first N) H).
(**)
apply
 (Rnot_lt_ge (frac_part_n_alpha (after N n))
    (frac_part_n_alpha (after (M N) n))); red in |- *;
 intro; apply (prop_after (M N) n (after (M N) n));
 auto with arith real.
split with (after N n); split.
unfold after in |- *;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N).
intro; elim s; intros x y; elim y; intros; assumption.
intro; generalize (a (last N) (le_O_n (last N)) (last_N N (prop_N N))); intro;
 elim H4; intros; clear a H4;
 generalize
  (last_n N n (prop_N N) H (contra_lt_minus_p n N (first N) H0) prop_alpha);
 intro; cut (frac_part_n_alpha n = frac_part_n_alpha (last N)).
intro; generalize (tech_fp_alp_irr alpha_irr n (last N) H7);
 rewrite (last_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
intro; generalize (lt_not_eq n (last (M N)) H1); intro; elimtype False;
 auto with arith real.
elim (Rle_le_eq (frac_part_n_alpha n) (frac_part_n_alpha (last N))); intros;
 clear H8; apply H7; auto with arith real.
split.
cut (after N n < N).
intro;
 apply
  (lt_le_trans (after N n) N (M N) H4
     (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)))).
unfold after in |- *;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N).
intro; elim s; intros x y; elim y; intros; elim H5; intros; assumption.
intro; apply (arith_2_0 N (prop_N N)).
split; auto with arith real.
apply (tech_after_lt N n (after N n) H (contra_lt_minus_p n N (first N) H0));
 auto with arith real.
red in |- *; unfold after in |- *;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N).
intro; elim s; intros x y H4; elim y; intros; generalize (lt_not_eq 0 x H5);
 intro; auto with arith real.
intros; generalize (a (last N) (le_O_n (last N)) (last_N N (prop_N N)));
 intro; elim H5; intros; clear a H5;
 generalize
  (last_n N n (prop_N N) H (contra_lt_minus_p n N (first N) H0) prop_alpha);
 intro; cut (frac_part_n_alpha n = frac_part_n_alpha (last N)).
intro; generalize (tech_fp_alp_irr alpha_irr n (last N) H8);
 rewrite (last_eq_M_N alpha_irr prop_alpha prop_N N (M N));
 auto with arith real.
intro; generalize (lt_not_eq n (last (M N)) H1); intro; elimtype False;
 auto with arith real.
elim (Rle_le_eq (frac_part_n_alpha n) (frac_part_n_alpha (last N))); intros;
 clear H9; apply H8; auto with arith real.
cut (N - first N <= last (M N)).
intro; apply (lt_le_trans n (N - first N) (last (M N)) H0 H1).
generalize (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)));
 unfold M at 1 in |- *;
 rewrite <-
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)))
  ; intro; apply (le_plus_min N (first N) (last N) H1).
Qed.

(**********)
Lemma eq_after_M_N2 :
 forall N n : nat, last N <= n -> n < N -> after (M N) n = after N n.
intros; generalize (le_lt_or_eq (last N) n H); intro; elim H1; intro;
 clear H1.
rewrite (last_eq_M_N alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)))
  in H;
 generalize
  (inter31b N n H
     (lt_le_trans n N (M N) H0
        (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)))));
 rewrite <-
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)))
  ; intro; apply (tech_fp_alp_irr alpha_irr (after (M N) n) (after N n));
 apply
  (Rge_antisym (frac_part_n_alpha (after (M N) n))
     (frac_part_n_alpha (after N n))).
apply
 (Rnot_lt_ge (frac_part_n_alpha (after (M N) n))
    (frac_part_n_alpha (after N n))); red in |- *;
 intro; cut (0 < after (M N) n).
intro; cut (after (M N) n < N).
intro; cut (frac_part_n_alpha n < frac_part_n_alpha (after (M N) n))%R.
intro;
 generalize
  (tech_suc_N N n (lt_trans 0 (last N) n (last_0 N (prop_N N)) H2) H0
     (after (M N) n) H4 H5 H6
     (Rlt_dichotomy_converse (frac_part_n_alpha (after (M N) n))
        (frac_part_n_alpha (after N n))
        (or_introl
           (frac_part_n_alpha (after (M N) n) > frac_part_n_alpha (after N n))%R
           H3))); intro;
 generalize
  (Rlt_asym (frac_part_n_alpha (after (M N) n))
     (frac_part_n_alpha (after N n)) H3); intro; elimtype False;
 auto with arith real.
apply
 (tech_after_lt (M N) n (after (M N) n)
    (lt_trans 0 (last N) n (last_0 N (prop_N N)) H2)
    (lt_le_trans n N (M N) H0
       (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)))));
 auto with arith real.
rewrite H1; red in |- *; intro; apply (lt_minus_not (last N) n H2);
 auto with arith real.
rewrite H1; apply (lt_minus_p n N (last N) H0).
rewrite H1; apply (lt_minus2 (last N) n H2).
(**)
apply
 (Rnot_lt_ge (frac_part_n_alpha (after N n))
    (frac_part_n_alpha (after (M N) n))); red in |- *;
 intro; apply (prop_after (M N) n (after (M N) n));
 auto with arith real.
split with (after N n); split.
unfold after in |- *;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N).
intro; elim s; intros x y; elim y; intros; assumption.
intro; generalize (a (last N) (le_O_n (last N)) (last_N N (prop_N N))); intro;
 elim H4; intros; clear a H4;
 generalize
  (last_n N n (prop_N N) (lt_trans 0 (last N) n (last_0 N (prop_N N)) H2) H0
     prop_alpha); intro;
 cut (frac_part_n_alpha n = frac_part_n_alpha (last N)).
intro; generalize (tech_fp_alp_irr alpha_irr n (last N) H7).
intro; generalize (lt_not_eq (last N) n H2); intro; elimtype False;
 auto with arith real.
elim (Rle_le_eq (frac_part_n_alpha n) (frac_part_n_alpha (last N))); intros;
 clear H8; apply H7; auto with arith real.
split.
cut (after N n < N).
intro;
 apply
  (lt_le_trans (after N n) N (M N) H4
     (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (M N)))).
unfold after in |- *;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N).
intro; elim s; intros x y; elim y; intros; elim H5; intros; assumption.
intro; apply (arith_2_0 N (prop_N N)).
split; auto with arith real.
apply
 (tech_after_lt N n (after N n)
    (lt_trans 0 (last N) n (last_0 N (prop_N N)) H2) H0);
 auto with arith real.
red in |- *; unfold after in |- *;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N).
intro; elim s; intros x y H4; elim y; intros; generalize (lt_not_eq 0 x H5);
 intro; auto with arith real.
intros; generalize (a (last N) (le_O_n (last N)) (last_N N (prop_N N)));
 intro; elim H5; intros; clear a H5;
 generalize
  (last_n N n (prop_N N) (lt_trans 0 (last N) n (last_0 N (prop_N N)) H2) H0
     prop_alpha); intro;
 cut (frac_part_n_alpha n = frac_part_n_alpha (last N)).
intro; generalize (tech_fp_alp_irr alpha_irr n (last N) H8); intro;
 generalize (lt_not_eq (last N) n H2); intro; auto with arith real.
elim (Rle_le_eq (frac_part_n_alpha n) (frac_part_n_alpha (last N))); intros;
 clear H9; apply H8; auto with arith real.
rewrite <- H2; rewrite (after_last prop_alpha prop_N N);
 rewrite
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N))); auto with arith real;
 rewrite (after_last prop_alpha prop_N (M N)); trivial.
Qed.

End particular.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal5.

Set Printing Depth 1000.
Definition lfind_eval  x:=
len (rev x).


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L Require Import UpToC.
From Undecidability.L Require Import Functions.EqBool.

From Undecidability.L.Datatypes Require Export List.List_enc LBool LOptions LNat.

Set Default Proof Using "Type".

Section Fix_X.
  Variable (X:Type).
  Context {intX : encodable X}.

  Fixpoint inb eqb (x:X) (A: list X) :=
    match A with
      nil => false
    | a::A' => orb (eqb a x) (inb eqb x A')
    end.

  Variable X_eqb : X -> X -> bool.
  Hypothesis X_eqb_spec : (forall (x y:X), Bool.reflect (x=y) (X_eqb x y)).

  Lemma inb_spec: forall x A, Bool.reflect (In x A) (inb X_eqb x A).
  Proof using X_eqb_spec.
    intros x A. induction A.
    -constructor. tauto.
    -simpl. destruct (X_eqb_spec a x).
    +constructor. tauto.
    +inv IHA. destruct (X_eqb_spec a x).
      *constructor. tauto.
      *constructor. tauto.
      *constructor. tauto.
  Qed.

  Global Instance term_inb: computableTime' inb (fun eq eqT => (5,fun x _ => (1,fun l _ =>
                                        (fold_right (fun x' res => callTime2 eqT x' x
                                                                + res + 17) 4 l ,tt)))).
  Proof.
    extract.
    solverec.
  Defined. (*because other extract*)

  Global Instance term_inb_notime: computable inb.
  Proof.
    extract.
  Defined. (*because other extract*)

End Fix_X.

Section list_eqb.

  Variable X : Type.
  Variable eqb : X -> X -> bool.
  Variable spec : forall x y, reflect (x = y) (eqb x y).

  Fixpoint list_eqb A B :=
    match A,B with
    | nil,nil => true
    | a::A',b::B' => eqb a b && list_eqb A' B'
    | _,_ => false
    end.

  Lemma list_eqb_spec A B : reflect (A = B) (list_eqb A B).
  Proof using spec.
    revert B; induction A; intros; destruct B; cbn in *; try now econstructor.
    destruct (spec a x), (IHA B); cbn; econstructor; congruence.
  Qed.

End list_eqb.

Section int.

  Context {X : Type}.
  Context {HX : encodable X}.

  Fixpoint list_eqbTime (eqbT: timeComplexity (X -> X -> bool)) (A B:list X) :=
    match A,B with
      a::A,b::B => callTime2 eqbT a b + 22 + list_eqbTime eqbT A B
    | _,_ => 9
    end.

  Global Instance term_list_eqb : computableTime' (list_eqb (X:=X))
                                                  (fun _ eqbT => (1,(fun A _ => (5,fun B _ => (list_eqbTime eqbT A B,tt))))).
  Proof.
    extract.
    solverec.
  Qed.

  Definition list_eqbTime_leq (eqbT: timeComplexity (X -> X -> bool)) (A B:list X) k:
    (forall a b, callTime2 eqbT a b <= k)
    -> list_eqbTime eqbT A B <= length A * (k+22) + 9.
  Proof.
    intros H'. induction A in B|-*.
    -cbn. lia.
    -destruct B.
    {cbn. intuition. }
    cbn - [callTime2]. setoid_rewrite IHA.
    rewrite H'. ring_simplify. intuition.
  Qed.

  Lemma list_eqbTime_bound_r (eqbT : timeComplexity (X -> X -> bool)) (A B : list X) f:
    (forall (x y:X), callTime2 eqbT x y <= f y) ->
    list_eqbTime eqbT A B <= sumn (map f B) + 9 + length B * 22.
  Proof.
    intros H.
    induction A in B|-*;unfold list_eqbTime;fold list_eqbTime. now Lia.lia.
    destruct B.
    -cbn. Lia.lia.
    -rewrite H,IHA. cbn [length map sumn]. Lia.lia.
  Qed.

  Global Instance eqbList f `{eqbClass (X:=X) f}:
    eqbClass (list_eqb f).
  Proof.
    intros ? ?. eapply list_eqb_spec. all:eauto using eqb_spec.
  Qed.
  Import EqBool.
  Global Instance eqbComp_List `{eqbCompT X (R:=HX)}:
    eqbCompT (list X).
  Proof.
    evar (c:nat). exists c. unfold list_eqb.
    extract. unfold eqb,eqbTime. cbn - ["+"].
    [c]:exact (c__eqbComp X + 6).
    all:unfold c. set (c__eqbComp X).
    solverec. all: set (f:=enc (X:=list X)); unfold enc in f;subst f;cbn [size encodable_list_enc].
    all:try nia.
  Qed.
End int.


Require Import NonSpec.
Require Import Spec.
Require Import Coq.Sets.Ensembles.
Require Import erasure.
Require Import AST.
Require Import SfLib.

Theorem listAlign : forall (T:Type) l (x y :T) l' (e:T),
                      x::y::l = l' ++ [e] ->
                      exists l'', (y::l) = l'' ++ [e].
Proof.
  induction l; intros.
  {destruct l'. inversion H. exists nil. inversion H.
   destruct l'. inversion H2. auto. inversion H2. destruct l'; inversion H4. }
  {destruct l'.
   {inversion H. }
   {inversion H. exists l'. assumption. }
  }
Qed.

Theorem appNil : forall (T:Type) (x:T), [x] = nil ++ [x].
Proof.
  intros. auto. Qed.

Theorem unspecBasicAction1 : forall a M M' s2 tid tid' T,
                               basicAction a M' tid' ->
                               unspecPoolAux(tAdd T (tid, [a], s2, M)) =
                               unspecPoolAux(tAdd T (tid', nil, s2, M')).
Proof.
  intros. apply Extensionality_Ensembles. unfold Same_set. unfold Included. split; intros.
  {inversion H0; subst. inversion H1; subst. inversion H4; subst; clear H4. inversion H3; subst.
   {econstructor. econstructor. econstructor. eassumption. reflexivity. assumption. }
   {destruct tid'. destruct p. econstructor. econstructor. eapply Union_intror. econstructor.
    reflexivity. inversion H4; subst; clear H4. eapply unspecLastAct. eassumption. eassumption. }
  }
  {inversion H0; subst. inversion H1; subst. inversion H4; subst; clear H4. inversion H3; subst.
   {econstructor. econstructor. econstructor. eassumption. reflexivity. assumption. }
   {destruct tid. destruct p. econstructor. econstructor. apply Union_intror. econstructor.
    reflexivity. inversion H4; subst; clear H4. eapply unspecLastAct; eauto. }
  }
Qed.

Theorem unspecBasicAction2 : forall a b s1' s2 M M' tid tid' T,
                              basicAction a M' tid' ->
                              unspecPoolAux(tAdd T (tid, a::b::s1', s2, M)) =
                              unspecPoolAux(tAdd T (tid', b::s1', s2, M')).
Proof.
  intros. apply Extensionality_Ensembles. unfold Same_set. unfold Included. split; intros.
  {inversion H0; subst. inversion H1; subst. inversion H4; subst; clear H4. inversion H3; subst.
   {econstructor. econstructor. econstructor. eassumption. reflexivity. assumption. }
   {destruct tid'. destruct p. econstructor. econstructor. apply Union_intror. econstructor.
    reflexivity. inversion H4; subst; clear H4. eapply unspecTwoActs. eassumption. }
  }
  {inversion H0; subst. inversion H1; subst. inversion H4; subst; clear H4. inversion H3; subst.
   {econstructor. econstructor. econstructor. eassumption. reflexivity. assumption. }
   {destruct tid. destruct p. econstructor. econstructor. apply Union_intror. econstructor.
    reflexivity. inversion H4; subst; clear H4. eapply unspecTwoActs. eassumption. }
  }
Qed.

Theorem rollbackWellFormed : forall tid As H T H' T',
                               wellFormed H T -> rollback tid As H T H' T' ->
                               wellFormed H' T'.
Proof.
  intros. induction H1; subst.
  {assumption. }
  {apply IHrollback. inversion H0; subst. inversion H2; subst. destruct s1'.
   {eapply wf with (T' := (unspecPoolAux (tAdd T (tid', [rAct x tid'' M'], s2, M)))).
    erewrite unspecBasicAction1. econstructor. constructor. eapply unspecHeapRBRead; eauto.


Require Import Coq.PArith.BinPos.
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Specific.FancyMachine256.Core.

Definition compiled_syntax
:= fun (ops : fancy_machine.instructions (2 * 128)) (var : base_type -> Type) =>
(λ (x x0 : var TZ) (x1 x2 : var TW),
 slet x3 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TZ) (@Tbase base_type TW) OPldi
              (@Var base_type (interp_base_type ops) op var TZ x) in
 slet x4 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TZ) (@Tbase base_type TW) OPldi
              (@Var base_type (interp_base_type ops) op var TZ x0) in
 slet x5 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TZ) (@Tbase base_type TW) OPldi
              (@Const base_type (interp_base_type ops) op var (@Tbase base_type TZ) 0) in
 slet x6 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type TZ)%ctype
              (@Tbase base_type TW) OPshrd
              (@Var base_type (interp_base_type ops) op var TW x2, @Var base_type (interp_base_type ops) op var TW x1,
              @Const base_type (interp_base_type ops) op var (@Tbase base_type TZ) 250) in
 slet x7 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW)%ctype
              (@Tbase base_type TW) OPmulhwhh
              (@Var base_type (interp_base_type ops) op var TW x6, @Var base_type (interp_base_type ops) op var TW x4) in
 slet x8 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW)%ctype
              (@Tbase base_type TW) OPmulhwhl
              (@Var base_type (interp_base_type ops) op var TW x6, @Var base_type (interp_base_type ops) op var TW x4) in
 slet x9 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW)%ctype
              (@Tbase base_type TW) OPmulhwll
              (@Var base_type (interp_base_type ops) op var TW x6, @Var base_type (interp_base_type ops) op var TW x4) in
 slet x10 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type Tbool)%ctype
               (@Tbase base_type Tbool * @Tbase base_type TW)%ctype OPadc
               (@Var base_type (interp_base_type ops) op var TW x9,
               @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TZ)%ctype
                 (@Tbase base_type TW) OPshl
                 (@Var base_type (interp_base_type ops) op var TW x8,
                 @Const base_type (interp_base_type ops) op var (@Tbase base_type TZ) 128),
               @Const base_type (interp_base_type ops) op var (@Tbase base_type Tbool) false) in
 slet x11 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type Tbool)%ctype
               (@Tbase base_type Tbool * @Tbase base_type TW)%ctype OPadc
               (@Var base_type (interp_base_type ops) op var TW x7,
               @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TZ)%ctype
                 (@Tbase base_type TW) OPshr
                 (@Var base_type (interp_base_type ops) op var TW x8,
                 @Const base_type (interp_base_type ops) op var (@Tbase base_type TZ) 128),
               @Var base_type (interp_base_type ops) op var Tbool (let (H, _) := x10 in H)) in
 slet x12 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW)%ctype
               (@Tbase base_type TW) OPmulhwhl
               (@Var base_type (interp_base_type ops) op var TW x4, @Var base_type (interp_base_type ops) op var TW x6) in
 slet x13 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type Tbool)%ctype
               (@Tbase base_type Tbool * @Tbase base_type TW)%ctype OPadc
               (@Var base_type (interp_base_type ops) op var TW (let (_, H) := x10 in H),
               @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TZ)%ctype
                 (@Tbase base_type TW) OPshl
                 (@Var base_type (interp_base_type ops) op var TW x12,
                 @Const base_type (interp_base_type ops) op var (@Tbase base_type TZ) 128),
               @Const base_type (interp_base_type ops) op var (@Tbase base_type Tbool) false) in
 slet x14 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type Tbool)%ctype
               (@Tbase base_type Tbool * @Tbase base_type TW)%ctype OPadc
               (@Var base_type (interp_base_type ops) op var TW (let (_, H) := x11 in H),
               @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TZ)%ctype
                 (@Tbase base_type TW) OPshr
                 (@Var base_type (interp_base_type ops) op var TW x12,
                 @Const base_type (interp_base_type ops) op var (@Tbase base_type TZ) 128),
               @Var base_type (interp_base_type ops) op var Tbool (let (H, _) := x13 in H)) in
 slet x15 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW)%ctype
               (@Tbase base_type TW) OPmulhwll
               (@Var base_type (interp_base_type ops) op var TW (let (_, H) := x14 in H),
               @Var base_type (interp_base_type ops) op var TW x3) in
 slet x16 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW)%ctype
               (@Tbase base_type TW) OPmulhwhl
               (@Var base_type (interp_base_type ops) op var TW (let (_, H) := x14 in H),
               @Var base_type (interp_base_type ops) op var TW x3) in
 slet x17 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type Tbool)%ctype
               (@Tbase base_type Tbool * @Tbase base_type TW)%ctype OPadc
               (@Var base_type (interp_base_type ops) op var TW x15,
               @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TZ)%ctype
                 (@Tbase base_type TW) OPshl
                 (@Var base_type (interp_base_type ops) op var TW x16,
                 @Const base_type (interp_base_type ops) op var (@Tbase base_type TZ) 128),
               @Const base_type (interp_base_type ops) op var (@Tbase base_type Tbool) false) in
 slet x18 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW)%ctype
               (@Tbase base_type TW) OPmulhwhl
               (@Var base_type (interp_base_type ops) op var TW x3,
               @Var base_type (interp_base_type ops) op var TW (let (_, H) := x14 in H)) in
 slet x19 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type Tbool)%ctype
               (@Tbase base_type Tbool * @Tbase base_type TW)%ctype OPadc
               (@Var base_type (interp_base_type ops) op var TW (let (_, H) := x17 in H),
               @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TZ)%ctype
                 (@Tbase base_type TW) OPshl
                 (@Var base_type (interp_base_type ops) op var TW x18,
                 @Const base_type (interp_base_type ops) op var (@Tbase base_type TZ) 128),
               @Const base_type (interp_base_type ops) op var (@Tbase base_type Tbool) false) in
 slet x20 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type Tbool)%ctype
               (@Tbase base_type Tbool * @Tbase base_type TW)%ctype OPsubc
               (@Var base_type (interp_base_type ops) op var TW x1,
               @Var base_type (interp_base_type ops) op var TW (let (_, H) := x19 in H),
               @Const base_type (interp_base_type ops) op var (@Tbase base_type Tbool) false) in
 slet x21 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type TW)%ctype
               (@Tbase base_type TW) OPaddm
               (@Var base_type (interp_base_type ops) op var TW (let (_, H) := x20 in H),
               @Var base_type (interp_base_type ops) op var TW x5, @Var base_type (interp_base_type ops) op var TW x3) in
 slet x22 := @Op base_type (interp_base_type ops) op var (@Tbase base_type TW * @Tbase base_type TW * @Tbase base_type TW)%ctype
               (@Tbase base_type TW) OPaddm
               (@Var base_type (interp_base_type ops) op var TW x21, @Var base_type (interp_base_type ops) op var TW x5,
               @Var base_type (interp_base_type ops) op var TW x3) in
 @Var base_type (interp_base_type ops) op var TW x22)%expr.

Definition v ops :=
  Eval cbv [compiled_syntax] in (DefaultAssembleSyntax (compiled_syntax ops)).

Local Open Scope positive_scope.

Require Import Crypto.Reflection.Named.Syntax.

Time Eval lazy in v. (* Finished transaction in 0.033 secs (0.032u,0.004s) (successful) *)
Time Eval compute in v. (* Finished transaction in 0.03 secs (0.032u,0.s) (successful) *)
Time Eval native_compute in v. (* Finished transaction in 0.081 secs (0.012u,0.016s) (successful) *)
Fail Timeout 5 Eval vm_compute in v. (* The command has indeed failed with message:
         Timeout! *)
Goal fancy_machine.instructions (2 * 128) -> True.
  intros ops.
  pose (v ops) as v'.
  unfold v in *; rename v' into v.
  let T := type of v in set (T' := T) in *; vm_compute in T'; subst T'.
  unfold DefaultAssembleSyntax, AssembleSyntax, AssembleSyntax', DeadCodeElimination.CompileAndEliminateDeadCode in (value of v).
  set (k := List.map _ _) in (value of v); vm_compute in k; subst k.
  set (v' := Compile.compile _ _) in (value of v); vm_compute in v'; subst v'.
  cbv beta iota in v.
  set (k := EstablishLiveness.insert_dead_names _ _ _) in (value of v).
  unfold EstablishLiveness.insert_dead_names in (value of k).
  revert v; set (n := DefaultRegisters _) in (value of k); intro v.
  vm_compute in n; subst n.
  revert v; set (l := EstablishLiveness.compute_liveness _ _ _) in (value of k); intro v.
  unfold EstablishLiveness.compute_liveness in (value of l).
  Notation hidden := (FMapPositive.PositiveMap.Node _ _ _).
  pose I as c.
  (* HERE: change 15 to other values to see exponential behavior of vm_compute *)
  do 15 (let m := fresh "c" in
         unfold EstablishLiveness.compute_livenessf in (value of l); fold (@EstablishLiveness.compute_livenessf base_type (interp_base_type _) op positive _) in (value of l); unfold EstablishLiveness.compute_livenessf_step at 1 in (value of l);
         revert k v; set (m := extend _ _ _) in (value of l); intros k v;
         vm_compute in m;
         subst c; rename m into c;
         simpl @List.app in (value of l));
    time vm_compute in v.


From mathcomp Require Import all_ssreflect.
From Usuba Require Import usuba_AST usuba_sem equiv_rel.

Goal
    forall arch prog type_ctxt ctxt opt_ctxt' var typ dir,
        find_val type_ctxt var = Some typ ->
        well_typed_ctxt type_ctxt ctxt ->
        convert_type typ nil = Some (dir, 1::nil) ->
        eval_deq arch prog type_ctxt ctxt
            (Eqn (Index (Var var) (Const_e 0) :: (Index (Var var) (Const_e 0)) :: nil) (Tuple (ECons (Const 1 None)
                            (ECons (Const 2 None) Enil)))
                true) = opt_ctxt'
        -> (ctxt' <- opt_ctxt'; find_val ctxt' var) = Some (CoIR dir (2::nil) (Some (1::nil))).
Proof.
    simpl.
    unfold bind; unfold bind_aux_list.
    unfold bind_aux.
    simpl.
    move=> _ _ type_ctxt ctxt opt_ctxt var typ dir HEqType well_typed.
    rewrite HEqType; move=> Convert; rewrite Convert; simpl.
    case_eq (find_val ctxt var).
    {
        move=> c HEq.
        pose (p := well_typed_ctxt_imp_find_val _ _ _ _ well_typed HEq).
        destruct p as [typ' [find_typ valoType]].
        rewrite find_typ in HEqType; inversion HEqType as [HEq'].
        destruct HEq'; clear HEqType.
        destruct c as [|d [|hd tl] form]; simpl.
        {
            rewrite String.eqb_refl; simpl.
            move=> <-; simpl.
            rewrite String.eqb_refl; reflexivity.
        }
        {
            exfalso.
            apply (val_of_type_len _ _ _ dir _ [:: 1]) in valoType; trivial.
            simpl in valoType.
            unfold muln, muln_rec in valoType.
            rewrite PeanoNat.Nat.mul_1_l in valoType; discriminate.
        }
        destruct tl; simpl.
        {
            rewrite String.eqb_refl; simpl.
            move=> <-; simpl.
            rewrite String.eqb_refl; reflexivity.
        }
        {
            exfalso.
            apply (val_of_type_len _ _ _ dir _ [:: 1]) in valoType; trivial.
            simpl in valoType.
            unfold muln, muln_rec in valoType.
            rewrite PeanoNat.Nat.mul_1_l in valoType; discriminate.
        }
    }
    {
        move=> _; simpl; rewrite String.eqb_refl; simpl.
        move=> <-; simpl.
        rewrite String.eqb_refl; reflexivity.
    }
Qed.

Goal
    update (2::nil) (1::2::nil) (ASlice [:: 0] AAll) [:: CoIL 1] (DirH 8) = Some (1::2::nil, nil).
Proof.
    simpl; reflexivity.
Qed.

Goal
    forall arch prog type_ctxt ctxt opt_ctxt' var typ dir,
        find_val type_ctxt var = Some typ ->
        well_typed_ctxt type_ctxt ctxt ->
        convert_type typ nil = Some (dir, 2::nil) ->
        eval_deq arch prog type_ctxt ctxt
             (Eqn (Range (Var var) (Const_e 1) (Const_e 0)::nil) (Tuple (ECons (Const 1 None)
                            (ECons (Const 2 None) Enil)))
                true) = opt_ctxt'
        -> (ctxt' <- opt_ctxt'; find_val ctxt' var) = Some (CoIR dir (2::1::nil) (Some (2::nil))).
Proof.
    simpl.
    unfold bind; unfold bind_aux_list.
    unfold bind_aux.
    simpl.
    move=> _ _ type_ctxt ctxt opt_ctxt var typ dir HEqType well_typed.
    rewrite HEqType; move=> Convert; rewrite Convert; simpl.
    case_eq (find_val ctxt var).
    {
        move=> c HEq.
        pose (p := well_typed_ctxt_imp_find_val _ _ _ _ well_typed HEq).
        destruct p as [typ' [find_typ valoType]].
        rewrite find_typ in HEqType; inversion HEqType as [HEq'].
        destruct HEq'; clear HEqType.
        destruct typ' as [|d m n|typ len]; simpl in Convert.
        by discriminate.
        all: swap 1 2.
        {
            destruct (eval_arith_expr nil len) as [ilen|].
            2: by discriminate.
            exfalso; move: Convert.
            clear.
            pose (p := [:: ilen]); fold p.
            assert (p <> nil) as NotEmpty by (unfold p; move=> Eq; discriminate).
            move: p NotEmpty; clear.
            induction typ as [|d m n|typ HRec len']; simpl.
            by discriminate.
            {
                destruct m.
                + move=> []; destruct d; auto.
                    3-6: by discriminate.
                    1-2: move=> a []; simpl; discriminate.
                + discriminate.
                + discriminate.
            }
            {
                destruct (eval_arith_expr nil len').
                2: by discriminate.
                move=> [|hd tl] NotEmpty.
                by exfalso; apply NotEmpty; reflexivity.
                apply HRec.
                discriminate.
            }
        }
        simpl in *.
        destruct m as [| |].
        2,3: by destruct valoType.
        destruct c as [|d' l form]; simpl.
        {
            destruct d.
            3-6: discriminate.
            all: inversion Convert.
            all: destruct valoType as [_ [_ HEq2]].
            all: symmetry in HEq2; destruct HEq2; discriminate.
        }
        destruct form.
        2: by destruct valoType.
        rewrite muln1 in valoType.
        destruct d.
        3-5: by discriminate.
        all: inversion Convert as [[HEq2 HEq3]]; clear Convert; simpl.
        all: destruct HEq2.
        all: symmetry in HEq3; destruct HEq3.
        all: destruct valoType as [simpl_eq [length_eq dir_eq]].
        all: rewrite length_eq; simpl.
        all: destruct l as [|h1 l].
        1,3: by discriminate.
        all: destruct l as [|h2 l].
        1,3: by discriminate.
        all: destruct l as [|].
        2,4: by discriminate.
        all: simpl.
        all: move=> <-; simpl.
        all: rewrite String.eqb_refl.
        all: reflexivity.
    }
    {
        simpl.
        move=> _ <-; simpl.
        rewrite String.eqb_refl.
        reflexivity.
    }
Qed.


From iris.proofmode Require Import tactics.
From iris.algebra Require Import excl agree csum.
From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import assert proofmode notation adequacy.
From iris.heap_lang.lib Require Import par.
Set Default Proof Using "Type".

(** This is the introductory example from the "Iris from the Ground Up" journal
paper. *)

Definition one_shot_example : val := λ: <>,
  let: "x" := ref NONE in (
  (* tryset *) (λ: "n",
    CAS "x" NONE (SOME "n")),
  (* check  *) (λ: <>,
    let: "y" := !"x" in λ: <>,
    match: "y" with
      NONE => #()
    | SOME "n" =>
       match: !"x" with
         NONE => assert: #false
       | SOME "m" => assert: "n" = "m"
       end
    end)).

Definition one_shotR := csumR (exclR unitO) (agreeR ZO).
Definition Pending : one_shotR := Cinl (Excl ()).
Definition Shot (n : Z) : one_shotR := Cinr (to_agree n).

Class one_shotG Σ := { one_shot_inG :> inG Σ one_shotR }.
Definition one_shotΣ : gFunctors := #[GFunctor one_shotR].
Instance subG_one_shotΣ {Σ} : subG one_shotΣ Σ → one_shotG Σ.
Proof. solve_inG. Qed.

Section proof.
Local Set Default Proof Using "Type*".
Context `{!heapG Σ, !one_shotG Σ}.

Definition one_shot_inv (γ : gname) (l : loc) : iProp Σ :=
  (l ↦ NONEV ∗ own γ Pending ∨ ∃ n : Z, l ↦ SOMEV #n ∗ own γ (Shot n))%I.

Lemma wp_one_shot (Φ : val → iProp Σ) :
  (∀ f1 f2 : val,
    (∀ n : Z, □ WP f1 #n {{ w, ⌜w = #true⌝ ∨ ⌜w = #false⌝ }}) ∗
    □ WP f2 #() {{ g, □ WP g #() {{ _, True }} }} -∗ Φ (f1,f2)%V)
  ⊢ WP one_shot_example #() {{ Φ }}.
Proof.
  iIntros "Hf /=". pose proof (nroot .@ "N") as N.
  rewrite -wp_fupd. wp_lam. wp_alloc l as "Hl".
  iMod (own_alloc Pending) as (γ) "Hγ"; first done.
  iMod (inv_alloc N _ (one_shot_inv γ l) with "[Hl Hγ]") as "#HN".
  { iNext. iLeft. by iSplitL "Hl". }
  wp_pures. iModIntro. iApply "Hf"; iSplit.
  - iIntros (n) "!>". wp_lam. wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as ">[[Hl Hγ]|H]"; last iDestruct "H" as (m) "[Hl Hγ]".
    + iMod (own_update with "Hγ") as "Hγ".
      { by apply cmra_update_exclusive with (y:=Shot n). }
      wp_cmpxchg_suc. iModIntro. iSplitL; last (wp_pures; by eauto).
      iNext; iRight; iExists n; by iFrame.
    + wp_cmpxchg_fail. iModIntro. iSplitL; last (wp_pures; by eauto).
      rewrite /one_shot_inv; eauto 10.
  - iIntros "!> /=". wp_lam. wp_bind (! _)%E.
    iInv N as ">Hγ".
    iAssert (∃ v, l ↦ v ∗ ((⌜v = NONEV⌝ ∗ own γ Pending) ∨
       ∃ n : Z, ⌜v = SOMEV #n⌝ ∗ own γ (Shot n)))%I with "[Hγ]" as "Hv".
    { iDestruct "Hγ" as "[[Hl Hγ]|Hl]"; last iDestruct "Hl" as (m) "[Hl Hγ]".
      + iExists NONEV. iFrame. eauto.
      + iExists (SOMEV #m). iFrame. eauto. }
    iDestruct "Hv" as (v) "[Hl Hv]". wp_load.
    iAssert (one_shot_inv γ l ∗ (⌜v = NONEV⌝ ∨ ∃ n : Z,
      ⌜v = SOMEV #n⌝ ∗ own γ (Shot n)))%I with "[Hl Hv]" as "[Hinv #Hv]".
    { iDestruct "Hv" as "[[% ?]|Hv]"; last iDestruct "Hv" as (m) "[% ?]"; subst.
      + Show. iSplit. iLeft; by iSplitL "Hl". eauto.
      + iSplit. iRight; iExists m; by iSplitL "Hl". eauto. }
    iSplitL "Hinv"; first by eauto.
    iModIntro. wp_pures. iIntros "!>". wp_lam.
    iDestruct "Hv" as "[%|Hv]"; last iDestruct "Hv" as (m) "[% Hγ']";
      subst; wp_match; [done|].
    wp_bind (! _)%E.
    iInv N as "[[Hl >Hγ]|H]"; last iDestruct "H" as (m') "[Hl Hγ]".
    { by iDestruct (own_valid_2 with "Hγ Hγ'") as %?. }
    wp_load. Show.
    iDestruct (own_valid_2 with "Hγ Hγ'") as %?%to_agree_op_inv_L; subst.
    iModIntro. iSplitL "Hl".
    { iNext; iRight; by eauto. }
    wp_apply wp_assert. wp_pures. by case_bool_decide.
Qed.

Lemma ht_one_shot (Φ : val → iProp Σ) :
  ⊢ {{ True }} one_shot_example #()
    {{ ff,
      (∀ n : Z, {{ True }} Fst ff #n {{ w, ⌜w = #true⌝ ∨ ⌜w = #false⌝ }}) ∗
      {{ True }} Snd ff #() {{ g, {{ True }} g #() {{ _, True }} }}
    }}.
Proof.
  iIntros "!> _". iApply wp_one_shot. iIntros (f1 f2) "[#Hf1 #Hf2]"; iSplit.
  - iIntros (n) "!> _". wp_apply "Hf1".
  - iIntros "!> _". wp_apply (wp_wand with "Hf2"). by iIntros (v) "#? !> _".
Qed.
End proof.

(* Have a client with a closed proof. *)
Definition client : expr :=
  let: "ff" := one_shot_example #() in
  (Fst "ff" #5 ||| let: "check" := Snd "ff" #() in "check" #()).

Section client.
  Context `{!heapG Σ, !one_shotG Σ, !spawnG Σ}.

  Lemma client_safe : ⊢ WP client {{ _, True }}.
  Proof using Type*.
    rewrite /client. wp_apply wp_one_shot. iIntros (f1 f2) "[#Hf1 #Hf2]".
    wp_let. wp_apply wp_par.
    - wp_apply "Hf1".
    - wp_proj. wp_bind (f2 _)%E. iApply wp_wand; first by iExact "Hf2".
      iIntros (check) "Hcheck". wp_pures. iApply "Hcheck".
    - auto.
  Qed.
End client.

(** Put together all library functors. *)
Definition clientΣ : gFunctors := #[ heapΣ; one_shotΣ; spawnΣ ].
(** This lemma implicitly shows that these functors are enough to meet
all library assumptions. *)
Lemma client_adequate σ : adequate NotStuck client σ (λ _ _, True).
Proof. apply (heap_adequacy clientΣ)=> ?. iIntros "_". iApply client_safe. Qed.

(* Since we check the output of the test files, this means
our test suite will fail if we ever accidentally add an axiom
to anything used by this proof. *)
Print Assumptions client_adequate.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L Require Import UpToC.
From Undecidability.L.Datatypes Require Export List_enc List_in List_basics LBool LNat.

Set Default Proof Using "Type".

Definition lengthEq A :=
  fix f (t:list A) n :=
    match n,t with
      0,nil => true
    | (S n), _::t => f t n
    | _,_ => false
    end.
Lemma lengthEq_spec A (t:list A) n:
| t | =? n = lengthEq t n.
Proof.
  induction n in t|-*;destruct t;now cbn.
Qed.
Definition lengthEq_time k := k * 15 + 9.
Instance term_lengthEq A `{registered A} : computableTime' (lengthEq (A:=A)) (fun l _ => (5, fun n _ => (lengthEq_time (min (length l) n),tt))).
Proof.
  extract. unfold lengthEq_time. solverec.
Qed.

(* seq *)
Definition c__seq := 20.
Definition seq_time (len : nat) := (len + 1) * c__seq.
Instance term_seq : computableTime' seq (fun start _ => (5, fun len _ => (seq_time len, tt))).
Proof.
  extract. solverec.
  all: unfold seq_time, c__seq; solverec.
Defined.

(* prodLists *)
Section fixprodLists.
  Variable (X Y : Type).
  Context `{Xint : registered X} `{Yint : registered Y}.

  Definition c__prodLists1 := 22 + c__map + c__app.
  Definition c__prodLists2 := 2 * c__map + 39 + c__app.
  Definition prodLists_time (l1 : list X) (l2 : list Y) := (|l1|) * (|l2| + 1) * c__prodLists2 + c__prodLists1.
  Global Instance term_prodLists : computableTime' (@list_prod X Y) (fun l1 _ => (5, fun l2 _ => (prodLists_time l1 l2, tt))).
  Proof.
    apply computableTimeExt with (x := fix rec (A : list X) (B : list Y) : list (X * Y) :=
      match A with
      | [] => []
      | x :: A' => map (@pair X Y x) B ++ rec A' B
      end).
    1: { unfold list_prod. change (fun x => ?h x) with h. intros l1 l2. induction l1; easy. }
    extract. solverec.
    all: unfold prodLists_time, c__prodLists1, c__prodLists2; solverec.
    rewrite map_length, map_time_const. leq_crossout.
  Defined.
End fixprodLists.