Require Import List Lia Relation_Operators.
Import ListNotations.

From Undecidability.StackMachines.Util Require Import Nat_facts List_facts.
Require Import Undecidability.StackMachines.Reductions.CM1_HALT_to_SMNdl_UB.SMX.

Require Import ssreflect ssrbool ssrfun.

Set Default Proof Using "Type".
Set Default Goal Selector "!".

Section SMX_facts.
Context {State Symbol : Set}.

Local Definition Config := @Config State Symbol.

(* reachable in at most n steps *)
Inductive reachable_n (M: SMX) : nat -> Config -> Config -> Prop :=
  | reach_refl (n: nat) (X: Config) : reachable_n M n X X
  | reach_step (n: nat) (X Y Z: Config) : step M X Y -> reachable_n M n Y Z -> reachable_n M (1+n) X Z.

Definition terminal (M: SMX) (X: Config) : Prop :=
  forall (Y: Config), not (step M X Y).

(* terminating or reachable in at most n steps *)
Definition maybe_reachable (M: SMX) (n: nat) (X Y: Config) : Prop :=
  reachable_n M n X Y \/ (exists Z, reachable_n M n X Z /\ terminal M Z).

Lemma reachable_n_maybe_reachable {M n X Y} : reachable_n M n X Y-> maybe_reachable M n X Y.
Proof. move=> ?. by left. Qed.

Lemma terminal_maybe_reachable {M n X Y} : terminal M X -> maybe_reachable M n X Y.
Proof. move=> ?. right. exists X. constructor; [by apply: reach_refl | done]. Qed.

Lemma reachable_n_step {M X Y} : step M X Y -> reachable_n M 1 X Y.
Proof. move=> ?. apply: reach_step; [by eassumption | by apply: reach_refl]. Qed.

Lemma reachable_n_mon {M n m X Y} :
  n <= m -> reachable_n M n X Y -> reachable_n M m X Y.
Proof.
  elim: n m X Y.
  { move=> m X Y ?. move Hn: (0) => n HXY.
    case: HXY Hn => *; [by apply: reach_refl | by lia]. }
  move=> n IH m X Y Hnm. move Hn': (S n) => n' HXY.
  case: HXY Hn' => [|{}n'] *; first by apply: reach_refl.
  have ->: m = S (m - 1) by lia.
  apply: reach_step; first by eassumption. apply: IH; first by lia.
  by (have ->: n = n' by lia).
Qed.

Lemma reachable_n_trans {M} n m X Y Z :
  reachable_n M n X Y -> reachable_n M m Y Z -> reachable_n M (n+m) X Z.
Proof.
  elim: n X Y.
  { move=> X Y /=. move Hn: (0) => n HXY. case: HXY Hn; [done | by lia]. }
  move=> n IH X Y /=. move Hn': (S n) => n' HXY. case: HXY Hn' => [| {}n' {}X Y1 Y2] *.
  { apply: reachable_n_mon; last by eassumption. by lia. }
  have ?: n' = n by lia. subst n'.
  apply: reach_step; first by eassumption. by apply: IH; eassumption.
Qed.

Lemma reachable_n_refl' {M n X X'} :
  X = X' -> reachable_n M n X X'.
Proof. move=> ->. by apply: reach_refl. Qed.

Lemma reachable_n_mon' {M n n' X X' Y Y'} :
  n <= n' -> (X, Y) = (X', Y') -> reachable_n M n X Y -> reachable_n M n' X' Y'.
Proof. move=> ? [? ?] ?. subst. by apply: reachable_n_mon; eassumption. Qed.

Lemma reachable_n_trans' {M} n {m k X X' Y Z} :
  m+n <= k -> X = X' -> reachable_n M n Y Z -> reachable_n M m X Y -> reachable_n M k X' Z.
Proof. move /reachable_n_mon => H *. subst. apply: H. by apply: reachable_n_trans; eassumption. Qed.

Lemma reachable_n_reachable {M T x y} :
  reachable_n M T x y -> reachable M x y.
Proof.
  elim: T x y.
  { move HT: (0) => T x y Hxy. case: Hxy HT => *; [by apply: rt_refl | by lia]. }
  move=> T IH x y. move HT': (S T) => T' Hxy.
  case: Hxy HT'; first by (move=> *; apply: rt_refl).
  move=> {}T' {}x z {}y /(@rt_step Config) Hxz + ?.
  have ->: T' = T by lia. move /IH. by apply: rt_trans.
Qed.

Lemma maybe_reachable_refl' {M n X Y} : X = Y -> maybe_reachable M n X Y.
Proof. move=> ->. left. by apply: reach_refl. Qed.

Lemma maybe_reachable_mon' {M n n' X X' Y Y'} :
  n <= n' -> (X, Y) = (X', Y') -> maybe_reachable M n X Y -> maybe_reachable M n' X' Y'.
Proof.
  move /reachable_n_mon => H [-> ->] [?|]; first by (left; apply: H).
  move=> [Z [HZ ?]]. right. exists Z. by constructor; [apply: H | ].
Qed.

Lemma maybe_reachable_trans' {M} n {m k X X' Y Z} :
  m + n <= k -> X = X' -> maybe_reachable M n Y Z -> maybe_reachable M m X Y -> maybe_reachable M k X' Z.
Proof.
  move /reachable_n_mon => H <- HYZ [?|]; first last.
  { move=> [Z' [HZ' ?]]. right. exists Z'. constructor; last done.
    apply: H. apply: reachable_n_mon; last by eassumption. by lia. }
  move: HYZ => [? | [Z' [HZ' ?]]].
  { left. apply: H. by apply: reachable_n_trans; eassumption. }
  right. exists Z'. constructor; last done.
  apply: H. by apply: reachable_n_trans; eassumption.
Qed.

Lemma first_step {M} (op : Instruction) (v w: list Symbol) {n X Z} :
  1 <= n -> In op M ->
  let '((r, s, x), (r', s', y), b) := op in
    X = (r ++ v, s ++ w, x) ->
    reachable_n M (n-1) (if b is true then (s' ++ w, r' ++ v, y) else (r' ++ v, s' ++ w, y)) Z ->
    reachable_n M n X Z.
