Require Import rt.util.all.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.task rt.model.priority.
Require Import rt.model.schedule.global.schedulability.
Require Import rt.model.schedule.global.basic.schedule.
Require Import rt.model.schedule.apa.affinity rt.model.schedule.apa.interference rt.model.schedule.apa.platform.
Require Import rt.analysis.apa.workload_bound
               rt.analysis.apa.interference_bound_edf
               rt.analysis.apa.bertogna_edf_comp.
Require Import rt.implementation.apa.job
               rt.implementation.apa.task
               rt.implementation.apa.schedule
               rt.implementation.apa.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq fintype bigop div.

Module ResponseTimeAnalysisEDF.

  Import Job Schedule SporadicTaskset Priority Schedulability
         Affinity Platform InterferenceBoundEDF WorkloadBound
         Interference ResponseTimeIterationEDF.
  Import ConcreteJob ConcreteTask ConcreteArrivalSequence ConcreteScheduler.

  (* In this section, we instantiate a simple example to show that the theorems
     contain no contradictory assumptions. *)
  Section ExampleRTA.

    (* Assume there are two processors. *)
    Let num_cpus := 2.

    (* Let (cpu j) denote the j-th processor *)
    Let cpu j := @Ordinal num_cpus j.

    (* Define alpha1 := {cpu 0, cpu 1} with the two processors. *)
    Program Let alpha1 : affinity num_cpus :=
      (Build_set [:: cpu 0 _; cpu 1 _] _).

    (* Define the singleton affinity alpha2 := {cpu 0}. *)
    Program Let alpha2 : affinity num_cpus :=
      (Build_set [:: cpu 0 _] _).

    (* Define the singleton affinity alpha3 := {cpu 1}. *)
    Program Let alpha3 : affinity num_cpus :=
      (Build_set [:: cpu 1 _] _).

    (* Now we create three tasks using the affinities above ... *)
    Let tsk1 := {| task_id := 1; task_cost := 3; task_period := 5;
                   task_deadline := 3; task_affinity := alpha1|}.
    Let tsk2 := {| task_id := 2; task_cost := 2; task_period := 6;
                   task_deadline := 5; task_affinity  := alpha2|}.
    Let tsk3 := {| task_id := 3; task_cost := 2; task_period := 12;
                   task_deadline := 11; task_affinity := alpha3|}.

    (* ... and group these tasks into task set ts. *)
    Program Let ts := Build_set [:: tsk1; tsk2; tsk3] _.

    (* In this section, we let Coq compute a few properties about ts. *)
    Section FactsAboutTaskset.

      (* There are no empty affinities. *)
      Fact ts_non_empty_affinities:
        forall tsk,
          tsk \in ts ->
          #|task_affinity tsk| > 0.
      Proof.
        intros tsk IN.
        by repeat (move: IN => /orP [/eqP EQ | IN]; subst; rewrite ?set_card; compute).
      Qed.

      (* The tasks have valid parameters (e.g., cost > 0). *)
      Fact ts_has_valid_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline ts.
      Proof.
        intros tsk IN.
        by repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute).
      Qed.

      (* The task set has constrained deadlines. *)
      Fact ts_has_constrained_deadlines:
        forall tsk,
          tsk \in ts ->
          task_deadline tsk <= task_period tsk.
      Proof.
        intros tsk IN.
        by repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute).
      Qed.

    End FactsAboutTaskset.

    (* Next, recall the EDF RTA schedulability test for APA scheduling.
       Note that the task functions (from implementation/apa/task.v)
       require num_cpus as a parameter, so we leave a blank space so that
       can be inferred automatically. *)
    Let schedulability_test :=
      edf_schedulable (@task_cost _) (@task_period _)
                      (@task_deadline _) num_cpus task_affinity
                      task_affinity. (* For simplicity, we use subaffinity alpha' = alpha. *)

    (* Now, we guide Coq to compute the schedulability test function
       and show it returns true. *)
    Fact schedulability_test_succeeds :
      schedulability_test ts = true.
    Proof.
      unfold schedulability_test, edf_schedulable, edf_claimed_bounds; desf.
      apply negbT in Heq; move: Heq => /negP ALL.
      exfalso; apply ALL; clear ALL.
      assert (STEPS: \sum_(tsk <- ts) (task_deadline tsk - task_cost tsk) + 1 = 13).
      {
        by rewrite unlock; compute.
      } rewrite STEPS; clear STEPS.

      Local Ltac f :=
        unfold edf_rta_iteration; simpl;
        unfold edf_response_time_bound, div_floor, total_interference_bound_edf, interference_bound_edf, interference_bound_generic, W, edf_specific_interference_bound, different_task_in, affinity_intersects; simpl;
        rewrite !addnE !set_card !big_cons ?big_nil /=.

      Local Ltac g := destruct master_key; f; simpl_exists_ord.
      rewrite [edf_rta_iteration]lock; simpl.
      unfold locked at 13; g.
      unfold locked at 12; g.
      unfold locked at 11; g.
      unfold locked at 10; g.
      unfold locked at 9; g.
      unfold locked at 8; g.
      unfold locked at 7; g.
      unfold locked at 6; g.
      unfold locked at 5; g.
      unfold locked at 4; g.
      unfold locked at 3; g.
      unfold locked at 2; g.
      by unfold locked at 1; g.
    Qed.

    (* Let arr_seq be the periodic arrival sequence from ts. *)
    Let arr_seq := periodic_arrival_sequence ts.

    (* Let sched be the weak APA EDF scheduler. *)
    Let sched := scheduler job_arrival job_cost job_task num_cpus arr_seq task_affinity
                           (JLFP_to_JLDP (EDF job_arrival job_deadline)).

    (* Recall the definition of deadline miss. *)
    Let no_deadline_missed_by :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.

    (* To show that the RTA works, we infer the schedulability of the task
       set from the result of the RTA procedure. *)
    Corollary ts_is_schedulable:
      forall tsk,
        tsk \in ts ->
        no_deadline_missed_by tsk.
    Proof.
      intros tsk IN.
      have VALID := periodic_arrivals_valid_job_parameters ts ts_has_valid_parameters.
      have VALIDTS := ts_has_valid_parameters.
      unfold valid_sporadic_job, valid_realtime_job in *; des.
      apply taskset_schedulable_by_edf_rta with (task_cost := task_cost) (task_period := task_period)
        (task_deadline := task_deadline) (alpha := task_affinity) (alpha' := task_affinity)
        (ts0 := ts); try (by done).
      - by apply ts_has_constrained_deadlines.
      - by apply ts_non_empty_affinities.
      - by ins.
      - by apply periodic_arrivals_all_jobs_from_taskset.
      - by apply periodic_arrivals_are_sporadic.
      - by apply scheduler_jobs_come_from_arrival_sequence.
      - by apply scheduler_jobs_must_arrive_to_execute.
      - apply scheduler_completed_jobs_dont_execute.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
      - apply scheduler_sequential_jobs.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
      - by apply scheduler_respects_affinity.
      - apply scheduler_apa_work_conserving.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
        -- by intros t; apply RM_is_transitive.
        -- by intros t x y; apply leq_total.
      - apply scheduler_respects_policy.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
        -- by intros t; apply RM_is_transitive.
        -- by intros t x y; apply leq_total.
      - by apply schedulability_test_succeeds.
    Qed.

  End ExampleRTA.

End ResponseTimeAnalysisEDF.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Multi-way branches (``switch'' statements) and their compilation
    to comparison trees. *)

Require Import EqNat.
Require Import FMaps.
Require FMapAVL.
Require Import Coqlib.
Require Import Integers.
Require Import Ordered.

Module IntMap := FMapAVL.Make(OrderedInt).
Module IntMapF := FMapFacts.Facts(IntMap).

(** A multi-way branch is composed of a list of (key, action) pairs,
  plus a default action.  *)

Definition table : Type := list (int * nat).

Fixpoint switch_target (n: int) (dfl: nat) (cases: table)
                       {struct cases} : nat :=
  match cases with
  | nil => dfl
  | (key, action) :: rem =>
      if Int.eq n key then action else switch_target n dfl rem
  end.

(** Multi-way branches are translated to comparison trees.
    Each node of the tree performs either
- an equality against one of the keys;
- or a "less than" test against one of the keys;
- or a computed branch (jump table) against a range of key values. *)

Inductive comptree : Type :=
  | CTaction: nat -> comptree
  | CTifeq: int -> nat -> comptree -> comptree
  | CTiflt: int -> comptree -> comptree -> comptree
  | CTjumptable: int -> int -> list nat -> comptree -> comptree.

Fixpoint comptree_match (n: int) (t: comptree) {struct t}: option nat :=
  match t with
  | CTaction act => Some act
  | CTifeq key act t' =>
      if Int.eq n key then Some act else comptree_match n t'
  | CTiflt key t1 t2 =>
      if Int.ltu n key then comptree_match n t1 else comptree_match n t2
  | CTjumptable ofs sz tbl t' =>
      if Int.ltu (Int.sub n ofs) sz
      then list_nth_z tbl (Int.unsigned (Int.sub n ofs))
      else comptree_match n t'
  end.

(** The translation from a table to a comparison tree is performed
  by untrusted Caml code (function [compile_switch] in
  file [RTLgenaux.ml]).  In Coq, we validate a posteriori the
  result of this function.  In other terms, we now develop
  and prove correct Coq functions that take a table and a comparison
  tree, and check that their semantics are equivalent. *)

Fixpoint split_lt (pivot: int) (cases: table)
                  {struct cases} : table * table :=
  match cases with
  | nil => (nil, nil)
  | (key, act) :: rem =>
      let (l, r) := split_lt pivot rem in
      if Int.ltu key pivot
      then ((key, act) :: l, r)
      else (l, (key, act) :: r)
  end.

Fixpoint split_eq (pivot: int) (cases: table)
                  {struct cases} : option nat * table :=
  match cases with
  | nil => (None, nil)
  | (key, act) :: rem =>
      let (same, others) := split_eq pivot rem in
      if Int.eq key pivot
      then (Some act, others)
      else (same, (key, act) :: others)
  end.

Fixpoint split_between (ofs sz: int) (cases: table)
                       {struct cases} : IntMap.t nat * table :=
  match cases with
  | nil => (IntMap.empty nat, nil)
  | (key, act) :: rem =>
      let (inside, outside) := split_between ofs sz rem in
      if Int.ltu (Int.sub key ofs) sz
      then (IntMap.add key act inside, outside)
      else (inside, (key, act) :: outside)
  end.

Definition refine_low_bound (v lo: Z) :=
  if zeq v lo then lo + 1 else lo.

Definition refine_high_bound (v hi: Z) :=
  if zeq v hi then hi - 1 else hi.

Fixpoint validate_jumptable (cases: IntMap.t nat) (default: nat)
                            (tbl: list nat) (n: int) {struct tbl} : bool :=
  match tbl with
  | nil => true
  | act :: rem =>
      beq_nat act (match IntMap.find n cases with Some a => a | None => default end)
      && validate_jumptable cases default rem (Int.add n Int.one)
  end.

Fixpoint validate (default: nat) (cases: table) (t: comptree)
                  (lo hi: Z) {struct t} : bool :=
  match t with
  | CTaction act =>
      match cases with
      | nil =>
          beq_nat act default
      | (key1, act1) :: _ =>
          zeq (Int.unsigned key1) lo && zeq lo hi && beq_nat act act1
      end
  | CTifeq pivot act t' =>
      match split_eq pivot cases with
      | (None, _) =>
          false
      | (Some act', others) =>
          beq_nat act act'
          && validate default others t'
                      (refine_low_bound (Int.unsigned pivot) lo)
                      (refine_high_bound (Int.unsigned pivot) hi)
      end
  | CTiflt pivot t1 t2 =>
      match split_lt pivot cases with
      | (lcases, rcases) =>
          validate default lcases t1 lo (Int.unsigned pivot - 1)
          && validate default rcases t2 (Int.unsigned pivot) hi
      end
  | CTjumptable ofs sz tbl t' =>
      let tbl_len := list_length_z tbl in
      match split_between ofs sz cases with
      | (inside, outside) =>
          zle (Int.unsigned sz) tbl_len
          && zle tbl_len Int.max_signed
          && validate_jumptable inside default tbl ofs
          && validate default outside t' lo hi
     end
  end.

Definition validate_switch (default: nat) (cases: table) (t: comptree) :=
  validate default cases t 0 Int.max_unsigned.

(** Correctness proof for validation. *)

Lemma split_eq_prop:
  forall v default n cases optact cases',
  split_eq n cases = (optact, cases') ->
  switch_target v default cases =
   (if Int.eq v n
    then match optact with Some act => act | None => default end
    else switch_target v default cases').
Proof.
  induction cases; simpl; intros until cases'.
  intros. inversion H; subst. simpl.
  destruct (Int.eq v n); auto.
  destruct a as [key act].
  case_eq (split_eq n cases). intros same other SEQ.
  rewrite (IHcases _ _ SEQ).
  predSpec Int.eq Int.eq_spec key n; intro EQ; inversion EQ; simpl.
  subst n. destruct (Int.eq v key). auto. auto.
  predSpec Int.eq Int.eq_spec v key.
  subst v. predSpec Int.eq Int.eq_spec key n. congruence. auto.
  auto.
Qed.

Lemma split_lt_prop:
  forall v default n cases lcases rcases,
  split_lt n cases = (lcases, rcases) ->
  switch_target v default cases =
    (if Int.ltu v n
     then switch_target v default lcases
     else switch_target v default rcases).
Proof.
  induction cases; intros until rcases; simpl.
  intro. inversion H; subst. simpl.
  destruct (Int.ltu v n); auto.
  destruct a as [key act].
  case_eq (split_lt n cases). intros lc rc SEQ.
  rewrite (IHcases _ _ SEQ).
  case_eq (Int.ltu key n); intros; inv H0; simpl.
  predSpec Int.eq Int.eq_spec v key.
  subst v. rewrite H. auto.
  auto.
  predSpec Int.eq Int.eq_spec v key.
  subst v. rewrite H. auto.
  auto.
Qed.

Lemma split_between_prop:
  forall v default ofs sz cases inside outside,
  split_between ofs sz cases = (inside, outside) ->
  switch_target v default cases =
    (if Int.ltu (Int.sub v ofs) sz
     then match IntMap.find v inside with Some a => a | None => default end
     else switch_target v default outside).
Proof.
  induction cases; intros until outside; simpl.
  intros. inv H. simpl. destruct (Int.ltu (Int.sub v ofs) sz); auto.
  destruct a as [key act]. case_eq (split_between ofs sz cases). intros ins outs SEQ.
  rewrite (IHcases _ _ SEQ).
  case_eq (Int.ltu (Int.sub key ofs) sz); intros; inv H0; simpl.
  rewrite IntMapF.add_o.
  predSpec Int.eq Int.eq_spec v key.
  subst v. rewrite H. rewrite dec_eq_true. auto.
  rewrite dec_eq_false; auto.
  case_eq (Int.ltu (Int.sub v ofs) sz); intros; auto.
  predSpec Int.eq Int.eq_spec v key.
  subst v. congruence.
  auto.
Qed.

Lemma validate_jumptable_correct_rec:
  forall cases default tbl base v,
  validate_jumptable cases default tbl base = true ->
  0 <= Int.unsigned v < list_length_z tbl ->
  list_nth_z tbl (Int.unsigned v) =
  Some(match IntMap.find (Int.add base v) cases with Some a => a | None => default end).
Proof.
  induction tbl; intros until v; simpl.
  unfold list_length_z; simpl. intros. omegaContradiction.
  rewrite list_length_z_cons. intros. destruct (andb_prop _ _ H). clear H.
  generalize (beq_nat_eq _ _ (sym_equal H1)). clear H1. intro. subst a.
  destruct (zeq (Int.unsigned v) 0).
  unfold Int.add. rewrite e. rewrite Zplus_0_r. rewrite Int.repr_unsigned. auto.
  assert (Int.unsigned (Int.sub v Int.one) = Int.unsigned v - 1).
    unfold Int.sub. change (Int.unsigned Int.one) with 1.
    apply Int.unsigned_repr. split. omega.
    generalize (Int.unsigned_range_2 v). omega.
  replace (Int.add base v) with (Int.add (Int.add base Int.one) (Int.sub v Int.one)).
  rewrite <- IHtbl. rewrite H. auto. auto. rewrite H. omega.
  rewrite Int.sub_add_opp. rewrite Int.add_permut. rewrite Int.add_assoc.
  replace (Int.add Int.one (Int.neg Int.one)) with Int.zero.
  rewrite Int.add_zero. apply Int.add_commut.
  apply Int.mkint_eq. reflexivity.
Qed.

Lemma validate_jumptable_correct:
  forall cases default tbl ofs v sz,
  validate_jumptable cases default tbl ofs = true ->
  Int.ltu (Int.sub v ofs) sz = true ->
  Int.unsigned sz <= list_length_z tbl ->
  list_nth_z tbl (Int.unsigned (Int.sub v ofs)) =
  Some(match IntMap.find v cases with Some a => a | None => default end).
Proof.
  intros.
  exploit Int.ltu_inv; eauto. intros.
  rewrite (validate_jumptable_correct_rec cases default tbl ofs).
  rewrite Int.sub_add_opp. rewrite Int.add_permut. rewrite <- Int.sub_add_opp.
  rewrite Int.sub_idem. rewrite Int.add_zero. auto.
  auto.
  omega.
Qed.

Lemma validate_correct_rec:
  forall default v t cases lo hi,
  validate default cases t lo hi = true ->
  lo <= Int.unsigned v <= hi ->
  comptree_match v t = Some (switch_target v default cases).
Proof.
Opaque Int.sub.
  induction t; simpl; intros until hi.
  (* base case *)
  destruct cases as [ | [key1 act1] cases1]; intros.
  replace n with default. reflexivity.
  symmetry. apply beq_nat_eq. auto.
  destruct (andb_prop _ _ H). destruct (andb_prop _ _ H1). clear H H1.
  assert (Int.unsigned key1 = lo). eapply proj_sumbool_true; eauto.
  assert (lo = hi). eapply proj_sumbool_true; eauto.
  assert (Int.unsigned v = Int.unsigned key1). omega.
  replace n with act1.
  simpl. unfold Int.eq. rewrite H5. rewrite zeq_true. auto.
  symmetry. apply beq_nat_eq. auto.
  (* eq node *)
  case_eq (split_eq i cases). intros optact cases' EQ.
  destruct optact as [ act | ]. 2: congruence.
  intros. destruct (andb_prop _ _ H). clear H.
  rewrite (split_eq_prop v default _ _ _ _ EQ).
  predSpec Int.eq Int.eq_spec v i.
  f_equal. apply beq_nat_eq; auto.
  eapply IHt. eauto.
  assert (Int.unsigned v <> Int.unsigned i).
    rewrite <- (Int.repr_unsigned v) in H.
    rewrite <- (Int.repr_unsigned i) in H.
    congruence.
  split.
  unfold refine_low_bound. destruct (zeq (Int.unsigned i) lo); omega.
  unfold refine_high_bound. destruct (zeq (Int.unsigned i) hi); omega.
  (* lt node *)
  case_eq (split_lt i cases). intros lcases rcases EQ V RANGE.
  destruct (andb_prop _ _ V). clear V.
  rewrite (split_lt_prop v default _ _ _ _ EQ).
  unfold Int.ltu. destruct (zlt (Int.unsigned v) (Int.unsigned i)).
  eapply IHt1. eauto. omega.
  eapply IHt2. eauto. omega.
  (* jumptable node *)
  case_eq (split_between i i0 cases). intros ins outs EQ V RANGE.
  destruct (andb_prop _ _ V). clear V.
  destruct (andb_prop _ _ H). clear H.
  destruct (andb_prop _ _ H1). clear H1.
  rewrite (split_between_prop v _ _ _ _ _ _ EQ).
  case_eq (Int.ltu (Int.sub v i) i0); intros.
  eapply validate_jumptable_correct; eauto.
  eapply proj_sumbool_true; eauto.
  eapply IHt; eauto.
Qed.

Definition table_tree_agree
    (default: nat) (cases: table) (t: comptree) : Prop :=
  forall v, comptree_match v t = Some(switch_target v default cases).

Theorem validate_switch_correct:
  forall default t cases,
  validate_switch default cases t = true ->
  table_tree_agree default cases t.
Proof.
  unfold validate_switch, table_tree_agree; intros.
  eapply validate_correct_rec; eauto.
  apply Int.unsigned_range_2.
Qed.


Require Import ExtLib.Structures.Monoid.
Require Import ExtLib.Data.List.

Require Import Coq.Vectors.Vector.
Import VectorNotations.

(* Dominic Orchard style graded/indexed monad *)
(* See "Embedding Effect Systems in Haskell"
   http://www.cl.cam.ac.uk/~dao29/publ/haskell14-effects.pdf *)
Section indexed.
  Context {x : Type}.
  Context {eff: Monoid x}.

  Class EffFunctor (f : x -> Type -> Type) : Type :=
  { fmap : forall {a b i}, (a -> b) -> f i a -> f i b }.

  Class EffApplicative (t : x -> Type -> Type) :=
  {
    (* applicative_is_functor :> EffFunctor t *)
    pure : forall {a}, a -> t (monoid_unit eff) a
  ; ap : forall {a b m n}, t m (a -> b) -> t n a -> t (monoid_plus eff m n) b
  }.

  Class EffMonad (m : x -> Type -> Type) : Type :=
  {
    (* monad_is_applicative :> EffApplicative m *)
    ret : forall {a}, a -> m (monoid_unit eff) a
  ; bind : forall {a b s t}, m s a -> (a -> m t b) -> m (monoid_plus eff s t) b
  }.

  Class EffMonadFix {x} (eff: Monoid x) (m : x -> Type -> Type) : Type :=
  { mfix : forall {a b s}, ((a -> m s b) -> a -> m s b) -> a -> m s b }.

  Definition mcompose {m} {M: EffMonad m}
             {T U V:Type} {a b}
             (f: T -> m a U) (g: U -> m b V): (T -> m (monoid_plus eff a b) V) :=
    fun x => bind (f x) g.

  (* Class EffTraversable (t : Type -> Type) : Type := *)
  (* { traverse_effect : forall {a}, t a -> x -> x *)
  (* ; mapT : forall {f : x -> Type -> Type} {Ap:EffApplicative f} {a b m}, *)
  (*     (a -> f m b) -> forall (i: t a), f (traverse_effect i m) (t b) *)
  (* }. *)
End indexed.

Module EffMonadNotation.
  Declare Scope eff_monad_scope.
  Delimit Scope eff_monad_scope with eff_monad.

  Notation "c >>= f" := (bind c f) (at level 58, left associativity) : eff_monad_scope.
  Notation "f =<< c" := (bind c f) (at level 61, right associativity) : eff_monad_scope.
  Notation "f >=> g" := (mcompose f g) (at level 61, right associativity) : eff_monad_scope.

  Notation "e1 ;; e2" := (bind e1%eff_monad (fun _ => e2%eff_monad))%eff_monad
    (at level 61, right associativity) : eff_monad_scope.

  Notation "x <- c1 ;; c2" := (bind c1 (fun x => c2))
    (at level 61, c1 at next level, right associativity) : eff_monad_scope.

  Notation "' pat <- c1 ;; c2" :=
    (bind c1 (fun x => match x with pat => c2 end))
    (at level 61, pat pattern, c1 at next level, right associativity) : eff_monad_scope.
End EffMonadNotation.

Module EffFunctorNotation.
  Notation "f <$> x" := (fmap f x) (at level 52, left associativity).
End EffFunctorNotation.

Module EffApplicativeNotation.
  Notation "f <*> x" := (ap f x) (at level 52, left associativity).
End EffApplicativeNotation.


Require Export assetmapping_spl_def.
Require Export featuremodel_spl_def.
Require Export cktrans_spl_def.
Require Export spl_int.
Require Export assetmapping_spl_int.
Require Export assetmapping_spl_inst.

Require Export featuremodel_spl_int.
Require Export featuremodel_spl_inst.
Require Export featuremodel_spl_proofs.

Require Export cktrans_spl_int.
Require Export cktrans_spl_proofs.
Require Export cktrans_spl_inst.

Require Export maps_proofs.
Require Export maps_int.
Require Export maps_def.
Require Export maps_inst.

Require Export spl_def.

Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.
Import Maps.
Import CKTransSPL.
Import FeatureModelSPL.
Import AssetMappingSPL.
Import SPL.

    Lemma equalsRefinementAlt:
      forall pl1 pl2, pl1 = pl2-> plRefinementAlt_func pl1 pl2.
      Proof.
      intros. rewrite H.
      unfold plRefinementAlt_func.
      intros.
      exists p1.
      split.
        + apply H0.
        + apply assetRefinementReflexivity_axiom.
      Qed.

    Lemma equalsStrongerPL:
    forall pl1 pl2, pl1 = pl2 -> strongerPLrefinement_func pl1 pl2.
    Proof.
    intros.
    unfold strongerPLrefinement_func.
    intros. split.
    - rewrite H in H0. apply H0.
    - rewrite H. apply assetRefinementReflexivity_axiom.
    Qed.

   Lemma equalsPL:
    forall pl1 pl2, pl1 = pl2 -> plRefinement_func pl1 pl2.
    Proof.
    intros.
    unfold plRefinement_func.
    intros.  exists c1. split.
    - rewrite H in H0. apply H0.
    - rewrite H. apply assetRefinementReflexivity_axiom.
    Qed.

    Axiom fmref: FMRef = FMRef_Func.
    Axiom equivalentCK_axiom:  equivalentCKs = equivalentCKs_func.
    Axiom weakerEqCK_axiom:  weakerEqCK = weakerEqCK_func.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  If a relation R is MMA_computable then it is MMA_mon_computable,
  where the first counter never decreases.
*)

From Undecidability Require Import TM.TM.
From Undecidability.MinskyMachines Require Import MM MMA MMA.mma_defs Util.MMA_computable.

From Undecidability.Shared.Libs.DLW
  Require Import Vec.pos Vec.vec Code.sss.

Require Undecidability.Shared.deterministic_simulation.

Require Import List PeanoNat Lia Relations.
Import ListNotations.

Require Import ssreflect.

Module Sim := deterministic_simulation.

Set Default Goal Selector "!".

#[local] Notation "P // s ~~> t" := (sss_output (@mma_sss _) P s t).
#[local] Notation "P // s ->> t" := (sss_compute (@mma_sss _) P s t).

Definition NonZero {n} (a : Fin.t (S n)) :=
  if a is Fin.F1 then False else True.

(* MMA computability with a non-decreasing first counter value *)
Definition MMA_mon_computable {k} (R : Vector.t nat k -> nat -> Prop) :=
  exists n : nat, exists P : list (mm_instr (Fin.t (S (k + n)))),
    Forall (fun instr => if instr is DEC c _ then NonZero c else True) P /\
    forall v : Vector.t nat k,
      (forall m, R v m <->
         exists c (v' : Vector.t nat (k + n)), (1, P) // (1, Vector.append (0 ## v) (Vector.const 0 n)) ~~> (c, m ## v')).

(* alternative characterization *)
Lemma MMA_mon_computable_iff {k} (R : Vector.t nat k -> nat -> Prop) :
  MMA_mon_computable R <->
  (exists n : nat, exists P : list (mm_instr (Fin.t (S (k + n)))),
    Forall (fun instr => if instr is DEC c _ then NonZero c else True) P /\
    (forall v m, R v m -> exists c v', (1, P) // (1, Vector.append (0 ## v) (Vector.const 0 n)) ~~> (c, m ## v')) /\
    (forall v, sss.sss_terminates (@mma_sss _) (1, P) (1, Vector.append (0 ## v) (Vector.const 0 n)) -> exists m, R v m)).
Proof.
  split.
  - move=> [n] [P] [H1P H2P]. exists n, P. split; [done|split].
    + by move=> ?? /H2P.
    + move=> v [[c' v']]. rewrite (Vector.eta v') => HP.
      exists (Vector.hd v'). apply /H2P.
      do 2 eexists. eassumption.
  - move=> [n] [P] [H1P [H2P H3P]]. exists n, P. split; [done|split].
    + apply: H2P.
    + move=> [c] [v'] Hm.
      have /H3P [m' Hm'] : sss_terminates (mma_sss (n:=S (k + n))) (1, P) (1, Vector.append (0 ## v) (Vector.const 0 n)).
      { eexists. eassumption. }
      suff : m' = m by move=> <-.
      move: Hm' Hm => /H2P [?] [?] /(sss_output_fun (@mma_sss_fun _)) /[apply].
      by move=> /pair_equal_spec [_] /Vector.cons_inj [].
Qed.

(* generic auxiliary facts *)
Module Facts.

(* transforms a goal (A -> B) -> C into goals A and B -> C *)
Lemma unnest : forall (A B C : Type), A -> (B -> C) -> (A -> B) -> C.
Proof. auto. Qed.

Lemma vec_append_const (c : nat) n m : Vector.append (Vector.const c n) (Vector.const c m) = Vector.const c (n + m).
Proof.
  elim: n. { done. }
  by move=> ? /= ->.
Qed.

Lemma vec_app_eq {T : Type} {n m} {v : Vector.t T n} {w : Vector.t T m} : Vector.append v w = vec_app v w.
Proof.
  elim: v. { by rewrite vec_app_nil. }
  move=> > /= ->. by rewrite vec_app_cons.
Qed.

Lemma vec_append_splitat {X n m} (v : Vector.t X (n + m)) : v = Vector.append (fst (Vector.splitat _ v)) (snd (Vector.splitat _ v)).
Proof.
  apply: Vector.append_splitat.
  by case: (Vector.splitat n v).
Qed.

Lemma vec_append_inj {X n m} {v v' : Vector.t X n} {w w' : Vector.t X m} :
  Vector.append v w = Vector.append v' w' -> v = v' /\ w = w'.
Proof.
  move=> /(f_equal (Vector.splitat _)).
  rewrite !Vector.splitat_append. by move=> [<- <-].
Qed.

End Facts.
Import Facts.

Lemma sss_compute_iff {n P s t} : P // s ->> t <-> clos_refl_trans _ (sss_step (@mma_sss n) P) s t.
Proof.
  split.
  - case=> k. elim: k s.
    { move=> ? /sss_steps_0_inv <-. by apply: rt_refl. }
    move=> ? IH ? H. inversion H.
    by apply: rt_trans; [apply: rt_step|apply: IH]; eassumption.
  - move=> /clos_rt_rt1n_iff. elim.
    { move=> ?. exists 0. by constructor. }
    move=> > ? _ ?. apply: sss_compute_trans; [|eassumption].
    exists 1. by econstructor; [eassumption|constructor].
Qed.

Lemma in_code_step {n s P} :
  subcode.in_code (fst s) P ->
  exists t, sss_step (@mma_sss n) P s t.
Proof.
  move: s P => [i v] [offset P] /= ?.
  case E: (nth_error P (i - offset)) => [instr|]; first last.
  { move=> /nth_error_None in E. cbn in *. lia. }
  have [t Ht] := mma_sss_total_ni instr (i, v).
  move: E => /(nth_error_split P) [?] [?] [->] Hi.
  eexists t, offset, _, instr, _, v.
  split; [done|split; [|eassumption]].
  congr pair. lia.
Qed.

Lemma out_code_iff {n s P} : subcode.out_code (fst s) P <-> Sim.stuck (sss_step (@mma_sss n) P) s.
Proof.
  split.
  - move=> /sss_steps_stall H t /in_sss_steps_S H'.
    by have /H' /H [] : sss_steps (mma_sss (n:=n)) P 0 t t by apply: in_sss_steps_0.
  - have [|] := subcode.in_out_code_dec (fst s) P; [|done].
    move=> /in_code_step [t] ? Hs. exfalso. by apply: (Hs t).
Qed.

Lemma sss_terminates_iff {n s P} : sss_terminates (@mma_sss n) P s <-> Sim.terminates (sss_step (@mma_sss n) P) s.
Proof.
  split.
  - move=> [t] [/sss_compute_iff ? /out_code_iff ?]. by exists t.
  - move=> [t] [/sss_compute_iff ? /out_code_iff ?]. by exists t.
Qed.

Module MMA_MMA_mon.

Section FixedMMA.
Context {k k' : nat}.

#[local] Notation num_counters := ((1 + k) + k').
#[local] Notation num_counters' := ((1 + k) + (k' + 1)).

Context {P : list (mm_instr (pos num_counters))}.

(* auxiliary result counter *)
#[local] Notation F1' := (pos_right (1 + k) (pos_right k' Fin.F1)).

Definition shift_counter (X : pos num_counters) : pos num_counters' :=
  match pos_both _ _ X with
  | inl Fin.F1 => F1'
  | inl Y => pos_left _ Y
  | inr Y => pos_right _ (pos_left _ Y)
  end.

Definition shift_addr (p : nat) :=
  match p with
  | 0 =>  S (length P)
  | S p' =>
    match (S (length P)) - p' with
    | 0 => S (length P)
    | _ => p
    end
  end.

Definition shift_instr (instr : mm_instr (pos num_counters)) : mm_instr (pos num_counters') :=
  match instr with
  | INC X => INC (shift_counter X)
  | DEC X p => DEC (shift_counter X) (shift_addr p)
  end.

(* same as P, but F1' instead of F1 and move F1' to F1 when finished *)
Definition P' : list (mm_instr (pos num_counters')) :=
  map shift_instr P ++ [INC F1'; DEC F1' (4 + length P); INC Fin.F1; DEC F1' (3 + length P)].

Lemma length_P' : length P' = 4 + length P.
Proof.
  rewrite /P' app_length map_length /=. lia.
Qed.

Lemma P'_mon : Forall (fun instr => if instr is DEC c _ then NonZero c else True) P'.
Proof.
  rewrite /P'. apply /Forall_app. split.
  - apply /Forall_map /Forall_forall => - []; [done|].
    move=> X ? _ /=. pattern X. apply: Fin.caseS'; [done|].
    move=> {}X. rewrite /shift_counter /=.
    by case: (pos_both k k' X).
  - by do ? constructor.
Qed.

Lemma config_eqE2 (n n' i j a : nat) (v : Vector.t nat n) (w : Vector.t nat n') st : (i, Vector.append (a ## v) w) = (j, st) ->
  i = j /\ a = Vector.hd (fst (Vector.splitat _ st)) /\ v = Vector.tl ((fst (Vector.splitat _ st))) /\ w = snd (Vector.splitat _ st).
Proof.
  move=> /pair_equal_spec [->].
  move=> /(f_equal (Vector.splitat _)).
  rewrite Vector.splitat_append.
  move: (Vector.splitat _ st) => [a'v' w'].
  rewrite (Vector.eta a'v').
  by move=> /pair_equal_spec [/Vector.cons_inj] [-> ->] ->.
Qed.

#[local] Opaque Nat.sub.

Lemma shift_addr_range i : 1 <= i < S (S (length P)) -> shift_addr i = i.
Proof.
  move: i => [|i] ? /=; [lia|].
  by have -> : S (length P) - i = S (length P - i) by lia.
Qed.

Lemma in_mma_sss_dec_0' n (i i' : nat) (x : pos n) p (v v' : vec nat n) :
  i' = 1 + i ->
  v' = v ->
  vec_pos v x = 0 ->
  mma_sss (DEC x p) (i, v) (i', v').
Proof. move=> -> ->. by constructor. Qed.

Lemma in_mma_sss_dec_1' n u (i i' : nat) (x : pos n) p (v v' : vec nat n) :
  i' = p ->
  v' = vec_change v x u ->
  vec_pos v x = S u ->
  mma_sss (DEC x p) (i, v) (i', v').
Proof. move=> -> ->. by constructor. Qed.

Lemma in_mma_sss_inc' n (i i' : nat) (x : pos n) (v v' : vec nat n) :
  i' = 1 + i ->
  v' = vec_change v x (S (vec_pos v x)) ->
  mma_sss (INC x) (i, v) (i', v').
Proof. move=> -> ->. by constructor. Qed.

Lemma vec_pos_shift_counter x a v w :
  vec_pos (0 ## Vector.append v (Vector.append w (a ## vec_nil))) (shift_counter x) =
  vec_pos (a ## Vector.append v w) x.
Proof.
  rewrite /shift_counter [in RHS](eq_sym (pos_lr_both _ _ x)).
  case: (pos_both (1 + k) k' x) => [Y|Y].
  - have [->|[Y' ->]] := pos_S_inv Y.
    + by rewrite !vec_app_eq /= !vec_pos_app_right.
    + by rewrite !vec_app_eq /= !vec_pos_app_left.
  - by rewrite !vec_app_eq /= !vec_pos_app_right !vec_pos_app_left.
Qed.

Lemma vec_change_shift_counter {x a v w a' v' w' n} :
  Vector.append (a' ## v') w' = vec_change (Vector.append (a ## v) w) x n ->
  vec_change (0 ## Vector.append v (Vector.append w (a ## vec_nil))) (shift_counter x) n =
  (0 ## Vector.append v' (Vector.append w' (a' ## vec_nil))).
Proof.
  rewrite /shift_counter [in (vec_change _ x _)](eq_sym (pos_lr_both _ _ x)).
  case: (pos_both (1 + k) k' x) => [Y|Y].
  - have [->|[Y' ->]] := pos_S_inv Y.
    + rewrite !vec_app_eq !vec_app_cons /= !vec_change_app_right /= -!vec_app_eq.
      by move=> /Vector.cons_inj [<-] /vec_append_inj [<- <-].
    + rewrite !vec_app_eq !vec_app_cons /= !vec_change_app_left -!vec_app_eq.
      by move=> /Vector.cons_inj [<-] /vec_append_inj [<- <-].
  - rewrite !vec_app_eq !vec_app_cons /= !vec_change_app_right !vec_change_app_left -!vec_app_eq.
    by move=> /Vector.cons_inj [<-] /vec_append_inj [-> ->].
Qed.

Lemma simulation_mma_sss i instr a v w i' a' v' w' :
  1 <= i < S (length P) ->
  mma_sss instr (i, a ## (Vector.append v w)) (i', a' ## (Vector.append v' w')) ->
  mma_sss (shift_instr instr) (shift_addr i, Vector.append (0 ## v) (Vector.append w (a ## vec_nil))) (shift_addr i', Vector.append (0 ## v') (Vector.append w' (a' ## vec_nil))).
Proof.
  move E1: ((i, a ## Vector.append v w)) => iavw.
  move E2: ((i', a' ## Vector.append v' w')) => i'a'v'w' Hi Hinstr.
  rewrite (shift_addr_range i). { lia. }
  case: Hinstr i a v w i' a' v' w' Hi E1 E2.
  - move=> > ? /=.
    move=> /pair_equal_spec [<- <-] /pair_equal_spec [->] E3.
    apply: in_mma_sss_inc'. { apply: shift_addr_range. lia. }
    by rewrite vec_pos_shift_counter (vec_change_shift_counter E3).
  - move=> > ? i > ?.
    move=> /pair_equal_spec [??] /pair_equal_spec [?]. subst.
    move=> /Vector.cons_inj [?] /vec_append_inj [??]. subst.
    rewrite (shift_addr_range). { lia. }
    apply: in_mma_sss_dec_0'; [done..|].
    by rewrite vec_pos_shift_counter.
  - move=> > ? i > ?.
    move=> /pair_equal_spec [??] /pair_equal_spec [?] E3. subst.
    rewrite /=.
    apply: in_mma_sss_dec_1'; [done| |rewrite vec_pos_shift_counter; eassumption].
    by rewrite (vec_change_shift_counter E3).
Qed.

Lemma simulation_sss_step i a v w i' a' v' w' :
  sss_step (mma_sss (n:=num_counters)) (1, P) (i, a ## (Vector.append v w)) (i', a' ## (Vector.append v' w')) ->
  sss_step (mma_sss (n:=num_counters')) (1, P') (shift_addr i, Vector.append (0 ## v) (Vector.append w (a ## vec_nil))) (shift_addr i', Vector.append (0 ## v') (Vector.append w' (a' ## vec_nil))).
Proof.
  rewrite /P'. move=> [offset'] [l] [instr] [r] [v''].
  move=> [[<-]] /[dup] HP.
  move=> -> [/config_eqE2] [->] [->] [-> ->] Hinstr.
  eexists 1, (map shift_instr l), (shift_instr instr), (map shift_instr r ++ _), _.
  split; [|split].
  - congr pair. by rewrite map_app /= -app_assoc.
  - congr pair. rewrite map_length shift_addr_range //.
    rewrite HP app_length /=. lia.
  - apply: simulation_mma_sss Hinstr.
    rewrite HP app_length /=. lia.
Qed.

Lemma shift_addr_outcode i :
  i < 1 \/ S (length P) <= i ->
  shift_addr i = S (length P).
Proof.
  move: i => [|i] Hi /=; [done|].
  case E: (S (length P) - i) => [|?]; [done|].
  cbn in *. lia.
Qed.

Inductive sync : nat * Vector.t nat num_counters -> nat * Vector.t nat num_counters' -> Prop :=
  | sync_intro {i a v w} : sync
      (i, Vector.append (a ## v) w)
      (shift_addr i, Vector.append (0 ## v) (Vector.append w (a ## vec_nil))).

Lemma syncE s s' : sync s s' ->
  let avw := Vector.splitat _ (snd s) in
  let i := fst s in
  let a := Vector.hd (fst avw) in
  let v := Vector.tl (fst avw) in
  let w := snd avw in
  s = (i, Vector.append (a ## v) w) /\
  s' = (shift_addr i, Vector.append (0 ## v) (Vector.append w (a ## vec_nil))).
Proof.
  case => /= >. by rewrite Vector.splitat_append.
Qed.

Lemma vec_change_F1' n v w {m m' : nat} :
  vec_change (vec_app (n ## v) (vec_app w (m ## vec_nil))) F1' m' = vec_app (n ## v) (vec_app w (m' ## vec_nil)).
Proof.
  by rewrite !vec_change_app_right.
Qed.

Lemma finalization v w n m :
  (1, P') //
  (S (length P), Vector.append (n ## v) (Vector.append w (m ## vec_nil))) ->>
  (5 + length P, Vector.append ((n+m) ## v) (Vector.append w (0 ## vec_nil))).
Proof.
  exists (2+m*2+1).
  econstructor.
  { eexists 1, _, _, _, _. split; [reflexivity|split].
    - rewrite map_length. reflexivity.
    - by constructor. }
  econstructor.
  { eexists 1, (map shift_instr P ++ [INC F1']), _, _, _.
    rewrite -app_assoc. split; [reflexivity|split].
    - rewrite app_length map_length /=. congr pair. lia.
    - apply: in_mma_sss_dec_1'; [done..|].
      by rewrite !vec_app_eq !vec_pos_app_right !vec_change_app_right !vec_pos_app_right. }
  rewrite -/(Nat.add _ _).
  rewrite !vec_app_eq !vec_pos_app_right !vec_change_app_right /=.
  elim: m n.
  { move=> n. rewrite Nat.add_0_r.
    econstructor; [|econstructor].
    eexists 1, (map shift_instr P ++ [_; _; _]), _, _, _.
    rewrite -app_assoc. split; [reflexivity|split].
    - rewrite app_length map_length /=. congr pair. lia.
    - apply: in_mma_sss_dec_0'; [done..|].
      by rewrite (vec_pos_app_right (n ## v)) vec_pos_app_right. }
  move=> m IH n.
  econstructor.
  { eexists 1, (map shift_instr P ++ [_; _; _]), _, _, _.
    rewrite -app_assoc. split; [reflexivity|split].
    - rewrite app_length map_length /=. congr pair. lia.
    - apply: in_mma_sss_dec_1'; [done..|].
      by rewrite (vec_pos_app_right (n ## v)) vec_pos_app_right. }
  econstructor.
  { eexists 1, (map shift_instr P ++ [_; _]), _, _, _.
    rewrite -app_assoc. split; [reflexivity|split].
    - rewrite app_length map_length /=. congr pair. lia.
    - by apply: in_mma_sss_inc'. }
  have := IH (S n). rewrite -(Nat.add_succ_comm n m).
  congr sss_steps. congr pair.
  by rewrite vec_change_F1' -!vec_app_eq.
Qed.

#[local] Notation step1 := (sss_step (@mma_sss num_counters) (1, P)).
#[local] Notation step2 := (sss_step (@mma_sss num_counters') (1, P')).

Lemma fstep s t s' : step1 s t -> sync s s' ->
  exists t', clos_trans _ step2 s' t' /\ sync t t'.
Proof.
  move=> + /syncE /= [Hs ?]. subst s'.
  rewrite Hs.
  move: (fst s) => i.
  move: (Vector.hd (snd s)) => a.
  move: (Vector.splitat _ (Vector.tl (snd s))) => [v w] /=.
  move: t => [i' a'v'w'].
  rewrite (Vector.eta a'v'w') (vec_append_splitat (VectorDef.tl a'v'w')) Vector.splitat_append.
  move=> /simulation_sss_step ?. eexists.
  by split; [apply: t_step; eassumption|apply: sync_intro].
Qed.

Lemma step2_det s' t1' t2' :
  sss_step (@mma_sss _) (1, P') s' t1' ->
  sss_step (@mma_sss _) (1, P') s' t2' -> t1' = t2'.
Proof.
  apply: sss_step_fun. by apply: mma_sss_fun.
Qed.

Lemma step1_intro s : (exists t, step1 s t) \/ (Sim.stuck step1 s).
Proof.
  have [|] := subcode.in_out_code_dec (fst s) (1, P).
  - move=> /in_code_step ?. by left.
  - move=> /out_code_iff ?. by right.
Qed.

Lemma simulation v v' w' c m :
  (1, P) // (1, 0 ## Vector.append v (Vector.const 0 k')) ->> (c, m ## (Vector.append v' w')) ->
  c < 1 \/ S (length P) <= c ->
  (1, P') // (1, 0 ## Vector.append v (Vector.const 0 (k' + 1))) ->>
  (5 + length P, m ## (Vector.append v' (Vector.append w' (0 ## vec_nil)))).
Proof.
  move=> /sss_compute_iff.
  move=> /(Sim.clos_refl_trans_transport fstep) => /(_ _ sync_intro).
  move=> [t'] [/syncE] /=. rewrite Vector.splitat_append /=.
  move=> [?] -> + /shift_addr_outcode Hc.
  rewrite Nat.sub_0_r Hc vec_append_const => H1.
  apply: sss_compute_trans; apply /sss_compute_iff; [eassumption|].
  by apply /sss_compute_iff /finalization.
Qed.

End FixedMMA.
End MMA_MMA_mon.
Import MMA_MMA_mon.

Theorem MMA_computable_to_MMA_mon_computable k (R : Vector.t nat k -> nat -> Prop) :
  MMA_computable R -> MMA_mon_computable R.
Proof.
  move=> /MMA_computable_iff [k'] [P] [H1P H2P].
  apply /MMA_mon_computable_iff.
  exists (k'+1), (@P' _ _ P). split; [by apply: P'_mon|split].
  - move=> v m /H1P [c] [v'] [] /=.
    rewrite (vec_append_splitat v').
    move=> /simulation /[apply] ?.
    eexists _, _. split; [eassumption|].
    rewrite /= length_P' /=. lia.
  - move=> v /sss_terminates_iff Hv. apply: H2P.
    apply /sss_terminates_iff. move: Hv.
    apply /(Sim.terminates_reflection step2_det fstep step1_intro).
    rewrite -vec_append_const. by apply: sync_intro.
Qed.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From CompDecModal.libs
 Require Import edone bcase fset base modular_hilbert sltype.

Set Default Proof Using "Type".

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * K* in Coq  *)

Notation "P =p Q" := (forall x, P x <-> Q x) (at level 40).
Definition PredC X (p : X -> Prop) x := ~ p x.

Arguments clos_refl_trans [A] R x _.

Section Characterizations.
  (** ** Inductive Characterizations *)

  Variables (X : Type) (e : X -> X -> Prop).

  Definition cEX (p : X -> Prop) (w : X) : Prop := exists2 v, e w v & p v.
  Definition cAX (p : X -> Prop) (w : X) : Prop := forall v, e w v -> p v.

  CoInductive cAG (p : X -> Prop) (w : X) : Prop :=
  | AGs : p w -> (forall v, e w v -> cAG p v) -> cAG p w.

  (** The coinductive definiton of AG is equivalent to the standard
  defintion using reflexive transitive closure. *)

  Fact cAG_crt p w :
    cAG p w <-> forall v, clos_refl_trans e w v -> p v.
  Proof.
    split.
    - move => C v H. apply clos_rt_rt1n in H.
      by elim: H C => [x|x y z xy _ IH]; case => // _ /(_ _ xy).
    - move: w. cofix cAG_crt => w H. apply: AGs; first by apply H,rt_refl.
      move => v wv. apply: cAG_crt => v' vv'. apply: H.
      eauto using rt_step, rt_trans.
  Qed.

  Inductive cEF (p : X -> Prop) (w : X) : Prop :=
  | EF0 : p w -> cEF p w
  | EFs v : e w v -> cEF p v -> cEF p w.

  Lemma cAG_cEF (p : X -> Prop) (w : X) :
    cEF (PredC p) w -> ~ cAG p w.
  Proof.
    move => E A. elim: E A => {w}[w qw|w v wv]; first by case.
    move => _ IH. case => //. by firstorder.
  Qed.

  (** Strengthening Lemmas *)

  Lemma AG_strengthen (p1 p2 : X -> Prop) w :
    (forall v, p1 v -> p2 v) -> cAG p1 w -> cAG p2 w.
  Proof.
    move => H1. move: w. cofix AG_strengthen => w. case => [/H1 p2w IH].
    by apply: AGs p2w _ => v /IH /AG_strengthen.
  Qed.

  Lemma EF_strengthen (p1 p2 : X -> Prop) w :
    (forall v, p1 v -> p2 v) -> cEF p1 w -> cEF p2 w.
  Proof.
    move => H1. elim => {w} - w; first by move => ?; apply EF0; auto.
    move => v wv ? IH. by apply: EFs ; auto.
  Qed.

End Characterizations.

(** ** Formulas *)

Definition var := nat.

Inductive form :=
| fF
| fV   of var
| fImp of form & form
| fAX  of form
| fAG  of form.

Lemma eq_form_dec (s t : form) : { s = t} + { s <> t}.
Proof. decide equality; apply eq_comparable. Qed.

Definition form_eqMixin := EqMixin (compareP eq_form_dec).
Canonical Structure form_eqType := Eval hnf in @EqType form form_eqMixin.

(** To use formulas and other types built around formulas as base type
for the finite set libaray, we need to show that formulas are
countable. We do this by embedding formulas into the Ssreflect's
generic trees *)

Module formChoice.
  Import GenTree.

  Fixpoint pickle (s : form) :=
    match s with
      | fV v => Leaf v
      | fF => Node 0 [::]
      | fImp s t => Node 1 [:: pickle s ; pickle t]
      | fAX s => Node 2 [:: pickle s]
      | fAG s => Node 3 [:: pickle s]
    end.

  Fixpoint unpickle t :=
    match t with
      | Leaf v  => Some (fV v)
      | Node 0 [::]  => Some (fF)
      | Node 1 [:: t ; t' ] =>
          obind (fun s => obind (fun s' => Some (fImp s s')) (unpickle t')) (unpickle t)
      | Node 2 [:: t ] => obind (fun s => Some (fAX s)) (unpickle t)
      | Node 3 [:: t ] => obind (fun s => Some (fAG s)) (unpickle t)
      | _ => None
    end.

  Lemma pickleP : pcancel pickle unpickle.
  Proof. move => s. by elim: s => //= [s -> t ->| s -> | s -> ]. Qed.
End formChoice.

Definition form_countMixin := PcanCountMixin formChoice.pickleP.
Definition form_choiceMixin := CountChoiceMixin form_countMixin.
Canonical Structure form_ChoiceType := Eval hnf in ChoiceType form form_choiceMixin.
Canonical Structure form_CountType := Eval hnf in CountType form form_countMixin.

(** ** Models

We distinguish thee classes of models

- raw models or transition systems ([ts]): The inductive
  satisfaction relation [eval] is defined on this class

- finite models ([fmodel]): models where the type of states is finite and
  everything else is decidable

- classical models, i.e., models where [eval] is logically decidable
  ([cmodel]): This is the largest class of models for which we can show
  soundness of the hilbert system. *)

Definition stable X Y (R : X -> Y -> Prop) := forall x y, ~ ~ R x y -> R x y.
Definition ldec X Y (R : X -> Y -> Prop) := forall x y, R x y \/ ~ R x y.

Record ts := TS {
  state  :> Type;
  trans  : state -> state -> Prop;
  label  : var -> state -> Prop
}.
Prenex Implicits trans.

Record fmodel := FModel {
  fstate :> finType;
  ftrans : rel fstate;
  flabel : var -> pred fstate
}.
Prenex Implicits ftrans.

(** Make ts inferable for states of fmodels *)
Canonical ts_of_fmodel (M : fmodel) : ts := TS (@ftrans M) (@flabel M).
Coercion ts_of_fmodel : fmodel >-> ts.

Fixpoint eval (M:ts) (s : form) :=
  match s with
    | fF       => (fun _ => False)
    | fV v     => label v
    | fImp s t => (fun w => eval M s w -> eval M t w)
    | fAX s    => cAX (@trans M) (eval M s)
    | fAG s    => cAG trans (eval M s)
  end.

Record cmodel := CModel { sts_of :> ts; modelP : ldec (@eval sts_of) }.

(** * Hilbert System *)

Section Hilbert.
  Local Notation "s ---> t" := (fImp s t).

  Inductive prv : form -> Prop :=
  | rMP s t : prv (s ---> t) -> prv s -> prv t
  | axK s t : prv (s ---> t ---> s)
  | axS s t u : prv ((u ---> s ---> t) ---> (u ---> s) ---> u ---> t)
  | axDN s : prv (((s ---> fF) ---> fF)  ---> s)
  | rNec s : prv s -> prv (fAX s)
  | axN s t : prv (fAX (s ---> t) ---> fAX s ---> fAX t)

  | axAGEl s    : prv (fAG s ---> s)
  | axAGEr s    : prv (fAG s ---> fAX (fAG s))
  | rAG_ind u s : prv (u ---> fAX u) -> prv (u ---> s) -> prv (u --->fAG s)
  .

  (** The hilbert system for K* can be seen as the composition of
  Hilbert systems for minimal logic (M), classical propositional logic
  (P), basic modal logic (K) and the rules and axioms specific to K* *)

  Canonical Structure prv_mSystem := MSystem rMP axK axS.
  Canonical Structure prv_pSystem := PSystem axDN.
  Canonical Structure prv_kSystem := KSystem rNec axN.
  Canonical Structure prv_ksSystem := KSSystem axAGEl axAGEr rAG_ind.

  Definition valid s := forall (M:cmodel) (w:M), eval s w.

  (** ** Soundness

   The Hilbert System is sound for classical models. *)

  Lemma soundness s : prv s -> forall (M:cmodel) (w:M), eval s w.
  Proof.
    elim => {s}. (* try by [move => /= *; firstorder]. -- unfortunately diverges *)
    - by [move => /= *; firstorder].
    - by [move => /= *; firstorder].
    - by [move => /= *; firstorder].
    - move => /= s M w H. by case: (modelP s w); firstorder.
    - by [move => /= *; firstorder].
    - by [move => /= *; firstorder].
    - by move => s M w [H ?].
    - by move => s M w [? H].
    - move => u s _ Hstep _ Hs M. cofix soundness => w /= Hw.
      apply: AGs => [|v wv]; first exact: Hs.
      apply: soundness. exact: Hstep wv.
  Qed.

  (** With excluded middle, every model is a classical model, and the
  Hilbert system is sound for all models *)

  Lemma xm_soundness (xm : forall P, P \/ ~ P) s :
    prv s -> forall (M : ts) (w : M), eval s w.
  Proof.
    move => H M w.
    have ldec_ts : ldec (@eval M) by move => ? ?; exact: xm.
    exact: (@soundness _ H (CModel ldec_ts)).
  Qed.

End Hilbert.

(** ** Equivalence to Segerberg style Hilbert system *)

Module S.
Section Seg.
  Local Notation "s ---> t" := (fImp s t).

  Inductive prv : form -> Prop :=
  | rMP s t : prv (s ---> t) -> prv s -> prv t
  | axK s t : prv (s ---> t ---> s)
  | axS s t u : prv ((u ---> s ---> t) ---> (u ---> s) ---> u ---> t)
  | axDN s : prv (((s ---> fF) ---> fF)  ---> s)
  | rNec s : prv s -> prv (fAX s)
  | axN s t : prv (fAX (s ---> t) ---> fAX s ---> fAX t)

  | axAGEl s    : prv (fAG s ---> s)
  | axAGEr s    : prv (fAG s ---> fAX (fAG s))

  | axSeg s     : prv (fAG (s ---> fAX s) ---> s --->  fAG s)
  | axNS  s t   : prv (fAG (s ---> t) ---> fAG s ---> fAG t)
  | rNecS s     : prv s -> prv (fAG s)
  .

End Seg.
End S.

Ltac S_rule H :=
  first [ eapply S.rMP; first eapply H | eapply S.rMP; first eapply S.rMP; first eapply H ].

Fact prv_Sprv s : prv s <-> S.prv s.
Proof.
  split.
  - elim => {s}; try by constructor.
    + move => ? ? ? ? ?. exact: S.rMP.
    + move => u s _ IH1 _ IH2.
      have H1 : S.prv (AG (u ---> AX u)). exact: S.rNecS.
      have H2 : S.prv (AG (u ---> s)). exact: S.rNecS.
      S_rule S.axS. S_rule S.axK. S_rule S.axNS. apply H2.
      by S_rule S.axSeg.
  - elim => {s}; try by constructor.
    + move => ? ? ? ? ?. exact: rMP.
    + move => t. exact: segerberg.
    + move => s t. exact: axAGN.
    + move => s _ . exact: rNecS.
Qed.

(** ** Soundness for Finite Models

A model is finite, if the underlying type of states is a finite type.
We show that the Hilbert system is sound for finite models. For this
we show that [eval] is decidable on finite models. For this we need to evaluate the
evanutalities. This requires a boolean reflection of AG which we
obtain using a fixpoint computation *)

Section DecidabilityAndAgreement.
  Variables (T: finType) (e : rel T) (p : pred T).

  Definition AG_fun (X : {set T}) := [set x | p x && [forall (y | e x y), y \in X]].

  Lemma AR_mono : mono AG_fun.
  Proof.
    move => X Y S. apply/subsetP => x; rewrite !inE.
    case (p x) => //= ?. apply/forall_inP => y xy. apply: (subsetP S). by apply/forall_inP : y xy.
  Qed.

  Definition AGb w := w \in gfp AG_fun.

  Lemma agP w : reflect (cAG e p w) (AGb w).
  Proof.
    rewrite /AGb; apply (iffP idP).
    - move: w. cofix agP => w. rewrite (gfpE AR_mono) !inE.
      case/andP => [x1 x2].
      apply: AGs _ => [//|v wv]. apply: agP. exact: (forall_inP x2).
    - apply: gfp_ind2 => {w} - w X CH.
      case => pw H. rewrite inE pw /=. apply/forall_inP => v /H. exact: CH.
  Qed.

End DecidabilityAndAgreement.

Arguments agP {T e p w}.

(** Given decidability and correctness for AG, decidavility and
correctness of [evalb] follows using a simple induction on formulas *)

Section FiniteModels.
  Variables (M : fmodel).

  Fixpoint evalb s : pred M :=
    match s with
    | fV p => flabel p
    | fF => xpred0
    | fImp s t => fun w => evalb s w ==> evalb t w
    | fAX s => fun w => [forall (v | ftrans w v) , evalb s v]
    | fAG s => AGb ftrans (evalb s)
  end.

  Lemma evalP (w:M) s : reflect (@eval M s w) (evalb s w).
  Proof.
    elim: s w => //=.
    - by constructor.
    - move => * ; exact: idP.
    - move => s IHs t IHt w.
      apply: iffP (@implyP _ _) _ _ => ? /IHs ?; apply/IHt; firstorder.
    - move => s IHs w.
      apply: iffP (@forall_inP _ _ _) _ _ => H v /H /IHs; done.
    - move => s IHs w.
      apply: (iffP agP); apply: AG_strengthen; intuition; solve [exact/IHs|exact/IHt].
  Qed.

  Lemma fin_modelP : ldec (@eval M).
  Proof. move => s w. case : (decP (evalP w s)); tauto. Qed.

End FiniteModels.

(** Every finite decidable model is a clasical model. Therefore, the
Hilberst system is sound for finite decidable models. *)

Definition cmodel_of_fmodel (M : fmodel) := CModel (@fin_modelP M).
Coercion cmodel_of_fmodel : fmodel >-> cmodel.

Theorem  finite_soundness s : prv s -> forall (M:fmodel) (w : M), eval s w.
Proof. move => H M w. exact: (@soundness _ H (cmodel_of_fmodel M) w). Qed.

(** * Clauses and Support *)

(** ** Signed Formulas

Our decision methods for CTL employ signed formulas. we also define a
number of inversion lemmas and other useful constructiuons *)

Definition sform  := (form * bool) %type.
Notation "s ^-" := (s,false) (at level 20, format "s ^-").
Notation "s ^+" := (s,true) (at level 20, format "s ^+").

Definition body s := match s with fAX t^+ => t^+ | fAX t^- => t^- | _ => s end.

Definition positive (s:sform) := if s is t^+ then true else false.
Definition positives C := [fset s.1 | s <- [fset t in C | positive t]].

Lemma posE C s : (s \in positives C) = (s^+ \in C).
Proof.
  apply/fimsetP/idP => [ [[t [|]]] | H].
  - by rewrite inE /= andbT => ? ->.
  - by rewrite inE /= andbF.
  - exists (s^+) => //. by rewrite inE.
Qed.

Definition negative (s:sform) := ~~ positive s.
Definition negatives C := [fset s.1 | s <- [fset t in C | negative t]].

Lemma negE C s : (s \in negatives C) = (s^- \in C).
Proof.
  apply/fimsetP/idP => [ [[t [|]]] | H].
  - by rewrite inE /= andbC.
  - by rewrite inE /negative  andbT => ? ->.
  - exists (s^-) => //. by rewrite inE.
Qed.

Definition isBox s := if s is fAX s^+ then true else false.

Inductive isBox_spec s : bool -> Type :=
| isBox_true t : s = fAX t^+ -> isBox_spec s true
| isBox_false  : isBox_spec s false.

Lemma isBoxP s : isBox_spec s (isBox s).
Proof. move: s => [ [|?|? ?|?|?] [|]] /=; try constructor. exact: isBox_true. Qed.

Definition isDia s := if s is fAX s^- then true else false.

Inductive isDia_spec s : bool -> Type :=
| isDia_true t : s = fAX t^- -> isDia_spec s true
| isDia_false  : isDia_spec s false.

Lemma isDiaP s : isDia_spec s (isDia s).
Proof. move: s => [ [|?|? ?|?|?] [|]] /=; try constructor. exact: isDia_true. Qed.

(** ** Clauses and Support *)

Definition clause := {fset sform}.

Definition lcons (L : clause) :=
  (fF^+ \notin L) && [all s in L, if s is fV p^+ then fV p^- \notin L else true].

Definition literal (s : sform) :=
  let: (t,_) := s in
  match t with
    | fV _ => true
    | fAX _ => true
    | fF    => true
    | _ => false
  end.

Fixpoint supp (L : clause) u b :=
    match u,b with
      | fImp s t,true  => supp L s false || supp L t true
      | fImp s t,false => supp L s true && supp L t false
      | fAG s,true     => supp L s true && ((fAX (fAG s),true) \in L)
      | fAG s,false    => supp L s false || ((fAX (fAG s),false) \in L)
      | _,_ => (u,b) \in L
    end.

Notation "C |> s ^ b" := (supp C s b) (at level 30, format "C  |>  s ^ b").
Notation "C |> s ^+"  := (supp C s true) (at level 30, format "C  |>  s ^+").
Notation "C |> s ^-"  := (supp C s false) (at level 30, format "C  |>  s ^-").
Notation "C |> s"     := (supp C s.1 s.2) (at level 30).

(** Would like to use
[Definition supp' L (s : sform) := let: (t,b) := s in supp L t b.]
[Notation "L |> t" := (supp' L t) (at level 30)]
However, simplification then breaks the notation *)

(** For a locally consistent clause [L], the collection of formulas
supported by [L] corresponds to an (infinite) Hintikka set. *)

Lemma supp_mon L1 L2 s : L1 `<=` L2 -> L1 |> s -> L2 |> s.
Proof.
  move/subP => sub. case: s.
  elim => //= [|p|s IHs t IHt|s IHs|s IHs] [|];
    solve [exact: sub| rewrite -?(rwP orP,rwP andP); intuition].
Qed.

Fixpoint f_weight (s : form) :=
  match s with
    | fImp s t => (f_weight s + f_weight t).+1
    | fAG s    => (f_weight s).+1
    | _        => 0
  end.

Lemma sweight_lit s : f_weight s.1 = 0 <-> literal s.
Proof. case: s => [[|p|s t|s|s] [|]] //. Qed.

Lemma supp_lit C s b : literal (s,b) -> supp C s b = ((s,b) \in C).
Proof. by case: s. Qed.

Definition form_slClass := SLClass supp_mon supp_lit sweight_lit.
Canonical Structure form_slType := SLType form_slClass.
Canonical Structure form_slpType := @SLPType prv_pSystem form_slClass.

(** Want suppC on singletons to expose the concrete support operation, not the
abstract one *)
Lemma suppC1 L s : suppC L [fset s] = L |> s.
Proof. exact: all_fset1. Qed.

(** ** Request *)

Definition R C := [fset body s | s <- [fset t in C | isBox t]].

Lemma RE C s : (s^+ \in R C) = (fAX s^+ \in C).
Proof.
  apply/fimsetP/idP => [ [t] | H].
  - rewrite inE andbC. by case: (isBoxP t) => //= t' -> /= ? [->].
  - exists (fAX s^+) => //. by rewrite inE H.
Qed.

Lemma Rpos s C : s^- \notin R C.
Proof.
  apply/negP. case/fimsetP => t. rewrite inE andbC.
    by case (isBoxP t) => // t' ->.
Qed.

Lemma RU (C C' : clause) : R (C `|` C') = (R C `|` R C').
Proof. by rewrite /R sepU fimsetU. Qed.

Lemma R1 (s : sform) : R [fset s] = if s is fAX u^+ then [fset u^+] else fset0.
Proof. case: s => [[|p|s t|s|s] [|]]; by rewrite /R sep1 /= ?fimset1 ?fimset0. Qed.

Lemma R0 : R fset0 = fset0.
Proof. by rewrite /R sep0 fimset0. Qed.

(** ** Subformula Closure *)

Fixpoint ssub' b s :=
  (s,b) |` match s with
             | fImp s t => ssub' (negb b) s `|` ssub' b t
             | fAX t => ssub' b t
             | fAG s => (fAX (fAG s),b) |` ssub' b s
             | _ => fset0
           end.

Lemma ssub'_refl s b : (s,b) \in ssub' b s.
Proof. case: s => [|x|s t|s|s] /=; by rewrite !inE. Qed.

Definition ssub (s : sform) := let (t,b) := s in (ssub' b t).

Lemma ssub_refl s : s \in ssub s.
Proof. case: s. exact: ssub'_refl. Qed.

Definition sf_closed' (F : {fset sform}) (s:sform) :=
  match s with
    | (fImp s t,b) => ((s,negb b) \in F) && ((t,b) \in F)
    | (fAX s, b) => (s,b) \in F
    | (fAG s, b) => [&& (fAX (fAG s),b) \in F & (s,b) \in F]
    | _ => true
  end.
Arguments sf_closed' F !s.

Definition sf_closed (F :{fset sform}) := forall s, s \in F -> sf_closed' F s.

Lemma sf_closed'_mon (X Y : clause) s : sf_closed' X s -> X `<=` Y -> sf_closed' Y s.
Proof.
  case: s. elim => [|x|s IHs t IHt|s IHs|s IHs ] b H /subP sub //=;
    rewrite ?sub //=; by [case/andP: H | case/and3P: H].
Qed.

Lemma sf_ssub F s : sf_closed F -> s \in F -> ssub s `<=` F.
Proof.
  case: s. elim => [|p|s IHs t IHt|s IHs |s IHs] [|] sfc_F inF //=;
   rewrite ?fsetU0 ?fsubUset ?fsub1 ?inF ?IHs ?IHt ?andbT //=;
   move: (sfc_F _ inF) => /=; try bcase.
Qed.

Lemma sfc_ssub s : sf_closed (ssub s).
Proof.
  case: s.
  elim => [|x|s IHs t IHt|s IHs|s IHs] b //= u; rewrite !inE ?orbF.
  - by move/eqP => -> /=.
  - by move/eqP => -> /=.
  - case/orP => [/eqP ->|H] /=. by rewrite !inE !ssub'_refl.
    apply: sf_closed'_mon (fsubUr _ _).
    case/orP: H => H. apply: sf_closed'_mon (fsubUl _ _). exact: IHs.
    apply: sf_closed'_mon (fsubUr _ _). exact: IHt.
  - case/orP => [/eqP ->|H] /=. by rewrite !inE !ssub'_refl.
    apply: sf_closed'_mon (fsubUr _ _). exact: IHs.
  - case/or3P => [/eqP ->| /eqP -> | H] /=; try by rewrite !inE ?ssub'_refl.
    do 2 apply: sf_closed'_mon (fsubUr _ _). exact: IHs.
Qed.

Lemma sfcU (X Y : {fset sform}) : sf_closed X -> sf_closed Y -> sf_closed (X `|` Y).
Proof.
  rewrite /sf_closed => /= H1 H2 s.
  case/fsetUP => [/H1 | /H2] H; apply: sf_closed'_mon H _; auto with fset.
Qed.

Definition sfc C : clause := \bigcup_(s in C) ssub s.

Lemma sfc_bigcup (T : choiceType) (C : {fset T}) F :
  (forall s, sf_closed (F s)) -> sf_closed (\bigcup_(s in C) F s).
Proof.
  move => H. apply: big_rec => [s|i D _]; by [rewrite inE|exact: sfcU].
Qed.

Lemma closed_sfc C : sf_closed (sfc C).
Proof. exact: sfc_bigcup sfc_ssub. Qed.

Lemma sub_sfc C : C `<=` (sfc C).
Proof.
  rewrite /sfc. apply/subP => s inC. apply/cupP.
  exists s => //. by rewrite inC ssub_refl.
Qed.

Lemma RinU (F : clause) : sf_closed F ->
  forall C, C \in powerset F -> R C \in powerset F.
Proof.
  move => sfc_F C. rewrite !powersetE => /subP H. apply/subP => s.
  case: s => s [|]; last by rewrite (negbTE (Rpos _ _)).
  by rewrite RE => /H /sfc_F.
Qed.

(** ** Associtated Formuals *)

Lemma satA (M:cmodel) (w:M) (C:clause) :
  (forall s, s \in C -> eval (interp s) w) <-> eval [af C] w.
Proof.
  case: C => xs i /=.
  change ((forall s, s \in xs -> eval (interp s) w) <-> eval [af xs] w).
  elim: xs {i} => [|/= s xs IH]. rewrite big_nil forall_nil /=. tauto.
  rewrite big_cons forall_cons IH {2}/And /=.
  move: (modelP (interp s) w) (modelP [af xs] w); tauto.
Qed.

Lemma box_request (C : clause) : prv ([af C] ---> AX [af R C]).
Proof.
  rewrite <- bigABBA. apply: bigAI. case => [s [|]]; last by rewrite (negbTE (Rpos _ _)).
  rewrite RE. exact: bigAE.
Qed.

Fixpoint f_size (s : form) :=
  match s with
    | fF => 1
    | fV p => 1
    | fImp s t => (f_size s + f_size t).+1
    | fAX s => (f_size s).+1
    | fAG s => (f_size s).+1
  end.

Require Import Lia.

Lemma size_ssub (s : form) (b : bool) : size (ssub (s,b)) <= 2 * f_size s.
Proof.
  elim: s b => //= [|p|s IHs t IHt|s IHs|s IHs ] b;
    try by rewrite fsetU0 fset1Es.
  - apply: leq_trans (fsizeU1 _ _) _. apply: leq_ltn_trans (fsizeU _ _) _.
    apply: leq_ltn_trans (leq_add (IHs _) (IHt _)) _.
    apply/leP; rewrite -!(multE,plusE); lia.
  - apply: leq_trans (fsizeU1 _ _) _. apply: leq_ltn_trans (IHs _) _.
    apply/leP; rewrite -!(multE,plusE); lia.
  - apply: leq_trans (fsizeU1 _ _) _. apply: leq_ltn_trans (fsizeU1 _ _) _.
    by rewrite mulnS add2n !ltnS.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011-2013 Sylvie Boldo
#<br />#
Copyright (C) 2011-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import ZArith.
Require Import Zquot.
Require Import Fcore_Zaux.

(** Number of bits (radix 2) of a positive integer.

It serves as an upper bound on the number of digits to ensure termination.
*)

Fixpoint digits2_Pnat (n : positive) : nat :=
  match n with
  | xH => O
  | xO p => S (digits2_Pnat p)
  | xI p => S (digits2_Pnat p)
  end.

Theorem digits2_Pnat_correct :
  forall n,
  let d := digits2_Pnat n in
  (Zpower_nat 2 d <= Zpos n < Zpower_nat 2 (S d))%Z.
Proof.
intros n d. unfold d. clear.
assert (Hp: forall m, (Zpower_nat 2 (S m) = 2 * Zpower_nat 2 m)%Z) by easy.
induction n ; simpl digits2_Pnat.
rewrite Zpos_xI, 2!Hp.
omega.
rewrite (Zpos_xO n), 2!Hp.
omega.
now split.
Qed.

Section Fcore_digits.

Variable beta : radix.

Definition Zdigit n k := Z.rem (Z.quot n (Zpower beta k)) beta.

Theorem Zdigit_lt :
  forall n k,
  (k < 0)%Z ->
  Zdigit n k = Z0.
Proof.
intros n [|k|k] Hk ; try easy.
now case n.
Qed.

Theorem Zdigit_0 :
  forall k, Zdigit 0 k = Z0.
Proof.
intros k.
unfold Zdigit.
rewrite Zquot_0_l.
apply Zrem_0_l.
Qed.

Theorem Zdigit_opp :
  forall n k,
  Zdigit (-n) k = Zopp (Zdigit n k).
Proof.
intros n k.
unfold Zdigit.
rewrite Zquot_opp_l.
apply Zrem_opp_l.
Qed.

Theorem Zdigit_ge_Zpower_pos :
  forall e n,
  (0 <= n < Zpower beta e)%Z ->
  forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof.
intros e n Hn k Hk.
unfold Zdigit.
rewrite Zquot_small.
apply Zrem_0_l.
split.
apply Hn.
apply Zlt_le_trans with (1 := proj2 Hn).
replace k with (e + (k - e))%Z by ring.
rewrite Zpower_plus.
rewrite <- (Zmult_1_r (beta ^ e)) at 1.
apply Zmult_le_compat_l.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zlt_le_weak.
now apply Zle_lt_trans with n.
generalize (Zle_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)).
clear.
now destruct e as [|e|e].
now apply Zle_minus_le_0.
Qed.

Theorem Zdigit_ge_Zpower :
  forall e n,
  (Zabs n < Zpower beta e)%Z ->
  forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof.
intros e [|n|n] Hn k.
easy.
apply Zdigit_ge_Zpower_pos.
now split.
intros He.
change (Zneg n) with (Zopp (Zpos n)).
rewrite Zdigit_opp.
rewrite Zdigit_ge_Zpower_pos with (2 := He).
apply Zopp_0.
now split.
Qed.

Theorem Zdigit_not_0_pos :
  forall e n, (0 <= e)%Z ->
  (Zpower beta e <= n < Zpower beta (e + 1))%Z ->
  Zdigit n e <> Z0.
Proof.
intros e n He (Hn1,Hn2).
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite Zrem_small.
intros H.
apply Zle_not_lt with (1 := Hn1).
rewrite (Z.quot_rem' n (beta ^ e)).
rewrite H, Zmult_0_r, Zplus_0_l.
apply Zrem_lt_pos_pos.
apply Zle_trans with (2 := Hn1).
apply Zpower_ge_0.
now apply Zpower_gt_0.
split.
apply Zle_trans with (2 := Hn1).
apply Zpower_ge_0.
replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z.
exact Hn2.
rewrite <- (Zmult_1_r beta) at 3.
now apply (Zpower_plus beta e 1).
Qed.

Theorem Zdigit_not_0 :
  forall e n, (0 <= e)%Z ->
  (Zpower beta e <= Zabs n < Zpower beta (e + 1))%Z ->
  Zdigit n e <> Z0.
Proof.
intros e n He Hn.
destruct (Zle_or_lt 0 n) as [Hn'|Hn'].
rewrite (Zabs_eq _ Hn') in Hn.
now apply Zdigit_not_0_pos.
intros H.
rewrite (Zabs_non_eq n) in Hn by now apply Zlt_le_weak.
apply (Zdigit_not_0_pos _ _ He Hn).
now rewrite Zdigit_opp, H.
Qed.

Theorem Zdigit_mul_pow :
  forall n k k', (0 <= k')%Z ->
  Zdigit (n * Zpower beta k') k = Zdigit n (k - k').
Proof.
intros n k k' Hk'.
destruct (Zle_or_lt k' k) as [H|H].
revert k H.
pattern k' ; apply Zlt_0_ind with (2 := Hk').
clear k' Hk'.
intros k' IHk' Hk' k H.
unfold Zdigit.
apply (f_equal (fun x => Z.rem x beta)).
pattern k at 1 ; replace k with (k - k' + k')%Z by ring.
rewrite Zpower_plus with (2 := Hk').
apply Zquot_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zle_minus_le_0.
destruct (Zle_or_lt 0 k) as [H0|H0].
rewrite (Zdigit_lt n) by omega.
unfold Zdigit.
replace k' with (k' - k + k)%Z by ring.
rewrite Zpower_plus with (2 := H0).
rewrite Zmult_assoc, Z_quot_mult.
replace (k' - k)%Z with (k' - k - 1 + 1)%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_assoc.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply Z_rem_mult.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
rewrite Zdigit_lt with (1 := H0).
apply sym_eq.
apply Zdigit_lt.
omega.
Qed.

Theorem Zdigit_div_pow :
  forall n k k', (0 <= k)%Z -> (0 <= k')%Z ->
  Zdigit (Z.quot n (Zpower beta k')) k = Zdigit n (k + k').
Proof.
intros n k k' Hk Hk'.
unfold Zdigit.
rewrite Zquot_Zquot.
rewrite Zplus_comm.
now rewrite Zpower_plus.
Qed.

Theorem Zdigit_mod_pow :
  forall n k k', (k < k')%Z ->
  Zdigit (Z.rem n (Zpower beta k')) k = Zdigit n k.
Proof.
intros n k k' Hk.
destruct (Zle_or_lt 0 k) as [H|H].
unfold Zdigit.
rewrite <- 2!ZOdiv_mod_mult.
apply (f_equal (fun x => Z.quot x (beta ^ k))).
replace k' with (k + 1 + (k' - (k + 1)))%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_comm.
rewrite Zpower_plus by easy.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply ZOmod_mod_mult.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zdigit_mod_pow_out :
  forall n k k', (0 <= k' <= k)%Z ->
  Zdigit (Z.rem n (Zpower beta k')) k = Z0.
Proof.
intros n k k' Hk.
unfold Zdigit.
rewrite ZOdiv_small_abs.
apply Zrem_0_l.
apply Zlt_le_trans with (Zpower beta k').
rewrite <- (Zabs_eq (beta ^ k')) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zpower_le.
Qed.

Fixpoint Zsum_digit f k :=
  match k with
  | O => Z0
  | S k => (Zsum_digit f k + f (Z_of_nat k) * Zpower beta (Z_of_nat k))%Z
  end.

Theorem Zsum_digit_digit :
  forall n k,
  Zsum_digit (Zdigit n) k = Z.rem n (Zpower beta (Z_of_nat k)).
Proof.
intros n.
induction k.
apply sym_eq.
apply Zrem_1_r.
simpl Zsum_digit.
rewrite IHk.
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite <- (ZOmod_mod_mult n beta).
rewrite Zmult_comm.
replace (beta ^ Z_of_nat k * beta)%Z with (Zpower beta (Z_of_nat (S k))).
rewrite Zplus_comm, Zmult_comm.
apply sym_eq.
apply Z.quot_rem'.
rewrite inj_S.
rewrite <- (Zmult_1_r beta) at 3.
apply Zpower_plus.
apply Zle_0_nat.
easy.
Qed.

Theorem Zpower_gt_id :
  forall n, (n < Zpower beta n)%Z.
Proof.
intros [|n|n] ; try easy.
simpl.
rewrite Zpower_pos_nat.
rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
induction (nat_of_P n).
easy.
rewrite inj_S.
change (Zpower_nat beta (S n0)) with (beta * Zpower_nat beta n0)%Z.
unfold Zsucc.
apply Zlt_le_trans with (beta * (Z_of_nat n0 + 1))%Z.
clear.
apply Zlt_0_minus_lt.
replace (beta * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((beta - 1) * (Z_of_nat n0 + 1))%Z by ring.
apply Zmult_lt_0_compat.
cut (2 <= beta)%Z. omega.
apply Zle_bool_imp_le.
apply beta.
apply (Zle_lt_succ 0).
apply Zle_0_nat.
apply Zmult_le_compat_l.
now apply Zlt_le_succ.
apply Zle_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply beta.
Qed.

Theorem Zdigit_ext :
  forall n1 n2,
  (forall k, (0 <= k)%Z -> Zdigit n1 k = Zdigit n2 k) ->
  n1 = n2.
Proof.
intros n1 n2 H.
rewrite <- (ZOmod_small_abs n1 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))).
rewrite <- (ZOmod_small_abs n2 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))) at 2.
replace (Zmax (Zabs n1) (Zabs n2)) with (Z_of_nat (Zabs_nat (Zmax (Zabs n1) (Zabs n2)))).
rewrite <- 2!Zsum_digit_digit.
induction (Zabs_nat (Zmax (Zabs n1) (Zabs n2))).
easy.
simpl.
rewrite H, IHn.
apply refl_equal.
apply Zle_0_nat.
rewrite inj_Zabs_nat.
apply Zabs_eq.
apply Zle_trans with (Zabs n1).
apply Zabs_pos.
apply Zle_max_l.
apply Zlt_le_trans with (Zpower beta (Zabs n2)).
apply Zpower_gt_id.
apply Zpower_le.
apply Zle_max_r.
apply Zlt_le_trans with (Zpower beta (Zabs n1)).
apply Zpower_gt_id.
apply Zpower_le.
apply Zle_max_l.
Qed.

Theorem ZOmod_plus_pow_digit :
  forall u v n, (0 <= u * v)%Z ->
  (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  Z.rem (u + v) (Zpower beta n) = (Z.rem u (Zpower beta n) + Z.rem v (Zpower beta n))%Z.
Proof.
intros u v n Huv Hd.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
rewrite Zplus_rem with (1 := Huv).
apply ZOmod_small_abs.
generalize (Zle_refl n).
pattern n at -2 ; rewrite <- Zabs_eq with (1 := Hn).
rewrite <- (inj_Zabs_nat n).
induction (Zabs_nat n) as [|p IHp].
now rewrite 2!Zrem_1_r.
rewrite <- 2!Zsum_digit_digit.
simpl Zsum_digit.
rewrite inj_S.
intros Hn'.
replace (Zsum_digit (Zdigit u) p + Zdigit u (Z_of_nat p) * beta ^ Z_of_nat p +
  (Zsum_digit (Zdigit v) p + Zdigit v (Z_of_nat p) * beta ^ Z_of_nat p))%Z with
  (Zsum_digit (Zdigit u) p + Zsum_digit (Zdigit v) p +
  (Zdigit u (Z_of_nat p) + Zdigit v (Z_of_nat p)) * beta ^ Z_of_nat p)%Z by ring.
apply (Zle_lt_trans _ _ _ (Zabs_triangle _ _)).
replace (beta ^ Zsucc (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z.
apply Zplus_lt_le_compat.
rewrite 2!Zsum_digit_digit.
apply IHp.
now apply Zle_succ_le.
rewrite Zabs_Zmult.
rewrite (Zabs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0.
apply Zmult_le_compat_r. 2: apply Zpower_ge_0.
apply Zlt_succ_le.
assert (forall u v, Zabs (Zdigit u v) < Zsucc (beta -  1))%Z.
clear ; intros n k.
assert (0 < beta)%Z.
apply Zlt_le_trans with 2%Z.
apply refl_equal.
apply Zle_bool_imp_le.
apply beta.
replace (Zsucc (beta - 1)) with (Zabs beta).
apply Zrem_lt.
now apply Zgt_not_eq.
rewrite Zabs_eq.
apply Zsucc_pred.
now apply Zlt_le_weak.
assert (0 <= Z_of_nat p < n)%Z.
split.
apply Zle_0_nat.
apply Zgt_lt.
now apply Zle_succ_gt.
destruct (Hd (Z_of_nat p) H0) as [K|K] ; rewrite K.
apply H.
rewrite Zplus_0_r.
apply H.
unfold Zsucc.
ring_simplify.
rewrite Zpower_plus.
change (beta ^1)%Z with (beta * 1)%Z.
now rewrite Zmult_1_r.
apply Zle_0_nat.
easy.
destruct n as [|n|n] ; try easy.
now rewrite 3!Zrem_0_r.
Qed.

Theorem ZOdiv_plus_pow_digit :
  forall u v n, (0 <= u * v)%Z ->
  (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  Z.quot (u + v) (Zpower beta n) = (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))%Z.
Proof.
intros u v n Huv Hd.
rewrite <- (Zplus_0_r (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))).
rewrite ZOdiv_plus with (1 := Huv).
rewrite <- ZOmod_plus_pow_digit by assumption.
apply f_equal.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
apply ZOdiv_small_abs.
rewrite <- Zabs_eq.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zpower_ge_0.
clear -Hn.
destruct n as [|n|n] ; try easy.
apply Zquot_0_r.
Qed.

Theorem Zdigit_plus :
  forall u v, (0 <= u * v)%Z ->
  (forall k, (0 <= k)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  forall k,
  Zdigit (u + v) k = (Zdigit u k + Zdigit v k)%Z.
Proof.
intros u v Huv Hd k.
destruct (Zle_or_lt 0 k) as [Hk|Hk].
unfold Zdigit.
rewrite ZOdiv_plus_pow_digit with (1 := Huv).
rewrite <- (Zmult_1_r beta) at 3 5 7.
change (beta * 1)%Z with (beta ^1)%Z.
apply ZOmod_plus_pow_digit.
apply Zsame_sign_trans_weak with v.
intros Zv ; rewrite Zv.
apply Zquot_0_l.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with u.
intros Zu ; rewrite Zu.
apply Zquot_0_l.
now rewrite Zmult_comm.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
intros k' (Hk1,Hk2).
rewrite 2!Zdigit_div_pow by assumption.
apply Hd.
now apply Zplus_le_0_compat.
intros k' (Hk1,Hk2).
now apply Hd.
now rewrite 3!Zdigit_lt.
Qed.

(** Left and right shifts *)

Definition Zscale n k :=
  if Zle_bool 0 k then (n * Zpower beta k)%Z else Z.quot n (Zpower beta (-k)).

Theorem Zdigit_scale :
  forall n k k', (0 <= k')%Z ->
  Zdigit (Zscale n k) k' = Zdigit n (k' - k).
Proof.
intros n k k' Hk'.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
now apply Zdigit_mul_pow.
apply Zdigit_div_pow with (1 := Hk').
omega.
Qed.

Theorem Zscale_0 :
  forall k,
  Zscale 0 k = Z0.
Proof.
intros k.
unfold Zscale.
case Zle_bool.
apply Zmult_0_l.
apply Zquot_0_l.
Qed.

Theorem Zsame_sign_scale :
  forall n k,
  (0 <= n * Zscale n k)%Z.
Proof.
intros n k.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
rewrite Zmult_assoc.
apply Zmult_le_0_compat.
apply Zsame_sign_imp ; apply Zlt_le_weak.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
Qed.

Theorem Zscale_mul_pow :
  forall n k k', (0 <= k)%Z ->
  Zscale (n * Zpower beta k) k' = Zscale n (k + k').
Proof.
intros n k k' Hk.
unfold Zscale.
case Zle_bool_spec ; intros Hk'.
rewrite Zle_bool_true.
rewrite <- Zmult_assoc.
apply f_equal.
now rewrite Zpower_plus.
now apply Zplus_le_0_compat.
case Zle_bool_spec ; intros Hk''.
pattern k at 1 ; replace k with (k + k' + -k')%Z by ring.
assert (0 <= -k')%Z by omega.
rewrite Zpower_plus by easy.
rewrite Zmult_assoc, Z_quot_mult.
apply refl_equal.
apply Zgt_not_eq.
now apply Zpower_gt_0.
replace (-k')%Z with (-(k+k') + k)%Z by ring.
rewrite Zpower_plus with (2 := Hk).
apply Zquot_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
omega.
Qed.

Theorem Zscale_scale :
  forall n k k', (0 <= k)%Z ->
  Zscale (Zscale n k) k' = Zscale n (k + k').
Proof.
intros n k k' Hk.
unfold Zscale at 2.
rewrite Zle_bool_true with (1 := Hk).
now apply Zscale_mul_pow.
Qed.

(** Slice of an integer *)

Definition Zslice n k1 k2 :=
  if Zle_bool 0 k2 then Z.rem (Zscale n (-k1)) (Zpower beta k2) else Z0.

Theorem Zdigit_slice :
  forall n k1 k2 k, (0 <= k < k2)%Z ->
  Zdigit (Zslice n k1 k2) k = Zdigit n (k1 + k).
Proof.
intros n k1 k2 k Hk.
unfold Zslice.
rewrite Zle_bool_true.
rewrite Zdigit_mod_pow by apply Hk.
rewrite Zdigit_scale by apply Hk.
unfold Zminus.
now rewrite Zopp_involutive, Zplus_comm.
omega.
Qed.

Theorem Zdigit_slice_out :
  forall n k1 k2 k, (k2 <= k)%Z ->
  Zdigit (Zslice n k1 k2) k = Z0.
Proof.
intros n k1 k2 k Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
apply Zdigit_mod_pow_out.
now split.
apply Zdigit_0.
Qed.

Theorem Zslice_0 :
  forall k k',
  Zslice 0 k k' = Z0.
Proof.
intros k k'.
unfold Zslice.
case Zle_bool.
rewrite Zscale_0.
apply Zrem_0_l.
apply refl_equal.
Qed.

Theorem Zsame_sign_slice :
  forall n k k',
  (0 <= n * Zslice n k k')%Z.
Proof.
intros n k k'.
unfold Zslice.
case Zle_bool.
apply Zsame_sign_trans_weak with (Zscale n (-k)).
intros H ; rewrite H.
apply Zrem_0_l.
apply Zsame_sign_scale.
rewrite Zmult_comm.
apply Zrem_sgn2.
now rewrite Zmult_0_r.
Qed.

Theorem Zslice_slice :
  forall n k1 k2 k1' k2', (0 <= k1' <= k2)%Z ->
  Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Zmin (k2 - k1') k2').
Proof.
intros n k1 k2 k1' k2' Hk1'.
destruct (Zle_or_lt 0 k2') as [Hk2'|Hk2'].
apply Zdigit_ext.
intros k Hk.
destruct (Zle_or_lt (Zmin (k2 - k1') k2') k) as [Hk'|Hk'].
rewrite (Zdigit_slice_out n (k1 + k1')) with (1 := Hk').
destruct (Zle_or_lt k2' k) as [Hk''|Hk''].
now apply Zdigit_slice_out.
rewrite Zdigit_slice by now split.
apply Zdigit_slice_out.
zify ; omega.
rewrite Zdigit_slice by (zify ; omega).
rewrite (Zdigit_slice n (k1 + k1')) by now split.
rewrite Zdigit_slice.
now rewrite Zplus_assoc.
zify ; omega.
unfold Zslice.
rewrite Zmin_r.
now rewrite Zle_bool_false.
omega.
Qed.

Theorem Zslice_mul_pow :
  forall n k k1 k2, (0 <= k)%Z ->
  Zslice (n * Zpower beta k) k1 k2 = Zslice n (k1 - k) k2.
Proof.
intros n k k1 k2 Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
rewrite Zscale_mul_pow with (1 := Hk).
now replace (- (k1 - k))%Z with (k + -k1)%Z by ring.
Qed.

Theorem Zslice_div_pow :
  forall n k k1 k2, (0 <= k)%Z -> (0 <= k1)%Z ->
  Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zslice n (k1 + k) k2.
Proof.
intros n k k1 k2 Hk Hk1.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
apply (f_equal (fun x => Z.rem x (beta ^ k2))).
unfold Zscale.
case Zle_bool_spec ; intros Hk1'.
replace k1 with Z0 by omega.
case Zle_bool_spec ; intros Hk'.
replace k with Z0 by omega.
simpl.
now rewrite Zquot_1_r.
rewrite Zopp_involutive.
apply Zmult_1_r.
rewrite Zle_bool_false by omega.
rewrite 2!Zopp_involutive, Zplus_comm.
rewrite Zpower_plus by assumption.
apply Zquot_Zquot.
Qed.

Theorem Zslice_scale :
  forall n k k1 k2, (0 <= k1)%Z ->
  Zslice (Zscale n k) k1 k2 = Zslice n (k1 - k) k2.
Proof.
intros n k k1 k2 Hk1.
unfold Zscale.
case Zle_bool_spec; intros Hk.
now apply Zslice_mul_pow.
apply Zslice_div_pow with (2 := Hk1).
omega.
Qed.

Theorem Zslice_div_pow_scale :
  forall n k k1 k2, (0 <= k)%Z ->
  Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zscale (Zslice n k (k1 + k2)) (-k1).
Proof.
intros n k k1 k2 Hk.
apply Zdigit_ext.
intros k' Hk'.
rewrite Zdigit_scale with (1 := Hk').
unfold Zminus.
rewrite (Zplus_comm k'), Zopp_involutive.
destruct (Zle_or_lt k2 k') as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
apply sym_eq.
apply Zdigit_slice_out.
now apply Zplus_le_compat_l.
rewrite Zdigit_slice by now split.
destruct (Zle_or_lt 0 (k1 + k')) as [Hk1'|Hk1'].
rewrite Zdigit_slice by omega.
rewrite Zdigit_div_pow by assumption.
apply f_equal.
ring.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zplus_slice :
  forall n k l1 l2, (0 <= l1)%Z -> (0 <= l2)%Z ->
  (Zslice n k l1 + Zscale (Zslice n (k + l1) l2) l1)%Z = Zslice n k (l1 + l2).
Proof.
intros n k1 l1 l2 Hl1 Hl2.
clear Hl1.
apply Zdigit_ext.
intros k Hk.
rewrite Zdigit_plus.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt (l1 + l2) k) as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
now rewrite 2!Zdigit_slice_out by omega.
rewrite Zdigit_slice with (1 := conj Hk Hk2).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
rewrite Zdigit_slice_out with (1 := Hk1).
rewrite Zdigit_slice by omega.
simpl ; apply f_equal.
ring.
rewrite Zdigit_slice with (1 := conj Hk Hk1).
rewrite (Zdigit_lt _ (k - l1)) by omega.
apply Zplus_0_r.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with n.
intros H ; rewrite H.
apply Zslice_0.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with (Zslice n (k1 + l1) l2).
intros H ; rewrite H.
apply Zscale_0.
apply Zsame_sign_slice.
apply Zsame_sign_scale.
apply Zsame_sign_slice.
clear k Hk ; intros k Hk.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
left.
now apply Zdigit_slice_out.
right.
apply Zdigit_lt.
omega.
Qed.

Section digits_aux.

Variable p : Z.

Fixpoint Zdigits_aux (nb pow : Z) (n : nat) { struct n } : Z :=
  match n with
  | O => nb
  | S n => if Zlt_bool p pow then nb else Zdigits_aux (nb + 1) (Zmult beta pow) n
  end.

End digits_aux.

(** Number of digits of an integer *)

Definition Zdigits n :=
  match n with
  | Z0 => Z0
  | Zneg p => Zdigits_aux (Zpos p) 1 beta (digits2_Pnat p)
  | Zpos p => Zdigits_aux n 1 beta (digits2_Pnat p)
  end.

Theorem Zdigits_correct :
  forall n,
  (Zpower beta (Zdigits n - 1) <= Zabs n < Zpower beta (Zdigits n))%Z.
Proof.
cut (forall p, Zpower beta (Zdigits (Zpos p) - 1) <= Zpos p < Zpower beta (Zdigits (Zpos p)))%Z.
intros H [|n|n] ; try exact (H n).
now split.
intros n.
simpl.
(* *)
assert (U: (Zpos n < Zpower beta (Z_of_nat (S (digits2_Pnat n))))%Z).
apply Zlt_le_trans with (1 := proj2 (digits2_Pnat_correct n)).
rewrite Zpower_Zpower_nat.
rewrite Zabs_nat_Z_of_nat.
induction (S (digits2_Pnat n)).
easy.
rewrite 2!(Zpower_nat_S).
apply Zmult_le_compat with (2 := IHn0).
apply Zle_bool_imp_le.
apply beta.
easy.
rewrite <- (Zabs_nat_Z_of_nat n0).
rewrite <- Zpower_Zpower_nat.
apply (Zpower_ge_0 (Build_radix 2 (refl_equal true))).
apply Zle_0_nat.
apply Zle_0_nat.
(* *)
revert U.
rewrite inj_S.
unfold Zsucc.
generalize (digits2_Pnat n).
intros u U.
pattern (radix_val beta) at 2 4 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
assert (V: (Zpower beta (1 - 1) <= Zpos n)%Z).
now apply (Zlt_le_succ 0).
generalize (conj V U).
clear.
generalize (Zle_refl 1).
generalize 1%Z at 2 3 5 6 7 9 10.
(* *)
induction u.
easy.
rewrite inj_S; unfold Zsucc.
simpl Zdigits_aux.
intros v Hv U.
case Zlt_bool_spec ; intros K.
now split.
pattern (radix_val beta) at 2 5 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
rewrite <- Zpower_plus.
rewrite Zplus_comm.
apply IHu.
clear -Hv ; omega.
split.
now ring_simplify (1 + v - 1)%Z.
now rewrite Zplus_assoc.
easy.
apply Zle_succ_le with (1 := Hv).
Qed.

Theorem Zdigits_unique :
  forall n d,
  (Zpower beta (d - 1) <= Zabs n < Zpower beta d)%Z ->
  Zdigits n = d.
Proof.
intros n d Hd.
assert (Hd' := Zdigits_correct n).
apply Zle_antisym.
apply (Zpower_lt_Zpower beta).
now apply Zle_lt_trans with (Zabs n).
apply (Zpower_lt_Zpower beta).
now apply Zle_lt_trans with (Zabs n).
Qed.

Theorem Zdigits_abs :
  forall n, Zdigits (Zabs n) = Zdigits n.
Proof.
now intros [|n|n].
Qed.

Theorem Zdigits_gt_0 :
  forall n, n <> Z0 -> (0 < Zdigits n)%Z.
Proof.
intros n Zn.
rewrite <- (Zdigits_abs n).
assert (Hn: (0 < Zabs n)%Z).
destruct n ; try easy.
now elim Zn.
destruct (Zabs n) as [|p|p] ; try easy ; clear.
simpl.
generalize 1%Z (radix_val beta) (refl_equal Lt : (0 < 1)%Z).
induction (digits2_Pnat p).
easy.
simpl.
intros.
case Zlt_bool.
exact H.
apply IHn.
now apply Zlt_lt_succ.
Qed.

Theorem Zdigits_ge_0 :
  forall n, (0 <= Zdigits n)%Z.
Proof.
intros n.
destruct (Z_eq_dec n 0) as [H|H].
now rewrite H.
apply Zlt_le_weak.
now apply Zdigits_gt_0.
Qed.

Theorem Zdigit_out :
  forall n k, (Zdigits n <= k)%Z ->
  Zdigit n k = Z0.
Proof.
intros n k Hk.
apply Zdigit_ge_Zpower with (2 := Hk).
apply Zdigits_correct.
Qed.

Theorem Zdigit_digits :
  forall n, n <> Z0 ->
  Zdigit n (Zdigits n - 1) <> Z0.
Proof.
intros n Zn.
apply Zdigit_not_0.
apply Zlt_0_le_0_pred.
now apply Zdigits_gt_0.
ring_simplify (Zdigits n - 1 + 1)%Z.
apply Zdigits_correct.
Qed.

Theorem Zdigits_slice :
  forall n k l, (0 <= l)%Z ->
  (Zdigits (Zslice n k l) <= l)%Z.
Proof.
intros n k l Hl.
unfold Zslice.
rewrite Zle_bool_true with (1 := Hl).
destruct (Zdigits_correct (Z.rem (Zscale n (- k)) (Zpower beta l))) as (H1,H2).
apply Zpower_lt_Zpower with beta.
apply Zle_lt_trans with (1 := H1).
rewrite <- (Zabs_eq (beta ^ l)) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
Qed.

Theorem Zdigits_mult_Zpower :
  forall m e,
  m <> Z0 -> (0 <= e)%Z ->
  Zdigits (m * Zpower beta e) = (Zdigits m + e)%Z.
Proof.
intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
rewrite Z.abs_mul, Z.abs_pow, (Zabs_eq beta).
2: now apply Zlt_le_weak, radix_gt_0.
split.
replace (Zdigits m + e - 1)%Z with (Zdigits m - 1 + e)%Z by ring.
rewrite Zpower_plus with (2 := He).
apply Zmult_le_compat_r.
apply H.
apply Zpower_ge_0.
now apply Zlt_0_le_0_pred, Zdigits_gt_0.
rewrite Zpower_plus with (2 := He).
apply Zmult_lt_compat_r.
now apply Zpower_gt_0.
apply H.
now apply Zlt_le_weak, Zdigits_gt_0.
Qed.

Theorem Zdigits_Zpower :
  forall e,
  (0 <= e)%Z ->
  Zdigits (Zpower beta e) = (e + 1)%Z.
Proof.
intros e He.
rewrite <- (Zmult_1_l (Zpower beta e)).
rewrite Zdigits_mult_Zpower ; try easy.
apply Zplus_comm.
Qed.

Theorem Zdigits_le :
  forall x y,
  (0 <= x)%Z -> (x <= y)%Z ->
  (Zdigits x <= Zdigits y)%Z.
Proof.
intros x y Zx Hxy.
assert (Hx := Zdigits_correct x).
assert (Hy := Zdigits_correct y).
apply (Zpower_lt_Zpower beta).
zify ; omega.
Qed.

Theorem lt_Zdigits :
  forall x y,
  (0 <= y)%Z ->
  (Zdigits x < Zdigits y)%Z ->
  (x < y)%Z.
Proof.
intros x y Hy.
cut (y <= x -> Zdigits y <= Zdigits x)%Z. omega.
now apply Zdigits_le.
Qed.

Theorem Zpower_le_Zdigits :
  forall e x,
  (e < Zdigits x)%Z ->
  (Zpower beta e <= Zabs x)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
apply Zle_trans with (2 := H1).
apply Zpower_le.
clear -Hex ; omega.
Qed.

Theorem Zdigits_le_Zpower :
  forall e x,
  (Zabs x < Zpower beta e)%Z ->
  (Zdigits x <= e)%Z.
Proof.
intros e x.
generalize (Zpower_le_Zdigits e x).
omega.
Qed.

Theorem Zpower_gt_Zdigits :
  forall e x,
  (Zdigits x <= e)%Z ->
  (Zabs x < Zpower beta e)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
apply Zlt_le_trans with (1 := H2).
now apply Zpower_le.
Qed.

Theorem Zdigits_gt_Zpower :
  forall e x,
  (Zpower beta e <= Zabs x)%Z ->
  (e < Zdigits x)%Z.
Proof.
intros e x Hex.
generalize (Zpower_gt_Zdigits e x).
omega.
Qed.

(** Number of digits of a product.

This strong version is needed for proofs of division and square root
algorithms, since they involve operation remainders.
*)

Theorem Zdigits_mult_strong :
  forall x y,
  (0 <= x)%Z -> (0 <= y)%Z ->
  (Zdigits (x + y + x * y) <= Zdigits x + Zdigits y)%Z.
Proof.
intros x y Hx Hy.
apply Zdigits_le_Zpower.
rewrite Zabs_eq.
apply Zlt_le_trans with ((x + 1) * (y + 1))%Z.
ring_simplify.
apply Zle_lt_succ, Zle_refl.
rewrite Zpower_plus by apply Zdigits_ge_0.
apply Zmult_le_compat.
apply Zlt_le_succ.
rewrite <- (Zabs_eq x) at 1 by easy.
apply Zdigits_correct.
apply Zlt_le_succ.
rewrite <- (Zabs_eq y) at 1 by easy.
apply Zdigits_correct.
clear -Hx ; omega.
clear -Hy ; omega.
change Z0 with (0 + 0 + 0)%Z.
apply Zplus_le_compat.
now apply Zplus_le_compat.
now apply Zmult_le_0_compat.
Qed.

Theorem Zdigits_mult :
  forall x y,
  (Zdigits (x * y) <= Zdigits x + Zdigits y)%Z.
Proof.
intros x y.
rewrite <- Zdigits_abs.
rewrite <- (Zdigits_abs x).
rewrite <- (Zdigits_abs y).
apply Zle_trans with (Zdigits (Zabs x + Zabs y + Zabs x * Zabs y)).
apply Zdigits_le.
apply Zabs_pos.
rewrite Zabs_Zmult.
generalize (Zabs_pos x) (Zabs_pos y).
omega.
apply Zdigits_mult_strong ; apply Zabs_pos.
Qed.

Theorem Zdigits_mult_ge :
  forall x y,
  (x <> 0)%Z -> (y <> 0)%Z ->
  (Zdigits x + Zdigits y - 1 <= Zdigits (x * y))%Z.
Proof.
intros x y Zx Zy.
cut ((Zdigits x - 1) + (Zdigits y - 1) < Zdigits (x * y))%Z. omega.
apply Zdigits_gt_Zpower.
rewrite Zabs_Zmult.
rewrite Zpower_exp.
apply Zmult_le_compat.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_ge_0.
apply Zpower_ge_0.
generalize (Zdigits_gt_0 x). omega.
generalize (Zdigits_gt_0 y). omega.
Qed.

Theorem Zdigits_div_Zpower :
  forall m e,
  (0 <= m)%Z ->
  (0 <= e <= Zdigits m)%Z ->
  Zdigits (m / Zpower beta e) = (Zdigits m - e)%Z.
Proof.
intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He'].
  rewrite Zabs_eq in H by easy.
  destruct H as [H1 H2].
  rewrite Zabs_eq.
  split.
  replace (Zdigits m - e - 1)%Z with (Zdigits m - 1 - e)%Z by ring.
  rewrite Z.pow_sub_r.
  2: apply Zgt_not_eq, radix_gt_0.
  2: clear -He He' ; omega.
  apply Z_div_le with (2 := H1).
  now apply Zlt_gt, Zpower_gt_0.
  apply Zmult_lt_reg_r with (Zpower beta e).
  now apply Zpower_gt_0.
  apply Zle_lt_trans with m.
  rewrite Zmult_comm.
  apply Z_mult_div_ge.
  now apply Zlt_gt, Zpower_gt_0.
  rewrite <- Zpower_plus.
  now replace (Zdigits m - e + e)%Z with (Zdigits m) by ring.
  now apply Zle_minus_le_0.
  apply He.
  apply Z_div_pos with (2 := Hm).
  now apply Zlt_gt, Zpower_gt_0.
rewrite He'.
rewrite (Zeq_minus _ (Zdigits m)) by reflexivity.
simpl.
rewrite Zdiv_small.
easy.
split.
exact Hm.
now rewrite <- (Zabs_eq m) at 1.
Qed.

End Fcore_digits.

(** Specialized version for computing the number of bits of an integer *)

Section Zdigits2.

Theorem Z_of_nat_S_digits2_Pnat :
  forall m : positive,
  Z_of_nat (S (digits2_Pnat m)) = Zdigits radix2 (Zpos m).
Proof.
intros m.
apply eq_sym, Zdigits_unique.
rewrite <- Zpower_nat_Z.
rewrite Nat2Z.inj_succ.
change (_ - 1)%Z with (Zpred (Zsucc (Z.of_nat (digits2_Pnat m)))).
rewrite <- Zpred_succ.
rewrite <- Zpower_nat_Z.
apply digits2_Pnat_correct.
Qed.

Fixpoint digits2_pos (n : positive) : positive :=
  match n with
  | xH => xH
  | xO p => Psucc (digits2_pos p)
  | xI p => Psucc (digits2_pos p)
  end.

Theorem Zpos_digits2_pos :
  forall m : positive,
  Zpos (digits2_pos m) = Zdigits radix2 (Zpos m).
Proof.
intros m.
rewrite <- Z_of_nat_S_digits2_Pnat.
unfold Z.of_nat.
apply f_equal.
induction m ; simpl ; try easy ;
  apply f_equal, IHm.
Qed.

Definition Zdigits2 n :=
  match n with
  | Z0 => n
  | Zpos p => Zpos (digits2_pos p)
  | Zneg p => Zpos (digits2_pos p)
  end.

Lemma Zdigits2_Zdigits :
  forall n, Zdigits2 n = Zdigits radix2 n.
Proof.
intros [|p|p] ; try easy ;
  apply Zpos_digits2_pos.
Qed.

End Zdigits2.