Proof.
  move=> Hn. move: op=> [[[[r s] x] [[r' s'] y]] b].
  move /(transition M v w) /reachable_n_step => + ? ?. subst X.
  by (apply: (reachable_n_trans' (n-1)); first by lia).
Qed.

Lemma maybe_first_step {M} (op : Instruction) (v w: list Symbol) {n X Z} :
  1 <= n -> In op M ->
  let '((r, s, x), (r', s', y), b) := op in
    X = (r ++ v, s ++ w, x) ->
    maybe_reachable M (n-1) (if b is true then (s' ++ w, r' ++ v, y) else (r' ++ v, s' ++ w, y)) Z ->
    maybe_reachable M n X Z.
Proof.
  move=> Hn. move: op=> [[[[r s] x] [[r' s'] y]] b].
  move /(transition M v w) /reachable_n_step => HXY ? HYZ. subst X.
  move: HYZ => [? | [Z' [HZ' ?]]].
  - left. move: HXY. by (apply: (reachable_n_trans' (n-1)); first by lia).
  - right. exists Z'. constructor; last done.
    move: HXY. by (apply: (reachable_n_trans' (n-1)); first by lia).
Qed.

End SMX_facts.


(* It would be desirable to follow the article and formalize for every possible
   Id, Exp and Bexp. We just need to assert their properties. *)
Axiom Id : Set.
Axiom Exp : Set.
Axiom Bexp : Set.

Inductive Com : Set :=
| cskip : Com
| cassign : Id -> Exp -> Com
| cseq : Com -> Com -> Com
| cif : Bexp -> Com -> Com -> Com
| cwhile : Bexp -> Com -> Com
| cpar : Com -> Com -> Com
| cawait : Bexp -> Com -> Com.

Require Import Coq.MSets.MSets.

(* To define a weak finite set of [Id], it has to be decidable. Is there a way
   to assert the existance of a module with some signature? Should I just
   formalize the article inside of a functor with a [DecidableType] parameter? *)
Module IdDec <: DecidableType.
  Definition t := Id.
  Axiom eq : t -> t -> Prop.
  Declare Instance eq_equiv : Equivalence eq.
  Parameter eq_dec : forall x y : t, { eq x y } + { ~ (eq x y) }.
End IdDec.

Module IdSet := MSetWeakList.Make IdDec.
Module IdSetProps := Properties IdSet.

(* Those axioms are ok, they are only require because we want to keep the [Exp]
   and [Bexp] abstract. *)
Axiom freeE : Exp -> IdSet.t.
Axiom freeB : Bexp -> IdSet.t.
Fixpoint freeC (c : Com) : IdSet.t :=
  match c with
  | cskip => IdSet.empty
  | cassign x e => IdSet.add x (freeE e)
  | cseq c1 c2 => IdSet.union (freeC c1) (freeC c2)
  | cif b c1 c2 => IdSet.union (freeB b) (IdSet.union (freeC c1) (freeC c2))
  | cwhile b c => IdSet.union (freeB b) (freeC c)
  | cpar c1 c2 => IdSet.union (freeC c1) (freeC c2)
  | cawait b c => IdSet.union (freeB b) (freeC c)
  end.

(*
In the article, it is defined as following:
Let S = Id ->p N denote the set of states, ranged over by s.
Does ->p means it is a partial function?
In this case, the definition should probably be the following:
Definition S := Id -> option nat.
*)
Definition S := Id -> nat.

(*
If I represent S as a Coq function, how can I define the [dom] function?
*)
Axiom dom : S -> IdSet.t.

Definition S_add (x : Id) (n : nat) (s : S) :=
  fun y => if IdDec.eq_dec x y then n else s y.

Definition defined_onE (e : Exp)  (s : S) := IdSet.Subset (freeE e) (dom s).
Definition defined_onB (b : Bexp) (s : S) := IdSet.Subset (freeB b) (dom s).
Definition defined_onC (c : Com)  (s : S) := IdSet.Subset (freeC c) (dom s).

(* Those correspond to the following in the article (§3):
   When s is a state defined on (at least the free identifiers of E, we write
   <E,s> ->* n to indicate that E evaluates to n in state s. Similarly for
   boolean expressions. *)
(* Is it a good idea to use a dependent pair? *)
Definition ExpS := {x : Exp * S | prod_curry defined_onE x}.
Definition mk_ExpS (e : Exp) (s : S) (P : defined_onE e s) : ExpS :=
  exist (prod_curry defined_onE) (e, s) P.
Axiom evalE : ExpS -> nat.

Definition BexpS := {x : Bexp * S | prod_curry defined_onB x}.
Definition mk_BexpS (e : Bexp) (s : S) (P : defined_onB e s) : BexpS :=
  exist (prod_curry defined_onB) (e, s) P.
Axiom evalB : BexpS -> bool.

(* I don't know how to represent the semantic functions E and B (§3) for
   expressions and boolean expressions. It should be a function with type
   [Exp -> set { (s, n) : S * nat | evalE (mk_ExpS e s P) = n }]
   But I cannot use a [MSets] since those are finite and the semantics functions
   return an infinite set of states and results.
*)

Definition closed (c : Com) := IdSet.Empty (freeC c).

Lemma defined_onC_closed_term : forall (c : Com) (s : S),
  closed c ->
  defined_onC c s.
Proof.
  intros.
  unfold defined_onC.
  apply IdSetProps.empty_is_empty_1 in H.
  rewrite H.
  apply IdSetProps.subset_empty.
Qed.

Definition Conf := { p : Com * S | prod_curry defined_onC p }.
Definition mk_Conf (c : Com) (s : S) (P : defined_onC c s) : Conf :=
  exist (prod_curry defined_onC) (c, s) P.
Definition mk_closed_Conf (c : Com) (s : S) (H : closed c) : Conf :=
  mk_Conf c s (defined_onC_closed_term _ s H).

(* BEGIN BORING FUNCTIONS *)
(* It would be nice to hide them somewhere since they are unimportant... *)
Lemma lift : forall (e : Exp) (s : S) (x : Id),
  defined_onE e s ->
  IdSet.In x (dom s) ->
  defined_onC (cassign x e) s.
Proof.
  unfold defined_onE, defined_onC.
  intros. simpl.
  auto using IdSetProps.subset_add_3.
Qed.

Lemma cskip_closed :
  closed cskip.
Proof.
  exact IdSet.empty_spec.
Qed.

Lemma merge_par : forall (c1 c2 : Com) (s : S) (P1 : defined_onC c1 s)
  (P2 : defined_onC c2 s),
  defined_onC (cpar c1 c2) s.
Proof.
  unfold defined_onC.
  intros. simpl.
  auto using IdSetProps.union_subset_3.
Qed.

Lemma merge_seq : forall (c1 c2 : Com) (s : S) (P1 : defined_onC c1 s)
  (P2 : defined_onC c2 s),
  defined_onC (cseq c1 c2) s.
Proof.
  unfold defined_onC.
  intros. simpl.
  auto using IdSetProps.union_subset_3.
Qed.

Lemma merge_if : forall (b : Bexp) (c1 c2 : Com) (s : S) (Pb : defined_onB b s)
  (P1 : defined_onC c1 s) (P2 : defined_onC c2 s),
  defined_onC (cif b c1 c2) s.
Proof.
  unfold defined_onB, defined_onC.
  intros. simpl.
  auto using IdSetProps.union_subset_3.
Qed.

Lemma merge_while : forall (b : Bexp) (c : Com) (s : S) (Pb : defined_onB b s)
  (P : defined_onC c s),
  defined_onC (cwhile b c) s.
Proof.
  unfold defined_onB, defined_onC.
  intros. simpl.
  auto using IdSetProps.union_subset_3.
Qed.

Lemma merge_await : forall (b : Bexp) (c : Com) (s : S) (Pb : defined_onB b s)
  (P : defined_onC c s),
  defined_onC (cawait b c) s.
Proof.
  unfold defined_onB, defined_onC.
  intros. simpl.
  auto using IdSetProps.union_subset_3.
Qed.

(* END BORING FUNCTIONS *)

(* There are two different relations:
   - the subset of successfully terminated configuations [term] and;
   - a [transition] relation. *)

Inductive term : Conf -> Prop :=
| term_skip : forall (s : S),
    term (mk_closed_Conf cskip s cskip_closed)

| term_par : forall (c1 c2 : Com) (s : S) (P1 : defined_onC c1 s)
  (P2 : defined_onC c2 s),
    term (mk_Conf c1 s P1) ->
    term (mk_Conf c2 s P2) ->
    term (mk_Conf (cpar c1 c2) s (merge_par _ _ _ P1 P2)).

Inductive transition : Conf -> Conf -> Prop :=
| tassign : forall (x : Id) (e : Exp) (s : S) (P : defined_onE e s) (n : nat)
  (DOM : IdSet.In x (dom s)),
    evalE (mk_ExpS e s P) = n ->
    transition
      (mk_Conf (cassign x e) s (lift e s x P DOM))
      (mk_closed_Conf cskip (S_add x n s) cskip_closed)

| tseq_step : forall (c1 c1' c2 : Com) (s s' : S) (P1 : defined_onC c1 s)
  (P1' : defined_onC c1' s') (P2 : defined_onC c2 s) (P2' : defined_onC c2 s'),
    transition (mk_Conf c1 s P1) (mk_Conf c1' s' P1') ->
    transition
      (mk_Conf (cseq c1 c2) s (merge_seq _ _ _ P1 P2))
      (mk_Conf (cseq c1' c2) s' (merge_seq _ _ _ P1' P2'))

| tseq_term : forall (c1 c2 : Com) (s : S) (P1 : defined_onC c1 s)
  (P2 : defined_onC c2 s),
    term (mk_Conf c1 s P1) ->
    transition
      (mk_Conf (cseq c1 c2) s (merge_seq _ _ _ P1 P2))
      (mk_Conf c2 s P2)

| tif_true : forall (b : Bexp) (c1 c2 : Com) (s : S) (Pb : defined_onB b s)
  (P1 : defined_onC c1 s) (P2 : defined_onC c2 s),
    evalB (mk_BexpS b s Pb) = true ->
    transition
      (mk_Conf (cif b c1 c2) s (merge_if _ _ _ _ Pb P1 P2))
      (mk_Conf c1 s P1)

| tif_false : forall (b : Bexp) (c1 c2 : Com) (s : S) (Pb : defined_onB b s)
  (P1 : defined_onC c1 s) (P2 : defined_onC c2 s),
    evalB (mk_BexpS b s Pb) = false ->
    transition
      (mk_Conf (cif b c1 c2) s (merge_if _ _ _ _ Pb P1 P2))
      (mk_Conf c2 s P2)

| twhile : forall (b : Bexp) (c : Com) (s : S) (Pb : defined_onB b s)
  (P : defined_onC c s),
    let Pwhile := merge_while _ _ _ Pb P in
    let Pseq := merge_seq _ _ _ P Pwhile in
    let Pskip := defined_onC_closed_term cskip s cskip_closed in
    let Pif := merge_if _ _ _ _ Pb Pseq Pskip in
    transition
      (mk_Conf (cwhile b c) s Pwhile)
      (mk_Conf (cif b (cseq c (cwhile b c)) cskip) s Pif)

| tpar1 : forall (c1 c1' c2 : Com) (s s' : S) (P1 : defined_onC c1 s)
  (P1' : defined_onC c1' s') (P2 : defined_onC c2 s) (P2' : defined_onC c2 s'),
    transition (mk_Conf c1 s P1) (mk_Conf c1' s' P1') ->
    transition
      (mk_Conf (cpar c1 c2) s (merge_par _ _ _ P1 P2))
      (mk_Conf (cpar c1' c2) s' (merge_par _ _ _ P1' P2'))

| tpar2 : forall (c1 c2 c2' : Com) (s s' : S) (P1 : defined_onC c1 s)
  (P1' : defined_onC c1 s') (P2 : defined_onC c2 s) (P2' : defined_onC c2' s'),
    transition (mk_Conf c2 s P2) (mk_Conf c2' s' P2') ->
    transition
      (mk_Conf (cpar c1 c2) s (merge_par _ _ _ P1 P2))
      (mk_Conf (cpar c1 c2') s' (merge_par _ _ _ P1' P2'))

| tawait_true : forall (b : Bexp) (c c' : Com) (s s' : S) (Pb : defined_onB b s)
  (P : defined_onC c s) (P' : defined_onC c' s'),
    evalB (mk_BexpS b s Pb) = true ->
    transition_star (mk_Conf c s P) (mk_Conf c' s' P') ->
    term (mk_Conf c' s' P') ->
    transition
      (mk_Conf (cawait b c) s (merge_await _ _ _ Pb P))
      (mk_Conf c' s' P')

| tawait_false : forall (b : Bexp) (c c' : Com) (s s' : S) (Pb : defined_onB b s)
  (P : defined_onC c s) (P' : defined_onC c' s'),
    evalB (mk_BexpS b s Pb) = false ->
    let conf := mk_Conf (cawait b c) s (merge_await _ _ _ Pb P) in
    transition conf conf

(* Reflexive transitive closure of the [transition] relation *)
with transition_star : Conf -> Conf -> Prop :=
| transition_refl : forall (conf : Conf),
    transition_star conf conf

| transition_step : forall (conf1 conf2 conf3 : Conf),
    transition conf1 conf2 ->
    transition_star conf2 conf3 ->
    transition_star conf1 conf3.


(* Permutations based on Pmap from std++. *)

Require Import DecimalString.
From stdpp Require Import strings pmap.
From permlib Require Import util.

Definition pmap_swap (i j : positive) : Pmap positive :=
  {[i:=j; j:=i]}.

Definition pmap_apply (m : Pmap positive) (i : positive) : positive :=
  default i (m !! i).

Definition pmap_compose (m1 m2 : Pmap positive) : Pmap positive :=
  merge (from_option Some) m2 (pmap_apply m2 <$> m1).

Definition pmap_invert (m : Pmap positive) : Pmap positive :=
  list_to_map (prod_swap <$> map_to_list m).

Definition pmap_red (m : Pmap positive) : Pmap positive :=
  list_to_map (filter (not ∘ uncurry eq) (map_to_list m)).

Definition FinInj `{Lookup X X (M X)} (m : M X) :=
  ∀ x1 x2 y, m !! x1 = Some y -> m !! x2 = Some y -> x1 = x2.

Definition FinSurj `{Lookup X X (M X)} (m : M X) :=
  ∀ y z, m !! y = Some z -> ∃ x, m !! x = Some y.

Definition FinCoSurj `{Lookup X X (M X)} (m : M X) :=
  ∀ x y, m !! x = Some y -> is_Some (m !! y).

Local Ltac simpl_inj :=
  repeat match goal with
  | inj : FinInj ?m, H1 : ?m !! ?i = Some ?y, H2 : ?m !! ?j = Some ?y |- _ =>
    let H := fresh in assert (H := inj _ _ _ H1 H2); clear H1; subst
  end.

Section Bijection.

Section Pmap_Bijection.

Lemma fin_inj_if_inj m :
  Inj eq eq (pmap_apply m) -> FinInj m.
Proof.
unfold pmap_apply; intros inj x1 x2 y H1 H2.
apply inj; rewrite H1, H2; done.
Qed.

Lemma fin_surj_iff_surj m :
  Surj eq (pmap_apply m) ↔ FinSurj m.
Proof.
unfold pmap_apply; split; intros surj y.
- intros z Hz; destruct (surj y) as [x Hy], (m !! x) eqn:Hx; cbn in Hy; subst.
  eexists; done. congruence.
- destruct (m !! y) eqn:H. apply surj in H as [x]; exists x; rewrite H; done.
  exists y; rewrite H; done.
Qed.

Local Ltac decide_neq P :=
  destruct (decide P); [subst; congruence|].

Variable m : Pmap positive.
Hypothesis inj : FinInj m.
Hypothesis surj : FinSurj m.

Lemma fin_co_surj :
  FinCoSurj m.
Proof.
remember (size m) as n; revert Heqn; revert inj surj; revert m.
induction n; intros m inj surj Hn; symmetry in Hn.
- apply map_size_empty_inv in Hn; subst; done.
- intros x y Hx; apply surj in Hx as Hu; destruct Hu as [u Hu].
  destruct (m !! y) as [z|] eqn:Hy. eexists; done. exfalso.
  decide_neq (x = y); decide_neq (x = y);
  decide_neq (u = x); decide_neq (u = y).
  cut (FinCoSurj (<[u:=y]> (delete x m))); [intros co_surj|apply IHn].
  + destruct (co_surj u y); simplify_map_eq; done.
  + intros x1 x2 y' H1 H2; simpl_lookup; simpl_inj; eapply inj; done.
  + intros y' z' H'; simpl_lookup.
    * apply surj in Hu as Hx'; destruct Hx' as [x' Hx'].
      decide_neq (x' = y'); decide_neq (x' = x). exists x'; simpl_map; done.
    * apply surj in H1 as Hx'; destruct Hx' as [x' Hx'].
      decide_neq (x' = u); decide_neq (x' = x). exists x'; simpl_map; done.
  + rewrite map_size_insert, map_size_delete, Hn; simpl_map; done.
Qed.

Lemma inj_if_fin_inj_surj :
  Inj eq eq (pmap_apply m).
Proof.
unfold pmap_apply; intros x1 x2.
destruct (m !! x1) eqn:H1, (m !! x2) eqn:H2; cbn; intros; subst.
eapply inj; done. apply fin_co_surj in H1 as []; congruence.
apply fin_co_surj in H2 as []; congruence. done.
Qed.

Section Permutation.

Lemma values_prod_swap :
  values m = (prod_swap <$> map_to_list m).*1.
Proof.
rewrite <-list_fmap_compose, list_fmap_ext with (g:=snd).
done. intros i [] _; done.
Qed.

Lemma NoDup_values :
  NoDup (values m).
Proof.
rewrite values_prod_swap; apply NoDup_fmap_fst; intros.
simpl_elem_of; simplify_eq/=; simpl_inj; done. apply NoDup_fmap.
apply prod_swap_inj. apply NoDup_map_to_list.
Qed.

Lemma pmap_Permutation :
  keys m ≡ₚ values m.
Proof.
apply NoDup_Permutation.
apply NoDup_keys. apply NoDup_values.
intros i; rewrite elem_of_keys, elem_of_values; split; intros [j H].
apply surj in H; done. apply fin_co_surj in H; done.
Qed.

End Permutation.

End Pmap_Bijection.

Lemma pmap_empty_inj :
  FinInj (∅ : Pmap positive).
Proof.
done.
Qed.

Lemma pmap_empty_surj :
  FinSurj (∅ : Pmap positive).
Proof.
intros x; done.
Qed.

Lemma pmap_swap_inj i j :
  FinInj (pmap_swap i j).
Proof.
intros x1 x2; unfold pmap_swap; intros; simpl_lookup; subst; done.
Qed.

Lemma pmap_swap_surj i j :
  FinSurj (pmap_swap i j).
Proof.
intros y z; unfold pmap_swap; intros; exists z.
destruct (decide (i = j)); simpl_lookup; subst; simplify_map_eq; done.
Qed.

Section Compose.

Lemma contra {P Q : Prop} :
  (P -> Q) -> ¬ Q -> ¬ P.
Proof.
auto.
Qed.

Lemma apply_pmap_compose_inj m1 m2 :
  Inj eq eq (pmap_apply m1) ->
  Inj eq eq (pmap_apply m2) ->
  Inj eq eq (pmap_apply (pmap_compose m1 m2)).
Proof.
repeat unfold pmap_apply, pmap_compose; intros H1 H2 x1 x2.
rewrite ?lookup_merge, ?lookup_fmap; intros H3.
destruct (decide (x1 = x2)) as [H4|H4]; [done|exfalso].
assert (H5 := contra (H1 _ _) H4); cbn in *;
repeat destruct (m1 !! _); cbn in *;
assert (H6 := contra (H2 _ _) H5); cbn in *;
repeat destruct (m2 !! _); done.
Qed.

Lemma apply_pmap_compose_surj m1 m2 :
  Surj eq (pmap_apply m1) ->
  Surj eq (pmap_apply m2) ->
  Surj eq (pmap_apply (pmap_compose m1 m2)).
Proof.
repeat unfold pmap_apply, pmap_compose; intros H1 H2 z.
destruct (H2 z) as [y Hy], (H1 y) as [x Hx]; exists x.
rewrite lookup_merge, lookup_fmap; simplify_option_eq.
destruct (m1 !! x) as [y|]; cbn.
destruct (m2 !! x), (m2 !! y); done.
destruct (m2 !! x); done.
Qed.

Lemma pmap_compose_inj (m1 m2 : Pmap positive) :
  FinInj m1 -> FinSurj m1 ->
  FinInj m2 -> FinSurj m2 ->
  FinInj (pmap_compose m1 m2).
Proof.
intros; apply fin_inj_if_inj, apply_pmap_compose_inj;
apply inj_if_fin_inj_surj; done.
Qed.

Lemma pmap_compose_surj m1 m2 :
  FinSurj m1 -> FinSurj m2 -> FinSurj (pmap_compose m1 m2).
Proof.
intros; apply fin_surj_iff_surj, apply_pmap_compose_surj;
apply fin_surj_iff_surj; done.
Qed.

Lemma keys_pmap_compose m1 m2 :
  keys (pmap_compose m1 m2) ≡ₚ list_union (keys m1) (keys m2).
Proof.
apply NoDup_Permutation. apply NoDup_keys.
apply NoDup_list_union; apply NoDup_keys.
intros i; unfold pmap_compose; rewrite elem_of_list_union.
rewrite ?elem_of_keys, lookup_merge, lookup_fmap; split.
- intros [j H]; repeat destruct (_ !! i); intuition.
- intros [[j ->]|[j ->]]; repeat destruct (_ !! i); done.
Qed.

End Compose.

Section Invert.

Lemma pmap_invert_None m x :
  FinInj m -> FinSurj m -> m !! x = None -> pmap_invert m !! x = None.
Proof.
(* This is NOT a direct consequence of the other lemmas, since pmap_invert would
still be allowed to contain redundant identity mappings that are not in m.
According to this lemma it does not contain such redundant mappings. *)
unfold pmap_invert; intros inj surj Hx; apply not_elem_of_list_to_map; intros H.
assert (co_surj : FinCoSurj m) by now apply fin_co_surj.
simpl_elem_of; simplify_eq/=; apply co_surj in H as []; congruence.
Qed.

Lemma pmap_invert_None_inv m x :
  FinSurj m -> pmap_invert m !! x = None -> m !! x = None.
Proof.
unfold pmap_invert; intros surj Hx.
destruct (m !! x) as [y|] eqn:H; [exfalso|done]; apply surj in H as [z].
apply not_elem_of_list_to_map in Hx; apply Hx; clear Hx.
apply elem_of_list_fmap; exists (x, z); repeat split.
apply elem_of_list_fmap; exists (z, x); repeat split.
apply elem_of_map_to_list; done.
Qed.

Lemma pmap_invert_Some m x y :
  FinInj m -> m !! x = Some y -> pmap_invert m !! y = Some x.
Proof.
unfold pmap_invert; intros inj Hx; apply elem_of_list_to_map.
rewrite <-values_prod_swap; apply NoDup_values, inj.
apply elem_of_list_fmap; exists (x, y); repeat split.
apply elem_of_map_to_list; done.
Qed.

Lemma pmap_invert_Some_inv m x y :
  FinInj m -> pmap_invert m !! y = Some x -> m !! x = Some y.
Proof.
unfold pmap_invert; intros inj Hy; apply elem_of_list_to_map in Hy.
simpl_elem_of; simplify_eq/=; done.
rewrite <-values_prod_swap; apply NoDup_values, inj.
Qed.

Lemma pmap_invert_inj m :
  FinInj m -> FinInj (pmap_invert m).
Proof.
intros inj x1 x2 y H1 H2.
apply pmap_invert_Some_inv in H1, H2; [congruence|done|done].
Qed.

Lemma pmap_invert_surj m :
  FinInj m -> FinSurj m -> FinSurj (pmap_invert m).
Proof.
intros inj surj y z Hy; apply pmap_invert_Some_inv in Hy; [|done].
assert (co_surj : FinCoSurj m) by now apply fin_co_surj.
apply co_surj in Hy as [x Hx]; exists x.
apply pmap_invert_Some; done.
Qed.

End Invert.

Section Reduction.

Lemma pmap_red_eq m i :
  pmap_apply (pmap_red m) i = pmap_apply m i.
Proof.
unfold pmap_apply, pmap_red; destruct (list_to_map _ !! i) eqn:E; cbn.
- apply elem_of_list_to_map in E. simpl_elem_of; rewrite E1; done.
  apply NoDup_fmap_fst; intros. simpl_elem_of; congruence.
  apply NoDup_filter, NoDup_map_to_list.
- destruct (m !! i) eqn:Hi; [|done].
  destruct (decide (i = p)); [done|exfalso].
  apply not_elem_of_list_to_map in E; apply E.
  apply elem_of_list_fmap; exists (i, p); split; [done|].
  apply elem_of_list_filter; split; [done|].
  apply elem_of_map_to_list; done.
Qed.

End Reduction.

End Bijection.

Inductive perm := Perm {
  perm_car  : Pmap positive;
  perm_inj  : FinInj perm_car;
  perm_surj : FinSurj perm_car;
}.

Global Instance : FinMapToList positive positive perm :=
  λ π, map_to_list (perm_car π).

Global Instance perm_lookup : LookupTotal positive positive perm :=
  λ i π, pmap_apply (perm_car π) i.

Global Instance : Empty perm :=
  Perm _ pmap_empty_inj pmap_empty_surj.

Definition perm_swap (i j : positive) :=
  Perm _ (pmap_swap_inj i j) (pmap_swap_surj i j).

Definition perm_compose (π τ : perm) :=
  let (τ_m, τ_inj, τ_surj) := τ in
  let (π_m, π_inj, π_surj) := π in Perm _
    (pmap_compose_inj _ _ τ_inj τ_surj π_inj π_surj)
    (pmap_compose_surj _ _ τ_surj π_surj).

Definition perm_invert (π : perm) :=
  let (π_m, π_inj, π_surj) := π in Perm _
    (pmap_invert_inj _ π_inj)
    (pmap_invert_surj _ π_inj π_surj).

Notation "⟨ i ; j ⟩" := (perm_swap i j) (format "⟨ i ;  j ⟩").
Notation "π ⋅ τ" := (perm_compose π τ) (at level 15).
Notation "(⋅)" := perm_compose (only parsing).
Notation inv := perm_invert.

Definition perm_cycle (i : positive) (is : list positive) : perm :=
  foldl (λ π j, ⟨i; j⟩ ⋅ π) ∅ is.

Notation "⟨ i ; x ; y ; .. ; z ⟩" :=
  (perm_cycle i (cons x (cons y .. (cons z nil) ..)))
  (format "⟨ i ;  x ;  y ;  .. ;  z ⟩").

Section Group.

Class Group (X : Type) `{_equiv : Equiv X}
  (f : X -> X -> X) (inv : X -> X) (e : X) : Prop :=
{
  Group_Equivalence :> Equivalence (≡);
  Group_Proper      :> Proper ((≡) ==> (≡) ==> (≡)) f;
  Group_Assoc       :> Assoc (≡) f;
  Group_LeftId      :> LeftId (≡) e f;
  Group_RightId     :> RightId (≡) e f;
  left_inv x        : f (inv x) x ≡ e;
  right_inv x       : f x (inv x) ≡ e;
}.

Global Instance group_inv_proper `{Group X f i e} :
  Proper ((≡) ==> (≡)) i.
Proof.
intros x y Hxy; rewrite <-(right_id e f), <-(right_inv y), <-Hxy at 1.
rewrite (assoc f), left_inv, (left_id e f); done.
Qed.

Lemma group_inv_inv `{Group X f i e} (x : X) :
  i (i x) ≡ x.
Proof.
rewrite <-(right_id e f), <-(left_inv x).
rewrite (assoc f), left_inv, (left_id e f); done.
Qed.

Lemma group_inv_compose `{Group X f i e} (x y : X) :
  i (f x y) ≡ f (i y) (i x).
Proof.
rewrite <-(right_id e f).
assert (R : e ≡ f (f x y) (f (i y) (i x))).
rewrite <-(assoc f), (assoc f y), right_inv, (left_id e f), right_inv; done.
rewrite R, (assoc f), left_inv, (left_id e f); done.
Qed.

Lemma group_inv_cancel `{Group X f i e} (x y : X) :
  i x ≡ i y -> x ≡ y.
Proof.
intros R; rewrite <-(group_inv_inv x), <-(group_inv_inv y), R; done.
Qed.

Lemma group_compose_cancel `{Group X f i e} (x y z : X) :
  f x z ≡ f y z -> x ≡ y.
Proof.
intros R; rewrite <-(right_id e f x), <-(right_id e f y).
rewrite <-?(right_inv z), ?(assoc f), R; done.
Qed.

Lemma lookup_perm_compose π τ i :
  π ⋅ τ !!! i = π !!! (τ !!! i).
Proof.
destruct τ as [τ_m ? ?], π as [π_m ? ?]; unfold lookup_total, perm_lookup; cbn.
unfold pmap_apply, pmap_compose; rewrite lookup_merge, lookup_fmap.
destruct (τ_m !! i) as [i1|]; cbn; unfold pmap_apply.
destruct (π_m !! i) as [i0|], (π_m !! i1); done.
destruct (π_m !! i) as [i0|]; done.
Qed.

Global Instance : Equiv perm :=
  λ τ π, ∀ i, τ !!! i = π !!! i.

Lemma eq_perm_car (π τ : perm) :
  perm_car π = perm_car τ -> π ≡ τ.
Proof.
intros H i; unfold lookup_total, perm_lookup; rewrite H; done.
Qed.

Global Instance :
  Group _ (⋅) inv ∅.
Proof.
split; repeat intros ?; rewrite ?lookup_perm_compose; cbn; try done.
split; congruence. etrans; auto; f_equal; done.
all: unfold lookup_total, perm_lookup, pmap_apply.
all: destruct x as [m inj surj]; cbn.
- destruct (_ !! i) eqn:H; cbn.
  apply pmap_invert_Some in H as ->; done.
  apply pmap_invert_None in H as ->; done.
- destruct (_ !! i) eqn:H; cbn.
  apply pmap_invert_Some_inv in H as ->; done.
  apply pmap_invert_None_inv in H as ->; done.
Qed.

End Group.

Arguments perm_swap _ _ : simpl never.
Arguments perm_compose _ _ : simpl never.
Arguments perm_invert _ : simpl never.

Section Permutation.

Lemma perm_keys_unfold_1 (π : perm) : keys π = keys (perm_car π).
Proof. done. Qed.
Lemma perm_keys_unfold_2 (π : perm) : keys π = (map_to_list (perm_car π)).*1.
Proof. done. Qed.
Lemma perm_values_unfold (π : perm) : values π = (map_to_list (perm_car π)).*2.
Proof. done. Qed.

Lemma perm_Permutation (π : perm) :
  keys π ≡ₚ values π.
Proof.
apply pmap_Permutation.
apply perm_inj. apply perm_surj.
Qed.

Lemma keys_perm_compose (π τ : perm) :
  keys (π ⋅ τ) ≡ₚ list_union (keys τ) (keys π).
Proof.
rewrite ?perm_keys_unfold_1; destruct τ as [τ_m ? ?], π as [π_m ? ?].
unfold perm_compose; cbn; apply keys_pmap_compose.
Qed.

Lemma perm_eq_values (π τ : perm) :
  values π = values τ -> π ≡ τ.
Proof.
intros H1; apply eq_perm_car, map_to_list_inj.
assert (H2 : keys π ≡ₚ keys τ) by now rewrite ?perm_Permutation, H1.
(* FinMap does not require that the order of keys in map_to_list is independent
from the order of the values, it only requires that map_to_list is NoDup. We
have to prove this independence specifically for Pmap. *)
rewrite <-zip_fst_snd; rewrite <-zip_fst_snd at 1.
rewrite <-?perm_keys_unfold_2, ?perm_keys_unfold_1, <-?perm_values_unfold.
rewrite H1; apply pmap_keys_Permutation in H2 as ->; done.
Qed.

End Permutation.

Section Format.

Definition cycle := list positive.

(* Append a cycle segment to a list of cycles. *)
Fixpoint cycles_add (cycles : list (positive * cycle * positive))
  (i0 : positive) (is : cycle) (ik : positive) :=
  match cycles with
  | [] => [(i0, is, ik)]
  | (j0, js, jk) :: cs =>
    if decide (ik = j0)
    then cycles_add cs i0 (is ++ [ik] ++ js) jk
    else if decide (i0 = jk)
    then cycles_add cs j0 (js ++ [i0] ++ is) ik
    else (j0, js, jk) :: cycles_add cs i0 is ik
  end.

(* Convert a permutation to a list of cycles. *)
Definition perm_cycles (π : perm) : list cycle :=
  (λ c, match c with (i0, is, ik) => i0 :: is ++ [ik] end) <$>
  (foldl (λ cs m, match m with (i, j) =>
    if decide (i = j) then cs
    else cycles_add cs i [] j end)
    [] (map_to_list π)).

Fixpoint str_join (sep : string) (l : list string) :=
  match l with
  | [] => ""
  | [x] => x
  | x :: l' => x +:+ sep +:+ str_join sep l'
  end.

Definition str_of_pos i :=
  NilZero.string_of_uint (Pos.to_uint i).

Definition str_of_cycle (c : cycle) :=
  "(" +:+ str_join " " (map str_of_pos (removelast c)) +:+ ")".

Definition str_of_perm (π : perm) :=
  str_join "" (str_of_cycle <$> perm_cycles π).

End Format.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(**********************************************************)
(** Complements for the reals.Integer and fractional part *)
(*                                                        *)
(**********************************************************)

Require Import Rbase.
Require Import Omega.
Open Local Scope R_scope.

(*********************************************************)
(** *    Fractional part                                 *)
(*********************************************************)

(**********)
Definition Int_part (r:R) : Z := (up r - 1)%Z.

(**********)
Definition frac_part (r:R) : R := r - IZR (Int_part r).

(**********)
Lemma tech_up : forall (r:R) (z:Z), r < IZR z -> IZR z <= r + 1 -> z = up r.
Proof.
  intros; generalize (archimed r); intro; elim H1; intros; clear H1;
    unfold Rgt in H2; unfold Rminus in H3;
      generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3);
        intro; clear H3; rewrite (Rplus_comm (IZR (up r)) (- r)) in H1;
          rewrite <- (Rplus_assoc r (- r) (IZR (up r))) in H1;
            rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r)));
              intros a b; rewrite b in H1; clear a b; apply (single_z_r_R1 r z (up r));
                auto with zarith real.
Qed.

(**********)
Lemma up_tech :
  forall (r:R) (z:Z), IZR z <= r -> r < IZR (z + 1) -> (z + 1)%Z = up r.
Proof.
  intros; generalize (Rplus_le_compat_l 1 (IZR z) r H); intro; clear H;
    rewrite (Rplus_comm 1 (IZR z)) in H1; rewrite (Rplus_comm 1 r) in H1;
      cut (1 = IZR 1); auto with zarith real.
  intro; generalize H1; pattern 1 at 1 in |- *; rewrite H; intro; clear H H1;
    rewrite <- (plus_IZR z 1) in H2; apply (tech_up r (z + 1));
      auto with zarith real.
Qed.

(**********)
Lemma fp_R0 : frac_part 0 = 0.
Proof.
  unfold frac_part in |- *; unfold Int_part in |- *; elim (archimed 0); intros;
    unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1)));
      intros a b; rewrite b; clear a b; rewrite <- Z_R_minus;
        cut (up 0 = 1%Z).
  intro; rewrite H1;
    rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1)));
      apply Ropp_0.
  elim (archimed 0); intros; clear H2; unfold Rgt in H1;
    rewrite (Rminus_0_r (IZR (up 0))) in H0; generalize (lt_O_IZR (up 0) H1);
      intro; clear H1; generalize (le_IZR_R1 (up 0) H0);
        intro; clear H H0; omega.
Qed.

(**********)
Lemma for_base_fp : forall r:R, IZR (up r) - r > 0 /\ IZR (up r) - r <= 1.
Proof.
  intro; split; cut (IZR (up r) > r /\ IZR (up r) - r <= 1).
  intro; elim H; intros.
  apply (Rgt_minus (IZR (up r)) r H0).
  apply archimed.
  intro; elim H; intros.
  exact H1.
  apply archimed.
Qed.

(**********)
Lemma base_fp : forall r:R, frac_part r >= 0 /\ frac_part r < 1.
Proof.
  intro; unfold frac_part in |- *; unfold Int_part in |- *; split.
     (*sup a O*)
  cut (r - IZR (up r) >= -1).
  rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
      fold (r - IZR (up r)) in |- *; fold (r - IZR (up r) - -1) in |- *;
        apply Rge_minus; auto with zarith real.
  rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r);
    auto with zarith real.
    (*inf a 1*)
  cut (r - IZR (up r) < 0).
  rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
      fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive;
        elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *;
          rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1);
            apply Rplus_lt_compat_l; auto with zarith real.
  elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr;
    apply Ropp_gt_lt_contravar; auto with zarith real.
Qed.

(*********************************************************)
(** *    Properties                                      *)
(*********************************************************)

(**********)
Lemma base_Int_part :
  forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1.
Proof.
  intro; unfold Int_part in |- *; elim (archimed r); intros.
  split; rewrite <- (Z_R_minus (up r) 1); simpl in |- *.
  generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1;
    rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1;
      rewrite (Rplus_comm (- r) (-1)) in H1;
        rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1;
          fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1;
            apply Rminus_le; auto with zarith real.
  generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro;
    rewrite (Rplus_comm (-1) (IZR (up r))) in H1;
      generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1);
        intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2;
          fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2;
            rewrite (Rplus_comm (- r) (-1 + r)) in H2;
              rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2;
                elim (Rplus_ne (-1)); intros a b; rewrite a in H2;
                  clear a b; auto with zarith real.
Qed.

(**********)
Lemma Int_part_INR : forall n:nat, Int_part (INR n) = Z_of_nat n.
Proof.
  intros n; unfold Int_part in |- *.
  cut (up (INR n) = (Z_of_nat n + Z_of_nat 1)%Z).
  intros H'; rewrite H'; simpl in |- *; ring.
  apply sym_equal; apply tech_up; auto.
  replace (Z_of_nat n + Z_of_nat 1)%Z with (Z_of_nat (S n)).
  repeat rewrite <- INR_IZR_INZ.
  apply lt_INR; auto.
  rewrite Zplus_comm; rewrite <- Znat.inj_plus; simpl in |- *; auto.
  rewrite plus_IZR; simpl in |- *; auto with real.
  repeat rewrite <- INR_IZR_INZ; auto with real.
Qed.

(**********)
Lemma fp_nat : forall r:R, frac_part r = 0 ->  exists c : Z, r = IZR c.
Proof.
  unfold frac_part in |- *; intros; split with (Int_part r);
    apply Rminus_diag_uniq; auto with zarith real.
Qed.

(**********)
Lemma R0_fp_O : forall r:R, 0 <> frac_part r -> 0 <> r.
Proof.
  red in |- *; intros; rewrite <- H0 in H; generalize fp_R0; intro;
    auto with zarith real.
Qed.

(**********)
Lemma Rminus_Int_part1 :
  forall r1 r2:R,
    frac_part r1 >= frac_part r2 ->
    Int_part (r1 - r2) = (Int_part r1 - Int_part r2)%Z.
Proof.
  intros; elim (base_fp r1); elim (base_fp r2); intros;
    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4);
        intro; clear H4; rewrite Ropp_0 in H0;
          generalize (Rge_le 0 (- frac_part r2) H0); intro;
            clear H0; generalize (Rge_le (frac_part r1) 0 H2);
              intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
                intro; clear H1; unfold Rgt in H2;
                  generalize
                    (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
                    intro; elim H1; intros; clear H1; elim (Rplus_ne 1);
                      intros a b; rewrite a in H6; clear a b H5;
                        generalize (Rge_minus (frac_part r1) (frac_part r2) H);
                          intro; clear H; fold (frac_part r1 - frac_part r2) in H6;
                            generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1);
                              intro; clear H1 H3 H4 H0 H2; unfold frac_part in H6, H;
                                unfold Rminus in H6, H;
                                  rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H;
                                    rewrite (Ropp_involutive (IZR (Int_part r2))) in H;
                                      rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                        in H;
                                        rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                          in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H;
                                            rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                              rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                                in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                                  fold (r1 - r2) in H; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H;
                                                    generalize
                                                      (Rplus_le_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) 0
                                                        (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H);
                                                      intro; clear H;
                                                        rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
                                                          rewrite <-
                                                            (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                              (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                            in H0; unfold Rminus in H0; fold (r1 - r2) in H0;
                                                              rewrite
                                                                (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
                                                                  (IZR (Int_part r2) + - IZR (Int_part r1))) in H0;
                                                                rewrite <-
                                                                  (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
                                                                    (- IZR (Int_part r1))) in H0;
                                                                  rewrite (Rplus_opp_l (IZR (Int_part r2))) in H0;
                                                                    elim (Rplus_ne (- IZR (Int_part r1))); intros a b;
                                                                      rewrite b in H0; clear a b;
                                                                        elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2)));
                                                                          intros a b; rewrite a in H0; clear a b;
                                                                            rewrite (Rplus_opp_r (IZR (Int_part r1))) in H0; elim (Rplus_ne (r1 - r2));
                                                                              intros a b; rewrite b in H0; clear a b;
                                                                                fold (IZR (Int_part r1) - IZR (Int_part r2)) in H0;
                                                                                rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H6;
                                                                                rewrite (Ropp_involutive (IZR (Int_part r2))) in H6;
                                                                                rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                                                                in H6;
                                                                                rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                                                                in H6; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H6;
                                                                                rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
                                                                                rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                                                                in H6;
                                                                                rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
                                                                                fold (r1 - r2) in H6; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H6;
                                                                                generalize
                                                                                (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6);
                                                                                intro; clear H6;
                                                                                rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
                                                                                rewrite <-
                                                                                (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                                                in H;
                                                                                rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                                                                rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H;
                                                                                elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H;
                                                                                clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
                                                                                cut (1 = IZR 1); auto with zarith real.
  intro; rewrite H1 in H; clear H1;
    rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
      generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H);
        intros; clear H H0; unfold Int_part at 1 in |- *;
          omega.
Qed.

(**********)
Lemma Rminus_Int_part2 :
  forall r1 r2:R,
    frac_part r1 < frac_part r2 ->
    Int_part (r1 - r2) = (Int_part r1 - Int_part r2 - 1)%Z.
Proof.
  intros; elim (base_fp r1); elim (base_fp r2); intros;
    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4);
        intro; clear H4; rewrite Ropp_0 in H0;
          generalize (Rge_le 0 (- frac_part r2) H0); intro;
            clear H0; generalize (Rge_le (frac_part r1) 0 H2);
              intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
                intro; clear H1; unfold Rgt in H2;
                  generalize
                    (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
                    intro; elim H1; intros; clear H1; elim (Rplus_ne (-1));
                      intros a b; rewrite b in H5; clear a b H6;
                        generalize (Rlt_minus (frac_part r1) (frac_part r2) H);
                          intro; clear H; fold (frac_part r1 - frac_part r2) in H5;
                            clear H3 H4 H0 H2; unfold frac_part in H5, H1; unfold Rminus in H5, H1;
                              rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H5;
                                rewrite (Ropp_involutive (IZR (Int_part r2))) in H5;
                                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                    in H5;
                                    rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                      in H5; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H5;
                                        rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
                                          rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                            in H5;
                                            rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
                                              fold (r1 - r2) in H5; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H5;
                                                generalize
                                                  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) (-1)
                                                    (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5);
                                                  intro; clear H5;
                                                    rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
                                                      rewrite <-
                                                        (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                          (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                        in H; unfold Rminus in H; fold (r1 - r2) in H;
                                                          rewrite
                                                            (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
                                                              (IZR (Int_part r2) + - IZR (Int_part r1))) in H;
                                                            rewrite <-
                                                              (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
                                                                (- IZR (Int_part r1))) in H;
                                                              rewrite (Rplus_opp_l (IZR (Int_part r2))) in H;
                                                                elim (Rplus_ne (- IZR (Int_part r1))); intros a b;
                                                                  rewrite b in H; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H;
                                                                    elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H;
                                                                      clear a b; fold (IZR (Int_part r1) - IZR (Int_part r2)) in H;
                                                                        fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H;
                                                                          rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H1;
                                                                            rewrite (Ropp_involutive (IZR (Int_part r2))) in H1;
                                                                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
                                                                                in H1;
                                                                                rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
                                                                                in H1; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H1;
                                                                                rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                                                                                rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
                                                                                in H1;
                                                                                rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                                                                                fold (r1 - r2) in H1; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H1;
                                                                                generalize
                                                                                (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1);
                                                                                intro; clear H1;
                                                                                rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
                                                                                rewrite <-
                                                                                (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
                                                                                (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
                                                                                in H0;
                                                                                rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
                                                                                rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0;
                                                                                elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0;
                                                                                clear a b; rewrite <- (Rplus_opp_l 1) in H0;
                                                                                rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1)
                                                                                in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0;
                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
                                                                                cut (1 = IZR 1); auto with zarith real.
  intro; rewrite H1 in H; rewrite H1 in H0; clear H1;
    rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H;
      rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0;
        rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0;
          generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H);
            intro; clear H;
              generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0);
                intros; clear H0 H1; unfold Int_part at 1 in |- *;
                  omega.
Qed.

(**********)
Lemma Rminus_fp1 :
  forall r1 r2:R,
    frac_part r1 >= frac_part r2 ->
    frac_part (r1 - r2) = frac_part r1 - frac_part r2.
Proof.
  intros; unfold frac_part in |- *; generalize (Rminus_Int_part1 r1 r2 H);
    intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
      unfold Rminus in |- *;
        rewrite (Ropp_plus_distr (IZR (Int_part r1)) (- IZR (Int_part r2)));
          rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
            rewrite (Ropp_involutive (IZR (Int_part r2)));
              rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
                rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
                  rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
                    rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
                      rewrite (Rplus_comm (- r2) (- IZR (Int_part r1)));
                        auto with zarith real.
Qed.

(**********)
Lemma Rminus_fp2 :
  forall r1 r2:R,
    frac_part r1 < frac_part r2 ->
    frac_part (r1 - r2) = frac_part r1 - frac_part r2 + 1.
Proof.
  intros; unfold frac_part in |- *; generalize (Rminus_Int_part2 r1 r2 H);
    intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1);
      rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
        unfold Rminus in |- *;
          rewrite
            (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1))
            ; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
              rewrite (Ropp_involutive (IZR 1));
                rewrite (Ropp_involutive (IZR (Int_part r2)));
                  rewrite (Ropp_plus_distr (IZR (Int_part r1)));
                    rewrite (Ropp_involutive (IZR (Int_part r2))); simpl in |- *;
                      rewrite <-
                        (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1)
                        ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
                          rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
                            rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
                              rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
                                rewrite (Rplus_comm (- r2) (- IZR (Int_part r1)));
                                  auto with zarith real.
Qed.

(**********)
Lemma plus_Int_part1 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 >= 1 ->
    Int_part (r1 + r2) = (Int_part r1 + Int_part r2 + 1)%Z.
Proof.
  intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H;
    elim (base_fp r1); elim (base_fp r2); intros; clear H H2;
      generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3);
        intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1);
          intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2;
            generalize
              (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2);
              intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1;
                unfold frac_part in H0, H1; unfold Rminus in H0, H1;
                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                    in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
                      rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
                        in H1;
                        rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
                          rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                            in H1;
                            rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                                in H0; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H0;
                                  rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
                                    in H0;
                                    rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H0;
                                      rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                                        in H0;
                                        rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
                                          generalize
                                            (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1
                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0);
                                            intro; clear H0;
                                              generalize
                                                (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1);
                                                intro; clear H1;
                                                  rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                    in H;
                                                    rewrite <-
                                                      (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                        (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                      in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H;
                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H;
                                                          clear a b;
                                                            rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                              in H0;
                                                              rewrite <-
                                                                (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                                  (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                                in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
                                                                  elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0;
                                                                    clear a b;
                                                                      rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0;
                                                                        cut (1 = IZR 1); auto with zarith real.
  intro; rewrite H1 in H0; rewrite H1 in H; clear H1;
    rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H;
      rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
        rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H;
          rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0;
            rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0;
              generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0);
                intro; clear H H0; unfold Int_part at 1 in |- *; omega.
Qed.

(**********)
Lemma plus_Int_part2 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 < 1 ->
    Int_part (r1 + r2) = (Int_part r1 + Int_part r2)%Z.
Proof.
  intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3;
    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
      generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2;
        generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1);
          intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b;
            rewrite a in H2; clear a b;
              generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2);
                intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1;
                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                    in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
                      rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
                        in H1;
                        rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
                          rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                            in H1;
                            rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
                                in H; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H;
                                  rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) in H;
                                    rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H;
                                      rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
                                        in H;
                                        rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
                                          generalize
                                            (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0
                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1);
                                            intro; clear H1;
                                              generalize
                                                (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H);
                                                intro; clear H;
                                                  rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                    in H1;
                                                    rewrite <-
                                                      (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                        (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                      in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1;
                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1;
                                                          clear a b;
                                                            rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
                                                              in H0;
                                                              rewrite <-
                                                                (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
                                                                  (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
                                                                in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
                                                                  elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2)));
                                                                    intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2));
                                                                      intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1);
                                                                        auto with zarith real.
  intro; rewrite H in H1; clear H;
    rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
      rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
        rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
          generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1);
            intro; clear H0 H1; unfold Int_part at 1 in |- *;
              omega.
Qed.

(**********)
Lemma plus_frac_part1 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 >= 1 ->
    frac_part (r1 + r2) = frac_part r1 + frac_part r2 - 1.
Proof.
  intros; unfold frac_part in |- *; generalize (plus_Int_part1 r1 r2 H); intro;
    rewrite H0; rewrite (plus_IZR (Int_part r1 + Int_part r2) 1);
      rewrite (plus_IZR (Int_part r1) (Int_part r2)); simpl in |- *;
        unfold Rminus at 3 4 in |- *;
          rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
            rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
              rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
                rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
                  rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
                    rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
                      unfold Rminus in |- *;
                        rewrite
                          (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1))
                          ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1);
                            trivial with zarith real.
Qed.

(**********)
Lemma plus_frac_part2 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 < 1 ->
    frac_part (r1 + r2) = frac_part r1 + frac_part r2.
Proof.
  intros; unfold frac_part in |- *; generalize (plus_Int_part2 r1 r2 H); intro;
    rewrite H0; rewrite (plus_IZR (Int_part r1) (Int_part r2));
      unfold Rminus at 2 3 in |- *;
        rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
          rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
            rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
              rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
                rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
                  rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
                    unfold Rminus in |- *; trivial with zarith real.
Qed.


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

Require Import List Arith Lia.

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

From Undecidability.MinskyMachines.MMA
  Require Import mma_defs.

Set Implicit Arguments.

Set Default Proof Using "Type".

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

Local Notation "P // s -[ k ]-> t" := (sss_steps (@mma_sss _) P k s t).
Local Notation "P // s -+> t" := (sss_progress (@mma_sss _) P s t).
Local Notation "P // s ->> t" := (sss_compute (@mma_sss _) P s t).
Local Notation "P // s ↓" := (sss_terminates (@mma_sss _) P s).

(* Utils for FRACTRAN with two counter *)

Section Minsky_Machine_alt_utils.

  Variable (n : nat).

  Ltac dest x y := destruct (pos_eq_dec x y) as [ | ]; [ subst x | ]; rew vec.

  Hint Resolve subcode_refl : core.

  Section mma_jump.

    Variable (j : nat) (x : pos n).

    Definition mma_jump := INCₐ x :: DECₐ x j :: nil.

    Notation JUMPₐ := mma_jump.

    Fact mma_jump_length : length JUMPₐ = 2.
    Proof. auto. Qed.

    Fact mma_jump_progress i v w : w = v -> (i,JUMPₐ) // (i,v) -+> (j,w).
    Proof.
      intros ->.
      unfold mma_jump.
      mma sss INC with x.
      mma sss DEC S with x j (v#>x); rew vec.
      mma sss stop.
    Qed.

  End mma_jump.

  Notation JUMPₐ := mma_jump.

  Hint Rewrite mma_jump_length : length_db.

  Section mma_null.

    (* Empty one register/counter *)

    Variable (x : pos n) (i : nat).

    Definition mma_null := DECₐ x i :: nil.

    Fact mma_null_length : length mma_null = 1.
    Proof. auto. Qed.

    Let mma_null_spec k v w :   v#>x = k
                             -> w = v[0/x]
                             -> (i,mma_null) // (i,v) -+> (1+i,w).
    Proof.
      unfold mma_null.
      revert v w.
      induction k as [ | k IHk ]; intros v w H1 H2; subst w.
      + mma sss DEC zero with x i.
        mma sss stop; f_equal.
        apply vec_pos_ext; intros z; dest z x.
      + mma sss DEC S with x i k.
        apply sss_progress_compute.
        apply IHk; rew vec.
    Qed.

    Fact mma_null_progress v st :
             st = (1+i,v[0/x])
          -> (i,mma_null) // (i,v) -+> st.
    Proof.
      intros; subst.
      apply mma_null_spec with (1 := eq_refl); auto.
    Qed.

  End mma_null.

  Notation NULLₐ := mma_null.

  Hint Rewrite mma_null_length : length_db.

  Section mma_incs.

    (* Add a constant value k to register x *)

    Variable (x : pos n).

    Fixpoint mma_incs k :=
      match k with
        | 0   => nil
        | S k => INCₐ x :: mma_incs k
      end.

    Fact mma_incs_length k : length (mma_incs k) = k.
    Proof. induction k; simpl; f_equal; auto. Qed.

    Fact mma_incs_compute k i v st :
             st = (k+i,v[(k+(v#>x))/x])
          -> (i,mma_incs k) // (i,v) ->> st.
    Proof.
      revert i v st; induction k as [ | k IHk ]; intros i v st ?; subst.
      + mma sss stop; f_equal; auto.
        apply vec_pos_ext; intros p; dest p x.
      + simpl; mma sss INC with x.
        apply subcode_sss_compute with (P := (1+i,mma_incs k)); auto.
        apply IHk; f_equal; try lia.
        apply vec_pos_ext; intros p; dest p x.
    Qed.

  End mma_incs.

  Notation INCSₐ := mma_incs.

  Hint Rewrite mma_incs_length : length_db.

  Section mma_isempty.

    Variable (x : pos n) (p i : nat).

    Definition mma_isempty := DECₐ x (3+i) :: JUMPₐ p x ++ INCₐ x :: nil.

    Notation EMPTYₐ := mma_isempty.

    Fact mma_isempty_length : length EMPTYₐ = 4.
    Proof. auto. Qed.

    Fact mma_empty_progress v st : st = (p,v) -> v#>x = 0 -> (i,EMPTYₐ) // (i,v) -+> st.
    Proof.
      intros -> H.
      unfold mma_isempty, mma_jump; simpl app.
      mma sss DEC zero with x (3+i); rew vec.
      mma sss INC with x.
      mma sss DEC S with x p (0); rew vec.
      mma sss stop; f_equal.
      apply vec_pos_ext; intros y; dest y x; lia.
    Qed.

    Fact mma_non_empty_progress v st : st = (4+i,v) -> v#>x <> 0 -> (i,EMPTYₐ) // (i,v) -+> st.
    Proof.
      intros -> H.
      unfold mma_isempty.
      case_eq (v#>x).
      + now intros; subst.
      + clear H; intros u H.
        mma sss DEC S with x (3+i) u; rew vec.
        mma sss INC with x; auto.
        mma sss stop; f_equal.
        apply vec_pos_ext; intros y; dest y x; lia.
    Qed.

  End mma_isempty.

  Notation EMPTYₐ := mma_isempty.

  Hint Rewrite mma_isempty_length : length_db.

  Section mma_transfert.

    (* Added the content of src to dst while emptying src *)

    Variables (src dst : pos n) (Hsd : src <> dst) (i : nat).

    Definition mma_transfert := INCₐ dst :: DECₐ src i :: DECₐ dst (3+i) :: nil.

    Fact mma_transfert_length : length mma_transfert = 3.
    Proof. reflexivity. Qed.

    Let mma_transfert_spec v w k x :    v#>src = k
                                     -> v#>dst = x
                                     -> w = v[0/src][(1+k+x)/dst]
                                     -> (i,mma_transfert) // (i,v) -+> (2+i,w).
    Proof.
      unfold mma_transfert.
      revert v w x.
      induction k as [ | k IHk ]; intros v w x H1 H2 H3; subst w.
      + mma sss INC with dst.
        mma sss DEC zero with src i; rew vec.
        mma sss stop; f_equal; auto.
        apply vec_pos_ext; intros z; dest z dst; dest z src.
      + mma sss INC with dst.
        mma sss DEC S with src i k; rew vec.
        apply sss_progress_compute, IHk with (x := 1+x); rew vec.
        apply vec_pos_ext; intros p.
        dest p dst; try lia; dest p src.
    Qed.

    Fact mma_transfert_progress v st :
           st = (3+i,v[0/src][((v#>src)+(v#>dst))/dst])
        -> (i,mma_transfert) // (i,v) -+> st.
    Proof using Hsd.
      intros ?; subst.
      apply sss_progress_trans with (2+i, v[0/src][(1+(v#>src)+(v#>dst))/dst]).
      + apply mma_transfert_spec with (1 := eq_refl) (2 := eq_refl); auto.
      + unfold mma_transfert.
        mma sss DEC S with dst (3+i) ((v#>src)+(v#>dst)); rew vec.
        mma sss stop.
    Qed.

  End mma_transfert.

  Notation TRANSFERTₐ := mma_transfert.

  Hint Rewrite mma_transfert_length : length_db.

  Section mma_mult_cst.

    (* dst <- k*src+dst *)

    Variable (src dst : pos n) (Hsd : src <> dst) (k i : nat).

    Definition mma_mult_cst :=
           DECₐ src (3+i) :: JUMPₐ (5+k+i) src
        ++ INCSₐ dst k ++ JUMPₐ i src.

    Fact mma_mult_cst_length : length mma_mult_cst = 5+k.
    Proof. unfold mma_mult_cst; rew length; lia. Qed.

    Let mma_mult_cst_spec x v st :
             v#>src = x
          -> st = (5+k+i,v[0/src][(x*k+(v#>dst))/dst])
          -> (i,mma_mult_cst) // (i,v) -+> st.
    Proof.
      unfold mma_mult_cst.
      revert v st; induction x as [ | x IHx ]; intros v st Hv ?; subst.
      + mma sss DEC zero with src (3+i).
        apply sss_progress_compute.
        apply subcode_sss_progress with (P := (1+i,JUMPₐ (5+k+i) src)); auto.
        apply mma_jump_progress.
        apply vec_pos_ext; intros y; dest y dst; dest y src; lia.
      + mma sss DEC S with src (3+i) x.
        apply sss_compute_trans with (3+k+i,v[x/src][(k+(v#>dst))/dst]).
        * apply subcode_sss_compute with (P := (3+i,mma_incs dst k)); auto.
          apply mma_incs_compute; f_equal; try lia.
          apply vec_pos_ext; intros y; dest y dst; lia.
        * apply sss_compute_trans with (i,v[x/src][(k+(v#>dst))/dst]).
          - apply sss_progress_compute.
            apply subcode_sss_progress with (P := (3+k+i,JUMPₐ i src)); auto.
            apply mma_jump_progress.
            apply vec_pos_ext; intros y; dest y dst; dest y src; lia.
          - apply sss_progress_compute, IHx; rew vec; f_equal.
            apply vec_pos_ext; intros y; dest y dst; try ring.
            dest y src.
    Qed.

    Fact mma_mult_cst_progress v st :
             st = (5+k+i,v[0/src][(k*(v#>src)+(v#>dst))/dst])
          -> (i,mma_mult_cst) // (i,v) -+> st.
    Proof using Hsd.
      intros ?; subst.
      apply mma_mult_cst_spec with (1 := eq_refl); do 2 f_equal.
      ring.
    Qed.

  End mma_mult_cst.

  Notation MULT_CSTₐ := mma_mult_cst.

  Hint Rewrite mma_mult_cst_length : length_db.

  Section mma_decs.

    (* "mma_dec dst p q k" at i

        removes constant k to dst:

        if dst < k, dst ends up empty and jump to q
        if k <= dst, dst is decremented by k and jump to p

      *)

    Variable (dst : pos n) (p q : nat).

    Fixpoint mma_decs k i :=
      match k with
        | 0   => INCₐ dst :: DECₐ dst p :: nil
        | S k => DECₐ dst (3+i) :: INCₐ dst :: DECₐ dst q :: mma_decs k (3+i)
      end.

    Fact mma_decs_length k i : length (mma_decs k i) = 2+3*k.
    Proof.
      revert i; induction k as [ | ? IHk ]; intros i; simpl; auto.
      rewrite IHk; lia.
    Qed.

    Let mma_decs_spec_lt k i v w :
            v#>dst < k
         -> w = v[0/dst]
         -> (i,mma_decs k i) // (i,v) -+> (q,w).
    Proof.
      revert i v w; induction k as [ | k IHk ]; intros i v w H1 ?; subst w.
      + lia.
      + unfold mma_decs; fold mma_decs.
        case_eq (v#>dst).
        * intros H2.
          mma sss DEC zero with dst (3+i).
          mma sss INC with dst.
          mma sss DEC S with dst q (v#>dst); rew vec.
          mma sss stop; f_equal.
          apply vec_pos_ext; intros x; dest x dst.
        * intros d Hd.
          mma sss DEC S with dst (3+i) d.
          apply subcode_sss_compute with (P := (3+i,mma_decs k (3+i))); auto.
          apply sss_progress_compute, IHk; rew vec; try lia.
    Qed.

    Let mma_decs_spec_le k i v w :
            k <= v#>dst
         -> w = v[((v#>dst)-k)/dst]
         -> (i,mma_decs k i) // (i,v) -+> (p,w).
    Proof.
      revert i v w; induction k as [ | k IHk ]; intros i v w H1 ?; subst w.
      + simpl.
        mma sss INC with dst.
        mma sss DEC S with dst p (v#>dst); rew vec.
        mma sss stop; f_equal.
        apply vec_pos_ext; intros x; dest x dst; try lia.
      + unfold mma_decs; fold mma_decs.
        mma sss DEC S with dst (3+i) ((v#>dst) - 1); try lia.
        apply subcode_sss_compute with (P := (3+i,mma_decs k (3+i))); auto.
        apply sss_progress_compute, IHk; rew vec; try lia.
        apply vec_pos_ext; intros x; dest x dst; lia.
    Qed.

    Fact mma_decs_lt_progress k i v st :
             v#>dst < k
          -> st = (q,v[0/dst])
          -> (i,mma_decs k i) // (i,v) -+> st.
    Proof.
      intros H1 ?; subst st.
      apply mma_decs_spec_lt; auto.
    Qed.

    Fact mma_decs_le_progress k i v st :
             k <= v#>dst
          -> st = (p,v[((v#>dst)-k)/dst])
          -> (i,mma_decs k i) // (i,v) -+> st.
    Proof.
      intros H1 ?; subst st.
      apply mma_decs_spec_le; auto.
    Qed.

  End mma_decs.

  Notation DECSₐ := mma_decs.

  Section mma_decs_copy.

    (* Same as mma_decs except that the quantity
       removed from dst is transfered into tmp *)

    Variable (dst tmp : pos n) (Hdt : dst <> tmp) (p q : nat).

    Fixpoint mma_decs_copy k i :=
      match k with
        | 0   => INCₐ dst :: DECₐ dst p :: nil
        | S k => DECₐ dst (3+i) :: INCₐ dst :: DECₐ dst q :: INCₐ tmp :: mma_decs_copy k (4+i)
      end.

    Fact mma_decs_copy_length k i : length (mma_decs_copy k i) = 2+4*k.
    Proof.
      revert i; induction k as [ | ? IHk ]; intros i; simpl; auto.
      rewrite IHk; lia.
    Qed.

    Let mma_decs_copy_spec_lt k i v w :
            v#>dst < k
         -> w = v[0/dst][((v#>dst)+(v#>tmp))/tmp]
         -> (i,mma_decs_copy k i) // (i,v) -+> (q,w).
    Proof.
      revert i v w; induction k as [ | k IHk ]; intros i v w H1 ?; subst w.
      + lia.
      + unfold mma_decs_copy; fold mma_decs_copy.
        case_eq (v#>dst).
        * intros H2.
          mma sss DEC zero with dst (3+i).
          mma sss INC with dst.
          mma sss DEC S with dst q (v#>dst); rew vec.
          mma sss stop; f_equal.
          apply vec_pos_ext; intros x; dest x tmp; dest x dst.
        * intros d Hd.
          mma sss DEC S with dst (3+i) d.
          mma sss INC with tmp.
          apply subcode_sss_compute with (P := (4+i,mma_decs_copy k (4+i))); auto.
          apply sss_progress_compute; rewrite plus_assoc.
          apply IHk; rew vec; try lia.
          apply vec_pos_ext; intros x; dest x tmp; try lia; dest x dst.
    Qed.

    Let mma_decs_copy_spec_le k i v w :
            k <= v#>dst
         -> w = v[((v#>dst)-k)/dst][(k+(v#>tmp))/tmp]
         -> (i,mma_decs_copy k i) // (i,v) -+> (p,w).
    Proof.
      revert i v w; induction k as [ | k IHk ]; intros i v w H1 ?; subst w.
      + simpl.
        mma sss INC with dst.
        mma sss DEC S with dst p (v#>dst); rew vec.
        mma sss stop; f_equal.
        apply vec_pos_ext; intros x; dest x dst; try lia; dest x tmp.
      + unfold mma_decs_copy; fold mma_decs_copy.
        mma sss DEC S with dst (3+i) ((v#>dst) - 1); try lia.
        mma sss INC with tmp.
        apply subcode_sss_compute with (P := (4+i,mma_decs_copy k (4+i))); auto.
        apply sss_progress_compute, IHk; rew vec; try lia.
        apply vec_pos_ext; intros x; dest x tmp; try lia; dest x dst; lia.
    Qed.

    Fact mma_decs_copy_lt_progress k i v st :
             v#>dst < k
          -> st = (q,v[0/dst][((v#>dst)+(v#>tmp))/tmp])
          -> (i,mma_decs_copy k i) // (i,v) -+> st.
    Proof using Hdt.
      intros H1 ?; subst st.
      apply mma_decs_copy_spec_lt; auto.
    Qed.

    Fact mma_decs_copy_le_progress k i v st :
             k <= v#>dst
          -> st = (p,v[((v#>dst)-k)/dst][(k+(v#>tmp))/tmp])
          -> (i,mma_decs_copy k i) // (i,v) -+> st.
    Proof using Hdt.
      intros H1 ?; subst st.
      apply mma_decs_copy_spec_le; auto.
    Qed.

  End mma_decs_copy.

  Notation DECS_COPYₐ := mma_decs_copy.

  Hint Rewrite mma_decs_length mma_decs_copy_length : length_db.

  Section mma_mod_cst.

    (* test whether k divides src and transfer of src into dst *)

    Variable (x t : pos n) (Hxt : x <> t) (p q k i : nat).

    Definition mma_mod_cst :=
            EMPTYₐ x p i ++ DECS_COPYₐ x t i q k (4+i).

    Fact mma_mod_cst_length : length mma_mod_cst = 6+4*k.
    Proof. unfold mma_mod_cst; rew length; lia. Qed.

    (* This is of no use when k = 0 *)

    Hypothesis (Hk : 0 < k).

    Let mma_mod_cst_spec_0 v :
           v#>x = 0
        -> (i,mma_mod_cst) // (i,v) -+> (p,v).
    Proof.
      intros H; unfold mma_mod_cst.
      apply subcode_sss_progress with (P := (i, EMPTYₐ x p i)); auto.
      apply mma_empty_progress; auto.
    Qed.

    Let mma_mod_cst_spec_1 a b v w :
           v#>x = a*k+b
        -> w = v[b/x][(a*k+(v#>t))/t]
        -> (i,mma_mod_cst) // (i,v) ->> (i,w).
    Proof.
      revert v w; induction a as [ | a IHa ]; intros v w H1 H2; subst w.
      + mma sss stop; f_equal.
        simpl in H1; rewrite <- H1; simpl; rew vec.
      + unfold mma_mod_cst.
        apply sss_compute_trans with (4+i,v).
        * apply sss_progress_compute,
                subcode_sss_progress with (P := (i, EMPTYₐ x p i)); auto.
          apply mma_non_empty_progress; auto; lia.
        * apply sss_compute_trans with (i, v[(a*k+b)/x][(k+(v#>t))/t]).
          - apply subcode_sss_compute with (P := (4+i,mma_decs_copy x t i q k (4+i))); auto.
            apply sss_progress_compute, mma_decs_copy_le_progress; auto; rew vec.
            { simpl; generalize (a*k); intro; lia. }
            do 3 f_equal; rewrite H1; simpl mult; generalize (a*k); intro; lia.
          - apply IHa; rew vec.
            apply vec_pos_ext; intros y; dest y t; try ring; dest y x.
    Qed.

    Let mma_mod_cst_spec_2 v w :
           0 < v#>x < k
        -> w = v[0/x][((v#>x)+(v#>t))/t]
        -> (i,mma_mod_cst) // (i,v) -+> (q,w).
    Proof.
      intros H ?; subst; unfold mma_mod_cst.
      apply sss_progress_trans with (4+i,v).
      + apply subcode_sss_progress with (P := (i, EMPTYₐ x p i)); auto.
        apply mma_non_empty_progress; auto; lia.
      + apply subcode_sss_progress with (P := (4+i, DECS_COPYₐ x t i q k (4+i))); auto.
        apply mma_decs_copy_lt_progress; auto; lia.
    Qed.

    Fact mma_mod_cst_divides_progress v a st :
            v#>x = a*k
         -> st = (p,v[0/x][((v#>x)+(v#>t))/t])
         -> (i,mma_mod_cst) // (i,v) -+> st.
    Proof using Hxt Hk.
      intros H1 ?; subst st.
      apply sss_compute_progress_trans with (i,v[0/x][((v#>x)+(v#>t))/t]).
      + apply mma_mod_cst_spec_1 with (a := a) (b := 0); try lia.
        rewrite <- H1; auto.
      + apply mma_mod_cst_spec_0; rew vec.
    Qed.

    Fact mma_mod_cst_not_divides_progress v a b st :
            v#>x = a*k+b
         -> 0 < b < k
         -> st = (q,v[0/x][((v#>x)+(v#>t))/t])
         -> (i,mma_mod_cst) // (i,v) -+> st.
    Proof using Hxt Hk.
      intros H1 H2 ?; subst st.
      apply sss_compute_progress_trans with (i,v[b/x][(a*k+(v#>t))/t]).
      + apply mma_mod_cst_spec_1 with (a := a) (b := b); try lia; auto.
      + apply mma_mod_cst_spec_2; rew vec.
        apply vec_pos_ext; intros y; dest y t; try lia; dest y x.
    Qed.

  End mma_mod_cst.

  Notation MOD_CSTₐ := mma_mod_cst.

  Hint Rewrite mma_decs_length mma_mod_cst_length : length_db.

  Section mma_div_cst.

    (* Division by a constant *)

    Variable (s d : pos n) (Hsd : s <> d) (k i : nat).

    Let p := (2+3*k+i).
    Let q := (5+3*k+i).

    Definition mma_div_cst :=
         DECSₐ s p q k i ++ INCₐ d :: JUMPₐ i s.

    Fact mma_div_cst_length : length mma_div_cst = 5+3*k.
    Proof. unfold mma_div_cst; rew length; lia. Qed.

    Hypothesis (Hk : 0 < k).

    Let mma_div_cst_spec a v w :
           v#>s = a*k
        -> w = v[0/s][(a+(v#>d))/d]
        -> (i, mma_div_cst) // (i,v) -+> (q,w).
    Proof.
      unfold mma_div_cst; revert v w; induction a as [ | a IHa ]; intros v w H1 ?; subst w.
      + apply subcode_sss_progress with (P := (i,mma_decs s p q k i)); auto.
        apply mma_decs_lt_progress; try lia.
        f_equal; simpl.
        apply vec_pos_ext; intros y; dest y d.
      + apply sss_progress_trans with (p,v[(a*k)/s]).
        * apply subcode_sss_progress with (P := (i,mma_decs s p q k i)); auto.
          apply mma_decs_le_progress.
          - rewrite H1; simpl; generalize (a*k); intro; lia.
          - f_equal.
            apply vec_pos_ext; intros y; dest y d; dest y s.
            rewrite H1; simpl; generalize (a*k); intro; lia.
        * unfold p.
          mma sss INC with d.
          apply sss_compute_trans with (i,v[(a*k)/s][(S (v[(a*k)/s]#>d))/d]).
          - apply sss_progress_compute,
                  subcode_sss_progress with (P := (3+3*k+i, JUMPₐ i s)); auto.
            apply mma_jump_progress; auto.
          - apply sss_progress_compute, IHa; rew vec.
            apply vec_pos_ext; intros y; dest y d; try lia; dest y s.
    Qed.

    Fact mma_div_cst_progress a v st :
            v#>s = a*k
         -> st = (q,v[0/s][(a+(v#>d))/d])
         -> (i, mma_div_cst) // (i,v) -+> st.
    Proof using Hsd Hk.
      intros H1 H2; subst st; apply mma_div_cst_spec with (1 := H1); auto.
    Qed.

  End mma_div_cst.

  Notation DIV_CSTₐ := mma_div_cst.

  Hint Rewrite mma_div_cst_length : length_db.

  Section mma_loop.

    Variables (x : pos n) (i : nat).

    Definition mma_loop := JUMPₐ i x.

    Fact mma_loop_loop v : (i,mma_loop) // (i,v) -+> (i,v).
    Proof. apply mma_jump_progress; auto. Qed.

    Theorem mma_loop_spec v : ~ (i,mma_loop) // (i,v) ↓.
    Proof.
      apply sss_progress_non_termination.
      + apply mma_sss_fun.
      + apply mma_loop_loop.
    Qed.

  End mma_loop.

  Notation LOOPₐ := mma_loop.

End Minsky_Machine_alt_utils.


Lemma deMorgen: forall x y:Prop, not (x \/ y) <-> not x /\ not y.
Proof.
intros.
unfold not.
split.
- intros.
  split.
  + intros.
    apply H.
    left.
    exact H0.
  + intros.
    apply H.
    right.
    assumption.
- intros.
  destruct H.
  destruct H0.
  + apply H.
    assumption.
  + apply H1.
    assumption.
Qed.


Require Import Metalib.Metatheory.
(** syntax *)
Definition index : Set := nat.

Inductive typ : Set :=  (*r types *)
 | typ_base : typ (*r base type *)
 | typ_arrow (T1:typ) (T2:typ) (*r function types *).

Inductive exp : Set :=  (*r expressions *)
 | var_b (_:nat) (*r variables *)
 | var_f (x:var) (*r variables *)
 | abs (e:exp) (*r abstractions *)
 | app (e1:exp) (e2:exp) (*r applications *).

Definition ctx : Set := list ( atom * typ ).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => var_b nat
        | inleft (right _) => e_5
        | inright _ => var_b (nat - 1)
      end
  | (var_f x) => var_f x
  | (abs e) => abs (open_exp_wrt_exp_rec (S k) e_5 e)
  | (app e1 e2) => app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
end.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_var_f : forall (x:var),
     (lc_exp (var_f x))
 | lc_abs : forall (e:exp),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (var_f x) )  )  ->
     (lc_exp (abs e))
 | lc_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (app e1 e2)).
(** free variables *)
Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (var_b nat) => {}
  | (var_f x) => {{x}}
  | (abs e) => (fv_exp e)
  | (app e1 e2) => (fv_exp e1) \u (fv_exp e2)
end.

(** substitutions *)
Fixpoint subst_exp (e_5:exp) (x5:var) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (var_b nat) => var_b nat
  | (var_f x) => (if eq_var x x5 then e_5 else (var_f x))
  | (abs e) => abs (subst_exp e_5 x5 e)
  | (app e1 e2) => app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
end.

Definition is_value (e : exp) : Prop :=
  match e with
  | abs _   => True
  | _       => False
  end.

Module StlcNotations.
Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0).
Notation open e1 e2     := (open_exp_wrt_exp e1 e2).
End StlcNotations.

(** definitions *)

(* defns JTyping *)
Inductive typing : ctx -> exp -> typ -> Prop :=    (* defn typing *)
 | typing_var : forall (G:ctx) (x:var) (T:typ),
      uniq  G  ->
      binds  x T G  ->
     typing G (var_f x) T
 | typing_abs : forall (L:vars) (G:ctx) (e:exp) (T1 T2:typ),
      ( forall x , x \notin  L  -> typing  (( x ~ T1 )++ G )   ( open_exp_wrt_exp e (var_f x) )  T2 )  ->
     typing G (abs e) (typ_arrow T1 T2)
 | typing_app : forall (G:ctx) (e1 e2:exp) (T2 T1:typ),
     typing G e1 (typ_arrow T1 T2) ->
     typing G e2 T1 ->
     typing G (app e1 e2) T2.

(* defns JEval *)
Inductive step : exp -> exp -> Prop :=    (* defn step *)
 | step_beta : forall (e1 e2:exp),
     lc_exp (abs e1) ->
     lc_exp e2 ->
     step (app  ( (abs e1) )  e2)  (open_exp_wrt_exp  e1 e2 )
 | step_app : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (app e1 e2) (app e1' e2).

(** infrastructure *)
#[export] Hint Constructors typing step lc_exp : core.


(**********************************************************************

 Every monad induces a monad on the hom-categories

 Given a bicategory `B`, a monad `m` in `B`, and an object `x`,
 then we get a monad on `hom x (pr1 m)`.

 **********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.

Local Open Scope cat.

Section MonadToCatMonad.
  Context {B : bicat}
          (m : mnd B)
          (x : B).

  Definition mnd_to_functor
    : hom x (pr1 m) ⟶ hom x (pr1 m)
    := post_comp x (endo_of_mnd m).

  Definition mnd_to_cat_mu
    : mnd_to_functor ∙ mnd_to_functor ⟹ mnd_to_functor.
  Proof.
    use make_nat_trans.
    - exact (λ f, rassociator _ _ _ • (f ◃ mult_of_mnd m)).
    - abstract
        (intros f g α ; cbn ;
         rewrite !vassocr ;
         rewrite rwhisker_rwhisker_alt ;
         rewrite !vassocl ;
         rewrite vcomp_whisker ;
         apply idpath).
  Defined.

  Definition mnd_to_cat_unit
    : functor_identity _ ⟹ mnd_to_functor.
  Proof.
    use make_nat_trans.
    - exact (λ f, rinvunitor _ • (f ◃ unit_of_mnd m)).
    - abstract
        (intros f g α ; cbn ;
         rewrite !vassocr ;
         rewrite rinvunitor_natural ;
         rewrite <- rwhisker_hcomp ;
         rewrite !vassocl ;
         rewrite vcomp_whisker ;
         apply idpath).
  Defined.

  Definition mnd_to_cat_Monad_data
    : Monad_data (hom x (pr1 m)).
  Proof.
    simple refine ((_ ,, _) ,, _).
    - exact mnd_to_functor.
    - exact mnd_to_cat_mu.
    - exact mnd_to_cat_unit.
  Defined.

  Definition mnd_to_cat_Monad_laws
    : Monad_laws mnd_to_cat_Monad_data.
  Proof.
    repeat split ; intro f ; cbn.
    - rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite lwhisker_vcomp.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite <- rinvunitor_triangle.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      rewrite lwhisker_vcomp.
      refine (_ @ lwhisker_id2 _ _).
      apply maponpaths.
      rewrite !vassocr.
      exact (mnd_unit_right m).
    - rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        rewrite lwhisker_vcomp.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      rewrite lwhisker_vcomp.
      refine (_ @ lwhisker_id2 _ _).
      apply maponpaths.
      rewrite !vassocr.
      exact (mnd_unit_left m).
    - rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        rewrite lwhisker_vcomp.
        apply idpath.
      }
      use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      rewrite inverse_pentagon_7.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      refine (!_).
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      exact (mnd_mult_assoc m).
  Qed.

  Definition mnd_to_cat_Monad
    : Monad (hom x (pr1 m)).
  Proof.
    simple refine (_ ,, _).
    - exact mnd_to_cat_Monad_data.
    - exact mnd_to_cat_Monad_laws.
  Defined.
End MonadToCatMonad.